- dipping seq-2nmap, seq-2each\r
- array sort\r
- tiled window manager\r
-- PPC #box-float #unbox-float\r
+- redo new compiler backend for PowerPC\r
- weird bug uncovered during bootstrap stress-test\r
- images saved from plugin do not work\r
- making an image from plugin hangs\r
- generic skip\r
+- inference needs to be more robust with heavily recursive code\r
\r
+ plugin:\r
\r
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
-USING: assembler compiler errors generic hashtables kernel lists
-math namespaces parser sequences strings words ;
+USING: assembler compiler compiler-backend errors generic
+hashtables kernel lists math namespaces parser sequences strings
+words ;
: <c-type> ( -- type )
<namespace> [
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
-USING: assembler compiler errors generic inference kernel lists
-math namespaces sequences stdio strings unparser words ;
+USING: assembler compiler compiler-backend errors generic
+inference kernel lists math namespaces sequences stdio strings
+unparser words ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler io-internals kernel
-lists namespaces parser sequences stdio unparser words ;
+lists math namespaces parser sequences stdio unparser words ;
"Compiling base..." print
compile? [
\ car compile
+ \ * compile
\ length compile
\ = compile
\ unparse compile
! Copyright (C) 2004, 2005 Slava Pestov.
IN: compiler
-USING: errors inference kernel lists namespaces prettyprint
-stdio words ;
+USING: compiler-backend compiler-frontend errors inference
+kernel lists namespaces prettyprint stdio words ;
: supported-cpu? ( -- ? )
cpu "unknown" = not ;
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler errors inference kernel lists math namespaces
-sequences strings vectors words ;
+IN: compiler-backend
+USING: assembler compiler errors inference kernel lists math
+namespaces sequences strings vectors words ;
+
+! Compile a VOP.
+GENERIC: generate-node ( vop -- )
: generate-code ( word linear -- length )
compiled-offset >r
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler generic hashtables inference kernel
-kernel-internals lists math math-internals namespaces sequences
-words ;
+IN: compiler-frontend
+USING: assembler compiler-backend generic hashtables inference
+kernel kernel-internals lists math math-internals namespaces
+sequences words ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
[[ fixnum< %fixnum< ]]
[[ fixnum>= %fixnum>= ]]
[[ fixnum> %fixnum> ]]
+ [[ eq? %eq? ]]
] [
uncons over intrinsic
[ literal, 0 , \ binary-op , ] make-list
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: inference kernel lists math namespaces words strings
-errors prettyprint kernel-internals ;
+IN: compiler-frontend
+USING: compiler-backend inference kernel lists math namespaces
+words strings errors prettyprint kernel-internals ;
: >linear ( node -- )
#! Dataflow OPs have a linearizer word property. This
#! rest is arguments.
[ %prologue , (linearize) ] make-list ;
-: <label> ( -- label )
- gensym dup t "label" set-word-prop ;
-
-: label? ( obj -- ? )
- dup word? [ "label" word-prop ] [ drop f ] ifte ;
-
: linearize-simple-label ( node -- )
#! Some labels become simple labels after the optimization
#! stage.
#! not contain non-tail recursive calls to itself.
<label> dup %return-to , >r
linearize-simple-label
- %return ,
+ f %return ,
r> %label , ;
#label [
#values [ drop ] "linearizer" set-word-prop
-#return [ drop %return , ] "linearizer" set-word-prop
+#return [ drop f %return , ] "linearizer" set-word-prop
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-frontend
USING: inference kernel kernel-internals lists namespaces
sequences vectors words words ;
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: inference kernel lists math namespaces prettyprint
-strings words ;
+IN: compiler-backend
+USING: generic inference kernel lists math namespaces
+prettyprint strings words ;
-: simplify ;
+! A peephole optimizer operating on the linear IR.
! The linear IR being simplified is stored in this variable.
-! SYMBOL: simplifying
-!
-! : simplifiers ( linear -- list )
-! #! A list of quotations with stack effect
-! #! ( linear -- linear ? ) that can simplify the first node
-! #! in the linear IR.
-! car car "simplifiers" word-prop ;
-!
-! : simplify-node ( linear list -- linear ? )
-! dup [
-! uncons >r call [
-! r> drop t
-! ] [
-! r> simplify-node
-! ] ifte
-! ] when ;
-!
-! : simplify-1 ( linear -- linear ? )
-! #! Return a new linear IR.
-! dup [
-! dup simplifiers simplify-node
-! [ uncons simplify-1 drop cons t ]
-! [ uncons simplify-1 >r cons r> ] ifte
-! ] [
-! f
-! ] ifte ;
-!
-! : simplify ( linear -- linear )
-! #! Keep simplifying until simplify-1 returns f.
-! [
-! dup simplifying set simplify-1
-! ] with-scope [ simplify ] when ;
-!
-! : label-called? ( label linear -- ? )
-! [ uncons pick = swap #label = not and ] some? nip ;
-!
-! #label [
-! [
-! dup car cdr simplifying get label-called?
-! [ f ] [ cdr t ] ifte
-! ]
-! ] "simplifiers" set-word-prop
-!
-! : next-physical? ( op linear -- ? )
-! cdr dup [ car car = ] [ 2drop f ] ifte ;
-!
-! : cancel ( linear op -- linear param ? )
-! #! If the following op is as given, remove it, and return
-! #! its param.
-! over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
-!
-! \ drop [
-! [
-! #push-immediate cancel [
-! #replace-immediate swons swons t
-! ] when
-! ] [
-! #push-indirect cancel [
-! #replace-indirect swons swons t
-! ] when
-! ]
-! ] "simplifiers" set-word-prop
-!
-! : find-label ( label -- rest )
-! simplifying get [
-! uncons pick = swap #label = and
-! ] some? nip ;
-!
-! : next-logical ( linear -- linear )
-! dup car car "next-logical" word-prop call ;
-!
-! #label [
-! cdr next-logical
-! ] "next-logical" set-word-prop
-!
-! #jump-label [
-! car cdr find-label cdr
-! ] "next-logical" set-word-prop
-!
-! #target-label [
-! car cdr find-label cdr
-! ] "next-logical" set-word-prop
-!
-! : next-logical? ( op linear -- ? )
-! next-logical dup [ car car = ] [ 2drop f ] ifte ;
-!
-! : reduce ( linear op new -- linear ? )
-! >r over cdr next-logical? [
-! unswons cdr r> swons swons t
-! ] [
-! r> drop f
-! ] ifte ;
-!
-! #call [
-! [ #return #jump reduce ]
-! ] "simplifiers" set-word-prop
-!
-! #call-label [
-! [ #return #jump-label reduce ]
-! ] "simplifiers" set-word-prop
-!
-! : double-jump ( linear op1 op2 -- linear ? )
-! #! A jump to a jump is just a jump. If the next logical node
-! #! is a jump of type op1, replace the jump at the car of the
-! #! list with a jump of type op2.
-! swap pick next-logical? [
-! over next-logical car cdr cons swap cdr cons t
-! ] [
-! drop f
-! ] ifte ;
-!
-! : useless-jump ( linear -- linear ? )
-! #! A jump to a label immediately following is not needed.
-! dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
-!
-! : (dead-code) ( linear -- linear ? )
-! #! Remove all nodes until the next #label.
-! dup [
-! dup car car #label = [
-! f
-! ] [
-! cdr (dead-code) t or
-! ] ifte
-! ] [
-! f
-! ] ifte ;
-!
-! : dead-code ( linear -- linear ? )
-! uncons (dead-code) >r cons r> ;
+SYMBOL: simplifying
+
+GENERIC: simplify-node ( linear vop -- linear ? )
+
+! The next node following this node in terms of control flow, or
+! f if this is a conditional.
+GENERIC: next-logical ( linear vop -- linear )
+
+! No delegation.
+M: tuple simplify-node drop f ;
+
+: simplify-1 ( list -- list ? )
+ #! Return a new linear IR.
+ dup [
+ dup car simplify-node
+ [ uncons simplify-1 drop cons t ]
+ [ uncons simplify-1 >r cons r> ] ifte
+ ] [
+ f
+ ] ifte ;
+
+: simplify ( linear -- linear )
+ #! Keep simplifying until simplify-1 returns f.
+ [
+ dup simplifying set simplify-1
+ ] with-scope [ simplify ] when ;
+
+: label-called? ( label -- ? )
+ simplifying get [ calls-label? ] some-with? ;
+
+M: %label simplify-node ( linear vop -- linear ? )
+ vop-label label-called? [ f ] [ cdr t ] ifte ;
+
+: next-physical? ( linear class -- vop ? )
+ #! If the following op has given class, remove it and
+ #! return it.
+ over cdr dup [
+ car class = [ cdr car t ] [ f ] ifte
+ ] [
+ 3drop f f
+ ] ifte ;
+
+M: %inc-d simplify-node ( linear vop -- linear ? )
+ #! %inc-d cancels a following %inc-d.
+ >r dup \ %inc-d next-physical? [
+ vop-literal r> vop-literal + dup 0 = [
+ drop cdr cdr f
+ ] [
+ %inc-d >r cdr cdr r> swons t
+ ] ifte
+ ] [
+ r> 2drop f
+ ] ifte ;
+
+: dead-load? ( linear vop -- ? )
+ #! Is the %replace-d followed by a %peek-d of the same
+ #! stack slot and vreg?
+ swap cdr car dup %peek-d? [
+ over vop-source over vop-dest = >r
+ swap vop-literal swap vop-literal = r> and
+ ] [
+ 2drop f
+ ] ifte ;
+
+: dead-store? ( linear n -- ? )
+ #! Is the %replace-d followed by a %dec-d, so the stored
+ #! value is lost?
+ swap \ %inc-d next-physical? [
+ vop-literal + 0 <
+ ] [
+ 2drop f
+ ] ifte ;
+
+M: %replace-d simplify-node ( linear vop -- linear ? )
+ 2dup dead-load? [
+ drop uncons cdr cons t
+ ] [
+ 2dup vop-literal dead-store? [
+ drop cdr t
+ ] [
+ drop f
+ ] ifte
+ ] ifte ;
+
+M: %immediate-d simplify-node ( linear vop -- linear ? )
+ over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
+
+: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
+
+: can-fast-branch? ( linear -- ? )
+ unswons class fast-branch [
+ unswons pop? [ car %jump-t? ] [ drop f ] ifte
+ ] [
+ drop f
+ ] ifte ;
+
+: fast-branch-params ( linear -- src dest label linear )
+ uncons >r dup vop-source swap vop-dest r> cdr
+ uncons >r vop-label r> ;
+
+M: %fixnum<= simplify-node ( linear vop -- linear ? )
+ drop dup can-fast-branch? [
+ fast-branch-params >r
+ %jump-fixnum<= >r -1 %inc-d r>
+ r> cons cons t
+ ] [
+ f
+ ] ifte ;
+
+M: %eq? simplify-node ( linear vop -- linear ? )
+ drop dup can-fast-branch? [
+ fast-branch-params >r
+ %jump-eq? >r -1 %inc-d r>
+ r> cons cons t
+ ] [
+ f
+ ] ifte ;
+
+: find-label ( label -- rest )
+ simplifying get [
+ dup %label? [ vop-label = ] [ 2drop f ] ifte
+ ] some-with? ;
+
+M: %label next-logical ( linear vop -- linear )
+ drop cdr dup car next-logical ;
+
+M: %jump-label next-logical ( linear vop -- linear )
+ nip vop-label find-label cdr ;
+
+M: %target-label next-logical ( linear vop -- linear )
+ nip vop-label find-label cdr ;
+
+M: object next-logical ( linear vop -- linear )
+ drop ;
+
+: next-logical? ( op linear -- ? )
+ dup car next-logical dup [ car class = ] [ 2drop f ] ifte ;
+
+: reduce ( linear op new -- linear ? )
+ >r over cdr next-logical? [
+ dup car vop-label
+ r> execute swap cdr cons t
+ ] [
+ r> drop f
+ ] ifte ; inline
+
+M: %call simplify-node ( linear vop -- ? )
+ #! Tail call optimization.
+ drop \ %return \ %jump reduce ;
+
+M: %call-label simplify-node ( linear vop -- ? )
+ #! Tail call optimization.
+ drop \ %return \ %jump-label reduce ;
+
+: double-jump ( linear op2 op1 -- linear ? )
+ #! A jump to a jump is just a jump. If the next logical node
+ #! is a jump of type op1, replace the jump at the car of the
+ #! list with a jump of type op2.
+ pick next-logical? [
+ >r dup dup car next-logical car vop-label
+ r> execute swap cdr cons t
+ ] [
+ drop f
+ ] ifte ; inline
+
+: useless-jump ( linear -- linear ? )
+ #! A jump to a label immediately following is not needed.
+ dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
+
+: (dead-code) ( linear -- linear ? )
+ #! Remove all nodes until the next #label.
+ dup [
+ dup car %label? [
+ f
+ ] [
+ cdr (dead-code) t or
+ ] ifte
+ ] [
+ f
+ ] ifte ;
+
+: dead-code ( linear -- linear ? )
+ uncons (dead-code) >r cons r> ;
+
+M: %jump-label simplify-node ( linear vop -- ? )
+ drop
+ \ %return dup double-jump [
+ t
+ ] [
+ \ %jump-label dup double-jump [
+ t
+ ] [
+ \ %jump dup double-jump
+ ! [
+ ! t
+ ! ] [
+ ! useless-jump [
+ ! t
+ ! ] [
+ ! dead-code
+ ! ] ifte
+ ! ] ifte
+ ] ifte
+ ] ifte ;
+
!
! #jump-label [
! [ #return #return double-jump ]
! ] "simplifiers" set-word-prop
!
! #target-label [
-! [ #jump-label #target-label double-jump ]
-! ! [ #jump #target double-jump ]
+! [ #target-label #jump-label double-jump ]
+! ! [ #target #jump double-jump ]
! ] "simplifiers" set-word-prop
!
! #jump [ [ dead-code ] ] "simplifiers" set-word-prop
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: errors generic kernel namespaces parser ;
+IN: compiler-backend
+USING: errors generic hashtables kernel math namespaces parser
+words ;
! The linear IR is the second of the two intermediate
! representations used by Factor. It is basically a high-level
! This file defines all the types of VOPs. A linear IR program
! is then just a list of VOPs.
+: <label> ( -- label )
+ #! Make a label.
+ gensym dup t "label" set-word-prop ;
+
+: label? ( obj -- ? )
+ dup word? [ "label" word-prop ] [ drop f ] ifte ;
+
! A virtual register
TUPLE: vreg n ;
! A virtual operation
TUPLE: vop source dest literal label ;
-! Compile a VOP.
-GENERIC: generate-node ( vop -- )
+GENERIC: calls-label? ( label vop -- ? )
+
+M: vop calls-label? vop-label = ;
: make-vop ( source dest literal label vop -- vop )
[ >r <vop> r> set-delegate ] keep ;
: %prologue empty-vop <%prologue> ;
VOP: %label
: %label label-vop <%label> ;
+M: %label calls-label? 2drop f ;
+
+! Return vops take a label that is ignored, to have the
+! same stack effect as jumps. This is needed for the
+! simplifier.
VOP: %return
-: %return empty-vop <%return> ;
+: %return ( label) label-vop <%return> ;
+
VOP: %return-to
: %return-to label-vop <%return-to> ;
VOP: %jump
! stack operations
VOP: %peek-d
: %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
-VOP: %dec-d
-: %dec-d ( n -- ) literal-vop <%dec-d> ;
VOP: %replace-d
: %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
VOP: %inc-d
: %inc-d ( n -- ) literal-vop <%inc-d> ;
+: %dec-d ( n -- ) neg %inc-d ;
VOP: %immediate
VOP: %immediate-d
: %immediate-d ( obj -- ) literal-vop <%immediate-d> ;
VOP: %peek-r
: %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
-VOP: %dec-r
-: %dec-r ( n -- ) literal-vop <%dec-r> ;
VOP: %replace-r
: %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
VOP: %inc-r
: %inc-r ( n -- ) literal-vop <%inc-r> ;
+! this exists, unlike %dec-d which does not, due to x86 quirks
+VOP: %dec-r
+: %dec-r ( n -- ) literal-vop <%dec-r> ;
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
VOP: %fixnum-bitnot : %fixnum-bitnot <vreg> dest-vop <%fixnum-bitnot> ;
VOP: %fixnum-shift : %fixnum-shift src/dest-vop <%fixnum-shift> ;
+
VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ;
-
VOP: %eq? : %eq? src/dest-vop <%eq?> ;
+VOP: %jump-fixnum<= : %jump-fixnum<= f swap <%jump-fixnum<=> ;
+VOP: %jump-fixnum< : %jump-fixnum< f swap <%jump-fixnum<> ;
+VOP: %jump-fixnum>= : %jump-fixnum>= f swap <%jump-fixnum>=> ;
+VOP: %jump-fixnum> : %jump-fixnum> f swap <%jump-fixnum>> ;
+VOP: %jump-eq? : %jump-eq? f swap <%jump-eq?> ;
+
+: fast-branch ( class -- class )
+ {{
+ [[ %fixnum<= %jump-fixnum<= ]]
+ [[ %fixnum< %jump-fixnum< ]]
+ [[ %fixnum>= %jump-fixnum>= ]]
+ [[ %fixnum> %jump-fixnum> ]]
+ [[ %eq? %jump-eq? ]]
+ }} hash ;
+
! some slightly optimized inline assembly
VOP: %type
: %type ( vreg ) <vreg> dest-vop <%type> ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
USING: alien assembler inference kernel kernel-internals lists
math memory namespaces words ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler errors kernel math math-internals memory
-namespaces words ;
+IN: compiler-backend
+USING: assembler compiler errors kernel math math-internals
+memory namespaces words ;
: simple-overflow ( dest -- )
#! If the previous arithmetic operation overflowed, then we
M: %eq? generate-node ( vop -- )
fixnum-compare \ JE conditional ;
+
+: fixnum-branch ( vop -- label )
+ dup vop-dest v>operand over vop-source v>operand CMP
+ vop-label ;
+
+M: %jump-fixnum< generate-node ( vop -- )
+ fixnum-branch JL ;
+
+M: %jump-fixnum<= generate-node ( vop -- )
+ fixnum-branch JLE ;
+
+M: %jump-fixnum> generate-node ( vop -- )
+ fixnum-branch JG ;
+
+M: %jump-fixnum>= generate-node ( vop -- )
+ fixnum-branch JGE ;
+
+M: %jump-eq? generate-node ( vop -- )
+ fixnum-branch JE ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien assembler inference kernel kernel-internals lists
-math memory namespaces sequences words ;
+IN: compiler-backend
+USING: alien assembler compiler inference kernel
+kernel-internals lists math memory namespaces sequences words ;
GENERIC: v>operand
M: integer v>operand address ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien assembler inference kernel lists math memory
-sequences words ;
+IN: compiler-backend
+USING: alien assembler compiler inference kernel lists math
+memory sequences words ;
: rel-cs ( -- )
#! Add an entry to the relocation table for the 32-bit
M: %peek-d generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal ds-op MOV ;
-M: %dec-d generate-node ( vop -- )
- vop-literal ESI swap cell * SUB ;
-
M: %replace-d generate-node ( vop -- )
dup vop-source v>operand swap vop-literal ds-op swap MOV ;
M: %inc-d generate-node ( vop -- )
- vop-literal ESI swap cell * ADD ;
+ ESI swap vop-literal cell *
+ dup 0 > [ ADD ] [ neg SUB ] ifte ;
M: %immediate generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal address MOV ;
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
- dup predicate-word swap [ swap class eq? ] cons
- define-compound ;
+ dup predicate-word swap [
+ literal, [ swap class eq? ] %
+ ] make-list define-compound ;
: check-shape ( word slots -- )
#! If the new list of slots is different from the previous,
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
-USING: errors generic interpreter kernel lists math namespaces
-sequences strings vectors words hashtables parser prettyprint ;
+USING: errors generic interpreter kernel lists math
+math-internals namespaces sequences strings vectors words
+hashtables parser prettyprint ;
: with-dataflow ( param op [[ in# out# ]] quot -- )
#! Take input parameters, execute quotation, take output
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
+\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
+\ <= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
+\ < [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
+\ >= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
+\ > [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
+\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
+\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
+\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
compiled
[ 9227465 ] [ 34 fib ] unit-test
+
+TUPLE: box i ;
+
+: tuple-fib ( n -- n )
+ dup box-i 1 <= [
+ drop 1 <box>
+ ] [
+ box-i 1 - <box>
+ dup tuple-fib
+ swap
+ box-i 1 - <box>
+ tuple-fib
+ swap box-i swap box-i + <box>
+ ] ifte ; compiled
+
+[ << box f 9227465 ] [ << box f 34 >> tuple-fib ] unit-test
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
+[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test
+[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
+[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test
point-x
] unit-test
+
+TUPLE: predicate-test ;
+: predicate-test drop f ;
+
+[ t ] [ <predicate-test> predicate-test? ] unit-test
projects / factor.git / commitdiff