Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-08-21 18:48:44 -05:00
commit 2c533472f8
540 changed files with 3736 additions and 1737 deletions

View File

@ -1,6 +1,6 @@
IN: alarms.tests
USING: alarms alarms.private kernel calendar sequences USING: alarms alarms.private kernel calendar sequences
tools.test threads concurrency.count-downs ; tools.test threads concurrency.count-downs ;
IN: alarms.tests
[ ] [ [ ] [
1 <count-down> 1 <count-down>

View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init USING: accessors assocs boxes calendar
kernel math namespaces sequences heaps boxes threads combinators.short-circuit fry heaps init kernel math.order
quotations assocs math.order ; namespaces quotations threads ;
IN: alarms IN: alarms
TUPLE: alarm TUPLE: alarm
@ -21,21 +21,21 @@ SYMBOL: alarm-thread
ERROR: bad-alarm-frequency frequency ; ERROR: bad-alarm-frequency frequency ;
: check-alarm ( frequency/f -- frequency/f ) : 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 ) : <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ; check-alarm <box> alarm boa ;
: register-alarm ( alarm -- ) : register-alarm ( alarm -- )
dup dup time>> alarms get-global heap-push* [ dup time>> alarms get-global heap-push* ]
swap entry>> >box [ entry>> >box ] bi
notify-alarm-thread ; notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? ) : alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ; [ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- ) : 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 -- ) : call-alarm ( alarm -- )
[ entry>> box> drop ] [ entry>> box> drop ]

View File

@ -1,6 +1,6 @@
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ; sequences system libc alien.strings io.encodings.utf8 ;
IN: alien.c-types.tests
CONSTANT: xyz 123 CONSTANT: xyz 123

View File

@ -10,4 +10,4 @@ IN: alien.complex
! This overrides the fact that small structures are never returned ! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86. ! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop "complex-float" c-type t >>return-in-registers? drop
>> >>

View File

@ -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

View File

@ -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

View File

@ -357,10 +357,10 @@ M: character-type (<fortran-result>)
: (shuffle-map) ( return parameters -- ret par ) : (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 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 [ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ; ] bi* ;

View File

@ -1,5 +1,5 @@
IN: alien.libraries.tests
USING: alien.libraries alien.syntax tools.test kernel ; USING: alien.libraries alien.syntax tools.test kernel ;
IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test

View File

@ -1,6 +1,6 @@
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces layouts ; sequences system libc words vocabs namespaces layouts ;
IN: alien.structs.tests
C-STRUCT: bar C-STRUCT: bar
{ "int" "x" } { "int" "x" }

View File

@ -31,8 +31,10 @@ SYNTAX: C-ENUM:
";" parse-tokens ";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ; [ [ create-in ] dip define-constant ] each-index ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value ) : address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ; 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &: SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ; scan "c-library" get '[ _ _ address-of ] over push-all ;

View File

@ -10,7 +10,7 @@ IN: ascii.tests
[ 4 ] [ [ 4 ] [
0 "There are Four Upper Case characters" 0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each [ LETTER? [ 1 + ] when ] each
] unit-test ] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test [ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test

View File

@ -34,7 +34,7 @@ SYMBOL: column
: write1-lines ( ch -- ) : write1-lines ( ch -- )
write1 write1
column get [ column get [
1+ [ 76 = [ crlf ] when ] 1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi [ 76 mod column set ] bi
] when* ; ] when* ;
@ -48,7 +48,7 @@ SYMBOL: column
: encode-pad ( seq n -- ) : encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ] [ 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 -- ) : decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ] [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]

View File

@ -1,5 +1,5 @@
USING: biassocs assocs namespaces tools.test hashtables kernel ;
IN: biassocs.tests IN: biassocs.tests
USING: biassocs assocs namespaces tools.test ;
<bihash> "h" set <bihash> "h" set
@ -30,3 +30,13 @@ H{ { "a" "A" } { "b" "B" } } "a" set
[ "A" ] [ "a" "b" get at ] unit-test [ "A" ] [ "a" "b" get at ] unit-test
[ "a" ] [ "A" "b" get value-at ] unit-test [ "a" ] [ "A" "b" get value-at ] unit-test
[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
[ ] [ "h" get clone "g" set ] unit-test
[ ] [ 3 4 "g" get set-at ] unit-test
[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

View File

@ -44,3 +44,6 @@ INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc ) : >biassoc ( assoc -- biassoc )
T{ biassoc } assoc-clone-like ; T{ biassoc } assoc-clone-like ;
M: biassoc clone
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

View File

@ -1,5 +1,5 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ; USING: binary-search math.order vectors kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 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 [ 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 [ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test [ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test [ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test [ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test [ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

View File

@ -44,33 +44,33 @@ PRIVATE>
: <bit-array> ( n -- bit-array ) : <bit-array> ( n -- bit-array )
dup bits>bytes <byte-array> bit-array boa ; inline dup bits>bytes <byte-array> bit-array boa ; inline
M: bit-array length length>> ; M: bit-array length length>> ; inline
M: bit-array nth-unsafe M: bit-array nth-unsafe
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
M: bit-array set-nth-unsafe M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi* [ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep [ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ; swap n>byte set-alien-unsigned-1 ; inline
GENERIC: clear-bits ( bit-array -- ) GENERIC: clear-bits ( bit-array -- )
M: bit-array clear-bits 0 (set-bits) ; M: bit-array clear-bits 0 (set-bits) ; inline
GENERIC: set-bits ( bit-array -- ) GENERIC: set-bits ( bit-array -- )
M: bit-array set-bits -1 (set-bits) ; M: bit-array set-bits -1 (set-bits) ; inline
M: bit-array clone M: bit-array clone
[ length>> ] [ underlying>> clone ] bi bit-array boa ; [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
: >bit-array ( seq -- bit-array ) : >bit-array ( seq -- bit-array )
T{ bit-array f 0 B{ } } clone-like ; inline T{ bit-array f 0 B{ } } clone-like ; inline
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
M: bit-array new-sequence drop <bit-array> ; M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal? M: bit-array equal?
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
@ -81,7 +81,7 @@ M: bit-array resize
resize-byte-array resize-byte-array
] 2bi ] 2bi
bit-array boa bit-array boa
dup clean-up ; dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ; M: bit-array byte-length length 7 + -3 shift ;
@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
dup 0 = [ dup 0 = [
<bit-array> <bit-array>
] [ ] [
[ log2 1+ <bit-array> 0 ] keep [ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [ [ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep [ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1+ ] [ -8 shift ] bi* [ 1 + ] [ -8 shift ] bi*
] until 2drop ] until 2drop
] if ; ] if ;

View File

@ -1,5 +1,5 @@
IN: bit-sets.tests
USING: bit-sets tools.test bit-arrays ; USING: bit-sets tools.test bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [ [ ?{ t f t f t f } ] [
?{ t f f f t f } ?{ t f f f t f }

View File

@ -1,5 +1,5 @@
IN: bit-vectors.tests
USING: tools.test bit-vectors vectors sequences kernel math ; USING: tools.test bit-vectors vectors sequences kernel math ;
IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test [ 0 ] [ 123 <bit-vector> length ] unit-test

View File

@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
io.streams.byte-array ; io.streams.byte-array ;
IN: bitstreams.tests IN: bitstreams.tests
[ BIN: 1111111111 ] [ BIN: 1111111111 ]
[ [
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader> B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

View File

@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- )
[ get-abp + ] [ set-abp ] bi ; inline [ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' ) : (align) ( n m -- n' )
[ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
: align ( n bitstream -- ) : align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline [ get-abp swap (align) ] [ set-abp ] bi ; inline

View File

@ -35,83 +35,87 @@ gc
: compile-unoptimized ( words -- ) : compile-unoptimized ( words -- )
[ optimized? not ] filter compile ; [ optimized? not ] filter compile ;
nl "debug-compiler" get [
"Compiling..." write flush
! Compile a set of words ahead of the full compile. nl
! This set of words was determined semi-empirically "Compiling..." write flush
! using the profiler. It improves bootstrap time
! significantly, because frequenly called words
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
not ?
2over roll -roll ! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
! using the profiler. It improves bootstrap time
! significantly, because frequenly called words
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
not ?
array? hashtable? vector? 2over roll -roll
tuple? sbuf? tombstone?
curry? compose? callable?
quotation?
curry compose uncurry array? hashtable? vector?
tuple? sbuf? tombstone?
curry? compose? callable?
quotation?
array-nth set-array-nth length>> curry compose uncurry
wrap probe array-nth set-array-nth length>>
namestack* wrap probe
layout-of namestack*
} compile-unoptimized
"." write flush layout-of
} compile-unoptimized
{ "." write flush
bitand bitor bitxor bitnot
} compile-unoptimized
"." write flush {
bitand bitor bitxor bitnot
} compile-unoptimized
{ "." write flush
+ 1+ 1- 2/ < <= > >= shift
} compile-unoptimized
"." write flush {
+ 2/ < <= > >= shift
} compile-unoptimized
{ "." write flush
new-sequence nth push pop last flip
} compile-unoptimized
"." write flush {
new-sequence nth push pop last flip
} compile-unoptimized
{ "." write flush
hashcode* = equal? assoc-stack (assoc-stack) get set
} compile-unoptimized
"." write flush {
hashcode* = equal? assoc-stack (assoc-stack) get set
} compile-unoptimized
{ "." write flush
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
like clone-like
} compile-unoptimized
"." write flush {
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
like clone-like
} compile-unoptimized
{ "." write flush
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
} compile-unoptimized
"." write flush {
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
} compile-unoptimized
{ "." write flush
malloc calloc free memcpy
} compile-unoptimized
"." write flush {
malloc calloc free memcpy
} compile-unoptimized
vocabs [ words compile-unoptimized "." write flush ] each "." write flush
" done" print flush vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush
] unless

View File

@ -1,6 +1,6 @@
IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test USING: bootstrap.image bootstrap.image.private tools.test
kernel math ; kernel math ;
IN: bootstrap.image.tests
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test

View File

@ -234,7 +234,7 @@ GENERIC: ' ( obj -- ptr )
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ; : 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 ) : bignum>seq ( n -- seq )
#! n is positive or zero. #! n is positive or zero.
@ -244,7 +244,7 @@ GENERIC: ' ( obj -- ptr )
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq dup dup 0 < [ neg ] when bignum>seq
[ nip length 1+ emit-fixnum ] [ nip length 1 + emit-fixnum ]
[ drop 0 < 1 0 ? emit ] [ drop 0 < 1 0 ? emit ]
[ nip emit-seq ] [ nip emit-seq ]
2tri ; 2tri ;

View File

@ -9,9 +9,9 @@ IN: bootstrap.image.upload
SYMBOL: upload-images-destination SYMBOL: upload-images-destination
: destination ( -- dest ) : destination ( -- dest )
upload-images-destination get upload-images-destination get
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ; or ;
: checksums ( -- temp ) "checksums.txt" temp-file ; : checksums ( -- temp ) "checksums.txt" temp-file ;

View File

@ -14,6 +14,7 @@ IN: bootstrap.tools
"tools.test" "tools.test"
"tools.time" "tools.time"
"tools.threads" "tools.threads"
"tools.deprecation"
"vocabs.hierarchy" "vocabs.hierarchy"
"vocabs.refresh" "vocabs.refresh"
"vocabs.refresh.monitor" "vocabs.refresh.monitor"

View File

@ -1,5 +1,5 @@
IN: boxes.tests
USING: boxes namespaces tools.test accessors ; USING: boxes namespaces tools.test accessors ;
IN: boxes.tests
[ ] [ <box> "b" set ] unit-test [ ] [ <box> "b" set ] unit-test

View File

@ -8,4 +8,3 @@ SYNTAX: HEX{
[ blank? not ] filter [ blank? not ] filter
2 group [ hex> ] B{ } map-as 2 group [ hex> ] B{ } map-as
parsed ; parsed ;

View File

@ -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

View File

@ -38,6 +38,6 @@ PRIVATE>
: purge-cache ( cache -- ) : purge-cache ( cache -- )
dup max-age>> '[ dup max-age>> '[
[ nip [ 1+ ] change-age age>> _ >= ] assoc-partition [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
[ values dispose-each ] dip [ values dispose-each ] dip
] change-assoc drop ; ] change-assoc drop ;

View File

@ -1,5 +1,5 @@
IN: cairo.tests
USING: cairo tools.test math.rectangles accessors ; USING: cairo tools.test math.rectangles accessors ;
IN: cairo.tests
[ { 10 20 } ] [ [ { 10 20 } ] [
{ 10 20 } [ { 10 20 } [

View File

@ -27,7 +27,7 @@ HELP: <date>
} ; } ;
HELP: month-names HELP: month-names
{ $values { "array" array } } { $values { "value" object } }
{ $description "Returns an array with the English names of all the months." } { $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;

View File

@ -34,25 +34,25 @@ C: <timestamp> timestamp
: <date> ( year month day -- timestamp ) : <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ; 0 0 0 gmt-offset-duration <timestamp> ;
ERROR: not-a-month n ; ERROR: not-a-month ;
M: not-a-month summary M: not-a-month summary
drop "Months are indexed starting at 1" ; drop "Months are indexed starting at 1" ;
<PRIVATE <PRIVATE
: check-month ( n -- n ) : check-month ( n -- n )
dup zero? [ not-a-month ] when ; [ not-a-month ] when-zero ;
PRIVATE> PRIVATE>
: month-names ( -- array ) CONSTANT: month-names
{ {
"January" "February" "March" "April" "May" "June" "January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December" "July" "August" "September" "October" "November" "December"
} ; }
: month-name ( n -- string ) : month-name ( n -- string )
check-month 1- month-names nth ; check-month 1 - month-names nth ;
CONSTANT: month-abbreviations CONSTANT: month-abbreviations
{ {
@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
} }
: month-abbreviation ( n -- string ) : 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 } 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 - 100 b * d + 4800 -
m 10 /i + m 3 + m 10 /i + m 3 +
12 m 10 /i * - 12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ ; e 153 m * 2 + 5 /i - 1 + ;
GENERIC: easter ( obj -- obj' ) GENERIC: easter ( obj -- obj' )
@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&& { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
[ 3 >>month 1 >>day ] when ; [ 3 >>month 1 >>day ] when ;
: unless-zero ( n quot -- )
[ dup zero? [ drop ] ] dip if ; inline
M: integer +year ( timestamp n -- timestamp ) M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ; [ [ + ] 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 ; [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years ) : 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 ) M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ; [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
@ -371,10 +368,10 @@ M: duration time-
#! http://web.textfiles.com/computers/formulas.txt #! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582 #! 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 [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
[ 1+ 3 * 5 /i + ] keep 2 * + [ 1 + 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ; ] dip 1 + + 7 mod ;
GENERIC: days-in-year ( obj -- n ) 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 leap-year? [
year month day <date> year month day <date>
year 3 1 <date> year 3 1 <date>
after=? [ 1+ ] when after=? [ 1 + ] when
] when ; ] when ;
: day-of-year ( timestamp -- n ) : day-of-year ( timestamp -- n )

View File

@ -68,8 +68,8 @@ M: array month. ( pair -- )
[ (days-in-month) day-abbreviations2 " " join print ] 2tri [ (days-in-month) day-abbreviations2 " " join print ] 2tri
over " " <repetition> concat write over " " <repetition> concat write
[ [
[ 1+ day. ] keep [ 1 + day. ] keep
1+ + 7 mod zero? [ nl ] [ bl ] if 1 + + 7 mod zero? [ nl ] [ bl ] if
] with each nl ; ] with each nl ;
M: timestamp month. ( timestamp -- ) M: timestamp month. ( timestamp -- )
@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
GENERIC: year. ( obj -- ) GENERIC: year. ( obj -- )
M: integer year. ( n -- ) M: integer year. ( n -- )
12 [ 1+ 2array month. nl ] with each ; 12 [ 1 + 2array month. nl ] with each ;
M: timestamp year. ( timestamp -- ) M: timestamp year. ( timestamp -- )
year>> year. ; year>> year. ;
@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
: read-rfc3339-seconds ( s -- s' ch ) : read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until [ "+-Z" read-until [
[ string>number ] [ length 10 swap ^ ] bi / + [ string>number ] [ length 10^ ] bi / +
] dip ; ] dip ;
: (rfc3339>timestamp) ( -- timestamp ) : (rfc3339>timestamp) ( -- timestamp )
@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
"," read-token day-abbreviations3 member? check-timestamp drop "," read-token day-abbreviations3 member? check-timestamp drop
read1 CHAR: \s assert= read1 CHAR: \s assert=
read-sp checked-number >>day 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-sp checked-number >>year
":" read-token checked-number >>hour ":" read-token checked-number >>hour
":" read-token checked-number >>minute ":" read-token checked-number >>minute
@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
"," read-token check-day-name "," read-token check-day-name
read1 CHAR: \s assert= read1 CHAR: \s assert=
"-" read-token checked-number >>day "-" 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-sp checked-number >>year
":" read-token checked-number >>hour ":" read-token checked-number >>hour
":" read-token checked-number >>minute ":" read-token checked-number >>minute
@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
: (cookie-string>timestamp-2) ( -- timestamp ) : (cookie-string>timestamp-2) ( -- timestamp )
timestamp new timestamp new
read-sp check-day-name 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-sp checked-number >>day
":" read-token checked-number >>hour ":" read-token checked-number >>hour
":" read-token checked-number >>minute ":" read-token checked-number >>minute

View File

@ -7,7 +7,7 @@ locals sequences ;
IN: channels.examples IN: channels.examples
: (counter) ( channel n -- ) : (counter) ( channel n -- )
[ swap to ] 2keep 1+ (counter) ; [ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- ) : counter ( channel -- )
2 (counter) ; 2 (counter) ;

View File

@ -1,9 +1,7 @@
! Copyright (C) 2009 Alaric Snell-Pym ! Copyright (C) 2009 Alaric Snell-Pym
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: checksums classes.singleton kernel math math.ranges USING: checksums classes.singleton kernel math math.ranges
math.vectors sequences ; math.vectors sequences ;
IN: checksums.fnv1 IN: checksums.fnv1
SINGLETON: fnv1-32 SINGLETON: fnv1-32

View File

@ -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 USING: byte-arrays checksums checksums.md5 io.encodings.binary
io.streams.byte-array kernel math namespaces tools.test ; io.streams.byte-array kernel math namespaces tools.test ;
IN: checksums.md5.tests
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

View File

@ -2,6 +2,7 @@
! See http;//factorcode.org/license.txt for BSD license ! See http;//factorcode.org/license.txt for BSD license
USING: arrays kernel tools.test sequences sequences.private USING: arrays kernel tools.test sequences sequences.private
circular strings ; circular strings ;
IN: circular.tests
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test [ 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 [ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

View File

@ -51,7 +51,7 @@ PRIVATE>
: push-growing-circular ( elt circular -- ) : push-growing-circular ( elt circular -- )
dup full? [ push-circular ] dup full? [ push-circular ]
[ [ 1+ ] change-length set-last ] if ; [ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular ) : <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ; { } new-sequence 0 0 growing-circular boa ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Kevin Reid. ! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: cocoa.callbacks
USING: assocs kernel namespaces cocoa cocoa.classes USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ; cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks SYMBOL: callbacks

View File

@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory compiler kernel namespaces cocoa.classes tools.test memory
compiler.units math core-graphics.types ; compiler.units math core-graphics.types ;
IN: cocoa.tests
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }

View File

@ -172,7 +172,7 @@ ERROR: no-objc-type name ;
[ ] [ no-objc-type ] ?if ; [ ] [ no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype ) : (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi { [ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] } { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] } { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] } { [ dup CHAR: { = ] [ drop objc-struct-type ] }

View File

@ -1,7 +1,7 @@
IN: cocoa.plists.tests
USING: tools.test cocoa.plists colors kernel hashtables USING: tools.test cocoa.plists colors kernel hashtables
core-foundation.utilities core-foundation destructors core-foundation.utilities core-foundation destructors
assocs cocoa.enumeration ; assocs cocoa.enumeration ;
IN: cocoa.plists.tests
[ [
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test

View File

@ -1,5 +1,5 @@
IN: colors.hsv.tests
USING: accessors kernel colors colors.hsv tools.test math ; USING: accessors kernel colors colors.hsv tools.test math ;
IN: colors.hsv.tests
: hsv>rgb ( h s v -- r g b ) : hsv>rgb ( h s v -- r g b )
[ 360 * ] 2dip [ 360 * ] 2dip

View File

@ -1,5 +1,5 @@
IN: columns.tests
USING: columns sequences kernel namespaces arrays tools.test math ; USING: columns sequences kernel namespaces arrays tools.test math ;
IN: columns.tests
! Columns ! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

View File

@ -1,32 +1,18 @@
USING: kernel math tools.test combinators.short-circuit.smart ; USING: kernel math tools.test combinators.short-circuit.smart ;
IN: combinators.short-circuit.smart.tests 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 ; [ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
: must-be-f ( in -- ) [ f ] swap 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 [ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f [ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
[ 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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test

View File

@ -1,13 +1,15 @@
USING: kernel sequences math stack-checker effects accessors macros USING: kernel sequences math stack-checker effects accessors
fry combinators.short-circuit ; macros fry combinators.short-circuit ;
IN: combinators.short-circuit.smart IN: combinators.short-circuit.smart
<PRIVATE <PRIVATE
ERROR: cannot-determine-arity ;
: arity ( quots -- n ) : arity ( quots -- n )
first infer first infer
dup terminated?>> [ "Cannot determine arity" throw ] when dup terminated?>> [ cannot-determine-arity ] when
effect-height neg 1+ ; effect-height neg 1 + ;
PRIVATE> PRIVATE>

View File

@ -28,7 +28,7 @@ HELP: output>array
{ $example { $example
<" USING: combinators combinators.smart math prettyprint ; <" USING: combinators combinators.smart math prettyprint ;
9 [ 9 [
{ [ 1- ] [ 1+ ] [ sq ] } cleave { [ 1 - ] [ 1 + ] [ sq ] } cleave
] output>array ."> ] output>array .">
"{ 8 10 81 }" "{ 8 10 81 }"
} }
@ -71,7 +71,7 @@ HELP: sum-outputs
{ $examples { $examples
{ $example { $example
"USING: combinators.smart kernel math prettyprint ;" "USING: combinators.smart kernel math prettyprint ;"
"10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ." "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
"20" "20"
} }
} ; } ;

View File

@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ;
IN: combinators.smart.tests IN: combinators.smart.tests
: test-bi ( -- 9 11 ) : test-bi ( -- 9 11 )
10 [ 1- ] [ 1+ ] bi ; 10 [ 1 - ] [ 1 + ] bi ;
[ [ test-bi ] output>array ] must-infer [ [ test-bi ] output>array ] must-infer
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test [ { 9 11 } ] [ [ test-bi ] output>array ] unit-test

View File

@ -1 +0,0 @@
IN: compiler.cfg.alias-analysis.tests

View File

@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ;
SYMBOL: ac-counter SYMBOL: ac-counter
: next-ac ( -- n ) : next-ac ( -- n )
ac-counter [ dup 1+ ] change ; ac-counter [ dup 1 + ] change ;
! Alias class for objects which are loaded from the data stack ! Alias class for objects which are loaded from the data stack
! or other object slots. We pessimistically assume that they ! or other object slots. We pessimistically assume that they

View File

@ -1,11 +1,11 @@
IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences words sequences.private fry USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
compiler.cfg arrays locals byte-arrays kernel.private math compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch slots.private vectors sbufs strings math.partial-dispatch
strings.private ; strings.private accessors compiler.cfg.instructions ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly. ! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) : unit-test-cfg ( quot -- )
@ -157,3 +157,26 @@ strings.private ;
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
] each ] each
: contains-insn? ( quot insn-check -- ? )
[ test-mr [ instructions>> ] map ] dip
'[ _ any? ] any? ; inline
[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
[ t ] [
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
] unit-test
[ t ] [
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
] unit-test
[ f ] [
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
] unit-test

View File

@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg.predecessors compiler.cfg ; compiler.cfg.predecessors compiler.cfg ;
IN: compiler.cfg.dataflow-analysis IN: compiler.cfg.dataflow-analysis
GENERIC: join-sets ( sets dfa -- set ) GENERIC: join-sets ( sets bb dfa -- set )
GENERIC: transfer-set ( in-set bb dfa -- out-set ) GENERIC: transfer-set ( in-set bb dfa -- out-set )
GENERIC: block-order ( cfg dfa -- bbs ) GENERIC: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq ) GENERIC: successors ( bb dfa -- seq )
@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-in-set 3drop f ; M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set ) M:: basic-block compute-in-set ( bb out-sets dfa -- set )
bb dfa predecessors [ out-sets at ] map dfa join-sets ; ! Only consider initialized sets.
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb dfa join-sets ;
:: update-in-set ( bb in-sets out-sets dfa -- ? ) :: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set bb out-sets dfa compute-in-set
@ -56,7 +60,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
in-sets in-sets
out-sets ; inline out-sets ; inline
M: dataflow-analysis join-sets drop assoc-refine ; M: dataflow-analysis join-sets 2drop assoc-refine ;
FUNCTOR: define-analysis ( name -- ) FUNCTOR: define-analysis ( name -- )

View File

@ -8,6 +8,7 @@ compiler.cfg
compiler.cfg.debugger compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.registers ; compiler.cfg.registers ;
IN: compiler.cfg.def-use.tests
V{ V{
T{ ##peek f 0 D 0 } T{ ##peek f 0 D 0 }

View File

@ -1,7 +1,7 @@
IN: compiler.cfg.dominance.tests
USING: tools.test sequences vectors namespaces kernel accessors assocs sets USING: tools.test sequences vectors namespaces kernel accessors assocs sets
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
compiler.cfg.predecessors ; compiler.cfg.predecessors ;
IN: compiler.cfg.dominance.tests
: test-dominance ( -- ) : test-dominance ( -- )
cfg new 0 get >>entry cfg new 0 get >>entry

View File

@ -1,8 +1,8 @@
IN: compiler.cfg.gc-checks.tests
USING: compiler.cfg.gc-checks compiler.cfg.debugger USING: compiler.cfg.gc-checks compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ; namespaces accessors sequences ;
IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- ) : test-gc-checks ( -- )
H{ } clone representations set H{ } clone representations set

View File

@ -8,11 +8,11 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.allot IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- ) : ##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 -- ) : emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi [ 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 ; [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs ) : tuple-slot-regs ( layout -- vregs )

View File

@ -1,9 +1,9 @@
IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
accessors accessors
compiler.cfg compiler.cfg
compiler.cfg.instructions cpu.architecture make sequences compiler.cfg.instructions cpu.architecture make sequences
compiler.cfg.linear-scan.allocation.state ; compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve.tests
[ [
{ {

View File

@ -65,7 +65,7 @@ SYMBOL: temp
: perform-mappings ( bb to mappings -- ) : perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [ dup empty? [ 3drop ] [
mapping-instructions <simple-block> insert-basic-block mapping-instructions insert-simple-basic-block
cfg get cfg-changed drop cfg get cfg-changed drop
] if ; ] if ;

View File

@ -1,4 +0,0 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;

View File

@ -28,4 +28,4 @@ M: live-analysis transfer-set
drop instructions>> transfer-liveness ; drop instructions>> transfer-liveness ;
M: live-analysis join-sets M: live-analysis join-sets
drop assoc-combine ; 2drop assoc-combine ;

View File

@ -1,8 +1,8 @@
IN: compiler.cfg.loop-detection.tests
USING: compiler.cfg compiler.cfg.loop-detection USING: compiler.cfg compiler.cfg.loop-detection
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.debugger compiler.cfg.debugger
tools.test kernel namespaces accessors ; tools.test kernel namespaces accessors ;
IN: compiler.cfg.loop-detection.tests
V{ } 0 test-bb V{ } 0 test-bb
V{ } 1 test-bb V{ } 1 test-bb

View File

@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection
TUPLE: natural-loop header index ends blocks ; TUPLE: natural-loop header index ends blocks ;
<PRIVATE
SYMBOL: loops SYMBOL: loops
<PRIVATE
: <natural-loop> ( header index -- loop ) : <natural-loop> ( header index -- loop )
H{ } clone H{ } clone natural-loop boa ; H{ } clone H{ } clone natural-loop boa ;

View File

@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ;
! computing anything. ! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [ 2dup [ kill-block? ] both? [ 2drop ] [
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty [ 2drop ] [ insert-simple-basic-block ] if-empty
] if ; ] if ;
: visit-block ( bb -- ) : visit-block ( bb -- )

View File

@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live
M: live-analysis transfer-set drop transfer-peeked-locs ; M: live-analysis transfer-set drop transfer-peeked-locs ;
M: live-analysis join-sets drop assoc-combine ; M: live-analysis join-sets 2drop assoc-combine ;
! A stack location is available at a location if all paths from ! A stack location is available at a location if all paths from
! the entry block to the location load the location into a ! the entry block to the location load the location into a

View File

@ -69,18 +69,11 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
: peek-loc ( loc -- vreg ) : peek-loc ( loc -- vreg )
translate-local-loc translate-local-loc
dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless dup replace-mapping get at
dup replace-mapping get at [ ] [ loc>vreg ] ?if ; [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
: replace-loc ( vreg loc -- ) : replace-loc ( vreg loc -- )
translate-local-loc translate-local-loc replace-mapping get set-at ;
2dup loc>vreg =
[ nip replace-mapping get delete-at ]
[
[ local-replace-set get conjoin ]
[ replace-mapping get set-at ]
bi
] if ;
: compute-local-kill-set ( -- assoc ) : compute-local-kill-set ( -- assoc )
basic-block get current-height get basic-block get current-height get
@ -90,13 +83,17 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
: begin-local-analysis ( -- ) : begin-local-analysis ( -- )
H{ } clone local-peek-set set H{ } clone local-peek-set set
H{ } clone local-replace-set set
H{ } clone replace-mapping set H{ } clone replace-mapping set
current-height get current-height get
[ 0 >>emit-d 0 >>emit-r drop ] [ 0 >>emit-d 0 >>emit-r drop ]
[ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ; [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
: remove-redundant-replaces ( -- )
replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
[ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
: end-local-analysis ( -- ) : end-local-analysis ( -- )
remove-redundant-replaces
emit-changes emit-changes
basic-block get { basic-block get {
[ [ local-peek-set get ] dip peek-sets get set-at ] [ [ local-peek-set get ] dip peek-sets get set-at ]

View File

@ -1,8 +1,8 @@
IN: compiler.cfg.stacks.uninitialized.tests
USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ; namespaces accessors sequences ;
IN: compiler.cfg.stacks.uninitialized.tests
: test-uninitialized ( -- ) : test-uninitialized ( -- )
cfg new 0 get >>entry cfg new 0 get >>entry

View File

@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
drop [ prepare ] dip visit-block finish ; drop [ prepare ] dip visit-block finish ;
M: uninitialized-analysis join-sets ( sets analysis -- pair ) M: uninitialized-analysis join-sets ( sets analysis -- pair )
drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
: uninitialized-locs ( bb -- locs ) : uninitialized-locs ( bb -- locs )
uninitialized-in dup [ uninitialized-in dup [

View File

@ -1,6 +1,6 @@
IN: compiler.cfg.two-operand.tests
USING: kernel compiler.cfg.two-operand compiler.cfg.instructions USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
compiler.cfg.registers cpu.architecture namespaces tools.test ; compiler.cfg.registers cpu.architecture namespaces tools.test ;
IN: compiler.cfg.two-operand.tests
3 vreg-counter set-global 3 vreg-counter set-global

View File

@ -3,7 +3,7 @@
USING: accessors assocs combinators combinators.short-circuit USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences cpu.architecture kernel layouts locals make math namespaces sequences
sets vectors fry compiler.cfg compiler.cfg.instructions sets vectors fry compiler.cfg compiler.cfg.instructions
compiler.cfg.rpo ; compiler.cfg.rpo arrays ;
IN: compiler.cfg.utilities IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block PREDICATE: kill-block < basic-block
@ -37,16 +37,16 @@ SYMBOL: visited
: skip-empty-blocks ( bb -- bb' ) : skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ; H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: insert-basic-block ( from to bb -- ) :: insert-basic-block ( froms to bb -- )
bb from 1vector >>predecessors drop bb froms V{ } like >>predecessors drop
bb to 1vector >>successors drop bb to 1vector >>successors drop
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
from successors>> [ dup to eq? [ drop bb ] when ] change-each ; froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
: add-instructions ( bb quot -- ) : add-instructions ( bb quot -- )
[ instructions>> building ] dip '[ [ instructions>> building ] dip '[
building get pop building get pop
@ [ @ ] dip
, ,
] with-variable ; inline ] with-variable ; inline
@ -56,6 +56,9 @@ SYMBOL: visited
\ ##branch new-insn over push \ ##branch new-insn over push
>>instructions ; >>instructions ;
: insert-simple-basic-block ( from to insns -- )
[ 1vector ] 2dip <simple-block> insert-basic-block ;
: has-phis? ( bb -- ? ) : has-phis? ( bb -- ? )
instructions>> first ##phi? ; instructions>> first ##phi? ;

View File

@ -0,0 +1,2 @@
Slava Pestov
Daniel Ehrenberg

View File

@ -1,7 +1,16 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
compiler.cfg.registers compiler.cfg.debugger cpu.architecture ! See http://factorcode.org/license.txt for BSD license.
arrays tools.test vectors compiler.cfg kernel accessors USING: accessors arrays assocs compiler.cfg
compiler.cfg.utilities ; compiler.cfg.alias-analysis compiler.cfg.block-joining
compiler.cfg.branch-splitting compiler.cfg.copy-prop
compiler.cfg.dce compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.loop-detection
compiler.cfg.registers compiler.cfg.ssa.construction
compiler.cfg.tco compiler.cfg.useless-conditionals
compiler.cfg.utilities compiler.cfg.value-numbering
compiler.cfg.write-barrier cpu.architecture kernel
kernel.private math namespaces sequences sequences.private
tools.test vectors ;
IN: compiler.cfg.write-barrier.tests IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns ) : test-write-barrier ( insns -- insns )
@ -70,3 +79,112 @@ IN: compiler.cfg.write-barrier.tests
T{ ##write-barrier f 19 30 3 } T{ ##write-barrier f 19 30 3 }
} test-write-barrier } test-write-barrier
] unit-test ] unit-test
V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 1 test-bb
V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 2 test-bb
1 get 2 get 1vector >>successors drop
cfg new 1 get >>entry 0 set
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
[ V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} ] [ 1 get instructions>> ] unit-test
[ V{
T{ ##set-slot-imm f 2 1 3 4 }
} ] [ 2 get instructions>> ] unit-test
V{
T{ ##allot f 1 }
} 1 test-bb
V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 2 test-bb
1 get 2 get 1vector >>successors drop
cfg new 1 get >>entry 0 set
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
[ V{
T{ ##allot f 1 }
} ] [ 1 get instructions>> ] unit-test
[ V{
T{ ##set-slot-imm f 2 1 3 4 }
} ] [ 2 get instructions>> ] unit-test
V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 1 test-bb
V{
T{ ##allot }
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 2 test-bb
1 get 2 get 1vector >>successors drop
cfg new 1 get >>entry 0 set
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
[ V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} ] [ 1 get instructions>> ] unit-test
[ V{
T{ ##allot }
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} ] [ 2 get instructions>> ] unit-test
V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 1 test-bb
V{
T{ ##allot }
} 2 test-bb
1 get 2 get 1vector >>successors drop
V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} 3 test-bb
2 get 3 get 1vector >>successors drop
cfg new 1 get >>entry 0 set
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
[ V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} ] [ 1 get instructions>> ] unit-test
[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test
[ V{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} ] [ 3 get instructions>> ] unit-test
: reverse-here' ( seq -- )
{ array } declare
[ length 2/ iota ] [ length ] [ ] tri
[ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: write-barrier-stats ( word -- cfg )
test-cfg first [
optimize-tail-calls
delete-useless-conditionals
split-branches
join-blocks
construct-ssa
alias-analysis
value-numbering
copy-propagation
eliminate-dead-code
eliminate-write-barriers
] with-cfg
post-order>> write-barriers
[ [ loop-nesting-at ] [ length ] bi* ] assoc-map ;
[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test

View File

@ -1,7 +1,16 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences USING: kernel accessors namespaces assocs sets sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; fry combinators.short-circuit locals make arrays
compiler.cfg
compiler.cfg.dominance
compiler.cfg.predecessors
compiler.cfg.loop-detection
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.dataflow-analysis
compiler.cfg.utilities ;
IN: compiler.cfg.write-barrier IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits. ! Eliminate redundant write barrier hits.
@ -19,21 +28,112 @@ M: ##allot eliminate-write-barrier
dst>> safe get conjoin t ; dst>> safe get conjoin t ;
M: ##write-barrier eliminate-write-barrier M: ##write-barrier eliminate-write-barrier
src>> dup [ safe get key? not ] [ mutated get key? ] bi and src>> dup safe get key? not
[ safe get conjoin t ] [ drop f ] if ; [ safe get conjoin t ] [ drop f ] if ;
M: ##set-slot eliminate-write-barrier
obj>> mutated get conjoin t ;
M: ##set-slot-imm eliminate-write-barrier
obj>> mutated get conjoin t ;
M: insn eliminate-write-barrier drop t ; M: insn eliminate-write-barrier drop t ;
! This doesn't actually benefit from being a dataflow analysis
! might as well be dominator-based
! Dealing with phi functions would help, though
FORWARD-ANALYSIS: safe
: has-allocation? ( bb -- ? )
instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
M: safe-analysis transfer-set
drop [ H{ } assoc-clone-like safe set ] dip
instructions>> [
eliminate-write-barrier drop
] each safe get ;
M: safe-analysis join-sets
drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
: write-barriers-step ( bb -- ) : write-barriers-step ( bb -- )
H{ } clone safe set dup safe-in H{ } assoc-clone-like safe set
H{ } clone mutated set
instructions>> [ eliminate-write-barrier ] filter-here ; instructions>> [ eliminate-write-barrier ] filter-here ;
GENERIC: remove-dead-barrier ( insn -- ? )
M: ##write-barrier remove-dead-barrier
src>> mutated get key? ;
M: ##set-slot remove-dead-barrier
obj>> mutated get conjoin t ;
M: ##set-slot-imm remove-dead-barrier
obj>> mutated get conjoin t ;
M: insn remove-dead-barrier drop t ;
: remove-dead-barriers ( bb -- )
H{ } clone mutated set
instructions>> [ remove-dead-barrier ] filter-here ;
! Availability of slot
! Anticipation of this and set-slot would help too, maybe later
FORWARD-ANALYSIS: slot
UNION: access ##read ##write ;
M: slot-analysis transfer-set
drop [ H{ } assoc-clone-like ] dip
instructions>> over '[
dup access? [
obj>> _ conjoin
] [ drop ] if
] each ;
: slot-available? ( vreg bb -- ? )
slot-in key? ;
: make-barriers ( vregs -- bb )
[ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
: emit-barriers ( vregs loop -- )
swap [
[ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
[ header>> ] bi
] [ make-barriers ] bi*
insert-basic-block ;
: write-barriers ( bbs -- bb=>barriers )
[
dup instructions>>
[ ##write-barrier? ] filter
[ src>> ] map
] { } map>assoc
[ nip empty? not ] assoc-filter ;
: filter-dominant ( bb=>barriers bbs -- barriers )
'[ drop _ [ dominates? ] with all? ] assoc-filter
values concat prune ;
: dominant-write-barriers ( loop -- vregs )
[ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
: safe-loops ( -- loops )
loops get values
[ blocks>> keys [ has-allocation? not ] all? ] filter ;
:: insert-extra-barriers ( cfg -- )
safe-loops [| loop |
cfg needs-dominance needs-predecessors drop
loop dominant-write-barriers
loop header>> '[ _ slot-available? ] filter
[ loop emit-barriers cfg cfg-changed drop ] unless-empty
] each ;
: contains-write-barrier? ( cfg -- ? )
post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
: eliminate-write-barriers ( cfg -- cfg' ) : eliminate-write-barriers ( cfg -- cfg' )
dup [ write-barriers-step ] each-basic-block ; dup contains-write-barrier? [
needs-loops
dup [ remove-dead-barriers ] each-basic-block
dup compute-slot-sets
dup insert-extra-barriers
dup compute-safe-sets
dup [ write-barriers-step ] each-basic-block
] when ;

View File

@ -1,6 +1,6 @@
IN: compiler.codegen.tests
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants ; compiler.constants ;
IN: compiler.codegen.tests
[ ] [ [ ] with-fixup drop ] unit-test [ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test [ ] [ [ \ + %call ] with-fixup drop ] unit-test

2
basis/compiler/compiler.factor Normal file → Executable file
View File

@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
} cond ; } cond ;
: optimize? ( word -- ? ) : optimize? ( word -- ? )
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; single-generic? not ;
: contains-breakpoints? ( -- ? ) : contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ; dependencies get keys [ "break?" word-prop ] any? ;

View File

@ -395,7 +395,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
: callback-9 ( -- callback ) : callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [ "int" { "int" "int" "int" } "cdecl" [
+ + 1+ + + 1 +
] alien-callback ; ] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ; FUNCTION: void ffi_test_36_point_5 ( ) ;

View File

@ -1,5 +1,5 @@
IN: compiler.tests.call-effect
USING: tools.test combinators generic.single sequences kernel ; USING: tools.test combinators generic.single sequences kernel ;
IN: compiler.tests.call-effect
: execute-ic-test ( a b -- c ) execute( a -- c ) ; : execute-ic-test ( a b -- c ) execute( a -- c ) ;

View File

@ -1,6 +1,6 @@
IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test

View File

@ -1,5 +1,5 @@
IN: compiler.tests.generic
USING: tools.test math kernel compiler.units definitions ; USING: tools.test math kernel compiler.units definitions ;
IN: compiler.tests.generic
GENERIC: bad ( -- ) GENERIC: bad ( -- )
M: integer bad ; M: integer bad ;

View File

@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler definitions ; compiler definitions generic.single ;
IN: compiler.tests.optimizer IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
@ -67,7 +67,7 @@ TUPLE: pred-test ;
[ 3 ] [ t bad-kill-2 ] unit-test [ 3 ] [ t bad-kill-2 ] unit-test
! regression ! 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) ; : the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test [ 2 0 ] [ the-test ] unit-test
@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * )
! regression ! regression
: branch-fold-regression-0 ( m -- n ) : 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 ) : branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ; 10 branch-fold-regression-0 ;
@ -348,12 +348,12 @@ TUPLE: some-tuple x ;
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test [ 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-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 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-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-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-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 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test
: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ; : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
@ -382,7 +382,7 @@ DEFER: loop-bbb
! Type inference issue ! Type inference issue
[ 4 3 ] [ [ 4 3 ] [
1 >bignum 2 >bignum 1 >bignum 2 >bignum
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
] unit-test ] unit-test
: broken-declaration ( -- ) \ + declare ; : broken-declaration ( -- ) \ + declare ;
@ -423,3 +423,6 @@ M: object bad-dispatch-position-test* ;
\ bad-dispatch-position-test* forget \ bad-dispatch-position-test* forget
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
! Not sure if I want to fix this...
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with

View File

@ -1,5 +1,5 @@
IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ; USING: peg.ebnf strings tools.test ;
IN: compiler.tests.peg-regression-2
GENERIC: <times> ( times -- term' ) GENERIC: <times> ( times -- term' )
M: string <times> ; M: string <times> ;

View File

@ -1,5 +1,5 @@
IN: compiler.tests.pic-problem-1
USING: kernel sequences prettyprint memory tools.test ; USING: kernel sequences prettyprint memory tools.test ;
IN: compiler.tests.pic-problem-1
TUPLE: x ; TUPLE: x ;

View File

@ -1,6 +1,6 @@
IN: compiler.tests.redefine0
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
namespaces macros assocs ; namespaces macros assocs ;
IN: compiler.tests.redefine0
! Test ripple-up behavior ! Test ripple-up behavior
: test-1 ( -- a ) 3 ; : test-1 ( -- a ) 3 ;

View File

@ -11,7 +11,7 @@ DEFER: word-1
: word-3 ( a -- b ) 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 1 ] [ 0 word-4 ] unit-test

View File

@ -1,6 +1,6 @@
IN: compiler.tests.redefine16
USING: eval tools.test definitions words compiler.units USING: eval tools.test definitions words compiler.units
quotations stack-checker ; quotations stack-checker ;
IN: compiler.tests.redefine16
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test [ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test

View File

@ -1,6 +1,6 @@
IN: compiler.tests.redefine17
USING: tools.test classes.mixin compiler.units arrays kernel.private USING: tools.test classes.mixin compiler.units arrays kernel.private
strings sequences vocabs definitions kernel ; strings sequences vocabs definitions kernel ;
IN: compiler.tests.redefine17
<< "compiler.tests.redefine17" words forget-all >> << "compiler.tests.redefine17" words forget-all >>

View File

@ -1,7 +1,7 @@
IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ; arrays words assocs eval words.symbol ;
IN: compiler.tests.redefine2
DEFER: redefine2-test DEFER: redefine2-test

View File

@ -1,15 +1,15 @@
IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ; definitions arrays words assocs eval ;
IN: compiler.tests.redefine3
GENERIC: sheeple ( obj -- x ) GENERIC: sheeple ( obj -- x )
M: object sheeple drop "sheeple" ; M: object sheeple drop "sheeple" ; inline
MIXIN: empty-mixin MIXIN: empty-mixin
M: empty-mixin sheeple drop "wake up" ; M: empty-mixin sheeple drop "wake up" ; inline
: sheeple-test ( -- string ) { } sheeple ; : sheeple-test ( -- string ) { } sheeple ;

View File

@ -1,5 +1,5 @@
IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ; USING: io.streams.string kernel tools.test eval ;
IN: compiler.tests.redefine4
: declaration-test-1 ( -- a ) 3 ; flushable : declaration-test-1 ( -- a ) 3 ; flushable

View File

@ -1,5 +1,5 @@
IN: compiler.tests.reload
USE: vocabs.loader USE: vocabs.loader
IN: compiler.tests.reload
! "parser" reload ! "parser" reload
! "sequences" reload ! "sequences" reload

View File

@ -1,7 +1,7 @@
IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ; words splitting grouping sorting accessors ;
IN: compiler.tests.stack-trace
: symbolic-stack-trace ( -- newseq ) : symbolic-stack-trace ( -- newseq )
error-continuation get call>> callstack>array error-continuation get call>> callstack>array
@ -13,7 +13,7 @@ words splitting grouping sorting accessors ;
[ baz ] [ 3 = ] must-fail-with [ baz ] [ 3 = ] must-fail-with
[ t ] [ [ t ] [
symbolic-stack-trace symbolic-stack-trace
[ word? ] filter 2 head*
{ baz bar foo } tail? { baz bar foo } tail?
] unit-test ] unit-test

View File

@ -1,5 +1,5 @@
IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ; USING: kernel tools.test compiler.units compiler ;
IN: compiler.tests.tuples
TUPLE: color red green blue ; TUPLE: color red green blue ;

View File

@ -1,6 +1,6 @@
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel USING: compiler.tree.builder tools.test sequences kernel
compiler.tree stack-checker stack-checker.errors ; compiler.tree stack-checker stack-checker.errors ;
IN: compiler.tree.builder.tests
: inline-recursive ( -- ) inline-recursive ; inline recursive : inline-recursive ( -- ) inline-recursive ; inline recursive

View File

@ -1,4 +0,0 @@
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;

View File

@ -1,4 +1,3 @@
IN: compiler.tree.cleanup.tests
USING: tools.test kernel.private kernel arrays sequences USING: tools.test kernel.private kernel arrays sequences
math.private math generic words quotations alien alien.c-types math.private math generic words quotations alien alien.c-types
strings sbufs sequences.private slots.private combinators strings sbufs sequences.private slots.private combinators
@ -17,6 +16,7 @@ compiler.tree.propagation
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.checker compiler.tree.checker
compiler.tree.debugger ; compiler.tree.debugger ;
IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
@ -41,13 +41,13 @@ compiler.tree.debugger ;
GENERIC: mynot ( x -- y ) GENERIC: mynot ( x -- y )
M: f mynot drop t ; M: f mynot drop t ; inline
M: object mynot drop f ; M: object mynot drop f ; inline
GENERIC: detect-f ( x -- y ) GENERIC: detect-f ( x -- y )
M: f detect-f ; M: f detect-f ; inline
[ t ] [ [ t ] [
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined? [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
@ -55,9 +55,9 @@ M: f detect-f ;
GENERIC: xyz ( n -- n ) GENERIC: xyz ( n -- n )
M: integer xyz ; M: integer xyz ; inline
M: object xyz ; M: object xyz ; inline
[ t ] [ [ t ] [
[ { integer } declare xyz ] \ xyz inlined? [ { integer } declare xyz ] \ xyz inlined?
@ -88,7 +88,7 @@ M: object xyz ;
2over dup xyz drop >= [ 2over dup xyz drop >= [
3drop 3drop
] [ ] [
[ swap [ call 1+ ] dip ] keep (i-repeat) [ swap [ call 1 + ] dip ] keep (i-repeat)
] if ; inline recursive ] if ; inline recursive
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
@ -115,10 +115,6 @@ M: object xyz ;
[ { fixnum } declare [ ] times ] \ >= inlined? [ { fixnum } declare [ ] times ] \ >= inlined?
] unit-test ] unit-test
[ t ] [
[ { fixnum } declare [ ] times ] \ 1+ inlined?
] unit-test
[ t ] [ [ t ] [
[ { fixnum } declare [ ] times ] \ + inlined? [ { fixnum } declare [ ] times ] \ + inlined?
] unit-test ] unit-test
@ -172,19 +168,6 @@ M: object xyz ;
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined? [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
] unit-test ] 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 -- ) GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ; M: fixnum annotate-entry-test-1 drop ;
@ -193,7 +176,7 @@ M: fixnum annotate-entry-test-1 drop ;
2dup >= [ 2dup >= [
2drop 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 ] if ; inline recursive
: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
@ -305,10 +288,6 @@ cell-bits 32 = [
] \ + inlined? ] \ + inlined?
] unit-test ] unit-test
[ t ] [
[ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b ) : rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline recursive dup 0 > [ 1 - rec ] when ; inline recursive
@ -467,7 +446,7 @@ cell-bits 32 = [
: buffalo-wings ( i seq -- ) : buffalo-wings ( i seq -- )
2dup < [ 2dup < [
2dup chicken-fingers 2dup chicken-fingers
[ 1+ ] dip buffalo-wings [ 1 + ] dip buffalo-wings
] [ ] [
2drop 2drop
] if ; inline recursive ] if ; inline recursive
@ -486,7 +465,7 @@ cell-bits 32 = [
: ribs ( i seq -- ) : ribs ( i seq -- )
2dup < [ 2dup < [
steak steak
[ 1+ ] dip ribs [ 1 + ] dip ribs
] [ ] [
2drop 2drop
] if ; inline recursive ] if ; inline recursive

View File

@ -1,5 +1,5 @@
IN: compiler.tree.combinators.tests
USING: compiler.tree.combinators tools.test kernel ; USING: compiler.tree.combinators tools.test kernel ;
IN: compiler.tree.combinators.tests
{ 1 0 } [ [ drop ] each-node ] must-infer-as { 1 0 } [ [ drop ] each-node ] must-infer-as
{ 1 1 } [ [ ] map-nodes ] must-infer-as { 1 1 } [ [ ] map-nodes ] must-infer-as

View File

@ -3,8 +3,7 @@
USING: sequences namespaces kernel accessors assocs sets fry USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend arrays combinators columns stack-checker.backend
stack-checker.branches compiler.tree compiler.tree.combinators 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 IN: compiler.tree.dead-code.branches
M: #if mark-live-values* look-at-inputs ; M: #if mark-live-values* look-at-inputs ;

Some files were not shown because too many files have changed in this diff Show More