Merge branch 'master' of git://factorcode.org/git/factor
						commit
						478b960560
					
				| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: alarms.tests
 | 
			
		||||
USING: alarms alarms.private kernel calendar sequences
 | 
			
		||||
tools.test threads concurrency.count-downs ;
 | 
			
		||||
IN: alarms.tests
 | 
			
		||||
 | 
			
		||||
[ ] [
 | 
			
		||||
    1 <count-down>
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors arrays calendar combinators generic init
 | 
			
		||||
kernel math namespaces sequences heaps boxes threads
 | 
			
		||||
quotations assocs math.order ;
 | 
			
		||||
USING: accessors assocs boxes calendar
 | 
			
		||||
combinators.short-circuit fry heaps init kernel math.order
 | 
			
		||||
namespaces quotations threads ;
 | 
			
		||||
IN: alarms
 | 
			
		||||
 | 
			
		||||
TUPLE: alarm
 | 
			
		||||
| 
						 | 
				
			
			@ -21,21 +21,21 @@ SYMBOL: alarm-thread
 | 
			
		|||
 | 
			
		||||
ERROR: bad-alarm-frequency frequency ;
 | 
			
		||||
: check-alarm ( frequency/f -- frequency/f )
 | 
			
		||||
    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
 | 
			
		||||
    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
 | 
			
		||||
 | 
			
		||||
: <alarm> ( quot time frequency -- alarm )
 | 
			
		||||
    check-alarm <box> alarm boa ;
 | 
			
		||||
 | 
			
		||||
: register-alarm ( alarm -- )
 | 
			
		||||
    dup dup time>> alarms get-global heap-push*
 | 
			
		||||
    swap entry>> >box
 | 
			
		||||
    [ dup time>> alarms get-global heap-push* ]
 | 
			
		||||
    [ entry>> >box ] bi
 | 
			
		||||
    notify-alarm-thread ;
 | 
			
		||||
 | 
			
		||||
: alarm-expired? ( alarm now -- ? )
 | 
			
		||||
    [ time>> ] dip before=? ;
 | 
			
		||||
 | 
			
		||||
: reschedule-alarm ( alarm -- )
 | 
			
		||||
    dup [ swap interval>> time+ now max ] change-time register-alarm ;
 | 
			
		||||
    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
 | 
			
		||||
 | 
			
		||||
: call-alarm ( alarm -- )
 | 
			
		||||
    [ entry>> box> drop ]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: alien.c-types.tests
 | 
			
		||||
USING: alien alien.syntax alien.c-types kernel tools.test
 | 
			
		||||
sequences system libc alien.strings io.encodings.utf8 ;
 | 
			
		||||
IN: alien.c-types.tests
 | 
			
		||||
 | 
			
		||||
CONSTANT: xyz 123
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -10,4 +10,4 @@ IN: alien.complex
 | 
			
		|||
! This overrides the fact that small structures are never returned
 | 
			
		||||
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
 | 
			
		||||
"complex-float" c-type t >>return-in-registers? drop
 | 
			
		||||
 >>
 | 
			
		||||
>>
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +0,0 @@
 | 
			
		|||
! Copyright (C) 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: tools.test alien.complex.functor ;
 | 
			
		||||
IN: alien.complex.functor.tests
 | 
			
		||||
| 
						 | 
				
			
			@ -1,4 +0,0 @@
 | 
			
		|||
! Copyright (C) 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: tools.test alien.destructors ;
 | 
			
		||||
IN: alien.destructors.tests
 | 
			
		||||
| 
						 | 
				
			
			@ -357,10 +357,10 @@ M: character-type (<fortran-result>)
 | 
			
		|||
 | 
			
		||||
: (shuffle-map) ( return parameters -- ret par )
 | 
			
		||||
    [
 | 
			
		||||
        fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
 | 
			
		||||
        fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
 | 
			
		||||
        letters swap head [ "ret" swap suffix ] map
 | 
			
		||||
    ] [
 | 
			
		||||
        [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
 | 
			
		||||
        [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
 | 
			
		||||
        [ first2 letters swap head [ "" 2sequence ] with map ] map concat
 | 
			
		||||
    ] bi* ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: alien.libraries.tests
 | 
			
		||||
USING: alien.libraries alien.syntax tools.test kernel ;
 | 
			
		||||
IN: alien.libraries.tests
 | 
			
		||||
 | 
			
		||||
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -7,4 +7,4 @@ USING: alien.libraries alien.syntax tools.test kernel ;
 | 
			
		|||
 | 
			
		||||
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
 | 
			
		||||
 | 
			
		||||
[ "fdasfsf" dll-valid? drop ] must-fail
 | 
			
		||||
[ "fdasfsf" dll-valid? drop ] must-fail
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: alien.structs.tests
 | 
			
		||||
USING: alien alien.syntax alien.c-types kernel tools.test
 | 
			
		||||
sequences system libc words vocabs namespaces layouts ;
 | 
			
		||||
IN: alien.structs.tests
 | 
			
		||||
 | 
			
		||||
C-STRUCT: bar
 | 
			
		||||
    { "int" "x" }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -31,8 +31,10 @@ SYNTAX: C-ENUM:
 | 
			
		|||
    ";" parse-tokens
 | 
			
		||||
    [ [ create-in ] dip define-constant ] each-index ;
 | 
			
		||||
 | 
			
		||||
ERROR: no-such-symbol name library ;
 | 
			
		||||
 | 
			
		||||
: address-of ( name library -- value )
 | 
			
		||||
    load-library dlsym [ "No such symbol" throw ] unless* ;
 | 
			
		||||
    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
 | 
			
		||||
 | 
			
		||||
SYNTAX: &:
 | 
			
		||||
    scan "c-library" get '[ _ _ address-of ] over push-all ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -10,7 +10,7 @@ IN: ascii.tests
 | 
			
		|||
 | 
			
		||||
[ 4 ] [
 | 
			
		||||
    0 "There are Four Upper Case characters"
 | 
			
		||||
    [ LETTER? [ 1+ ] when ] each
 | 
			
		||||
    [ LETTER? [ 1 + ] when ] each
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -34,7 +34,7 @@ SYMBOL: column
 | 
			
		|||
: write1-lines ( ch -- )
 | 
			
		||||
    write1
 | 
			
		||||
    column get [
 | 
			
		||||
        1+ [ 76 = [ crlf ] when ]
 | 
			
		||||
        1 + [ 76 = [ crlf ] when ]
 | 
			
		||||
        [ 76 mod column set ] bi
 | 
			
		||||
    ] when* ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -48,7 +48,7 @@ SYMBOL: column
 | 
			
		|||
 | 
			
		||||
: encode-pad ( seq n -- )
 | 
			
		||||
    [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
 | 
			
		||||
    [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 | 
			
		||||
    [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 | 
			
		||||
 | 
			
		||||
: decode4 ( seq -- )
 | 
			
		||||
    [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: biassocs.tests
 | 
			
		||||
USING: biassocs assocs namespaces tools.test ;
 | 
			
		||||
IN: biassocs.tests
 | 
			
		||||
 | 
			
		||||
<bihash> "h" set
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -29,4 +29,4 @@ H{ { "a" "A" } { "b" "B" } } "a" set
 | 
			
		|||
 | 
			
		||||
[ "A" ] [ "a" "b" get at ] unit-test
 | 
			
		||||
 | 
			
		||||
[ "a" ] [ "A" "b" get value-at ] unit-test
 | 
			
		||||
[ "a" ] [ "A" "b" get value-at ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: binary-search.tests
 | 
			
		||||
USING: binary-search math.order vectors kernel tools.test ;
 | 
			
		||||
IN: binary-search.tests
 | 
			
		||||
 | 
			
		||||
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
 | 
			
		||||
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
 | 
			
		|||
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 | 
			
		||||
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
 | 
			
		||||
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
 | 
			
		||||
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
 | 
			
		||||
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
 | 
			
		||||
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
 | 
			
		||||
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
 | 
			
		||||
[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
 | 
			
		||||
[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
 | 
			
		|||
    dup 0 = [
 | 
			
		||||
        <bit-array>
 | 
			
		||||
    ] [
 | 
			
		||||
        [ log2 1+ <bit-array> 0 ] keep
 | 
			
		||||
        [ log2 1 + <bit-array> 0 ] keep
 | 
			
		||||
        [ dup 0 = ] [
 | 
			
		||||
            [ pick underlying>> pick set-alien-unsigned-1 ] keep
 | 
			
		||||
            [ 1+ ] [ -8 shift ] bi*
 | 
			
		||||
            [ 1 + ] [ -8 shift ] bi*
 | 
			
		||||
        ] until 2drop
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: bit-sets.tests
 | 
			
		||||
USING: bit-sets tools.test bit-arrays ;
 | 
			
		||||
IN: bit-sets.tests
 | 
			
		||||
 | 
			
		||||
[ ?{ t f t f t f } ] [
 | 
			
		||||
    ?{ t f f f t f }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: bit-vectors.tests
 | 
			
		||||
USING: tools.test bit-vectors vectors sequences kernel math ;
 | 
			
		||||
IN: bit-vectors.tests
 | 
			
		||||
 | 
			
		||||
[ 0 ] [ 123 <bit-vector> length ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 | 
			
		|||
io.streams.byte-array ;
 | 
			
		||||
IN: bitstreams.tests
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
[ BIN: 1111111111 ]
 | 
			
		||||
[
 | 
			
		||||
    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- )
 | 
			
		|||
    [ get-abp + ] [ set-abp ] bi ; inline
 | 
			
		||||
    
 | 
			
		||||
: (align) ( n m -- n' )
 | 
			
		||||
    [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
 | 
			
		||||
    [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
 | 
			
		||||
    
 | 
			
		||||
: align ( n bitstream -- )
 | 
			
		||||
    [ get-abp swap (align) ] [ set-abp ] bi ; inline
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -74,7 +74,7 @@ nl
 | 
			
		|||
"." write flush
 | 
			
		||||
 | 
			
		||||
{
 | 
			
		||||
    + 1+ 1- 2/ < <= > >= shift
 | 
			
		||||
    + 2/ < <= > >= shift
 | 
			
		||||
} compile-unoptimized
 | 
			
		||||
 | 
			
		||||
"." write flush
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: bootstrap.image.tests
 | 
			
		||||
USING: bootstrap.image bootstrap.image.private tools.test
 | 
			
		||||
kernel math ;
 | 
			
		||||
IN: bootstrap.image.tests
 | 
			
		||||
 | 
			
		||||
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -234,7 +234,7 @@ GENERIC: ' ( obj -- ptr )
 | 
			
		|||
 | 
			
		||||
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 | 
			
		||||
 | 
			
		||||
: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
 | 
			
		||||
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 | 
			
		||||
 | 
			
		||||
: bignum>seq ( n -- seq )
 | 
			
		||||
    #! n is positive or zero.
 | 
			
		||||
| 
						 | 
				
			
			@ -244,7 +244,7 @@ GENERIC: ' ( obj -- ptr )
 | 
			
		|||
 | 
			
		||||
: emit-bignum ( n -- )
 | 
			
		||||
    dup dup 0 < [ neg ] when bignum>seq
 | 
			
		||||
    [ nip length 1+ emit-fixnum ]
 | 
			
		||||
    [ nip length 1 + emit-fixnum ]
 | 
			
		||||
    [ drop 0 < 1 0 ? emit ]
 | 
			
		||||
    [ nip emit-seq ]
 | 
			
		||||
    2tri ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -9,9 +9,9 @@ IN: bootstrap.image.upload
 | 
			
		|||
SYMBOL: upload-images-destination
 | 
			
		||||
 | 
			
		||||
: destination ( -- dest )
 | 
			
		||||
  upload-images-destination get
 | 
			
		||||
  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
 | 
			
		||||
  or ;
 | 
			
		||||
    upload-images-destination get
 | 
			
		||||
    "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
 | 
			
		||||
    or ;
 | 
			
		||||
 | 
			
		||||
: checksums ( -- temp ) "checksums.txt" temp-file ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ;
 | 
			
		|||
 | 
			
		||||
"math.ratios" require
 | 
			
		||||
"math.floats" require
 | 
			
		||||
"math.complex" require
 | 
			
		||||
"math.complex" require
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: boxes.tests
 | 
			
		||||
USING: boxes namespaces tools.test accessors ;
 | 
			
		||||
IN: boxes.tests
 | 
			
		||||
 | 
			
		||||
[ ] [ <box> "b" set ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -8,4 +8,3 @@ SYNTAX: HEX{
 | 
			
		|||
    [ blank? not ] filter
 | 
			
		||||
    2 group [ hex> ] B{ } map-as
 | 
			
		||||
    parsed ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +0,0 @@
 | 
			
		|||
! Copyright (C) 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: tools.test cache ;
 | 
			
		||||
IN: cache.tests
 | 
			
		||||
| 
						 | 
				
			
			@ -38,6 +38,6 @@ PRIVATE>
 | 
			
		|||
 | 
			
		||||
: purge-cache ( cache -- )
 | 
			
		||||
    dup max-age>> '[
 | 
			
		||||
        [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
 | 
			
		||||
        [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
 | 
			
		||||
        [ values dispose-each ] dip
 | 
			
		||||
    ] change-assoc drop ;
 | 
			
		||||
    ] change-assoc drop ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
IN: cairo.tests
 | 
			
		||||
USING: cairo tools.test math.rectangles accessors ;
 | 
			
		||||
IN: cairo.tests
 | 
			
		||||
 | 
			
		||||
[ { 10 20 } ] [
 | 
			
		||||
    { 10 20 } [
 | 
			
		||||
        { 0 1 } { 3 4 } <rect> fill-rect
 | 
			
		||||
    ] make-bitmap-image dim>>
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -34,14 +34,14 @@ C: <timestamp> timestamp
 | 
			
		|||
: <date> ( year month day -- timestamp )
 | 
			
		||||
    0 0 0 gmt-offset-duration <timestamp> ;
 | 
			
		||||
 | 
			
		||||
ERROR: not-a-month n ;
 | 
			
		||||
ERROR: not-a-month ;
 | 
			
		||||
M: not-a-month summary
 | 
			
		||||
    drop "Months are indexed starting at 1" ;
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
: check-month ( n -- n )
 | 
			
		||||
    dup zero? [ not-a-month ] when ;
 | 
			
		||||
    [ not-a-month ] when-zero ;
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -52,7 +52,7 @@ CONSTANT: month-names
 | 
			
		|||
    }
 | 
			
		||||
 | 
			
		||||
: month-name ( n -- string )
 | 
			
		||||
    check-month 1- month-names nth ;
 | 
			
		||||
    check-month 1 - month-names nth ;
 | 
			
		||||
 | 
			
		||||
CONSTANT: month-abbreviations
 | 
			
		||||
    {
 | 
			
		||||
| 
						 | 
				
			
			@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
 | 
			
		|||
    }
 | 
			
		||||
 | 
			
		||||
: month-abbreviation ( n -- string )
 | 
			
		||||
    check-month 1- month-abbreviations nth ;
 | 
			
		||||
    check-month 1 - month-abbreviations nth ;
 | 
			
		||||
 | 
			
		||||
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
 | 
			
		|||
    100 b * d + 4800 -
 | 
			
		||||
    m 10 /i + m 3 +
 | 
			
		||||
    12 m 10 /i * -
 | 
			
		||||
    e 153 m * 2 + 5 /i - 1+ ;
 | 
			
		||||
    e 153 m * 2 + 5 /i - 1 + ;
 | 
			
		||||
 | 
			
		||||
GENERIC: easter ( obj -- obj' )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
 | 
			
		|||
    { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
 | 
			
		||||
    [ 3 >>month 1 >>day ] when ;
 | 
			
		||||
 | 
			
		||||
: unless-zero ( n quot -- )
 | 
			
		||||
    [ dup zero? [ drop ] ] dip if ; inline
 | 
			
		||||
 | 
			
		||||
M: integer +year ( timestamp n -- timestamp )
 | 
			
		||||
    [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
 | 
			
		|||
    [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
 | 
			
		||||
 | 
			
		||||
: months/years ( n -- months years )
 | 
			
		||||
    12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
 | 
			
		||||
    12 /rem [ 1 - 12 ] when-zero swap ; inline
 | 
			
		||||
 | 
			
		||||
M: integer +month ( timestamp n -- timestamp )
 | 
			
		||||
    [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
 | 
			
		||||
| 
						 | 
				
			
			@ -371,10 +368,10 @@ M: duration time-
 | 
			
		|||
    #! http://web.textfiles.com/computers/formulas.txt
 | 
			
		||||
    #! good for any date since October 15, 1582
 | 
			
		||||
    [
 | 
			
		||||
        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
 | 
			
		||||
        dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
 | 
			
		||||
        [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
 | 
			
		||||
        [ 1+ 3 * 5 /i + ] keep 2 * +
 | 
			
		||||
    ] dip 1+ + 7 mod ;
 | 
			
		||||
        [ 1 + 3 * 5 /i + ] keep 2 * +
 | 
			
		||||
    ] dip 1 + + 7 mod ;
 | 
			
		||||
 | 
			
		||||
GENERIC: days-in-year ( obj -- n )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 | 
			
		|||
    year leap-year? [
 | 
			
		||||
        year month day <date>
 | 
			
		||||
        year 3 1 <date>
 | 
			
		||||
        after=? [ 1+ ] when
 | 
			
		||||
        after=? [ 1 + ] when
 | 
			
		||||
    ] when ;
 | 
			
		||||
 | 
			
		||||
: day-of-year ( timestamp -- n )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -68,8 +68,8 @@ M: array month. ( pair -- )
 | 
			
		|||
    [ (days-in-month) day-abbreviations2 " " join print ] 2tri
 | 
			
		||||
    over "   " <repetition> concat write
 | 
			
		||||
    [
 | 
			
		||||
        [ 1+ day. ] keep
 | 
			
		||||
        1+ + 7 mod zero? [ nl ] [ bl ] if
 | 
			
		||||
        [ 1 + day. ] keep
 | 
			
		||||
        1 + + 7 mod zero? [ nl ] [ bl ] if
 | 
			
		||||
    ] with each nl ;
 | 
			
		||||
 | 
			
		||||
M: timestamp month. ( timestamp -- )
 | 
			
		||||
| 
						 | 
				
			
			@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
 | 
			
		|||
GENERIC: year. ( obj -- )
 | 
			
		||||
 | 
			
		||||
M: integer year. ( n -- )
 | 
			
		||||
    12 [ 1+ 2array month. nl ] with each ;
 | 
			
		||||
    12 [ 1 + 2array month. nl ] with each ;
 | 
			
		||||
 | 
			
		||||
M: timestamp year. ( timestamp -- )
 | 
			
		||||
    year>> year. ;
 | 
			
		||||
| 
						 | 
				
			
			@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
 | 
			
		|||
        "," read-token day-abbreviations3 member? check-timestamp drop
 | 
			
		||||
        read1 CHAR: \s assert=
 | 
			
		||||
        read-sp checked-number >>day
 | 
			
		||||
        read-sp month-abbreviations index 1+ check-timestamp >>month
 | 
			
		||||
        read-sp month-abbreviations index 1 + check-timestamp >>month
 | 
			
		||||
        read-sp checked-number >>year
 | 
			
		||||
        ":" read-token checked-number >>hour
 | 
			
		||||
        ":" read-token checked-number >>minute
 | 
			
		||||
| 
						 | 
				
			
			@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
 | 
			
		|||
        "," read-token check-day-name
 | 
			
		||||
        read1 CHAR: \s assert=
 | 
			
		||||
        "-" read-token checked-number >>day
 | 
			
		||||
        "-" read-token month-abbreviations index 1+ check-timestamp >>month
 | 
			
		||||
        "-" read-token month-abbreviations index 1 + check-timestamp >>month
 | 
			
		||||
        read-sp checked-number >>year
 | 
			
		||||
        ":" read-token checked-number >>hour
 | 
			
		||||
        ":" read-token checked-number >>minute
 | 
			
		||||
| 
						 | 
				
			
			@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
 | 
			
		|||
: (cookie-string>timestamp-2) ( -- timestamp )
 | 
			
		||||
    timestamp new
 | 
			
		||||
        read-sp check-day-name
 | 
			
		||||
        read-sp month-abbreviations index 1+ check-timestamp >>month
 | 
			
		||||
        read-sp month-abbreviations index 1 + check-timestamp >>month
 | 
			
		||||
        read-sp checked-number >>day
 | 
			
		||||
        ":" read-token checked-number >>hour
 | 
			
		||||
        ":" read-token checked-number >>minute
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -7,7 +7,7 @@ locals sequences ;
 | 
			
		|||
IN: channels.examples
 | 
			
		||||
 | 
			
		||||
: (counter) ( channel n -- )
 | 
			
		||||
    [ swap to ] 2keep 1+ (counter) ;
 | 
			
		||||
    [ swap to ] 2keep 1 + (counter) ;
 | 
			
		||||
    
 | 
			
		||||
: counter ( channel -- )
 | 
			
		||||
    2 (counter) ;    
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,9 +1,7 @@
 | 
			
		|||
! Copyright (C) 2009 Alaric Snell-Pym
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
 | 
			
		||||
USING: checksums classes.singleton kernel math math.ranges
 | 
			
		||||
math.vectors sequences ;
 | 
			
		||||
 | 
			
		||||
IN: checksums.fnv1
 | 
			
		||||
 | 
			
		||||
SINGLETON: fnv1-32
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,8 @@
 | 
			
		|||
! Copyright (C) 2009 Doug Coleman.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: byte-arrays checksums checksums.md5 io.encodings.binary
 | 
			
		||||
io.streams.byte-array kernel math namespaces tools.test ;
 | 
			
		||||
 | 
			
		||||
IN: checksums.md5.tests 
 | 
			
		||||
 | 
			
		||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
 | 
			
		||||
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,6 +2,7 @@
 | 
			
		|||
! See http;//factorcode.org/license.txt for BSD license
 | 
			
		||||
USING: arrays kernel tools.test sequences sequences.private
 | 
			
		||||
circular strings ;
 | 
			
		||||
IN: circular.tests
 | 
			
		||||
 | 
			
		||||
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
 | 
			
		||||
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -51,7 +51,7 @@ PRIVATE>
 | 
			
		|||
 | 
			
		||||
: push-growing-circular ( elt circular -- )
 | 
			
		||||
    dup full? [ push-circular ]
 | 
			
		||||
    [ [ 1+ ] change-length set-last ] if ;
 | 
			
		||||
    [ [ 1 + ] change-length set-last ] if ;
 | 
			
		||||
 | 
			
		||||
: <growing-circular> ( capacity -- growing-circular )
 | 
			
		||||
    { } new-sequence 0 0 growing-circular boa ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
! Copyright (C) 2005, 2006 Kevin Reid.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
IN: cocoa.callbacks
 | 
			
		||||
USING: assocs kernel namespaces cocoa cocoa.classes
 | 
			
		||||
cocoa.subclassing debugger ;
 | 
			
		||||
IN: cocoa.callbacks
 | 
			
		||||
 | 
			
		||||
SYMBOL: callbacks
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: cocoa.tests
 | 
			
		||||
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 | 
			
		||||
compiler kernel namespaces cocoa.classes tools.test memory
 | 
			
		||||
compiler.units math core-graphics.types ;
 | 
			
		||||
IN: cocoa.tests
 | 
			
		||||
 | 
			
		||||
CLASS: {
 | 
			
		||||
    { +superclass+ "NSObject" }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -172,7 +172,7 @@ ERROR: no-objc-type name ;
 | 
			
		|||
    [ ] [ no-objc-type ] ?if ;
 | 
			
		||||
 | 
			
		||||
: (parse-objc-type) ( i string -- ctype )
 | 
			
		||||
    [ [ 1+ ] dip ] [ nth ] 2bi {
 | 
			
		||||
    [ [ 1 + ] dip ] [ nth ] 2bi {
 | 
			
		||||
        { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
 | 
			
		||||
        { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
 | 
			
		||||
        { [ dup CHAR: { = ] [ drop objc-struct-type ] }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: cocoa.plists.tests
 | 
			
		||||
USING: tools.test cocoa.plists colors kernel hashtables
 | 
			
		||||
core-foundation.utilities core-foundation destructors
 | 
			
		||||
assocs cocoa.enumeration ;
 | 
			
		||||
IN: cocoa.plists.tests
 | 
			
		||||
 | 
			
		||||
[
 | 
			
		||||
    [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -37,4 +37,4 @@ assocs cocoa.enumeration ;
 | 
			
		|||
    [ 3.5 ] [
 | 
			
		||||
        3.5 >cf &CFRelease plist>
 | 
			
		||||
    ] unit-test
 | 
			
		||||
] with-destructors
 | 
			
		||||
] with-destructors
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: colors.hsv.tests
 | 
			
		||||
USING: accessors kernel colors colors.hsv tools.test math ;
 | 
			
		||||
IN: colors.hsv.tests
 | 
			
		||||
 | 
			
		||||
: hsv>rgb ( h s v -- r g b )
 | 
			
		||||
    [ 360 * ] 2dip
 | 
			
		||||
| 
						 | 
				
			
			@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ;
 | 
			
		|||
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
 | 
			
		||||
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
 | 
			
		||||
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: columns.tests
 | 
			
		||||
USING: columns sequences kernel namespaces arrays tools.test math ;
 | 
			
		||||
IN: columns.tests
 | 
			
		||||
 | 
			
		||||
! Columns
 | 
			
		||||
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,32 +1,18 @@
 | 
			
		|||
 | 
			
		||||
USING: kernel math tools.test combinators.short-circuit.smart ;
 | 
			
		||||
 | 
			
		||||
IN: combinators.short-circuit.smart.tests
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
[ t ] [       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] unit-test
 | 
			
		||||
[ t ] [ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] unit-test
 | 
			
		||||
[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
 | 
			
		||||
 | 
			
		||||
: must-be-t ( in -- ) [ t ] swap unit-test ;
 | 
			
		||||
: must-be-f ( in -- ) [ f ] swap unit-test ;
 | 
			
		||||
[ f ] [       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          unit-test
 | 
			
		||||
[ f ] [ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       unit-test
 | 
			
		||||
[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
 | 
			
		||||
 | 
			
		||||
[       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] must-be-t
 | 
			
		||||
[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] must-be-t
 | 
			
		||||
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
 | 
			
		||||
[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       unit-test
 | 
			
		||||
 | 
			
		||||
[       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          must-be-f
 | 
			
		||||
[ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       must-be-f
 | 
			
		||||
[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
 | 
			
		||||
[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
 | 
			
		||||
 | 
			
		||||
[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       must-be-t
 | 
			
		||||
 | 
			
		||||
[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  must-be-t
 | 
			
		||||
 | 
			
		||||
[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  unit-test
 | 
			
		||||
 | 
			
		||||
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,13 +1,15 @@
 | 
			
		|||
USING: kernel sequences math stack-checker effects accessors macros
 | 
			
		||||
fry combinators.short-circuit ;
 | 
			
		||||
USING: kernel sequences math stack-checker effects accessors
 | 
			
		||||
macros fry combinators.short-circuit ;
 | 
			
		||||
IN: combinators.short-circuit.smart
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
ERROR: cannot-determine-arity ;
 | 
			
		||||
 | 
			
		||||
: arity ( quots -- n )
 | 
			
		||||
    first infer
 | 
			
		||||
    dup terminated?>> [ "Cannot determine arity" throw ] when
 | 
			
		||||
    effect-height neg 1+ ;
 | 
			
		||||
    dup terminated?>> [ cannot-determine-arity ] when
 | 
			
		||||
    effect-height neg 1 + ;
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,7 +28,7 @@ HELP: output>array
 | 
			
		|||
    { $example
 | 
			
		||||
        <" USING: combinators combinators.smart math prettyprint ;
 | 
			
		||||
9 [
 | 
			
		||||
    { [ 1- ] [ 1+ ] [ sq ] } cleave
 | 
			
		||||
    { [ 1 - ] [ 1 + ] [ sq ] } cleave
 | 
			
		||||
] output>array .">
 | 
			
		||||
    "{ 8 10 81 }"
 | 
			
		||||
    }
 | 
			
		||||
| 
						 | 
				
			
			@ -71,7 +71,7 @@ HELP: sum-outputs
 | 
			
		|||
{ $examples
 | 
			
		||||
    { $example
 | 
			
		||||
        "USING: combinators.smart kernel math prettyprint ;"
 | 
			
		||||
        "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
 | 
			
		||||
        "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
 | 
			
		||||
        "20"
 | 
			
		||||
    }
 | 
			
		||||
} ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ;
 | 
			
		|||
IN: combinators.smart.tests
 | 
			
		||||
 | 
			
		||||
: test-bi ( -- 9 11 )
 | 
			
		||||
    10 [ 1- ] [ 1+ ] bi ;
 | 
			
		||||
    10 [ 1 - ] [ 1 + ] bi ;
 | 
			
		||||
 | 
			
		||||
[ [ test-bi ] output>array ] must-infer
 | 
			
		||||
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -46,4 +46,4 @@ IN: combinators.smart.tests
 | 
			
		|||
 | 
			
		||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
 | 
			
		||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1 +0,0 @@
 | 
			
		|||
IN: compiler.cfg.alias-analysis.tests
 | 
			
		||||
| 
						 | 
				
			
			@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ;
 | 
			
		|||
SYMBOL: ac-counter
 | 
			
		||||
 | 
			
		||||
: next-ac ( -- n )
 | 
			
		||||
    ac-counter [ dup 1+ ] change ;
 | 
			
		||||
    ac-counter [ dup 1 + ] change ;
 | 
			
		||||
 | 
			
		||||
! Alias class for objects which are loaded from the data stack
 | 
			
		||||
! or other object slots. We pessimistically assume that they
 | 
			
		||||
| 
						 | 
				
			
			@ -285,4 +285,4 @@ M: insn eliminate-dead-stores* ;
 | 
			
		|||
    eliminate-dead-stores ;
 | 
			
		||||
 | 
			
		||||
: alias-analysis ( cfg -- cfg' )
 | 
			
		||||
    [ alias-analysis-step ] local-optimization ;
 | 
			
		||||
    [ alias-analysis-step ] local-optimization ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +1,3 @@
 | 
			
		|||
IN: compiler.cfg.builder.tests
 | 
			
		||||
USING: tools.test kernel sequences words sequences.private fry
 | 
			
		||||
prettyprint alien alien.accessors math.private compiler.tree.builder
 | 
			
		||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
 | 
			
		||||
| 
						 | 
				
			
			@ -6,6 +5,7 @@ compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
 | 
			
		|||
compiler.cfg arrays locals byte-arrays kernel.private math
 | 
			
		||||
slots.private vectors sbufs strings math.partial-dispatch
 | 
			
		||||
strings.private ;
 | 
			
		||||
IN: compiler.cfg.builder.tests
 | 
			
		||||
 | 
			
		||||
! Just ensure that various CFGs build correctly.
 | 
			
		||||
: unit-test-cfg ( quot -- )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -8,6 +8,7 @@ compiler.cfg
 | 
			
		|||
compiler.cfg.debugger
 | 
			
		||||
compiler.cfg.instructions
 | 
			
		||||
compiler.cfg.registers ;
 | 
			
		||||
IN: compiler.cfg.def-use.tests
 | 
			
		||||
 | 
			
		||||
V{
 | 
			
		||||
    T{ ##peek f 0 D 0 }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: compiler.cfg.dominance.tests
 | 
			
		||||
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
 | 
			
		||||
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
 | 
			
		||||
compiler.cfg.predecessors ;
 | 
			
		||||
IN: compiler.cfg.dominance.tests
 | 
			
		||||
 | 
			
		||||
: test-dominance ( -- )
 | 
			
		||||
    cfg new 0 get >>entry
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
IN: compiler.cfg.gc-checks.tests
 | 
			
		||||
USING: compiler.cfg.gc-checks compiler.cfg.debugger
 | 
			
		||||
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 | 
			
		||||
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 | 
			
		||||
namespaces accessors sequences ;
 | 
			
		||||
IN: compiler.cfg.gc-checks.tests
 | 
			
		||||
 | 
			
		||||
: test-gc-checks ( -- )
 | 
			
		||||
    H{ } clone representations set
 | 
			
		||||
| 
						 | 
				
			
			@ -23,4 +23,4 @@ V{
 | 
			
		|||
 | 
			
		||||
[ ] [ test-gc-checks ] unit-test
 | 
			
		||||
 | 
			
		||||
[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
 | 
			
		||||
[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -8,11 +8,11 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
 | 
			
		|||
IN: compiler.cfg.intrinsics.allot
 | 
			
		||||
 | 
			
		||||
: ##set-slots ( regs obj class -- )
 | 
			
		||||
    '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
 | 
			
		||||
    '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
 | 
			
		||||
 | 
			
		||||
: emit-simple-allot ( node -- )
 | 
			
		||||
    [ in-d>> length ] [ node-output-infos first class>> ] bi
 | 
			
		||||
    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
 | 
			
		||||
    [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
 | 
			
		||||
    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 | 
			
		||||
 | 
			
		||||
: tuple-slot-regs ( layout -- vregs )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,9 +1,9 @@
 | 
			
		|||
IN: compiler.cfg.linear-scan.resolve.tests
 | 
			
		||||
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
 | 
			
		||||
accessors
 | 
			
		||||
compiler.cfg
 | 
			
		||||
compiler.cfg.instructions cpu.architecture make sequences
 | 
			
		||||
compiler.cfg.linear-scan.allocation.state ;
 | 
			
		||||
IN: compiler.cfg.linear-scan.resolve.tests
 | 
			
		||||
 | 
			
		||||
[
 | 
			
		||||
    {
 | 
			
		||||
| 
						 | 
				
			
			@ -64,4 +64,4 @@ H{ } clone spill-temps set
 | 
			
		|||
            T{ _reload { dst 0 } { rep int-rep } { n 8 } }
 | 
			
		||||
        }
 | 
			
		||||
    } member?
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +0,0 @@
 | 
			
		|||
IN: compiler.cfg.linearization.tests
 | 
			
		||||
USING: compiler.cfg.linearization tools.test ;
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
IN: compiler.cfg.loop-detection.tests
 | 
			
		||||
USING: compiler.cfg compiler.cfg.loop-detection
 | 
			
		||||
compiler.cfg.predecessors
 | 
			
		||||
compiler.cfg.debugger
 | 
			
		||||
tools.test kernel namespaces accessors ;
 | 
			
		||||
IN: compiler.cfg.loop-detection.tests
 | 
			
		||||
 | 
			
		||||
V{ } 0 test-bb
 | 
			
		||||
V{ } 1 test-bb
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
IN: compiler.cfg.stacks.uninitialized.tests
 | 
			
		||||
USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
 | 
			
		||||
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 | 
			
		||||
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 | 
			
		||||
namespaces accessors sequences ;
 | 
			
		||||
IN: compiler.cfg.stacks.uninitialized.tests
 | 
			
		||||
 | 
			
		||||
: test-uninitialized ( -- )
 | 
			
		||||
    cfg new 0 get >>entry
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.cfg.two-operand.tests
 | 
			
		||||
USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
 | 
			
		||||
compiler.cfg.registers cpu.architecture namespaces tools.test ;
 | 
			
		||||
IN: compiler.cfg.two-operand.tests
 | 
			
		||||
 | 
			
		||||
3 vreg-counter set-global
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.codegen.tests
 | 
			
		||||
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
 | 
			
		||||
compiler.constants ;
 | 
			
		||||
IN: compiler.codegen.tests
 | 
			
		||||
 | 
			
		||||
[ ] [ [ ] with-fixup drop ] unit-test
 | 
			
		||||
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -395,7 +395,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 | 
			
		|||
 | 
			
		||||
: callback-9 ( -- callback )
 | 
			
		||||
    "int" { "int" "int" "int" } "cdecl" [
 | 
			
		||||
        + + 1+
 | 
			
		||||
        + + 1 +
 | 
			
		||||
    ] alien-callback ;
 | 
			
		||||
 | 
			
		||||
FUNCTION: void ffi_test_36_point_5 ( ) ;
 | 
			
		||||
| 
						 | 
				
			
			@ -599,4 +599,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 | 
			
		|||
[ 123 ] [
 | 
			
		||||
    "bool-field-test" <c-object> 123 over set-bool-field-test-parents
 | 
			
		||||
    ffi_test_48
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.call-effect
 | 
			
		||||
USING: tools.test combinators generic.single sequences kernel ;
 | 
			
		||||
IN: compiler.tests.call-effect
 | 
			
		||||
 | 
			
		||||
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -11,4 +11,4 @@ USING: tools.test combinators generic.single sequences kernel ;
 | 
			
		|||
[ ] [ [ ] call-test ] unit-test
 | 
			
		||||
[ ] [ f [ drop ] curry call-test ] unit-test
 | 
			
		||||
[ ] [ [ ] [ ] compose call-test ] unit-test
 | 
			
		||||
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
 | 
			
		||||
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tests.float
 | 
			
		||||
USING: compiler.units compiler kernel kernel.private memory math
 | 
			
		||||
math.private tools.test math.floats.private ;
 | 
			
		||||
IN: compiler.tests.float
 | 
			
		||||
 | 
			
		||||
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
 | 
			
		||||
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.generic
 | 
			
		||||
USING: tools.test math kernel compiler.units definitions ;
 | 
			
		||||
IN: compiler.tests.generic
 | 
			
		||||
 | 
			
		||||
GENERIC: bad ( -- )
 | 
			
		||||
M: integer bad ;
 | 
			
		||||
| 
						 | 
				
			
			@ -8,4 +8,4 @@ M: object bad ;
 | 
			
		|||
[ 0 bad ] must-fail
 | 
			
		||||
[ "" bad ] must-fail
 | 
			
		||||
 | 
			
		||||
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
 | 
			
		||||
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -67,7 +67,7 @@ TUPLE: pred-test ;
 | 
			
		|||
[ 3 ] [ t bad-kill-2 ] unit-test
 | 
			
		||||
 | 
			
		||||
! regression
 | 
			
		||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
 | 
			
		||||
: (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive
 | 
			
		||||
: the-test ( -- x y ) 2 dup (the-test) ;
 | 
			
		||||
 | 
			
		||||
[ 2 0 ] [ the-test ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * )
 | 
			
		|||
 | 
			
		||||
! regression
 | 
			
		||||
: branch-fold-regression-0 ( m -- n )
 | 
			
		||||
    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
 | 
			
		||||
    t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
: branch-fold-regression-1 ( -- m )
 | 
			
		||||
    10 branch-fold-regression-0 ;
 | 
			
		||||
| 
						 | 
				
			
			@ -348,12 +348,12 @@ TUPLE: some-tuple x ;
 | 
			
		|||
 | 
			
		||||
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test
 | 
			
		||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test
 | 
			
		||||
 | 
			
		||||
: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -382,7 +382,7 @@ DEFER: loop-bbb
 | 
			
		|||
! Type inference issue
 | 
			
		||||
[ 4 3 ] [
 | 
			
		||||
    1 >bignum 2 >bignum
 | 
			
		||||
    [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
 | 
			
		||||
    [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
: broken-declaration ( -- ) \ + declare ;
 | 
			
		||||
| 
						 | 
				
			
			@ -422,4 +422,4 @@ M: object bad-dispatch-position-test* ;
 | 
			
		|||
        \ bad-dispatch-position-test forget
 | 
			
		||||
        \ bad-dispatch-position-test* forget
 | 
			
		||||
    ] with-compilation-unit
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.peg-regression-2
 | 
			
		||||
USING: peg.ebnf strings tools.test ;
 | 
			
		||||
IN: compiler.tests.peg-regression-2
 | 
			
		||||
 | 
			
		||||
GENERIC: <times> ( times -- term' )
 | 
			
		||||
M: string <times> ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.pic-problem-1
 | 
			
		||||
USING: kernel sequences prettyprint memory tools.test ;
 | 
			
		||||
IN: compiler.tests.pic-problem-1
 | 
			
		||||
 | 
			
		||||
TUPLE: x ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -11,4 +11,4 @@ INSTANCE: x sequence
 | 
			
		|||
 | 
			
		||||
CONSTANT: blah T{ x }
 | 
			
		||||
 | 
			
		||||
[ T{ x } ] [ blah ] unit-test
 | 
			
		||||
[ T{ x } ] [ blah ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tests.redefine0
 | 
			
		||||
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
 | 
			
		||||
namespaces macros assocs ;
 | 
			
		||||
IN: compiler.tests.redefine0
 | 
			
		||||
 | 
			
		||||
! Test ripple-up behavior
 | 
			
		||||
: test-1 ( -- a ) 3 ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -11,7 +11,7 @@ DEFER: word-1
 | 
			
		|||
 | 
			
		||||
: word-3 ( a -- b ) 1 + ;
 | 
			
		||||
 | 
			
		||||
: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
 | 
			
		||||
: word-4 ( a -- b c ) 0 swap word-3 swap 1 + ;
 | 
			
		||||
 | 
			
		||||
[ 1 1 ] [ 0 word-4 ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tests.redefine16
 | 
			
		||||
USING: eval tools.test definitions words compiler.units
 | 
			
		||||
quotations stack-checker ;
 | 
			
		||||
IN: compiler.tests.redefine16
 | 
			
		||||
 | 
			
		||||
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tests.redefine17
 | 
			
		||||
USING: tools.test classes.mixin compiler.units arrays kernel.private
 | 
			
		||||
strings sequences vocabs definitions kernel ;
 | 
			
		||||
IN: compiler.tests.redefine17
 | 
			
		||||
 | 
			
		||||
<< "compiler.tests.redefine17" words forget-all >>
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: compiler.tests.redefine2
 | 
			
		||||
USING: compiler compiler.units tools.test math parser kernel
 | 
			
		||||
sequences sequences.private classes.mixin generic definitions
 | 
			
		||||
arrays words assocs eval words.symbol ;
 | 
			
		||||
IN: compiler.tests.redefine2
 | 
			
		||||
 | 
			
		||||
DEFER: redefine2-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: compiler.tests.redefine3
 | 
			
		||||
USING: accessors compiler compiler.units tools.test math parser
 | 
			
		||||
kernel sequences sequences.private classes.mixin generic
 | 
			
		||||
definitions arrays words assocs eval ;
 | 
			
		||||
IN: compiler.tests.redefine3
 | 
			
		||||
 | 
			
		||||
GENERIC: sheeple ( obj -- x )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.redefine4
 | 
			
		||||
USING: io.streams.string kernel tools.test eval ;
 | 
			
		||||
IN: compiler.tests.redefine4
 | 
			
		||||
 | 
			
		||||
: declaration-test-1 ( -- a ) 3 ; flushable
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.reload
 | 
			
		||||
USE: vocabs.loader
 | 
			
		||||
IN: compiler.tests.reload
 | 
			
		||||
 | 
			
		||||
! "parser" reload
 | 
			
		||||
! "sequences" reload
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: compiler.tests.stack-trace
 | 
			
		||||
USING: compiler tools.test namespaces sequences
 | 
			
		||||
kernel.private kernel math continuations continuations.private
 | 
			
		||||
words splitting grouping sorting accessors ;
 | 
			
		||||
IN: compiler.tests.stack-trace
 | 
			
		||||
 | 
			
		||||
: symbolic-stack-trace ( -- newseq )
 | 
			
		||||
    error-continuation get call>> callstack>array
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tests.tuples
 | 
			
		||||
USING: kernel tools.test compiler.units compiler ;
 | 
			
		||||
IN: compiler.tests.tuples
 | 
			
		||||
 | 
			
		||||
TUPLE: color red green blue ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tree.builder.tests
 | 
			
		||||
USING: compiler.tree.builder tools.test sequences kernel
 | 
			
		||||
compiler.tree stack-checker stack-checker.errors ;
 | 
			
		||||
IN: compiler.tree.builder.tests
 | 
			
		||||
 | 
			
		||||
: inline-recursive ( -- ) inline-recursive ; inline recursive
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +0,0 @@
 | 
			
		|||
IN: compiler.tree.checker.tests
 | 
			
		||||
USING: compiler.tree.checker tools.test ;
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -1,4 +1,3 @@
 | 
			
		|||
IN: compiler.tree.cleanup.tests
 | 
			
		||||
USING: tools.test kernel.private kernel arrays sequences
 | 
			
		||||
math.private math generic words quotations alien alien.c-types
 | 
			
		||||
strings sbufs sequences.private slots.private combinators
 | 
			
		||||
| 
						 | 
				
			
			@ -17,6 +16,7 @@ compiler.tree.propagation
 | 
			
		|||
compiler.tree.propagation.info
 | 
			
		||||
compiler.tree.checker
 | 
			
		||||
compiler.tree.debugger ;
 | 
			
		||||
IN: compiler.tree.cleanup.tests
 | 
			
		||||
 | 
			
		||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -88,7 +88,7 @@ M: object xyz ;
 | 
			
		|||
    2over dup xyz drop >= [
 | 
			
		||||
        3drop
 | 
			
		||||
    ] [
 | 
			
		||||
        [ swap [ call 1+ ] dip ] keep (i-repeat)
 | 
			
		||||
        [ swap [ call 1 + ] dip ] keep (i-repeat)
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
 | 
			
		||||
| 
						 | 
				
			
			@ -115,10 +115,6 @@ M: object xyz ;
 | 
			
		|||
    [ { fixnum } declare [ ] times ] \ >= inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ { fixnum } declare [ ] times ] \ 1+ inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ { fixnum } declare [ ] times ] \ + inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -172,19 +168,6 @@ M: object xyz ;
 | 
			
		|||
    [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ 5000 [ [ ] times ] each ] \ 1+ inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
 | 
			
		||||
    \ 1+ inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
GENERIC: annotate-entry-test-1 ( x -- )
 | 
			
		||||
 | 
			
		||||
M: fixnum annotate-entry-test-1 drop ;
 | 
			
		||||
| 
						 | 
				
			
			@ -193,7 +176,7 @@ M: fixnum annotate-entry-test-1 drop ;
 | 
			
		|||
    2dup >= [
 | 
			
		||||
        2drop
 | 
			
		||||
    ] [
 | 
			
		||||
        [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
 | 
			
		||||
        [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
 | 
			
		||||
| 
						 | 
				
			
			@ -305,10 +288,6 @@ cell-bits 32 = [
 | 
			
		|||
    ] \ + inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ t ] [
 | 
			
		||||
    [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
: rec ( a -- b )
 | 
			
		||||
    dup 0 > [ 1 - rec ] when ; inline recursive
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -467,7 +446,7 @@ cell-bits 32 = [
 | 
			
		|||
: buffalo-wings ( i seq -- )
 | 
			
		||||
    2dup < [
 | 
			
		||||
        2dup chicken-fingers
 | 
			
		||||
        [ 1+ ] dip buffalo-wings
 | 
			
		||||
        [ 1 + ] dip buffalo-wings
 | 
			
		||||
    ] [
 | 
			
		||||
        2drop
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
| 
						 | 
				
			
			@ -486,7 +465,7 @@ cell-bits 32 = [
 | 
			
		|||
: ribs ( i seq -- )
 | 
			
		||||
    2dup < [
 | 
			
		||||
        steak
 | 
			
		||||
        [ 1+ ] dip ribs
 | 
			
		||||
        [ 1 + ] dip ribs
 | 
			
		||||
    ] [
 | 
			
		||||
        2drop
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
| 
						 | 
				
			
			@ -543,4 +522,4 @@ cell-bits 32 = [
 | 
			
		|||
        [ 12 swap nth ] keep
 | 
			
		||||
        14 ndrop
 | 
			
		||||
    ] cleaned-up-tree nodes>quot
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tree.combinators.tests
 | 
			
		||||
USING: compiler.tree.combinators tools.test kernel ;
 | 
			
		||||
IN: compiler.tree.combinators.tests
 | 
			
		||||
 | 
			
		||||
{ 1 0 } [ [ drop ] each-node ] must-infer-as
 | 
			
		||||
{ 1 1 } [ [ ] map-nodes ] must-infer-as
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -3,8 +3,7 @@
 | 
			
		|||
USING: sequences namespaces kernel accessors assocs sets fry
 | 
			
		||||
arrays combinators columns stack-checker.backend
 | 
			
		||||
stack-checker.branches compiler.tree compiler.tree.combinators
 | 
			
		||||
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
 | 
			
		||||
;
 | 
			
		||||
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
 | 
			
		||||
IN: compiler.tree.dead-code.branches
 | 
			
		||||
 | 
			
		||||
M: #if mark-live-values* look-at-inputs ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
IN: compiler.tree.debugger.tests
 | 
			
		||||
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
 | 
			
		||||
IN: compiler.tree.debugger.tests
 | 
			
		||||
 | 
			
		||||
[ [ <=> ] sort ] optimized.
 | 
			
		||||
[ <reversed> [ print ] each ] optimizer-report.
 | 
			
		||||
[ <reversed> [ print ] each ] optimizer-report.
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -154,7 +154,7 @@ SYMBOL: node-count
 | 
			
		|||
        H{ } clone intrinsics-called set
 | 
			
		||||
 | 
			
		||||
        0 swap [
 | 
			
		||||
            [ 1+ ] dip
 | 
			
		||||
            [ 1 + ] dip
 | 
			
		||||
            dup #call? [
 | 
			
		||||
                word>> {
 | 
			
		||||
                    { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: compiler.tree.escape-analysis.check.tests
 | 
			
		||||
USING: compiler.tree.escape-analysis.check tools.test accessors kernel
 | 
			
		||||
kernel.private math compiler.tree.builder compiler.tree.normalization
 | 
			
		||||
compiler.tree.propagation compiler.tree.cleanup ;
 | 
			
		||||
IN: compiler.tree.escape-analysis.check.tests
 | 
			
		||||
 | 
			
		||||
: test-checker ( quot -- ? )
 | 
			
		||||
    build-tree normalize propagate cleanup run-escape-analysis? ;
 | 
			
		||||
| 
						 | 
				
			
			@ -24,4 +24,4 @@ compiler.tree.propagation compiler.tree.cleanup ;
 | 
			
		|||
[ f ] [
 | 
			
		||||
    [ swap 1 2 ? ]
 | 
			
		||||
    test-checker
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +1,3 @@
 | 
			
		|||
IN: compiler.tree.escape-analysis.tests
 | 
			
		||||
USING: compiler.tree.escape-analysis
 | 
			
		||||
compiler.tree.escape-analysis.allocations compiler.tree.builder
 | 
			
		||||
compiler.tree.recursive compiler.tree.normalization
 | 
			
		||||
| 
						 | 
				
			
			@ -10,11 +9,12 @@ classes.tuple namespaces
 | 
			
		|||
compiler.tree.propagation.info stack-checker.errors
 | 
			
		||||
compiler.tree.checker
 | 
			
		||||
kernel.private vectors ;
 | 
			
		||||
IN: compiler.tree.escape-analysis.tests
 | 
			
		||||
 | 
			
		||||
GENERIC: count-unboxed-allocations* ( m node -- n )
 | 
			
		||||
 | 
			
		||||
: (count-unboxed-allocations) ( m node -- n )
 | 
			
		||||
    out-d>> first escaping-allocation? [ 1+ ] unless ;
 | 
			
		||||
    out-d>> first escaping-allocation? [ 1 + ] unless ;
 | 
			
		||||
 | 
			
		||||
M: #call count-unboxed-allocations*
 | 
			
		||||
    dup immutable-tuple-boa?
 | 
			
		||||
| 
						 | 
				
			
			@ -25,7 +25,7 @@ M: #push count-unboxed-allocations*
 | 
			
		|||
    [ (count-unboxed-allocations) ] [ drop ] if ;
 | 
			
		||||
 | 
			
		||||
M: #introduce count-unboxed-allocations*
 | 
			
		||||
    out-d>> [ escaping-allocation? [ 1+ ] unless ] each ;
 | 
			
		||||
    out-d>> [ escaping-allocation? [ 1 + ] unless ] each ;
 | 
			
		||||
 | 
			
		||||
M: node count-unboxed-allocations* drop ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -212,10 +212,10 @@ C: <ro-box> ro-box
 | 
			
		|||
    dup i>> 1 <= [
 | 
			
		||||
        drop 1 <ro-box>
 | 
			
		||||
    ] [
 | 
			
		||||
        i>> 1- <ro-box>
 | 
			
		||||
        i>> 1 - <ro-box>
 | 
			
		||||
        dup tuple-fib
 | 
			
		||||
        swap
 | 
			
		||||
        i>> 1- <ro-box>
 | 
			
		||||
        i>> 1 - <ro-box>
 | 
			
		||||
        tuple-fib
 | 
			
		||||
        swap i>> swap i>> + <ro-box>
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
| 
						 | 
				
			
			@ -225,7 +225,7 @@ C: <ro-box> ro-box
 | 
			
		|||
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
 | 
			
		||||
 | 
			
		||||
: tuple-fib' ( m -- n )
 | 
			
		||||
    dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
 | 
			
		||||
    dup 1 <= [ 1 - tuple-fib' i>> ] when <ro-box> ; inline recursive
 | 
			
		||||
 | 
			
		||||
[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -233,10 +233,10 @@ C: <ro-box> ro-box
 | 
			
		|||
    dup i>> 1 <= [
 | 
			
		||||
        drop 1 <ro-box>
 | 
			
		||||
    ] [
 | 
			
		||||
        i>> 1- <ro-box>
 | 
			
		||||
        i>> 1 - <ro-box>
 | 
			
		||||
        dup bad-tuple-fib-1
 | 
			
		||||
        swap
 | 
			
		||||
        i>> 1- <ro-box>
 | 
			
		||||
        i>> 1 - <ro-box>
 | 
			
		||||
        bad-tuple-fib-1 dup .
 | 
			
		||||
        swap i>> swap i>> + <ro-box>
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
| 
						 | 
				
			
			@ -248,10 +248,10 @@ C: <ro-box> ro-box
 | 
			
		|||
    dup i>> 1 <= [
 | 
			
		||||
        drop 1 <ro-box>
 | 
			
		||||
    ] [
 | 
			
		||||
        i>> 1- <ro-box>
 | 
			
		||||
        i>> 1 - <ro-box>
 | 
			
		||||
        dup bad-tuple-fib-2
 | 
			
		||||
        swap
 | 
			
		||||
        i>> 1- <ro-box>
 | 
			
		||||
        i>> 1 - <ro-box>
 | 
			
		||||
        bad-tuple-fib-2
 | 
			
		||||
        swap i>> swap i>> + <ro-box>
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
| 
						 | 
				
			
			@ -262,9 +262,9 @@ C: <ro-box> ro-box
 | 
			
		|||
    dup 1 <= [
 | 
			
		||||
        drop 1 <ro-box>
 | 
			
		||||
    ] [
 | 
			
		||||
        1- dup tuple-fib-2
 | 
			
		||||
        1 - dup tuple-fib-2
 | 
			
		||||
        swap
 | 
			
		||||
        1- tuple-fib-2
 | 
			
		||||
        1 - tuple-fib-2
 | 
			
		||||
        swap i>> swap i>> + <ro-box>
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -274,9 +274,9 @@ C: <ro-box> ro-box
 | 
			
		|||
    dup 1 <= [
 | 
			
		||||
        drop 1 <ro-box>
 | 
			
		||||
    ] [
 | 
			
		||||
        1- dup tuple-fib-3
 | 
			
		||||
        1 - dup tuple-fib-3
 | 
			
		||||
        swap
 | 
			
		||||
        1- tuple-fib-3 dup .
 | 
			
		||||
        1 - tuple-fib-3 dup .
 | 
			
		||||
        swap i>> swap i>> + <ro-box>
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -286,9 +286,9 @@ C: <ro-box> ro-box
 | 
			
		|||
    dup 1 <= [
 | 
			
		||||
        drop 1 <ro-box>
 | 
			
		||||
    ] [
 | 
			
		||||
        1- dup bad-tuple-fib-3
 | 
			
		||||
        1 - dup bad-tuple-fib-3
 | 
			
		||||
        swap
 | 
			
		||||
        1- bad-tuple-fib-3
 | 
			
		||||
        1 - bad-tuple-fib-3
 | 
			
		||||
        2drop f
 | 
			
		||||
    ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -344,4 +344,4 @@ TUPLE: empty-tuple ;
 | 
			
		|||
[ 0 ] [
 | 
			
		||||
    [ { vector } declare length>> ]
 | 
			
		||||
    count-unboxed-allocations
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
IN: compiler.tree.escape-analysis.recursive.tests
 | 
			
		||||
USING: kernel tools.test namespaces sequences
 | 
			
		||||
compiler.tree.escape-analysis.recursive
 | 
			
		||||
compiler.tree.escape-analysis.allocations ;
 | 
			
		||||
IN: compiler.tree.escape-analysis.recursive.tests
 | 
			
		||||
 | 
			
		||||
H{ } clone allocations set
 | 
			
		||||
<escaping-values> escaping-values set
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,12 +1,12 @@
 | 
			
		|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
IN: compiler.tree.modular-arithmetic.tests
 | 
			
		||||
USING: kernel kernel.private tools.test math math.partial-dispatch
 | 
			
		||||
math.private accessors slots.private sequences sequences.private strings sbufs
 | 
			
		||||
compiler.tree.builder
 | 
			
		||||
compiler.tree.normalization
 | 
			
		||||
compiler.tree.debugger
 | 
			
		||||
alien.accessors layouts combinators byte-arrays ;
 | 
			
		||||
IN: compiler.tree.modular-arithmetic.tests
 | 
			
		||||
 | 
			
		||||
: test-modular-arithmetic ( quot -- quot' )
 | 
			
		||||
    cleaned-up-tree nodes>quot ;
 | 
			
		||||
| 
						 | 
				
			
			@ -175,4 +175,4 @@ cell {
 | 
			
		|||
[ t ] [
 | 
			
		||||
    [ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
 | 
			
		||||
    { >fixnum } inlined?
 | 
			
		||||
] unit-test
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,10 +1,10 @@
 | 
			
		|||
IN: compiler.tree.normalization.tests
 | 
			
		||||
USING: compiler.tree.builder compiler.tree.recursive
 | 
			
		||||
compiler.tree.normalization
 | 
			
		||||
compiler.tree.normalization.introductions
 | 
			
		||||
compiler.tree.normalization.renaming
 | 
			
		||||
compiler.tree compiler.tree.checker
 | 
			
		||||
sequences accessors tools.test kernel math ;
 | 
			
		||||
IN: compiler.tree.normalization.tests
 | 
			
		||||
 | 
			
		||||
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +0,0 @@
 | 
			
		|||
USING: compiler.tree.optimizer tools.test ;
 | 
			
		||||
IN: compiler.tree.optimizer.tests
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -35,7 +35,7 @@ M: +unknown+ curry-effect ;
 | 
			
		|||
 | 
			
		||||
M: effect curry-effect
 | 
			
		||||
    [ in>> length ] [ out>> length ] [ terminated?>> ] tri
 | 
			
		||||
    pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
 | 
			
		||||
    pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
 | 
			
		||||
    effect boa ;
 | 
			
		||||
 | 
			
		||||
M: curry cached-effect
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tree.propagation.copy.tests
 | 
			
		||||
USING: compiler.tree.propagation.copy tools.test namespaces kernel
 | 
			
		||||
assocs ;
 | 
			
		||||
IN: compiler.tree.propagation.copy.tests
 | 
			
		||||
 | 
			
		||||
H{ } clone copies set
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -19,7 +19,7 @@ IN: compiler.tree.propagation.inlining
 | 
			
		|||
SYMBOL: node-count
 | 
			
		||||
 | 
			
		||||
: count-nodes ( nodes -- n )
 | 
			
		||||
    0 swap [ drop 1+ ] each-node ;
 | 
			
		||||
    0 swap [ drop 1 + ] each-node ;
 | 
			
		||||
 | 
			
		||||
: compute-node-count ( nodes -- ) count-nodes node-count set ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -146,7 +146,7 @@ DEFER: (flat-length)
 | 
			
		|||
 | 
			
		||||
: body-length-bias ( word -- n )
 | 
			
		||||
    [ flat-length ] [ inlining-count get at 0 or ] bi
 | 
			
		||||
    over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
 | 
			
		||||
    over 2 <= [ drop ] [ 2/ 1 + * ] if 24 swap [-] 4 /i ;
 | 
			
		||||
 | 
			
		||||
: inlining-rank ( #call word -- n )
 | 
			
		||||
    [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -240,11 +240,11 @@ generic-comparison-ops [
 | 
			
		|||
    dup name>> {
 | 
			
		||||
        {
 | 
			
		||||
            [ "alien-signed-" ?head ]
 | 
			
		||||
            [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
 | 
			
		||||
            [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
 | 
			
		||||
        }
 | 
			
		||||
        {
 | 
			
		||||
            [ "alien-unsigned-" ?head ]
 | 
			
		||||
            [ string>number 8 * 2^ 1- 0 swap [a,b] ]
 | 
			
		||||
            [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
 | 
			
		||||
        }
 | 
			
		||||
    } cond
 | 
			
		||||
    [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -278,11 +278,11 @@ IN: compiler.tree.propagation.tests
 | 
			
		|||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ V{ fixnum } ] [
 | 
			
		||||
    [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
 | 
			
		||||
    [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ V{ -1 } ] [
 | 
			
		||||
    [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
 | 
			
		||||
    [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ V{ 2 } ] [
 | 
			
		||||
| 
						 | 
				
			
			@ -472,7 +472,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 | 
			
		|||
] unit-test
 | 
			
		||||
 | 
			
		||||
: recursive-test-4 ( i n -- )
 | 
			
		||||
    2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 | 
			
		||||
    2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 | 
			
		||||
 | 
			
		||||
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -487,7 +487,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 | 
			
		|||
[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
 | 
			
		||||
 | 
			
		||||
: recursive-test-7 ( a -- b )
 | 
			
		||||
    dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
 | 
			
		||||
    dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
 | 
			
		||||
 | 
			
		||||
[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -645,7 +645,7 @@ MIXIN: empty-mixin
 | 
			
		|||
] unit-test
 | 
			
		||||
  
 | 
			
		||||
[ V{ bignum } ] [
 | 
			
		||||
    [ { bignum } declare dup 1- bitxor ] final-classes
 | 
			
		||||
    [ { bignum } declare dup 1 - bitxor ] final-classes
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ V{ bignum integer } ] [
 | 
			
		||||
| 
						 | 
				
			
			@ -685,7 +685,7 @@ MIXIN: empty-mixin
 | 
			
		|||
 | 
			
		||||
TUPLE: littledan-1 { a read-only } ;
 | 
			
		||||
 | 
			
		||||
: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
 | 
			
		||||
: (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
 | 
			
		||||
 | 
			
		||||
: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -702,7 +702,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 | 
			
		|||
[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
 | 
			
		||||
 | 
			
		||||
: (littledan-3-test) ( x -- )
 | 
			
		||||
    length 1+ f <array> (littledan-3-test) ; inline recursive
 | 
			
		||||
    length 1 + f <array> (littledan-3-test) ; inline recursive
 | 
			
		||||
 | 
			
		||||
: littledan-3-test ( -- )
 | 
			
		||||
    0 f <array> (littledan-3-test) ; inline
 | 
			
		||||
| 
						 | 
				
			
			@ -711,7 +711,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 | 
			
		|||
 | 
			
		||||
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
 | 
			
		||||
 | 
			
		||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
 | 
			
		||||
[ V{ 1 } ] [ [ { } length 1 + f <array> length ] final-literals ] unit-test
 | 
			
		||||
 | 
			
		||||
! generalize-counter is not tight enough
 | 
			
		||||
[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
IN: compiler.tree.propagation.recursive.tests
 | 
			
		||||
USING: tools.test compiler.tree.propagation.recursive
 | 
			
		||||
math.intervals kernel math literals layouts ;
 | 
			
		||||
IN: compiler.tree.propagation.recursive.tests
 | 
			
		||||
 | 
			
		||||
[ T{ interval f { 0 t } { 1/0. t } } ] [
 | 
			
		||||
    T{ interval f { 1 t } { 1 t } }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -63,5 +63,5 @@ UNION: fixed-length-sequence array byte-array string ;
 | 
			
		|||
        { [ over 0 = ] [ 2drop fixnum <class-info> ] }
 | 
			
		||||
        { [ 2dup length-accessor? ] [ nip length>> ] }
 | 
			
		||||
        { [ dup literal?>> ] [ literal>> literal-info-slot ] }
 | 
			
		||||
        [ [ 1- ] [ slots>> ] bi* ?nth ]
 | 
			
		||||
        [ [ 1 - ] [ slots>> ] bi* ?nth ]
 | 
			
		||||
    } cond [ object-info ] unless* ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
Some files were not shown because too many files have changed in this diff Show More
		Loading…
	
		Reference in New Issue