-IN: alarms.tests\r
USING: alarms alarms.private kernel calendar sequences\r
tools.test threads concurrency.count-downs ;\r
+IN: alarms.tests\r
\r
[ ] [\r
1 <count-down>\r
! 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
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 ]
M: array c-type-class drop object ;
+M: array c-type-boxed-class drop object ;
+
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-M: value-type c-type-reg-class drop int-regs ;
+M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: string-type c-type ;
-M: string-type c-type-class
- drop object ;
+M: string-type c-type-class drop object ;
+
+M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type stack-size
drop "void*" stack-size ;
-M: string-type c-type-reg-class
- drop int-regs ;
+M: string-type c-type-rep
+ drop int-rep ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
-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
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-TUPLE: c-type
+TUPLE: abstract-c-type
{ class class initial: object }
-boxer
+{ boxed-class class initial: object }
{ boxer-quot callable }
-unboxer
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
-{ reg-class initial: int-regs }
size
-align
+align ;
+
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
stack-align? ;
: <c-type> ( -- type )
GENERIC: c-type-class ( name -- class )
-M: c-type c-type-class class>> ;
+M: abstract-c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
+GENERIC: c-type-boxed-class ( name -- class )
+
+M: abstract-c-type c-type-boxed-class boxed-class>> ;
+
+M: string c-type-boxed-class c-type c-type-boxed-class ;
+
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
GENERIC: c-type-boxer-quot ( name -- quot )
-M: c-type c-type-boxer-quot boxer-quot>> ;
+M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer-quot ( name -- quot )
-M: c-type c-type-unboxer-quot unboxer-quot>> ;
+M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
-GENERIC: c-type-reg-class ( name -- reg-class )
+GENERIC: c-type-rep ( name -- rep )
-M: c-type c-type-reg-class reg-class>> ;
+M: c-type c-type-rep rep>> ;
-M: string c-type-reg-class c-type c-type-reg-class ;
+M: string c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
GENERIC: c-type-align ( name -- n )
-M: c-type c-type-align align>> ;
+M: abstract-c-type c-type-align align>> ;
M: string c-type-align c-type c-type-align ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
- dup c-type-reg-class
- swap c-type-boxer [ "No boxer" throw ] unless*
+ [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
: c-type-unbox ( n ctype -- )
- dup c-type-reg-class
- swap c-type-unboxer [ "No unboxer" throw ] unless*
+ [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
GENERIC: box-parameter ( n ctype -- )
M: string heap-size c-type heap-size ;
-M: c-type heap-size size>> ;
+M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
[
<c-type>
c-ptr >>class
+ c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
<long-long-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
<long-long-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
<c-type>
float >>class
+ float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
- single-float-regs >>reg-class
+ single-float-rep >>rep
[ >float ] >>unboxer-quot
"float" define-primitive-type
<c-type>
float >>class
+ float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
- double-float-regs >>reg-class
+ double-float-rep >>rep
[ >float ] >>unboxer-quot
"double" define-primitive-type
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex kernel alien.c-types alien.syntax
-namespaces ;
+namespaces math ;
IN: alien.complex.tests
C-STRUCT: complex-holder
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
+
+[ number ] [ "complex-float" c-type-boxed-class ] unit-test
+
+[ number ] [ "complex-double" c-type-boxed-class ] unit-test
\ No newline at end of file
! 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
- >>
+>>
+++ /dev/null
-! 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
T c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
+number >>boxed-class
drop
;FUNCTOR
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests
: (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* ;
: (fortran-in-shuffle) ( ret par -- seq )
- [ [ second ] bi@ <=> ] sort append ;
+ [ second ] sort-with append ;
: (fortran-out-shuffle) ( ret par -- seq )
append ;
-IN: alien.libraries.tests
USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
-[ "fdasfsf" dll-valid? drop ] must-fail
\ No newline at end of file
+[ "fdasfsf" dll-valid? drop ] must-fail
-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" }
quotations byte-arrays ;
IN: alien.structs
-TUPLE: struct-type
-size
-align
-fields
-{ boxer-quot callable }
-{ unboxer-quot callable }
-{ getter callable }
-{ setter callable }
-return-in-registers? ;
+TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
M: struct-type c-type ;
-M: struct-type heap-size size>> ;
-
-M: struct-type c-type-class drop byte-array ;
-
-M: struct-type c-type-align align>> ;
-
M: struct-type c-type-stack-align? drop f ;
-M: struct-type c-type-boxer-quot boxer-quot>> ;
-
-M: struct-type c-type-unboxer-quot unboxer-quot>> ;
-
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type new
+ byte-array >>class
+ byte-array >>boxed-class
swap >>fields
swap >>align
swap >>size
";" 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 ;
[ 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
: write1-lines ( ch -- )
write1
column get [
- 1+ [ 76 = [ crlf ] when ]
+ 1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
: 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 ]
-IN: biassocs.tests
USING: biassocs assocs namespaces tools.test ;
+IN: biassocs.tests
<bihash> "h" set
[ "A" ] [ "a" "b" get at ] unit-test
-[ "a" ] [ "A" "b" get value-at ] unit-test
\ No newline at end of file
+[ "a" ] [ "A" "b" get value-at ] unit-test
-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
[ 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
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 ;
-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 }
-IN: bit-vectors.tests\r
USING: tools.test bit-vectors vectors sequences kernel math ;\r
+IN: bit-vectors.tests\r
\r
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
io.streams.byte-array ;
IN: bitstreams.tests
-
[ BIN: 1111111111 ]
[
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
[ 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
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
-compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
-compiler.cfg.stacks.finalize compiler.cfg.stacks.global
-compiler.codegen compiler.tree.builder compiler.tree.optimizer
-kernel make sequences tools.annotations tools.crossref ;
+USING: accessors kernel make sequences tools.annotations tools.crossref ;
+QUALIFIED: compiler.cfg.builder
+QUALIFIED: compiler.cfg.linear-scan
+QUALIFIED: compiler.cfg.mr
+QUALIFIED: compiler.cfg.optimizer
+QUALIFIED: compiler.cfg.stacks.finalize
+QUALIFIED: compiler.cfg.stacks.global
+QUALIFIED: compiler.codegen
+QUALIFIED: compiler.tree.builder
+QUALIFIED: compiler.tree.optimizer
IN: bootstrap.compiler.timing
: passes ( word -- seq )
def>> uses [ vocabulary>> "compiler." head? ] filter ;
-: high-level-passes ( -- seq ) \ optimize-tree passes ;
+: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
-: low-level-passes ( -- seq ) \ optimize-cfg passes ;
+: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
-: machine-passes ( -- seq ) \ build-mr passes ;
+: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
-: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
+: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
: all-passes ( -- seq )
[
- \ build-tree ,
- \ optimize-tree ,
+ \ compiler.tree.builder:build-tree ,
+ \ compiler.tree.optimizer:optimize-tree ,
high-level-passes %
- \ build-cfg ,
- \ compute-global-sets ,
- \ finalize-stack-shuffling ,
- \ optimize-cfg ,
+ \ compiler.cfg.builder:build-cfg ,
+ \ compiler.cfg.stacks.global:compute-global-sets ,
+ \ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
+ \ compiler.cfg.optimizer:optimize-cfg ,
low-level-passes %
- \ compute-live-sets ,
- \ build-mr ,
+ \ compiler.cfg.mr:build-mr ,
machine-passes %
linear-scan-passes %
- \ generate ,
+ \ compiler.codegen:generate ,
] { } make ;
all-passes [ [ reset ] [ add-timing ] bi ] each
\ No newline at end of file
-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
: 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.
: 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 ;
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 ;
"math.ratios" require
"math.floats" require
-"math.complex" require
\ No newline at end of file
+"math.complex" require
-IN: boxes.tests\r
USING: boxes namespaces tools.test accessors ;\r
+IN: boxes.tests\r
\r
[ ] [ <box> "b" set ] unit-test\r
\r
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
parsed ;
-
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests
: 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 ;
\ No newline at end of file
+ ] change-assoc drop ;
-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
\ No newline at end of file
+] unit-test
{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
- { $example "USING: calendar prettyprint ;"
- "2010 12 25 <date> >gmt midnight ."
+ { $example "USING: accessors calendar prettyprint ;"
+ "2010 12 25 <date> instant >>gmt-offset ."
"T{ timestamp { year 2010 } { month 12 } { day 25 } }"
}
} ;
HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
{ $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." } ;
: <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>
-: month-names ( -- array )
+CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
- } ;
+ }
: month-name ( n -- string )
- check-month 1- month-names nth ;
+ check-month 1 - month-names nth ;
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 }
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' )
{ [ 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 ;
[ 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 ;
#! 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 )
year leap-year? [
year month day <date>
year 3 1 <date>
- after=? [ 1+ ] when
+ after=? [ 1 + ] when
] when ;
: day-of-year ( timestamp -- n )
[ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
over " " <repetition> concat write\r
[\r
- [ 1+ day. ] keep\r
- 1+ + 7 mod zero? [ nl ] [ bl ] if\r
+ [ 1 + day. ] keep\r
+ 1 + + 7 mod zero? [ nl ] [ bl ] if\r
] with each nl ;\r
\r
M: timestamp month. ( timestamp -- )\r
GENERIC: year. ( obj -- )\r
\r
M: integer year. ( n -- )\r
- 12 [ 1+ 2array month. nl ] with each ;\r
+ 12 [ 1 + 2array month. nl ] with each ;\r
\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
\r
: read-rfc3339-seconds ( s -- s' ch )\r
"+-Z" read-until [\r
- [ string>number ] [ length 10 swap ^ ] bi / +\r
+ [ string>number ] [ length 10^ ] bi / +\r
] dip ;\r
\r
: (rfc3339>timestamp) ( -- timestamp )\r
"," read-token day-abbreviations3 member? check-timestamp drop\r
read1 CHAR: \s assert=\r
read-sp checked-number >>day\r
- read-sp month-abbreviations index 1+ check-timestamp >>month\r
+ read-sp month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>year\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
"," read-token check-day-name\r
read1 CHAR: \s assert=\r
"-" read-token checked-number >>day\r
- "-" read-token month-abbreviations index 1+ check-timestamp >>month\r
+ "-" read-token month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>year\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
: (cookie-string>timestamp-2) ( -- timestamp )\r
timestamp new\r
read-sp check-day-name\r
- read-sp month-abbreviations index 1+ check-timestamp >>month\r
+ read-sp month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>day\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
IN: channels.examples
: (counter) ( channel n -- )
- [ swap to ] 2keep 1+ (counter) ;
+ [ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- )
2 (counter) ;
! 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
+! 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
! 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
: 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 ;
! 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
-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" }
[ ] [ 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 ] }
-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
[ 3.5 ] [
3.5 >cf &CFRelease plist>
] unit-test
-] with-destructors
\ No newline at end of file
+] with-destructors
-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
[ 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
\ No newline at end of file
+[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
-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
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
HELP: 1&&
-{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 1||
-{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 2||
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 3||
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&
-
USING: kernel math tools.test combinators.short-circuit.smart ;
-
IN: combinators.short-circuit.smart.tests
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap 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
-
-[ { [ 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
+[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test
+[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
+[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
+[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test
-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>
{ $example
<" USING: combinators combinators.smart math prettyprint ;
9 [
- { [ 1- ] [ 1+ ] [ sq ] } cleave
+ { [ 1 - ] [ 1 + ] [ sq ] } cleave
] output>array .">
"{ 8 10 81 }"
}
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
- "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+ "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
"20"
}
} ;
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
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
-[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
\ No newline at end of file
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+++ /dev/null
-IN: compiler.cfg.alias-analysis.tests
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
-accessors vectors combinators sets classes compiler.cfg
+accessors vectors combinators sets classes cpu.architecture compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
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
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
- 2nip \ ##copy new-insn analyze-aliases* nip
+ 2nip any-rep \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
eliminate-dead-stores ;
: alias-analysis ( cfg -- cfg' )
- [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
+ [ alias-analysis-step ] local-optimization ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel sequences math
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.utilities ;
+compiler.cfg.predecessors compiler.cfg.utilities ;
IN: compiler.cfg.block-joining
! Joining blocks that are not calls and are connected by a single CFG edge.
-! Predecessors must be recomputed after this. Also this pass does not
-! update ##phi nodes and should therefore only run before stack analysis.
+! This pass does not update ##phi nodes and should therefore only run
+! before stack analysis.
: join-block? ( bb -- ? )
{
[ kill-block? not ]
[ join-instructions ] [ update-successors ] 2bi ;
: join-blocks ( cfg -- cfg' )
+ needs-predecessors
+
dup post-order [
dup join-block?
[ dup predecessor join-block ] [ drop ] if
] each
- cfg-changed ;
+
+ cfg-changed predecessors-changed ;
: check-predecessors ( cfg -- )
[ get-predecessors ]
- [ compute-predecessors drop ]
+ [ needs-predecessors drop ]
[ get-predecessors ] tri assert= ;
: check-branch-splitting ( cfg -- )
- compute-predecessors
+ needs-predecessors
split-branches
check-predecessors ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math math.order
sequences assocs namespaces vectors fry arrays splitting
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
] if ;
: split-branches ( cfg -- cfg' )
+ needs-predecessors
+
dup [
dup split-branch? [ split-branch ] [ drop ] if
] each-basic-block
+
cfg-changed ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
-combinators make classes words cpu.architecture
+combinators make classes words cpu.architecture layouts
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
-SYMBOL: spill-counts
-
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
M: _gc compute-stack-frame*
frame-required? on
- stack-frame new swap gc-root-size>> >>gc-root-size
+ stack-frame new swap tagged-values>> length cells >>gc-root-size
request-stack-frame ;
-M: _spill-counts compute-stack-frame*
- counts>> stack-frame get (>>spill-counts) ;
+M: _spill-area-size compute-stack-frame*
+ n>> stack-frame get (>>spill-area-size) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
: compute-stack-frame ( insns -- )
frame-required? off
- T{ stack-frame } clone stack-frame set
+ stack-frame new stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
-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
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-arrays locals byte-arrays kernel.private math slots.private vectors sbufs
-strings math.partial-dispatch strings.private ;
+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 -- )
- '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
+ '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
+compiler.cfg.stacks.local
compiler.alien ;
IN: compiler.cfg.builder
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
- ds-pop ^^offset>slot i ##dispatch emit-if ;
+ ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
! #call
M: #call emit-node
literal>> ^^load-literal ds-push ;
! #shuffle
+
+! Even though low level IR has its own dead code elimination pass,
+! we try not to introduce useless ##peeks here, since this reduces
+! the accuracy of global stack analysis.
+
+: make-input-map ( #shuffle -- assoc )
+ ! Assoc maps high-level IR values to stack locations.
+ [
+ [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
+ [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
+ ] H{ } make-assoc ;
+
+: make-output-seq ( values mapping input-map -- vregs )
+ '[ _ at _ at peek-loc ] map ;
+
+: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
+ [ [ out-d>> ] 2dip make-output-seq ]
+ [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
+
+: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
+ [ [ in-d>> length neg inc-d ] dip ds-store ]
+ [ [ in-r>> length neg inc-r ] dip rs-store ]
+ bi-curry* bi ;
+
M: #shuffle emit-node
- dup
- H{ } clone
- [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
- [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
- [ nip ] 2tri
- [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
- [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
+ dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
: emit-return ( -- )
M: #enter-recursive emit-node drop ;
M: #phi emit-node drop ;
+
+M: #declare emit-node drop ;
\ No newline at end of file
V{ } clone >>predecessors
\ basic-block counter >>id ;
-TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
+TUPLE: cfg { entry basic-block } word label
+spill-area-size reps
+post-order linear-order
+predecessors-valid? dominance-valid? loops-valid? ;
-: <cfg> ( entry word label -- cfg ) f f cfg boa ;
+: <cfg> ( entry word label -- cfg )
+ cfg new
+ swap >>label
+ swap >>word
+ swap >>entry ;
+
+: cfg-changed ( cfg -- cfg )
+ f >>post-order
+ f >>linear-order
+ f >>dominance-valid?
+ f >>loops-valid? ; inline
+
+: predecessors-changed ( cfg -- cfg )
+ f >>predecessors-valid? ;
-: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
+: with-cfg ( cfg quot: ( cfg -- ) -- )
+ [ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors sequences grouping
combinators compiler.cfg.rpo compiler.cfg.renaming
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.predecessors ;
IN: compiler.cfg.copy-prop
! The first three definitions are also used in compiler.cfg.alias-analysis.
PRIVATE>
: copy-propagation ( cfg -- cfg' )
+ needs-predecessors
+
[ collect-copies ]
[ rename-copies ]
[ ]
+++ /dev/null
-USING: accessors assocs compiler.cfg
-compiler.cfg.critical-edges compiler.cfg.debugger
-compiler.cfg.instructions compiler.cfg.predecessors
-compiler.cfg.registers cpu.architecture kernel namespaces
-sequences tools.test compiler.cfg.utilities ;
-IN: compiler.cfg.critical-edges.tests
-
-! Make sure we update phi nodes when splitting critical edges
-
-: test-critical-edges ( -- )
- cfg new 0 get >>entry
- compute-predecessors
- split-critical-edges ;
-
-V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } }
- T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-1 2 edge
-
-[ ] [ test-critical-edges ] unit-test
-
-[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test
-
-[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences locals assocs fry
-compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
-IN: compiler.cfg.critical-edges
-
-: critical-edge? ( from to -- ? )
- [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
-
-: new-key ( new-key old-key assoc -- )
- [ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ;
-
-:: update-phis ( from to bb -- )
- ! Any phi nodes in 'to' which reference 'from'
- ! should now reference 'bb'.
- to [ [ bb from ] dip inputs>> new-key ] each-phi ;
-
-: split-critical-edge ( from to -- )
- f <simple-block> [ insert-basic-block ] [ update-phis ] 3bi ;
-
-: split-critical-edges ( cfg -- )
- dup [
- dup successors>> [
- 2dup critical-edge?
- [ split-critical-edge ] [ 2drop ] if
- ] with each
- ] each-basic-block
- cfg-changed
- drop ;
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel locals sequences lexer
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg ;
+compiler.cfg.predecessors compiler.cfg ;
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: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq )
M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
- bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+ bb dfa predecessors [ out-sets at ] map bb dfa join-sets ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
] when ; inline
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
+ cfg needs-predecessors drop
H{ } clone :> in-sets
H{ } clone :> out-sets
cfg dfa <dfa-worklist> :> work-list
in-sets
out-sets ; inline
-M: dataflow-analysis join-sets drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-refine ;
FUNCTOR: define-analysis ( name -- )
entry>> instructions>> ;
[ V{
- T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
- T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
- T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
- T{ ##replace { src V int-regs 3 } { loc D 0 } }
+ T{ ##load-immediate { dst 1 } { val 8 } }
+ T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##add { dst 3 } { src1 1 } { src2 2 } }
+ T{ ##replace { src 3 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
- T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
- T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
- T{ ##replace { src V int-regs 3 } { loc D 0 } }
+ T{ ##load-immediate { dst 1 } { val 8 } }
+ T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##add { dst 3 } { src1 1 } { src2 2 } }
+ T{ ##replace { src 3 } { loc D 0 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
- T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
- T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##load-immediate { dst 1 } { val 8 } }
+ T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##add { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
[ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} test-dce ] unit-test
[ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} test-dce ] unit-test
[ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
} ] [ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.predecessors ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
+ needs-predecessors
+
init-dead-code
dup
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
classes.tuple accessors prettyprint prettyprint.config assocs
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.linearization
+cpu.architecture compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.mr compiler.cfg ;
+compiler.cfg.utilities compiler.cfg.def-use
+compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
: test-mr ( quot -- mrs )
test-cfg [
- optimize-cfg
- build-mr
+ [
+ optimize-cfg
+ build-mr
+ ] with-cfg
] map ;
: insn. ( insn -- )
] each ;
! Prettyprinting
-M: vreg pprint*
- <block
- \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
- block> ;
-
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: ds-loc pprint* \ D pprint-loc ;
0 1 edge
1 { 2 3 } edges
2 4 edge
- 3 4 edge ;
\ No newline at end of file
+ 3 4 edge ;
+
+: fake-representations ( cfg -- )
+ post-order [
+ instructions>>
+ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
+ map concat
+ ] map concat
+ [ int-rep ] H{ } map>assoc representations set ;
\ No newline at end of file
compiler.cfg.debugger
compiler.cfg.instructions
compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
} 1 test-bb
V{
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f 2 D 0 }
} 2 test-bb
-1 get 2 get 1vector >>successors drop
+1 2 edge
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
} 3 test-bb
-2 get 3 get 1vector >>successors drop
+2 3 edge
V{ } 4 test-bb
V{ } 5 test-bb
-3 get 4 get 5 get V{ } 2sequence >>successors drop
-V int-regs 2
- 2 get V int-regs 0 2array
- 3 get V int-regs 1 2array
-2array \ ##phi new-insn 1vector
-6 test-bb
-4 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
+3 { 4 5 } edges
+V{
+ T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
+} 6 test-bb
+4 6 edge
+5 6 edge
cfg new 1 get >>entry 0 set
-[ ] [ 0 get compute-def-use ] unit-test
+[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test
] each
] each-basic-block
use [ keys ] assoc-map uses set ;
-
-: compute-def-use ( cfg -- )
- [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;
-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
- compute-predecessors
- compute-dominance ;
+ needs-dominance drop ;
! Example with no back edges
V{ } 0 test-bb
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques vectors namespaces sequences sorting locals
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.predecessors ;
IN: compiler.cfg.dominance
! Reference:
H{ } clone maxpreorder set
[ 0 ] dip entry>> (compute-dfs) drop ;
+: compute-dominance ( cfg -- cfg' )
+ [ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ;
+
PRIVATE>
-: compute-dominance ( cfg -- )
- [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
+: needs-dominance ( cfg -- cfg' )
+ needs-predecessors
+ dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ;
: dominates? ( bb1 bb2 -- ? )
swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+USING: kernel accessors sequences namespaces combinators
+combinators.short-circuit classes vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.empty-blocks
-
+
+<PRIVATE
+
: update-predecessor ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
-
+
+SYMBOL: changed?
+
: delete-basic-block ( bb -- )
- [ update-predecessor ] [ update-successor ] bi ;
+ [ update-predecessor ] [ update-successor ] bi
+ changed? on ;
: delete-basic-block? ( bb -- ? )
{
[ successors>> length 1 = ]
[ instructions>> first ##branch? ]
} 1&& ;
-
+
+PRIVATE>
+
: delete-empty-blocks ( cfg -- cfg' )
+ changed? off
dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
- cfg-changed ;
\ No newline at end of file
+ changed? get [ cfg-changed ] when ;
\ No newline at end of file
-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
cfg new 0 get >>entry
- compute-predecessors
insert-gc-checks
drop ;
V{
T{ ##inc-d f 3 }
- T{ ##replace f V int-regs 0 D 1 }
+ T{ ##replace f 0 D 1 }
} 0 test-bb
V{
- T{ ##box-float f V int-regs 0 V int-regs 1 }
+ T{ ##box-float f 0 1 }
} 1 test-bb
0 1 edge
[ ] [ test-gc-checks ] unit-test
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
\ No newline at end of file
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs fry
+cpu.architecture
compiler.cfg.rpo
-compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks
+! Garbage collection check insertion. This pass runs after representation
+! selection, so it must keep track of representations.
+
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
: insert-gc-check ( bb -- )
dup '[
- i i f _ uninitialized-locs \ ##gc new-insn
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ f f _ uninitialized-locs \ ##gc new-insn
prefix
] change-instructions drop ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays kernel layouts math namespaces
+USING: accessors arrays byte-arrays kernel layouts math namespaces
sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
IN: compiler.cfg.hats
-: i ( -- vreg ) int-regs next-vreg ; inline
-: ^^i ( -- vreg vreg ) i dup ; inline
-: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
-: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
-: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
+: ^^r ( -- vreg vreg ) next-vreg dup ; inline
+: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
+: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
+: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
-: d ( -- vreg ) double-float-regs next-vreg ; inline
-: ^^d ( -- vreg vreg ) d dup ; inline
-: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
-: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
-: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
-
-: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
-: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
-: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
-: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
-: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
-: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
-: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
-: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
-: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
-: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
+: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
+: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
+: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
+: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
+: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
+: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
+: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
+: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
+: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
+: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
-: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
-: ^^and ( input mask -- output ) ^^i2 ##and ; inline
-: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
-: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
-: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
-: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
-: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
-: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
-: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
-: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
-: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
-: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
-: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
-: ^^not ( src -- dst ) ^^i1 ##not ; inline
-: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
-: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
-: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
-: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
-: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
-: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
-: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
+: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
+: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
+: ^^and ( input mask -- output ) ^^r2 ##and ; inline
+: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
+: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
+: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
+: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
+: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
+: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
+: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
+: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
+: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
+: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
+: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
+: ^^not ( src -- dst ) ^^r1 ##not ; inline
+: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
+: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
+: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
+: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
+: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
+: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
-: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
-: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
-: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
-: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
-: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
-: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
-: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
+: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
+: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
+: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
+: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
+: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
+: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
+: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
+: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
-: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
-: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
-: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
-: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
-: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ No newline at end of file
+: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
+: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
+: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
+: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
+: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
+: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
\ No newline at end of file
INSN: ##integer>float < ##unary ;
! Boxing and unboxing
-INSN: ##copy < ##unary ;
-INSN: ##copy-float < ##unary ;
+INSN: ##copy < ##unary rep ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
-INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
+INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
-INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
+INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
-INSN: _spill src class n ;
-INSN: _reload dst class n ;
-INSN: _copy dst src class ;
-INSN: _spill-counts counts ;
+INSN: _spill src rep n ;
+INSN: _reload dst rep n ;
+INSN: _spill-area-size n ;
! Instructions that use vregs
UNION: vreg-insn
##alien-indirect
##alien-callback ;
+! Instructions that output floats
+UNION: output-float-insn
+ ##add-float
+ ##sub-float
+ ##mul-float
+ ##div-float
+ ##integer>float
+ ##unbox-float
+ ##alien-float
+ ##alien-double ;
+
+! Instructions that take floats as inputs
+UNION: input-float-insn
+ ##add-float
+ ##sub-float
+ ##mul-float
+ ##div-float
+ ##float>integer
+ ##box-float
+ ##set-alien-float
+ ##set-alien-double
+ ##compare-float
+ ##compare-float-branch ;
+
+! Smackdown
+INTERSECTION: ##unary-float ##unary input-float-insn ;
+INTERSECTION: ##binary-float ##binary input-float-insn ;
+
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
- '[ ds-pop ^^unbox-float @ ]
+ '[ ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-cell-setter ( node -- )
[ ##set-alien-cell ] inline-alien-cell-setter ;
-: emit-alien-float-getter ( node reg-class -- )
+: emit-alien-float-getter ( node rep -- )
'[
_ {
- { single-float-regs [ ^^alien-float ] }
- { double-float-regs [ ^^alien-double ] }
- } case ^^box-float
+ { single-float-rep [ ^^alien-float ] }
+ { double-float-rep [ ^^alien-double ] }
+ } case
] inline-alien-getter ;
-: emit-alien-float-setter ( node reg-class -- )
+: emit-alien-float-setter ( node rep -- )
'[
_ {
- { single-float-regs [ ##set-alien-float ] }
- { double-float-regs [ ##set-alien-double ] }
+ { single-float-rep [ ##set-alien-float ] }
+ { double-float-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;
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 )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
: emit-float-op ( insn -- )
- [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
- ds-push ; inline
+ [ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
- [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
- ds-push ; inline
+ [ 2inputs ] dip ^^compare-float ds-push ; inline
: emit-float>fixnum ( -- )
- ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
+ ds-pop ^^float>integer ^^tag-fixnum ds-push ;
: emit-fixnum>float ( -- )
- ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
+ ds-pop ^^untag-fixnum ^^integer>float ds-push ;
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
- { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
- { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+ { \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
+ { \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
} case ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: layouts namespaces kernel accessors sequences
-classes.algebra compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+USING: layouts namespaces kernel accessors sequences classes.algebra
+compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.slots
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
- [ drop ] [ i i ##write-barrier ] if
+ [ drop ] [ next-vreg next-vreg ##write-barrier ] if
] [ drop emit-primitive ] if ;
: emit-string-nth ( -- )
: emit-set-string-nth-fast ( -- )
3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
- swap i ##set-string-nth-fast ;
+ swap next-vreg ##set-string-nth-fast ;
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
second 0 = ; inline
: assign-register ( new -- )
- dup coalesce? [ coalesce ] [
- dup register-status {
- { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
- { [ 2dup register-available? ] [ register-available ] }
- [ drop assign-blocked-register ]
- } cond
- ] if ;
+ dup register-status {
+ { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
+ { [ 2dup register-available? ] [ register-available ] }
+ [ drop assign-blocked-register ]
+ } cond ;
: handle-interval ( live-interval -- )
[
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces assocs fry
-combinators.short-circuit
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.state ;
-IN: compiler.cfg.linear-scan.allocation.coalescing
-
-: active-interval ( vreg -- live-interval )
- dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: avoids-inactive-intervals? ( live-interval -- ? )
- dup vreg>> inactive-intervals-for
- [ intervals-intersect? not ] with all? ;
-
-: coalesce? ( live-interval -- ? )
- {
- [ copy-from>> active-interval ]
- [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
- [ avoids-inactive-intervals? ]
- } 1&& ;
-
-: reuse-spill-slot ( old new -- )
- [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
-
-: reuse-register ( old new -- )
- reg>> >>reg drop ;
-
-: (coalesce) ( old new -- )
- [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
-
-: coalesce ( live-interval -- )
- dup copy-from>> active-interval
- [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
-
\ No newline at end of file
f >>spill-to ; inline
: split-after ( after -- after' )
- f >>copy-from f >>reg f >>reload-from ; inline
+ f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
live-interval n check-split
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math math.order namespaces sequences vectors
+compiler.cfg compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
- reg-class>> active-intervals get at ;
+ rep-of reg-class-of active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
- reg-class>> inactive-intervals get at ;
+ rep-of reg-class-of inactive-intervals get at ;
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
[ dup start>> unhandled-intervals get heap-push ]
bi ;
-CONSTANT: reg-classes { int-regs double-float-regs }
-
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
-! Mapping from register classes to spill counts
-SYMBOL: spill-counts
-
-: next-spill-slot ( reg-class -- n )
- spill-counts get [ dup 1 + ] change-at ;
+: next-spill-slot ( rep -- n )
+ rep-size cfg get
+ [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
! Mapping from vregs to spill slots
SYMBOL: spill-slots
: assign-spill-slot ( vreg -- n )
- spill-slots get [ reg-class>> next-spill-slot ] cache ;
+ spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
registers set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
- [ 0 ] reg-class-assoc spill-counts set
+ cfg get 0 >>spill-area-size drop
H{ } clone spill-slots set
-1 progress set ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
- vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+ vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals
+fry make combinators sets locals arrays
cpu.architecture
compiler.cfg
-compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.renaming.functor
+compiler.cfg.linearization.order
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
init-unhandled ;
: insert-spill ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
+ [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+ [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
+! TODO: needs tagged-rep
+
+: trace-on-gc ( assoc -- assoc' )
+ ! When a GC occurs, virtual registers which contain tagged data
+ ! are traced by the GC. Outputs a sequence physical registers.
+ [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
+
+: spill-on-gc? ( vreg reg -- ? )
+ [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
+
+: spill-on-gc ( assoc -- assoc' )
+ ! When a GC occurs, virtual registers which contain untagged data,
+ ! and are stored in physical registers, are saved to their spill
+ ! slots. Outputs sequence of triples:
+ ! - physical register
+ ! - spill slot
+ ! - representation
+ [
+ [
+ 2dup spill-on-gc?
+ [ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+ ] assoc-each
+ ] { } make ;
+
M: ##gc assign-registers-in-insn
- ! This works because ##gc is always the first instruction
- ! in a block.
+ ! Since ##gc is always the first instruction in a block, the set of
+ ! values live at the ##gc is just live-in.
dup call-next-method
- basic-block get register-live-ins get at >>live-values
+ basic-block get register-live-ins get at
+ [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
drop ;
M: insn assign-registers-in-insn drop ;
: assign-registers ( live-intervals cfg -- )
[ init-assignment ] dip
- [ assign-registers-in-block ] each-basic-block ;
+ linearization-order [ assign-registers-in-block ] each ;
: interval-picture ( interval -- str )
[ uses>> picture ]
- [ copy-from>> unparse ]
[ vreg>> unparse ]
- tri 3array ;
+ bi 2array ;
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
-math.order grouping strings strings.private classes
+math.order grouping strings strings.private classes layouts
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.rpo
compiler.cfg.linearization
compiler.cfg.debugger
+compiler.cfg.def-use
compiler.cfg.comparisons
compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
-H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+cfg new 0 >>spill-area-size cfg set
H{ } spill-slots set
+H{
+ { 1 single-float-rep }
+ { 2 single-float-rep }
+ { 3 single-float-rep }
+} representations set
+
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 0 }
{ end 2 }
{ uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } }
- { spill-to 10 }
+ { spill-to 0 }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
- { reload-from 10 }
+ { reload-from 0 }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ start 0 }
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 11 }
+ { spill-to 4 }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
- { reload-from 11 }
+ { reload-from 4 }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 0 }
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 12 }
+ { spill-to 8 }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 20 }
{ end 30 }
{ uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } }
- { reload-from 12 }
+ { reload-from 8 }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 0 }
{ end 30 }
{ uses V{ 0 20 30 } }
} 10 split-for-spill
] unit-test
+H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+} representations set
+
[
{
3
{ int-regs
V{
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ reg 3 }
{ start 3 }
{ end 10 }
} active-intervals set
H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ int-regs
V{
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ reg 2 }
{ start 3 }
{ end 8 }
} active-intervals set
H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
spill-status
] unit-test
+H{ { 1 int-rep } { 2 int-rep } } representations set
+
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 10 }
{ uses V{ 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 11 }
{ end 20 }
{ uses V{ 11 20 } }
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 30 }
{ end 60 }
{ uses V{ 30 60 } }
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 30 }
{ end 200 }
{ uses V{ 30 200 } }
[
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 30 }
{ end 100 }
{ uses V{ 30 100 } }
] must-fail
! Problem with spilling intervals with no more usages after the spill location
+H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+ { 4 int-rep }
+ { 5 int-rep }
+} representations set
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 20 }
{ uses V{ 0 10 20 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 0 }
{ end 20 }
{ uses V{ 0 10 20 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
- { vreg T{ vreg { n 3 } { reg-class int-regs } } }
+ { vreg 3 }
{ start 4 }
{ end 8 }
{ uses V{ 6 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
- { vreg T{ vreg { n 4 } { reg-class int-regs } } }
+ { vreg 4 }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
! This guy will invoke the 'spill partially available' code path
T{ live-interval
- { vreg T{ vreg { n 5 } { reg-class int-regs } } }
+ { vreg 5 }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
check-linear-scan
] unit-test
-
! Test spill-new code path
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 10 }
{ uses V{ 0 6 10 } }
! This guy will invoke the 'spill new' code path
T{ live-interval
- { vreg T{ vreg { n 5 } { reg-class int-regs } } }
+ { vreg 5 }
{ start 2 }
{ end 8 }
{ uses V{ 8 } }
check-linear-scan
] unit-test
-SYMBOL: available
-
-SYMBOL: taken
-
-SYMBOL: max-registers
-
-SYMBOL: max-insns
-
-SYMBOL: max-uses
-
-: not-taken ( -- n )
- available get keys dup empty? [ "Oops" throw ] when
- random
- dup taken get nth 1 + max-registers get = [
- dup available get delete-at
- ] [
- dup taken get [ 1 + ] change-nth
- ] if ;
-
-: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
- [
- max-insns set
- max-registers set
- max-uses set
- max-insns get [ 0 ] replicate taken set
- max-insns get [ dup ] H{ } map>assoc available set
- [
- \ live-interval new
- swap int-regs swap vreg boa >>vreg
- max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort
- [ >>uses ] [ first >>start ] bi
- dup uses>> last >>end
- dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
- ] map
- ] with-scope ;
-
-: random-test ( num-intervals max-uses max-registers max-insns -- )
- over [ random-live-intervals ] dip int-regs associate check-linear-scan ;
-
-[ ] [ 30 2 1 60 random-test ] unit-test
-[ ] [ 60 2 2 60 random-test ] unit-test
-[ ] [ 80 2 3 200 random-test ] unit-test
-[ ] [ 70 2 5 30 random-test ] unit-test
-[ ] [ 60 2 6 30 random-test ] unit-test
-[ ] [ 1 2 10 10 random-test ] unit-test
-
-[ ] [ 10 4 2 60 random-test ] unit-test
-[ ] [ 10 20 2 400 random-test ] unit-test
-[ ] [ 10 20 4 300 random-test ] unit-test
-
-USING: math.private ;
-
-[ ] [
- [ float+ float>fixnum 3 fixnum*fast ]
- test-cfg first optimize-cfg linear-scan drop
-] unit-test
-
-: fake-live-ranges ( seq -- seq' )
- [
- clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
- ] map ;
-
-! Coalescing interacted badly with splitting
-[ ] [
- {
- T{ live-interval
- { vreg V int-regs 70 }
- { start 14 }
- { end 17 }
- { uses V{ 14 15 16 17 } }
- { copy-from V int-regs 67 }
- }
- T{ live-interval
- { vreg V int-regs 67 }
- { start 13 }
- { end 14 }
- { uses V{ 13 14 } }
- }
- T{ live-interval
- { vreg V int-regs 30 }
- { start 4 }
- { end 18 }
- { uses V{ 4 12 16 17 18 } }
- }
- T{ live-interval
- { vreg V int-regs 27 }
- { start 3 }
- { end 13 }
- { uses V{ 3 7 13 } }
- }
- T{ live-interval
- { vreg V int-regs 59 }
- { start 10 }
- { end 18 }
- { uses V{ 10 11 12 18 } }
- { copy-from V int-regs 56 }
- }
- T{ live-interval
- { vreg V int-regs 60 }
- { start 12 }
- { end 17 }
- { uses V{ 12 17 } }
- }
- T{ live-interval
- { vreg V int-regs 56 }
- { start 9 }
- { end 10 }
- { uses V{ 9 10 } }
- }
- } fake-live-ranges
- { { int-regs { 0 1 2 3 } } }
- allocate-registers drop
-] unit-test
-
-[ ] [
- {
- T{ live-interval
- { vreg V int-regs 3687168 }
- { start 106 }
- { end 112 }
- { uses V{ 106 112 } }
- }
- T{ live-interval
- { vreg V int-regs 3687169 }
- { start 107 }
- { end 113 }
- { uses V{ 107 113 } }
- }
- T{ live-interval
- { vreg V int-regs 3687727 }
- { start 190 }
- { end 198 }
- { uses V{ 190 195 198 } }
- }
- T{ live-interval
- { vreg V int-regs 3686445 }
- { start 43 }
- { end 44 }
- { uses V{ 43 44 } }
- }
- T{ live-interval
- { vreg V int-regs 3686195 }
- { start 5 }
- { end 11 }
- { uses V{ 5 11 } }
- }
- T{ live-interval
- { vreg V int-regs 3686449 }
- { start 44 }
- { end 56 }
- { uses V{ 44 45 45 46 56 } }
- { copy-from V int-regs 3686445 }
- }
- T{ live-interval
- { vreg V int-regs 3686198 }
- { start 8 }
- { end 10 }
- { uses V{ 8 9 10 } }
- }
- T{ live-interval
- { vreg V int-regs 3686454 }
- { start 46 }
- { end 49 }
- { uses V{ 46 47 47 49 } }
- { copy-from V int-regs 3686449 }
- }
- T{ live-interval
- { vreg V int-regs 3686196 }
- { start 6 }
- { end 12 }
- { uses V{ 6 12 } }
- }
- T{ live-interval
- { vreg V int-regs 3686197 }
- { start 7 }
- { end 14 }
- { uses V{ 7 13 14 } }
- }
- T{ live-interval
- { vreg V int-regs 3686455 }
- { start 48 }
- { end 51 }
- { uses V{ 48 51 } }
- }
- T{ live-interval
- { vreg V int-regs 3686463 }
- { start 52 }
- { end 53 }
- { uses V{ 52 53 } }
- }
- T{ live-interval
- { vreg V int-regs 3686460 }
- { start 49 }
- { end 52 }
- { uses V{ 49 50 50 52 } }
- { copy-from V int-regs 3686454 }
- }
- T{ live-interval
- { vreg V int-regs 3686461 }
- { start 51 }
- { end 71 }
- { uses V{ 51 52 64 68 71 } }
- }
- T{ live-interval
- { vreg V int-regs 3686464 }
- { start 53 }
- { end 54 }
- { uses V{ 53 54 } }
- }
- T{ live-interval
- { vreg V int-regs 3686465 }
- { start 54 }
- { end 76 }
- { uses V{ 54 55 55 76 } }
- { copy-from V int-regs 3686464 }
- }
- T{ live-interval
- { vreg V int-regs 3686470 }
- { start 58 }
- { end 60 }
- { uses V{ 58 59 59 60 } }
- { copy-from V int-regs 3686469 }
- }
- T{ live-interval
- { vreg V int-regs 3686469 }
- { start 56 }
- { end 58 }
- { uses V{ 56 57 57 58 } }
- { copy-from V int-regs 3686449 }
- }
- T{ live-interval
- { vreg V int-regs 3686473 }
- { start 60 }
- { end 62 }
- { uses V{ 60 61 61 62 } }
- { copy-from V int-regs 3686470 }
- }
- T{ live-interval
- { vreg V int-regs 3686479 }
- { start 62 }
- { end 64 }
- { uses V{ 62 63 63 64 } }
- { copy-from V int-regs 3686473 }
- }
- T{ live-interval
- { vreg V int-regs 3686735 }
- { start 78 }
- { end 96 }
- { uses V{ 78 79 79 96 } }
- { copy-from V int-regs 3686372 }
- }
- T{ live-interval
- { vreg V int-regs 3686482 }
- { start 64 }
- { end 65 }
- { uses V{ 64 65 } }
- }
- T{ live-interval
- { vreg V int-regs 3686483 }
- { start 65 }
- { end 66 }
- { uses V{ 65 66 } }
- }
- T{ live-interval
- { vreg V int-regs 3687510 }
- { start 168 }
- { end 171 }
- { uses V{ 168 171 } }
- }
- T{ live-interval
- { vreg V int-regs 3687511 }
- { start 169 }
- { end 176 }
- { uses V{ 169 176 } }
- }
- T{ live-interval
- { vreg V int-regs 3686484 }
- { start 66 }
- { end 75 }
- { uses V{ 66 67 67 75 } }
- { copy-from V int-regs 3686483 }
- }
- T{ live-interval
- { vreg V int-regs 3687509 }
- { start 162 }
- { end 163 }
- { uses V{ 162 163 } }
- }
- T{ live-interval
- { vreg V int-regs 3686491 }
- { start 68 }
- { end 69 }
- { uses V{ 68 69 } }
- }
- T{ live-interval
- { vreg V int-regs 3687512 }
- { start 170 }
- { end 178 }
- { uses V{ 170 177 178 } }
- }
- T{ live-interval
- { vreg V int-regs 3687515 }
- { start 172 }
- { end 173 }
- { uses V{ 172 173 } }
- }
- T{ live-interval
- { vreg V int-regs 3686492 }
- { start 69 }
- { end 74 }
- { uses V{ 69 70 70 74 } }
- { copy-from V int-regs 3686491 }
- }
- T{ live-interval
- { vreg V int-regs 3687778 }
- { start 202 }
- { end 208 }
- { uses V{ 202 208 } }
- }
- T{ live-interval
- { vreg V int-regs 3686499 }
- { start 71 }
- { end 72 }
- { uses V{ 71 72 } }
- }
- T{ live-interval
- { vreg V int-regs 3687520 }
- { start 174 }
- { end 175 }
- { uses V{ 174 175 } }
- }
- T{ live-interval
- { vreg V int-regs 3687779 }
- { start 203 }
- { end 209 }
- { uses V{ 203 209 } }
- }
- T{ live-interval
- { vreg V int-regs 3687782 }
- { start 206 }
- { end 207 }
- { uses V{ 206 207 } }
- }
- T{ live-interval
- { vreg V int-regs 3686503 }
- { start 74 }
- { end 75 }
- { uses V{ 74 75 } }
- }
- T{ live-interval
- { vreg V int-regs 3686500 }
- { start 72 }
- { end 74 }
- { uses V{ 72 73 73 74 } }
- { copy-from V int-regs 3686499 }
- }
- T{ live-interval
- { vreg V int-regs 3687780 }
- { start 204 }
- { end 210 }
- { uses V{ 204 210 } }
- }
- T{ live-interval
- { vreg V int-regs 3686506 }
- { start 75 }
- { end 76 }
- { uses V{ 75 76 } }
- }
- T{ live-interval
- { vreg V int-regs 3687530 }
- { start 185 }
- { end 192 }
- { uses V{ 185 192 } }
- }
- T{ live-interval
- { vreg V int-regs 3687528 }
- { start 183 }
- { end 198 }
- { uses V{ 183 198 } }
- }
- T{ live-interval
- { vreg V int-regs 3687529 }
- { start 184 }
- { end 197 }
- { uses V{ 184 197 } }
- }
- T{ live-interval
- { vreg V int-regs 3687781 }
- { start 205 }
- { end 211 }
- { uses V{ 205 211 } }
- }
- T{ live-interval
- { vreg V int-regs 3687535 }
- { start 187 }
- { end 194 }
- { uses V{ 187 194 } }
- }
- T{ live-interval
- { vreg V int-regs 3686252 }
- { start 9 }
- { end 17 }
- { uses V{ 9 15 17 } }
- }
- T{ live-interval
- { vreg V int-regs 3686509 }
- { start 76 }
- { end 90 }
- { uses V{ 76 87 90 } }
- }
- T{ live-interval
- { vreg V int-regs 3687532 }
- { start 186 }
- { end 196 }
- { uses V{ 186 196 } }
- }
- T{ live-interval
- { vreg V int-regs 3687538 }
- { start 188 }
- { end 193 }
- { uses V{ 188 193 } }
- }
- T{ live-interval
- { vreg V int-regs 3687827 }
- { start 217 }
- { end 219 }
- { uses V{ 217 219 } }
- }
- T{ live-interval
- { vreg V int-regs 3687825 }
- { start 215 }
- { end 218 }
- { uses V{ 215 216 218 } }
- }
- T{ live-interval
- { vreg V int-regs 3687831 }
- { start 218 }
- { end 219 }
- { uses V{ 218 219 } }
- }
- T{ live-interval
- { vreg V int-regs 3686296 }
- { start 16 }
- { end 18 }
- { uses V{ 16 18 } }
- }
- T{ live-interval
- { vreg V int-regs 3686302 }
- { start 29 }
- { end 31 }
- { uses V{ 29 31 } }
- }
- T{ live-interval
- { vreg V int-regs 3687838 }
- { start 231 }
- { end 232 }
- { uses V{ 231 232 } }
- }
- T{ live-interval
- { vreg V int-regs 3686300 }
- { start 26 }
- { end 27 }
- { uses V{ 26 27 } }
- }
- T{ live-interval
- { vreg V int-regs 3686301 }
- { start 27 }
- { end 30 }
- { uses V{ 27 28 28 30 } }
- { copy-from V int-regs 3686300 }
- }
- T{ live-interval
- { vreg V int-regs 3686306 }
- { start 37 }
- { end 93 }
- { uses V{ 37 82 93 } }
- }
- T{ live-interval
- { vreg V int-regs 3686307 }
- { start 38 }
- { end 88 }
- { uses V{ 38 85 88 } }
- }
- T{ live-interval
- { vreg V int-regs 3687837 }
- { start 222 }
- { end 223 }
- { uses V{ 222 223 } }
- }
- T{ live-interval
- { vreg V int-regs 3686305 }
- { start 36 }
- { end 81 }
- { uses V{ 36 42 77 81 } }
- }
- T{ live-interval
- { vreg V int-regs 3686310 }
- { start 39 }
- { end 95 }
- { uses V{ 39 84 95 } }
- }
- T{ live-interval
- { vreg V int-regs 3687836 }
- { start 227 }
- { end 228 }
- { uses V{ 227 228 } }
- }
- T{ live-interval
- { vreg V int-regs 3687839 }
- { start 239 }
- { end 246 }
- { uses V{ 239 245 246 } }
- }
- T{ live-interval
- { vreg V int-regs 3687841 }
- { start 240 }
- { end 241 }
- { uses V{ 240 241 } }
- }
- T{ live-interval
- { vreg V int-regs 3687845 }
- { start 241 }
- { end 243 }
- { uses V{ 241 243 } }
- }
- T{ live-interval
- { vreg V int-regs 3686315 }
- { start 40 }
- { end 94 }
- { uses V{ 40 83 94 } }
- }
- T{ live-interval
- { vreg V int-regs 3687846 }
- { start 242 }
- { end 245 }
- { uses V{ 242 245 } }
- }
- T{ live-interval
- { vreg V int-regs 3687849 }
- { start 243 }
- { end 245 }
- { uses V{ 243 244 244 245 } }
- { copy-from V int-regs 3687845 }
- }
- T{ live-interval
- { vreg V int-regs 3687850 }
- { start 245 }
- { end 245 }
- { uses V{ 245 } }
- }
- T{ live-interval
- { vreg V int-regs 3687851 }
- { start 246 }
- { end 246 }
- { uses V{ 246 } }
- }
- T{ live-interval
- { vreg V int-regs 3687852 }
- { start 246 }
- { end 246 }
- { uses V{ 246 } }
- }
- T{ live-interval
- { vreg V int-regs 3687853 }
- { start 247 }
- { end 248 }
- { uses V{ 247 248 } }
- }
- T{ live-interval
- { vreg V int-regs 3687854 }
- { start 249 }
- { end 250 }
- { uses V{ 249 250 } }
- }
- T{ live-interval
- { vreg V int-regs 3687855 }
- { start 258 }
- { end 259 }
- { uses V{ 258 259 } }
- }
- T{ live-interval
- { vreg V int-regs 3687080 }
- { start 280 }
- { end 285 }
- { uses V{ 280 285 } }
- }
- T{ live-interval
- { vreg V int-regs 3687081 }
- { start 281 }
- { end 286 }
- { uses V{ 281 286 } }
- }
- T{ live-interval
- { vreg V int-regs 3687082 }
- { start 282 }
- { end 287 }
- { uses V{ 282 287 } }
- }
- T{ live-interval
- { vreg V int-regs 3687083 }
- { start 283 }
- { end 288 }
- { uses V{ 283 288 } }
- }
- T{ live-interval
- { vreg V int-regs 3687085 }
- { start 284 }
- { end 299 }
- { uses V{ 284 285 286 287 288 296 299 } }
- }
- T{ live-interval
- { vreg V int-regs 3687086 }
- { start 284 }
- { end 284 }
- { uses V{ 284 } }
- }
- T{ live-interval
- { vreg V int-regs 3687087 }
- { start 289 }
- { end 293 }
- { uses V{ 289 293 } }
- }
- T{ live-interval
- { vreg V int-regs 3687088 }
- { start 290 }
- { end 294 }
- { uses V{ 290 294 } }
- }
- T{ live-interval
- { vreg V int-regs 3687089 }
- { start 291 }
- { end 297 }
- { uses V{ 291 297 } }
- }
- T{ live-interval
- { vreg V int-regs 3687090 }
- { start 292 }
- { end 298 }
- { uses V{ 292 298 } }
- }
- T{ live-interval
- { vreg V int-regs 3687363 }
- { start 118 }
- { end 119 }
- { uses V{ 118 119 } }
- }
- T{ live-interval
- { vreg V int-regs 3686599 }
- { start 77 }
- { end 89 }
- { uses V{ 77 86 89 } }
- }
- T{ live-interval
- { vreg V int-regs 3687370 }
- { start 131 }
- { end 132 }
- { uses V{ 131 132 } }
- }
- T{ live-interval
- { vreg V int-regs 3687371 }
- { start 138 }
- { end 143 }
- { uses V{ 138 143 } }
- }
- T{ live-interval
- { vreg V int-regs 3687368 }
- { start 127 }
- { end 128 }
- { uses V{ 127 128 } }
- }
- T{ live-interval
- { vreg V int-regs 3687369 }
- { start 122 }
- { end 123 }
- { uses V{ 122 123 } }
- }
- T{ live-interval
- { vreg V int-regs 3687373 }
- { start 139 }
- { end 140 }
- { uses V{ 139 140 } }
- }
- T{ live-interval
- { vreg V int-regs 3686352 }
- { start 41 }
- { end 91 }
- { uses V{ 41 43 79 91 } }
- }
- T{ live-interval
- { vreg V int-regs 3687377 }
- { start 140 }
- { end 141 }
- { uses V{ 140 141 } }
- }
- T{ live-interval
- { vreg V int-regs 3687382 }
- { start 143 }
- { end 143 }
- { uses V{ 143 } }
- }
- T{ live-interval
- { vreg V int-regs 3687383 }
- { start 144 }
- { end 161 }
- { uses V{ 144 159 161 } }
- }
- T{ live-interval
- { vreg V int-regs 3687380 }
- { start 141 }
- { end 143 }
- { uses V{ 141 142 142 143 } }
- { copy-from V int-regs 3687377 }
- }
- T{ live-interval
- { vreg V int-regs 3687381 }
- { start 143 }
- { end 160 }
- { uses V{ 143 160 } }
- }
- T{ live-interval
- { vreg V int-regs 3687384 }
- { start 145 }
- { end 158 }
- { uses V{ 145 158 } }
- }
- T{ live-interval
- { vreg V int-regs 3687385 }
- { start 146 }
- { end 157 }
- { uses V{ 146 157 } }
- }
- T{ live-interval
- { vreg V int-regs 3687640 }
- { start 189 }
- { end 191 }
- { uses V{ 189 191 } }
- }
- T{ live-interval
- { vreg V int-regs 3687388 }
- { start 147 }
- { end 152 }
- { uses V{ 147 152 } }
- }
- T{ live-interval
- { vreg V int-regs 3687393 }
- { start 148 }
- { end 153 }
- { uses V{ 148 153 } }
- }
- T{ live-interval
- { vreg V int-regs 3687398 }
- { start 149 }
- { end 154 }
- { uses V{ 149 154 } }
- }
- T{ live-interval
- { vreg V int-regs 3686372 }
- { start 42 }
- { end 92 }
- { uses V{ 42 45 78 80 92 } }
- }
- T{ live-interval
- { vreg V int-regs 3687140 }
- { start 293 }
- { end 295 }
- { uses V{ 293 294 294 295 } }
- { copy-from V int-regs 3687087 }
- }
- T{ live-interval
- { vreg V int-regs 3687403 }
- { start 150 }
- { end 155 }
- { uses V{ 150 155 } }
- }
- T{ live-interval
- { vreg V int-regs 3687150 }
- { start 304 }
- { end 306 }
- { uses V{ 304 306 } }
- }
- T{ live-interval
- { vreg V int-regs 3687151 }
- { start 305 }
- { end 307 }
- { uses V{ 305 307 } }
- }
- T{ live-interval
- { vreg V int-regs 3687408 }
- { start 151 }
- { end 156 }
- { uses V{ 151 156 } }
- }
- T{ live-interval
- { vreg V int-regs 3687153 }
- { start 312 }
- { end 313 }
- { uses V{ 312 313 } }
- }
- T{ live-interval
- { vreg V int-regs 3686902 }
- { start 267 }
- { end 272 }
- { uses V{ 267 272 } }
- }
- T{ live-interval
- { vreg V int-regs 3686903 }
- { start 268 }
- { end 273 }
- { uses V{ 268 273 } }
- }
- T{ live-interval
- { vreg V int-regs 3686900 }
- { start 265 }
- { end 270 }
- { uses V{ 265 270 } }
- }
- T{ live-interval
- { vreg V int-regs 3686901 }
- { start 266 }
- { end 271 }
- { uses V{ 266 271 } }
- }
- T{ live-interval
- { vreg V int-regs 3687162 }
- { start 100 }
- { end 119 }
- { uses V{ 100 114 117 119 } }
- }
- T{ live-interval
- { vreg V int-regs 3687163 }
- { start 101 }
- { end 118 }
- { uses V{ 101 115 116 118 } }
- }
- T{ live-interval
- { vreg V int-regs 3686904 }
- { start 269 }
- { end 274 }
- { uses V{ 269 274 } }
- }
- T{ live-interval
- { vreg V int-regs 3687166 }
- { start 104 }
- { end 110 }
- { uses V{ 104 110 } }
- }
- T{ live-interval
- { vreg V int-regs 3687167 }
- { start 105 }
- { end 111 }
- { uses V{ 105 111 } }
- }
- T{ live-interval
- { vreg V int-regs 3687164 }
- { start 102 }
- { end 108 }
- { uses V{ 102 108 } }
- }
- T{ live-interval
- { vreg V int-regs 3687165 }
- { start 103 }
- { end 109 }
- { uses V{ 103 109 } }
- }
- } fake-live-ranges
- { { int-regs { 0 1 2 3 4 } } }
- allocate-registers drop
-] unit-test
-
-! A reduction of the above
-[ ] [
- {
- T{ live-interval
- { vreg V int-regs 6449 }
- { start 44 }
- { end 56 }
- { uses V{ 44 45 46 56 } }
- }
- T{ live-interval
- { vreg V int-regs 6454 }
- { start 46 }
- { end 49 }
- { uses V{ 46 47 49 } }
- }
- T{ live-interval
- { vreg V int-regs 6455 }
- { start 48 }
- { end 51 }
- { uses V{ 48 51 } }
- }
- T{ live-interval
- { vreg V int-regs 6460 }
- { start 49 }
- { end 52 }
- { uses V{ 49 50 52 } }
- }
- T{ live-interval
- { vreg V int-regs 6461 }
- { start 51 }
- { end 71 }
- { uses V{ 51 52 64 68 71 } }
- }
- T{ live-interval
- { vreg V int-regs 6464 }
- { start 53 }
- { end 54 }
- { uses V{ 53 54 } }
- }
- T{ live-interval
- { vreg V int-regs 6470 }
- { start 58 }
- { end 60 }
- { uses V{ 58 59 60 } }
- }
- T{ live-interval
- { vreg V int-regs 6469 }
- { start 56 }
- { end 58 }
- { uses V{ 56 57 58 } }
- }
- T{ live-interval
- { vreg V int-regs 6473 }
- { start 60 }
- { end 62 }
- { uses V{ 60 61 62 } }
- }
- T{ live-interval
- { vreg V int-regs 6479 }
- { start 62 }
- { end 64 }
- { uses V{ 62 63 64 } }
- }
- T{ live-interval
- { vreg V int-regs 6735 }
- { start 78 }
- { end 96 }
- { uses V{ 78 79 96 } }
- { copy-from V int-regs 6372 }
- }
- T{ live-interval
- { vreg V int-regs 6483 }
- { start 65 }
- { end 66 }
- { uses V{ 65 66 } }
- }
- T{ live-interval
- { vreg V int-regs 7845 }
- { start 91 }
- { end 93 }
- { uses V{ 91 93 } }
- }
- T{ live-interval
- { vreg V int-regs 6372 }
- { start 42 }
- { end 92 }
- { uses V{ 42 45 78 80 92 } }
- }
- } fake-live-ranges
- { { int-regs { 0 1 2 3 } } }
- allocate-registers drop
-] unit-test
-
[ f ] [
T{ live-range f 0 10 }
T{ live-range f 20 30 }
! register-status had problems because it used map>assoc where the sequence
! had multiple keys
+H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+ { 4 int-rep }
+} representations set
+
[ { 0 10 } ] [
H{ { int-regs { 0 1 } } } registers set
H{
{ int-regs
{
T{ live-interval
- { vreg V int-regs 1 }
+ { vreg 1 }
{ start 0 }
{ end 20 }
{ reg 0 }
}
T{ live-interval
- { vreg V int-regs 2 }
+ { vreg 2 }
{ start 4 }
{ end 40 }
{ reg 0 }
{ int-regs
{
T{ live-interval
- { vreg V int-regs 3 }
+ { vreg 3 }
{ start 0 }
{ end 40 }
{ reg 1 }
} active-intervals set
T{ live-interval
- { vreg V int-regs 4 }
+ { vreg 4 }
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
register-status
] unit-test
+:: test-linear-scan-on-cfg ( regs -- )
+ [
+ cfg new 0 get >>entry
+ dup cfg set
+ dup fake-representations
+ dup { { int-regs regs } } (linear-scan)
+ flatten-cfg 1array mr.
+ ] with-scope ;
+
! Bug in live spill slots calculation
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##peek
- { dst V int-regs 703128 }
+ { dst 703128 }
{ loc D 1 }
}
T{ ##peek
- { dst V int-regs 703129 }
+ { dst 703129 }
{ loc D 0 }
}
T{ ##copy
- { dst V int-regs 703134 }
- { src V int-regs 703128 }
+ { dst 703134 }
+ { src 703128 }
}
T{ ##copy
- { dst V int-regs 703135 }
- { src V int-regs 703129 }
+ { dst 703135 }
+ { src 703129 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 703128 }
+ { src1 703128 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##copy
- { dst V int-regs 703134 }
- { src V int-regs 703129 }
+ { dst 703134 }
+ { src 703129 }
}
T{ ##copy
- { dst V int-regs 703135 }
- { src V int-regs 703128 }
+ { dst 703135 }
+ { src 703128 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##replace
- { src V int-regs 703134 }
+ { src 703134 }
{ loc D 0 }
}
T{ ##replace
- { src V int-regs 703135 }
+ { src 703135 }
{ loc D 1 }
}
T{ ##epilogue }
1 { 2 3 } edges
2 3 edge
-SYMBOL: linear-scan-result
-
-:: test-linear-scan-on-cfg ( regs -- )
- [
- cfg new 0 get >>entry
- compute-predecessors
- dup { { int-regs regs } } (linear-scan)
- cfg-changed
- flatten-cfg 1array mr.
- ] with-scope ;
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##peek
- { dst V int-regs 689473 }
+ { dst 689473 }
{ loc D 2 }
}
T{ ##peek
- { dst V int-regs 689474 }
+ { dst 689474 }
{ loc D 1 }
}
T{ ##peek
- { dst V int-regs 689475 }
+ { dst 689475 }
{ loc D 0 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 689473 }
+ { src1 689473 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##copy
- { dst V int-regs 689481 }
- { src V int-regs 689475 }
+ { dst 689481 }
+ { src 689475 }
}
T{ ##copy
- { dst V int-regs 689482 }
- { src V int-regs 689474 }
+ { dst 689482 }
+ { src 689474 }
}
T{ ##copy
- { dst V int-regs 689483 }
- { src V int-regs 689473 }
+ { dst 689483 }
+ { src 689473 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##copy
- { dst V int-regs 689481 }
- { src V int-regs 689473 }
+ { dst 689481 }
+ { src 689473 }
}
T{ ##copy
- { dst V int-regs 689482 }
- { src V int-regs 689475 }
+ { dst 689482 }
+ { src 689475 }
}
T{ ##copy
- { dst V int-regs 689483 }
- { src V int-regs 689474 }
+ { dst 689483 }
+ { src 689474 }
}
T{ ##branch }
} 3 test-bb
V{
T{ ##replace
- { src V int-regs 689481 }
+ { src 689481 }
{ loc D 0 }
}
T{ ##replace
- { src V int-regs 689482 }
+ { src 689482 }
{ loc D 1 }
}
T{ ##replace
- { src V int-regs 689483 }
+ { src 689483 }
{ loc D 2 }
}
T{ ##epilogue }
V{
T{ ##peek
- { dst V int-regs 689600 }
+ { dst 689600 }
{ loc D 1 }
}
T{ ##peek
- { dst V int-regs 689601 }
+ { dst 689601 }
{ loc D 0 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 689600 }
+ { src1 689600 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##peek
- { dst V int-regs 689604 }
+ { dst 689604 }
{ loc D 2 }
}
T{ ##copy
- { dst V int-regs 689607 }
- { src V int-regs 689604 }
+ { dst 689607 }
+ { src 689604 }
}
T{ ##copy
- { dst V int-regs 689608 }
- { src V int-regs 689600 }
+ { dst 689608 }
+ { src 689600 }
}
T{ ##copy
- { dst V int-regs 689610 }
- { src V int-regs 689601 }
+ { dst 689610 }
+ { src 689601 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##peek
- { dst V int-regs 689609 }
+ { dst 689609 }
{ loc D 2 }
}
T{ ##copy
- { dst V int-regs 689607 }
- { src V int-regs 689600 }
+ { dst 689607 }
+ { src 689600 }
}
T{ ##copy
- { dst V int-regs 689608 }
- { src V int-regs 689601 }
+ { dst 689608 }
+ { src 689601 }
}
T{ ##copy
- { dst V int-regs 689610 }
- { src V int-regs 689609 }
+ { dst 689610 }
+ { src 689609 }
}
T{ ##branch }
} 3 test-bb
V{
T{ ##replace
- { src V int-regs 689607 }
+ { src 689607 }
{ loc D 0 }
}
T{ ##replace
- { src V int-regs 689608 }
+ { src 689608 }
{ loc D 1 }
}
T{ ##replace
- { src V int-regs 689610 }
+ { src 689610 }
{ loc D 2 }
}
T{ ##epilogue }
V{
T{ ##peek
- { dst V int-regs 0 }
+ { dst 0 }
{ loc D 0 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 0 }
+ { src1 0 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##peek
- { dst V int-regs 1 }
+ { dst 1 }
{ loc D 1 }
}
T{ ##copy
- { dst V int-regs 2 }
- { src V int-regs 1 }
+ { dst 2 }
+ { src 1 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##peek
- { dst V int-regs 3 }
+ { dst 3 }
{ loc D 2 }
}
T{ ##copy
- { dst V int-regs 2 }
- { src V int-regs 3 }
+ { dst 2 }
+ { src 3 }
}
T{ ##branch }
} 3 test-bb
V{
T{ ##replace
- { src V int-regs 2 }
+ { src 2 }
{ loc D 0 }
}
T{ ##return }
! Inactive interval handling: splitting active interval
! if it fits in lifetime hole only partially
-V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
+V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 2 R 0 }
- T{ ##compare-imm-branch f V int-regs 2 5 cc= }
+ T{ ##peek f 2 R 0 }
+ T{ ##compare-imm-branch f 2 5 cc= }
} 1 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 2 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 1 D 2 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 3 R 2 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 3 R 2 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 4 test-bb
! [ _copy ] [ 3 get instructions>> second class ] unit-test
! Resolve pass; make sure the spilling is done correctly
-V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
+V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 2 R 0 }
- T{ ##compare-imm-branch f V int-regs 2 5 cc= }
+ T{ ##peek f 2 R 0 }
+ T{ ##compare-imm-branch f 2 5 cc= }
} 1 test-bb
V{
} 2 test-bb
V{
- T{ ##replace f V int-regs 3 R 1 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 2 }
- T{ ##replace f V int-regs 0 D 2 }
+ T{ ##replace f 3 R 1 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 1 D 2 }
+ T{ ##replace f 0 D 2 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 3 R 2 }
+ T{ ##replace f 3 R 2 }
T{ ##return }
} 4 test-bb
} 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-imm-branch f 0 5 cc= }
} 1 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 1 D 0 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##replace f 1 D 0 }
+ T{ ##replace f 2 D 0 }
T{ ##branch }
} 2 test-bb
} 3 test-bb
V{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm-branch f 1 5 cc= }
} 4 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 5 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 6 test-bb
! got fixed
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 4 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##peek f 4 D 0 }
T{ ##branch }
} 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{ T{ ##branch } } 3 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
- T{ ##replace f V int-regs 4 D 4 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 3 D 3 }
+ T{ ##replace f 4 D 4 }
+ T{ ##replace f 0 D 0 }
T{ ##branch }
} 4 test-bb
-V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
+V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb
V{ T{ ##return } } 6 test-bb
V{ T{ ##branch } } 7 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 5 D 1 }
- T{ ##peek f V int-regs 6 D 2 }
- T{ ##peek f V int-regs 7 D 3 }
- T{ ##peek f V int-regs 8 D 4 }
- T{ ##replace f V int-regs 5 D 1 }
- T{ ##replace f V int-regs 6 D 2 }
- T{ ##replace f V int-regs 7 D 3 }
- T{ ##replace f V int-regs 8 D 4 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 3 D 3 }
+ T{ ##peek f 5 D 1 }
+ T{ ##peek f 6 D 2 }
+ T{ ##peek f 7 D 3 }
+ T{ ##peek f 8 D 4 }
+ T{ ##replace f 5 D 1 }
+ T{ ##replace f 6 D 2 }
+ T{ ##replace f 7 D 3 }
+ T{ ##replace f 8 D 4 }
T{ ##branch }
} 8 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 3 D 3 }
T{ ##return }
} 9 test-bb
[ _spill ] [ 1 get instructions>> second class ] unit-test
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test
! Resolve pass should insert this
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
! Some random bug
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 0 }
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##peek f 3 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 0 D 3 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 3 D 3 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 0 D 3 }
T{ ##branch }
} 2 test-bb
! Spilling an interval immediately after its activated;
! and the interval does not have a use at the activation point
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f 1 D 1 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 2 D 2 }
T{ ##branch }
} 3 test-bb
V{ T{ ##branch } } 4 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 5 test-bb
-1 get 1vector 0 get (>>successors)
-2 get 4 get V{ } 2sequence 1 get (>>successors)
-5 get 1vector 4 get (>>successors)
-3 get 1vector 2 get (>>successors)
-5 get 1vector 3 get (>>successors)
+0 1 edge
+1 { 2 4 } edges
+4 5 edge
+2 3 edge
+3 5 edge
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
- T{ ##load-immediate { dst V int-regs 61 } }
- T{ ##peek { dst V int-regs 62 } { loc D 0 } }
- T{ ##peek { dst V int-regs 64 } { loc D 1 } }
+ T{ ##load-immediate { dst 61 } }
+ T{ ##peek { dst 62 } { loc D 0 } }
+ T{ ##peek { dst 64 } { loc D 1 } }
T{ ##slot-imm
- { dst V int-regs 69 }
- { obj V int-regs 64 }
+ { dst 69 }
+ { obj 64 }
{ slot 1 }
{ tag 2 }
}
- T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
+ T{ ##copy { dst 79 } { src 69 } }
T{ ##slot-imm
- { dst V int-regs 85 }
- { obj V int-regs 62 }
+ { dst 85 }
+ { obj 62 }
{ slot 2 }
{ tag 7 }
}
T{ ##compare-branch
- { src1 V int-regs 69 }
- { src2 V int-regs 85 }
+ { src1 69 }
+ { src2 85 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##slot-imm
- { dst V int-regs 97 }
- { obj V int-regs 62 }
+ { dst 97 }
+ { obj 62 }
{ slot 2 }
{ tag 7 }
}
- T{ ##replace { src V int-regs 79 } { loc D 3 } }
- T{ ##replace { src V int-regs 62 } { loc D 4 } }
- T{ ##replace { src V int-regs 79 } { loc D 1 } }
- T{ ##replace { src V int-regs 62 } { loc D 2 } }
- T{ ##replace { src V int-regs 61 } { loc D 5 } }
- T{ ##replace { src V int-regs 62 } { loc R 0 } }
- T{ ##replace { src V int-regs 69 } { loc R 1 } }
- T{ ##replace { src V int-regs 97 } { loc D 0 } }
+ T{ ##replace { src 79 } { loc D 3 } }
+ T{ ##replace { src 62 } { loc D 4 } }
+ T{ ##replace { src 79 } { loc D 1 } }
+ T{ ##replace { src 62 } { loc D 2 } }
+ T{ ##replace { src 61 } { loc D 5 } }
+ T{ ##replace { src 62 } { loc R 0 } }
+ T{ ##replace { src 69 } { loc R 1 } }
+ T{ ##replace { src 97 } { loc D 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 2 test-bb
V{
- T{ ##peek { dst V int-regs 98 } { loc R 0 } }
- T{ ##peek { dst V int-regs 100 } { loc D 0 } }
+ T{ ##peek { dst 98 } { loc R 0 } }
+ T{ ##peek { dst 100 } { loc D 0 } }
T{ ##set-slot-imm
- { src V int-regs 100 }
- { obj V int-regs 98 }
+ { src 100 }
+ { obj 98 }
{ slot 2 }
{ tag 7 }
}
- T{ ##peek { dst V int-regs 108 } { loc D 2 } }
- T{ ##peek { dst V int-regs 110 } { loc D 3 } }
- T{ ##peek { dst V int-regs 112 } { loc D 0 } }
- T{ ##peek { dst V int-regs 114 } { loc D 1 } }
- T{ ##peek { dst V int-regs 116 } { loc D 4 } }
- T{ ##peek { dst V int-regs 119 } { loc R 0 } }
- T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
- T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
- T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
- T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
- T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
- T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
+ T{ ##peek { dst 108 } { loc D 2 } }
+ T{ ##peek { dst 110 } { loc D 3 } }
+ T{ ##peek { dst 112 } { loc D 0 } }
+ T{ ##peek { dst 114 } { loc D 1 } }
+ T{ ##peek { dst 116 } { loc D 4 } }
+ T{ ##peek { dst 119 } { loc R 0 } }
+ T{ ##copy { dst 109 } { src 108 } }
+ T{ ##copy { dst 111 } { src 110 } }
+ T{ ##copy { dst 113 } { src 112 } }
+ T{ ##copy { dst 115 } { src 114 } }
+ T{ ##copy { dst 117 } { src 116 } }
+ T{ ##copy { dst 120 } { src 119 } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
- T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
- T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
- T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
- T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
- T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
+ T{ ##copy { dst 109 } { src 62 } }
+ T{ ##copy { dst 111 } { src 61 } }
+ T{ ##copy { dst 113 } { src 62 } }
+ T{ ##copy { dst 115 } { src 79 } }
+ T{ ##copy { dst 117 } { src 64 } }
+ T{ ##copy { dst 120 } { src 69 } }
T{ ##branch }
} 4 test-bb
V{
- T{ ##replace { src V int-regs 120 } { loc D 0 } }
- T{ ##replace { src V int-regs 109 } { loc D 3 } }
- T{ ##replace { src V int-regs 111 } { loc D 4 } }
- T{ ##replace { src V int-regs 113 } { loc D 1 } }
- T{ ##replace { src V int-regs 115 } { loc D 2 } }
- T{ ##replace { src V int-regs 117 } { loc D 5 } }
+ T{ ##replace { src 120 } { loc D 0 } }
+ T{ ##replace { src 109 } { loc D 3 } }
+ T{ ##replace { src 111 } { loc D 4 } }
+ T{ ##replace { src 113 } { loc D 1 } }
+ T{ ##replace { src 115 } { loc D 2 } }
+ T{ ##replace { src 117 } { loc D 5 } }
T{ ##epilogue }
T{ ##return }
} 5 test-bb
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
- T{ ##peek { dst V int-regs 85 } { loc D 0 } }
+ T{ ##peek { dst 85 } { loc D 0 } }
T{ ##slot-imm
- { dst V int-regs 89 }
- { obj V int-regs 85 }
+ { dst 89 }
+ { obj 85 }
{ slot 3 }
{ tag 7 }
}
- T{ ##peek { dst V int-regs 91 } { loc D 1 } }
+ T{ ##peek { dst 91 } { loc D 1 } }
T{ ##slot-imm
- { dst V int-regs 96 }
- { obj V int-regs 91 }
+ { dst 96 }
+ { obj 91 }
{ slot 1 }
{ tag 2 }
}
T{ ##add
- { dst V int-regs 109 }
- { src1 V int-regs 89 }
- { src2 V int-regs 96 }
+ { dst 109 }
+ { src1 89 }
+ { src2 96 }
}
T{ ##slot-imm
- { dst V int-regs 115 }
- { obj V int-regs 85 }
+ { dst 115 }
+ { obj 85 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
- { dst V int-regs 118 }
- { obj V int-regs 115 }
+ { dst 118 }
+ { obj 115 }
{ slot 1 }
{ tag 2 }
}
T{ ##compare-branch
- { src1 V int-regs 109 }
- { src2 V int-regs 118 }
+ { src1 109 }
+ { src2 118 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##add-imm
- { dst V int-regs 128 }
- { src1 V int-regs 109 }
+ { dst 128 }
+ { src1 109 }
{ src2 8 }
}
- T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
+ T{ ##load-immediate { dst 129 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
- T{ ##replace { src V int-regs 109 } { loc D 2 } }
- T{ ##replace { src V int-regs 85 } { loc D 3 } }
- T{ ##replace { src V int-regs 128 } { loc D 0 } }
- T{ ##replace { src V int-regs 85 } { loc D 1 } }
- T{ ##replace { src V int-regs 89 } { loc D 4 } }
- T{ ##replace { src V int-regs 96 } { loc R 0 } }
- T{ ##replace { src V int-regs 129 } { loc R 0 } }
+ T{ ##replace { src 109 } { loc D 2 } }
+ T{ ##replace { src 85 } { loc D 3 } }
+ T{ ##replace { src 128 } { loc D 0 } }
+ T{ ##replace { src 85 } { loc D 1 } }
+ T{ ##replace { src 89 } { loc D 4 } }
+ T{ ##replace { src 96 } { loc R 0 } }
+ T{ ##replace { src 129 } { loc R 0 } }
T{ ##branch }
} 2 test-bb
V{
- T{ ##peek { dst V int-regs 134 } { loc D 1 } }
+ T{ ##peek { dst 134 } { loc D 1 } }
T{ ##slot-imm
- { dst V int-regs 140 }
- { obj V int-regs 134 }
+ { dst 140 }
+ { obj 134 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
- T{ ##replace { src V int-regs 140 } { loc D 0 } }
- T{ ##replace { src V int-regs 134 } { loc R 0 } }
+ T{ ##replace { src 140 } { loc D 0 } }
+ T{ ##replace { src 134 } { loc R 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##peek { dst V int-regs 141 } { loc R 0 } }
- T{ ##peek { dst V int-regs 143 } { loc D 0 } }
+ T{ ##peek { dst 141 } { loc R 0 } }
+ T{ ##peek { dst 143 } { loc D 0 } }
T{ ##set-slot-imm
- { src V int-regs 143 }
- { obj V int-regs 141 }
+ { src 143 }
+ { obj 141 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
- { src V int-regs 141 }
- { card# V int-regs 145 }
- { table V int-regs 146 }
+ { src 141 }
+ { card# 145 }
+ { table 146 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
- T{ ##peek { dst V int-regs 156 } { loc D 2 } }
- T{ ##peek { dst V int-regs 158 } { loc D 3 } }
- T{ ##peek { dst V int-regs 160 } { loc D 0 } }
- T{ ##peek { dst V int-regs 162 } { loc D 1 } }
- T{ ##peek { dst V int-regs 164 } { loc D 4 } }
- T{ ##peek { dst V int-regs 167 } { loc R 0 } }
- T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
- T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
- T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
- T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
- T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
- T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
+ T{ ##peek { dst 156 } { loc D 2 } }
+ T{ ##peek { dst 158 } { loc D 3 } }
+ T{ ##peek { dst 160 } { loc D 0 } }
+ T{ ##peek { dst 162 } { loc D 1 } }
+ T{ ##peek { dst 164 } { loc D 4 } }
+ T{ ##peek { dst 167 } { loc R 0 } }
+ T{ ##copy { dst 157 } { src 156 } }
+ T{ ##copy { dst 159 } { src 158 } }
+ T{ ##copy { dst 161 } { src 160 } }
+ T{ ##copy { dst 163 } { src 162 } }
+ T{ ##copy { dst 165 } { src 164 } }
+ T{ ##copy { dst 168 } { src 167 } }
T{ ##branch }
} 4 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
- T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
- T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
- T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
- T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
- T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
- T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
+ T{ ##copy { dst 157 } { src 85 } }
+ T{ ##copy { dst 159 } { src 89 } }
+ T{ ##copy { dst 161 } { src 85 } }
+ T{ ##copy { dst 163 } { src 109 } }
+ T{ ##copy { dst 165 } { src 91 } }
+ T{ ##copy { dst 168 } { src 96 } }
T{ ##branch }
} 5 test-bb
V{
T{ ##set-slot-imm
- { src V int-regs 163 }
- { obj V int-regs 161 }
+ { src 163 }
+ { obj 161 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
- T{ ##replace { src V int-regs 168 } { loc D 0 } }
- T{ ##replace { src V int-regs 157 } { loc D 3 } }
- T{ ##replace { src V int-regs 159 } { loc D 4 } }
- T{ ##replace { src V int-regs 161 } { loc D 1 } }
- T{ ##replace { src V int-regs 163 } { loc D 2 } }
- T{ ##replace { src V int-regs 165 } { loc D 5 } }
+ T{ ##replace { src 168 } { loc D 0 } }
+ T{ ##replace { src 157 } { loc D 3 } }
+ T{ ##replace { src 159 } { loc D 4 } }
+ T{ ##replace { src 161 } { loc D 1 } }
+ T{ ##replace { src 163 } { loc D 2 } }
+ T{ ##replace { src 165 } { loc D 5 } }
T{ ##epilogue }
T{ ##return }
} 6 test-bb
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-imm-branch f 0 5 cc= }
} 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 1 D 0 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##replace f 1 D 0 }
+ T{ ##replace f 2 D 0 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 4 test-bb
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-imm-branch f 0 5 cc= }
} 1 test-bb
V{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 1 D 0 }
- T{ ##replace f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##replace f 1 D 0 }
+ T{ ##replace f 2 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##branch }
} 2 test-bb
} 3 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 4 test-bb
[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-! GC check tests
-
-! Spill slot liveness was computed incorrectly, leading to a FEP
-! early in bootstrap on x86-32
-[ t ] [
- [
- T{ basic-block
- { id 12345 }
- { instructions
- V{
- T{ ##gc f V int-regs 6 V int-regs 7 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 4 D 4 }
- T{ ##peek f V int-regs 5 D 5 }
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##replace f V int-regs 1 D 2 }
- T{ ##replace f V int-regs 2 D 3 }
- T{ ##replace f V int-regs 3 D 4 }
- T{ ##replace f V int-regs 4 D 5 }
- T{ ##replace f V int-regs 5 D 0 }
- }
- }
- } cfg new over >>entry
- { { int-regs V{ 0 1 2 3 } } } (linear-scan)
- instructions>> first
- live-values>> assoc-empty?
- ] with-scope
-] unit-test
-
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##replace f 1 D 1 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##gc f V int-regs 2 V int-regs 3 }
+ T{ ##gc f 2 3 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 2 test-bb
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
-
-
+[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-imm-branch f 1 5 cc= }
} 0 test-bb
V{
- T{ ##gc f V int-regs 2 V int-regs 3 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##gc f 2 3 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 1 test-bb
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
+[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
+compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
cfg check-numbering ;
: linear-scan ( cfg -- cfg' )
- [
- dup machine-registers (linear-scan)
- spill-counts get >>spill-counts
- cfg-changed
- ] with-scope ;
+ dup machine-registers (linear-scan) ;
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-interval
vreg
reg spill-to reload-from
-start end ranges uses
-copy-from ;
+start end ranges uses ;
GENERIC: covers? ( insn# obj -- ? )
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
-: record-copy ( insn -- )
- [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
-
-M: ##copy compute-live-intervals*
- [ call-next-method ] [ record-copy ] bi ;
-
-M: ##copy-float compute-live-intervals*
- [ call-next-method ] [ record-copy ] bi ;
-
: handle-live-out ( bb -- )
live-out keys
basic-block get [ block-from ] [ block-to ] bi
: compute-live-intervals ( cfg -- live-intervals )
H{ } clone [
live-intervals set
- post-order [ compute-live-intervals-step ] each
+ linearization-order <reversed>
+ [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.rpo ;
+compiler.cfg.linearization.order ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
- [ 0 ] dip [
+ linearization-order 0 [
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
- ] each-basic-block drop ;
+ ] reduce drop ;
SYMBOL: check-numbering?
[ drop ] [ bad-numbering ] if ;
: check-numbering ( cfg -- )
- check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;
\ No newline at end of file
+ check-numbering? get
+ [ linearization-order [ check-block-numbering ] each ] [ drop ] if ;
\ No newline at end of file
-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
[
{
- { { T{ spill-slot f 0 } int-regs } { 1 int-regs } }
+ { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
}
] [
[
- 0 <spill-slot> 1 int-regs add-mapping
+ 0 <spill-slot> 1 int-rep add-mapping
] { } make
] unit-test
[
{
- T{ _reload { dst 1 } { class int-regs } { n 0 } }
+ T{ _reload { dst 1 } { rep int-rep } { n 0 } }
}
] [
[
- { T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn
+ { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
] { } make
] unit-test
[
{
- T{ _spill { src 1 } { class int-regs } { n 0 } }
+ T{ _spill { src 1 } { rep int-rep } { n 0 } }
}
] [
[
- { 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn
+ { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
] { } make
] unit-test
[
{
- T{ _copy { src 1 } { dst 2 } { class int-regs } }
+ T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
}
] [
[
- { 1 int-regs } { 2 int-regs } >insn
+ { 1 int-rep } { 2 int-rep } >insn
] { } make
] unit-test
-H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+cfg new 8 >>spill-area-size cfg set
H{ } clone spill-temps set
[
t
] [
- { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } }
+ { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
mapping-instructions {
{
- T{ _spill { src 0 } { class int-regs } { n 10 } }
- T{ _copy { dst 0 } { src 1 } { class int-regs } }
- T{ _reload { dst 1 } { class int-regs } { n 10 } }
+ T{ _spill { src 0 } { rep int-rep } { n 8 } }
+ T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
+ T{ _reload { dst 1 } { rep int-rep } { n 8 } }
}
{
- T{ _spill { src 1 } { class int-regs } { n 10 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ T{ _spill { src 1 } { rep int-rep } { n 8 } }
+ T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
+ T{ _reload { dst 0 } { rep int-rep } { n 8 } }
}
} member?
-] unit-test
\ No newline at end of file
+] unit-test
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals namespaces
make math sequences hashtables
+compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
+compiler.cfg.registers
compiler.cfg.utilities
compiler.cfg.instructions
+compiler.cfg.predecessors
compiler.cfg.parallel-copy
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.allocation.state ;
SYMBOL: spill-temps
-: spill-temp ( reg-class -- n )
+: spill-temp ( rep -- n )
spill-temps get [ next-spill-slot ] cache ;
-: add-mapping ( from to reg-class -- )
+: add-mapping ( from to rep -- )
'[ _ 2array ] bi@ 2array , ;
:: resolve-value-data-flow ( bb to vreg -- )
vreg bb vreg-at-end
vreg to vreg-at-start
- 2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
+ 2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
dup live-in dup assoc-empty? [ 3drop f ] [
drop [ first2 ] [ second spill-temp ] bi _spill ;
: register->register ( from to -- )
- swap [ first ] [ first2 ] bi* _copy ;
+ swap [ first ] [ first2 ] bi* ##copy ;
SYMBOL: temp
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
- mapping-instructions <simple-block>
- insert-basic-block
+ mapping-instructions <simple-block> insert-basic-block
+ cfg get cfg-changed drop
] if ;
: resolve-edge-data-flow ( bb to -- )
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( cfg -- )
+ needs-predecessors
+
H{ } clone spill-temps set
[ resolve-block-data-flow ] each-basic-block ;
+++ /dev/null
-IN: compiler.cfg.linearization.tests
-USING: compiler.cfg.linearization tools.test ;
-
-
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals cpu.architecture
+combinators assocs arrays locals layouts hashtables
+cpu.architecture
compiler.cfg
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.linearization.order ;
IN: compiler.cfg.linearization
+<PRIVATE
+
+SYMBOL: numbers
+
+: block-number ( bb -- n ) numbers get at ;
+
+: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
+
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
[ successors>> [ block-number _dispatch-label ] each ]
bi* ;
-: (compute-gc-roots) ( n live-values -- n )
- [
- [ nip 2array , ]
- [ drop reg-class>> reg-size + ]
- 3bi
- ] assoc-each ;
-
-: oop-values ( regs -- regs' )
- [ drop reg-class>> int-regs eq? ] assoc-filter ;
-
-: data-values ( regs -- regs' )
- [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
-
-: compute-gc-roots ( live-values -- alist )
- [
- [ 0 ] dip
- ! we put float registers last; the GC doesn't actually scan them
- [ oop-values (compute-gc-roots) ]
- [ data-values (compute-gc-roots) ] bi
- drop
- ] { } make ;
-
-: count-gc-roots ( live-values -- n )
- ! Size of GC root area, minus the float registers
- oop-values assoc-size ;
+: gc-root-offsets ( registers -- alist )
+ ! Outputs a sequence of { offset register/spill-slot } pairs
+ [ length iota [ cell * ] map ] keep zip ;
M: ##gc linearize-insn
nip
{
[ temp1>> ]
[ temp2>> ]
- [
- live-values>>
- [ compute-gc-roots ]
- [ count-gc-roots ]
- [ gc-roots-size ]
- tri
- ]
+ [ data-values>> ]
+ [ tagged-values>> gc-root-offsets ]
[ uninitialized-locs>> ]
} cleave
_gc ;
: linearize-basic-blocks ( cfg -- insns )
[
- [ linearization-order [ linearize-basic-block ] each ]
- [ spill-counts>> _spill-counts ]
- bi
+ [
+ linearization-order
+ [ number-blocks ]
+ [ [ linearize-basic-block ] each ] bi
+ ] [ spill-area-size>> _spill-area-size ] bi
] { } make ;
+PRIVATE>
+
: flatten-cfg ( cfg -- mr )
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make
+USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
-fry math sets compiler.cfg.rpo compiler.cfg.utilities ;
+fry math sets compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg.loop-detection ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
<PRIVATE
-SYMBOLS: work-list loop-heads visited numbers next-number ;
+SYMBOLS: work-list loop-heads visited ;
: visited? ( bb -- ? ) visited get key? ;
work-list get push-back
] if ;
+: init-linearization-order ( cfg -- )
+ <dlist> work-list set
+ H{ } clone visited set
+ entry>> add-to-work-list ;
+
: (find-alternate-loop-head) ( bb -- bb' )
dup {
[ predecessor visited? not ]
add-to-work-list
] [ drop ] if ;
-: assign-number ( bb -- )
- next-number [ get ] [ inc ] bi swap numbers get set-at ;
+: sorted-successors ( bb -- seq )
+ successors>> <reversed> [ loop-nesting-at ] sort-with ;
: process-block ( bb -- )
- {
- [ , ]
- [ assign-number ]
- [ visited get conjoin ]
- [ successors>> <reversed> [ process-successor ] each ]
- } cleave ;
+ [ , ]
+ [ visited get conjoin ]
+ [ sorted-successors [ process-successor ] each ]
+ tri ;
+
+: (linearization-order) ( cfg -- bbs )
+ init-linearization-order
+
+ [ work-list get [ process-block ] slurp-deque ] { } make ;
PRIVATE>
: linearization-order ( cfg -- bbs )
- ! We call 'post-order drop' to ensure blocks receive their
- ! RPO numbers.
- <dlist> work-list set
- H{ } clone visited set
- H{ } clone numbers set
- 0 next-number set
- [ post-order drop ]
- [ entry>> add-to-work-list ] bi
- [ work-list get [ process-block ] slurp-deque ] { } make ;
+ needs-post-order needs-loops
-: block-number ( bb -- n ) numbers get at ;
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if ;
\ No newline at end of file
: test-liveness ( -- )
cfg new 1 get >>entry
- compute-predecessors
compute-live-sets ;
! Sanity check...
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
+ T{ ##peek f 1 D 1 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f 2 D 0 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##replace f 3 D 0 }
T{ ##return }
} 3 test-bb
[
H{
- { V int-regs 1 V int-regs 1 }
- { V int-regs 2 V int-regs 2 }
- { V int-regs 3 V int-regs 3 }
+ { 1 1 }
+ { 2 2 }
+ { 3 3 }
}
]
[ 1 get live-in ]
! Tricky case; defs must be killed before uses
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##add-imm f V int-regs 0 V int-regs 0 10 }
+ T{ ##add-imm f 0 0 10 }
T{ ##return }
} 2 test-bb
test-liveness
-[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 get live-in ] unit-test
\ No newline at end of file
+[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test
\ No newline at end of file
drop instructions>> transfer-liveness ;
M: live-analysis join-sets
- drop assoc-combine ;
\ No newline at end of file
+ 2drop assoc-combine ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry
+hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities
+compiler.cfg.predecessors ;
+IN: compiler.cfg.liveness.ssa
+
+! TODO: merge with compiler.cfg.liveness
+
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in correspondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( basic-blocks -- )
+ work-list get '[ _ push-front ] each ;
+
+: compute-live-in ( basic-block -- live-in )
+ [ live-out ] keep instructions>> transfer-liveness ;
+
+: compute-phi-live-in ( basic-block -- phi-live-in )
+ H{ } clone [
+ '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
+ ] keep ;
+
+: update-live-in ( basic-block -- changed? )
+ [ [ compute-live-in ] keep live-ins get maybe-set-at ]
+ [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+ bi or ;
+
+: compute-live-out ( basic-block -- live-out )
+ [ successors>> [ live-in ] map ]
+ [ dup successors>> [ phi-live-in ] with map ] bi
+ append assoc-combine ;
+
+: update-live-out ( basic-block -- changed? )
+ [ compute-live-out ] keep
+ live-outs get maybe-set-at ;
+
+: liveness-step ( basic-block -- )
+ dup update-live-out [
+ dup update-live-in
+ [ predecessors>> add-to-work-list ] [ drop ] if
+ ] [ drop ] if ;
+
+: compute-ssa-live-sets ( cfg -- cfg' )
+ needs-predecessors
+
+ <hashed-dlist> work-list set
+ H{ } clone live-ins set
+ H{ } clone phi-live-ins set
+ H{ } clone live-outs set
+ dup post-order add-to-work-list
+ work-list get [ liveness-step ] slurp-deque ;
+
+: live-in? ( vreg bb -- ? ) live-in key? ;
+
+: live-out? ( vreg bb -- ? ) live-out key? ;
\ No newline at end of file
--- /dev/null
+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
+V{ } 2 test-bb
+
+0 { 1 2 } edges
+2 0 edge
+
+: test-loop-detection ( -- ) cfg new 0 get >>entry needs-loops drop ;
+
+[ ] [ test-loop-detection ] unit-test
+
+[ 1 ] [ 0 get loop-nesting-at ] unit-test
+[ 0 ] [ 1 get loop-nesting-at ] unit-test
+[ 1 ] [ 2 get loop-nesting-at ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators deques dlists fry kernel
+namespaces sequences sets compiler.cfg compiler.cfg.predecessors ;
+IN: compiler.cfg.loop-detection
+
+TUPLE: natural-loop header index ends blocks ;
+
+<PRIVATE
+
+SYMBOL: loops
+
+: <natural-loop> ( header index -- loop )
+ H{ } clone H{ } clone natural-loop boa ;
+
+: lookup-header ( header -- loop )
+ loops get [
+ loops get assoc-size <natural-loop>
+ ] cache ;
+
+SYMBOLS: visited active ;
+
+: record-back-edge ( from to -- )
+ lookup-header ends>> conjoin ;
+
+DEFER: find-loop-headers
+
+: visit-edge ( from to -- )
+ dup active get key?
+ [ record-back-edge ]
+ [ nip find-loop-headers ]
+ if ;
+
+: find-loop-headers ( bb -- )
+ dup visited get key? [ drop ] [
+ {
+ [ visited get conjoin ]
+ [ active get conjoin ]
+ [ dup successors>> [ visit-edge ] with each ]
+ [ active get delete-at ]
+ } cleave
+ ] if ;
+
+SYMBOL: work-list
+
+: process-loop-block ( bb loop -- )
+ 2dup blocks>> key? [ 2drop ] [
+ [ blocks>> conjoin ] [
+ 2dup header>> eq? [ 2drop ] [
+ drop predecessors>> work-list get push-all-front
+ ] if
+ ] 2bi
+ ] if ;
+
+: process-loop-ends ( loop -- )
+ [ ends>> keys <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
+ '[ _ process-loop-block ] slurp-deque ;
+
+: process-loop-headers ( -- )
+ loops get values [ process-loop-ends ] each ;
+
+SYMBOL: loop-nesting
+
+: compute-loop-nesting ( -- )
+ loops get H{ } clone [
+ [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each
+ ] keep loop-nesting set ;
+
+: detect-loops ( cfg -- cfg' )
+ needs-predecessors
+ H{ } clone loops set
+ H{ } clone visited set
+ H{ } clone active set
+ H{ } clone loop-nesting set
+ dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;
+
+PRIVATE>
+
+: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
+
+: needs-loops ( cfg -- cfg' )
+ needs-predecessors
+ dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.gc-checks compiler.cfg.linear-scan
-compiler.cfg.build-stack-frame compiler.cfg.rpo ;
+USING: kernel namespaces accessors compiler.cfg
+compiler.cfg.linearization compiler.cfg.gc-checks
+compiler.cfg.linear-scan compiler.cfg.build-stack-frame ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
- convert-two-operand
insert-gc-checks
linear-scan
flatten-cfg
compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
+compiler.cfg.representations
+compiler.cfg.two-operand
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
-compiler.cfg.predecessors
-compiler.cfg.rpo
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
] when ;
: optimize-cfg ( cfg -- cfg' )
- ! Note that compute-predecessors has to be called several times.
- ! The passes that need this document it.
- [
- optimize-tail-calls
- delete-useless-conditionals
- compute-predecessors
- split-branches
- join-blocks
- compute-predecessors
- construct-ssa
- alias-analysis
- value-numbering
- compute-predecessors
- copy-propagation
- eliminate-dead-code
- eliminate-write-barriers
- destruct-ssa
- delete-empty-blocks
- ?check
- ] with-scope ;
+ optimize-tail-calls
+ delete-useless-conditionals
+ split-branches
+ join-blocks
+ construct-ssa
+ alias-analysis
+ value-numbering
+ copy-propagation
+ eliminate-dead-code
+ eliminate-write-barriers
+ select-representations
+ convert-two-operand
+ destruct-ssa
+ delete-empty-blocks
+ ?check ;
[
{
- T{ ##copy f V int-regs 4 V int-regs 2 }
- T{ ##copy f V int-regs 2 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 4 }
+ T{ ##copy f 4 2 any-rep }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##copy f 1 4 any-rep }
}
] [
H{
- { V int-regs 1 V int-regs 2 }
- { V int-regs 2 V int-regs 1 }
+ { 1 2 }
+ { 2 1 }
} test-parallel-copy
] unit-test
[
{
- T{ ##copy f V int-regs 1 V int-regs 2 }
- T{ ##copy f V int-regs 3 V int-regs 4 }
+ T{ ##copy f 1 2 any-rep }
+ T{ ##copy f 3 4 any-rep }
}
] [
H{
- { V int-regs 1 V int-regs 2 }
- { V int-regs 3 V int-regs 4 }
+ { 1 2 }
+ { 3 4 }
} test-parallel-copy
] unit-test
[
{
- T{ ##copy f V int-regs 1 V int-regs 3 }
- T{ ##copy f V int-regs 2 V int-regs 1 }
+ T{ ##copy f 1 3 any-rep }
+ T{ ##copy f 2 1 any-rep }
}
] [
H{
- { V int-regs 1 V int-regs 3 }
- { V int-regs 2 V int-regs 3 }
+ { 1 3 }
+ { 2 3 }
} test-parallel-copy
] unit-test
[
{
- T{ ##copy f V int-regs 4 V int-regs 3 }
- T{ ##copy f V int-regs 3 V int-regs 2 }
- T{ ##copy f V int-regs 2 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 4 }
+ T{ ##copy f 4 3 any-rep }
+ T{ ##copy f 3 2 any-rep }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##copy f 1 4 any-rep }
}
] [
{
- { V int-regs 2 V int-regs 1 }
- { V int-regs 3 V int-regs 2 }
- { V int-regs 1 V int-regs 3 }
- { V int-regs 4 V int-regs 3 }
+ { 2 1 }
+ { 3 2 }
+ { 1 3 }
+ { 4 3 }
} test-parallel-copy
] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs compiler.cfg.hats compiler.cfg.instructions
-deques dlists fry kernel locals namespaces sequences
-hashtables ;
+USING: assocs cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions deques dlists fry kernel locals namespaces
+sequences hashtables ;
IN: compiler.cfg.parallel-copy
! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
] slurp-deque
] with-scope ; inline
-: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ;
\ No newline at end of file
+: parallel-copy ( mapping -- )
+ next-vreg [ any-rep ##copy ] parallel-mapping ;
\ No newline at end of file
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.predecessors
+<PRIVATE
+
: update-predecessors ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
[ [ update-phis ] each-basic-block ]
[ ]
} cleave ;
+
+PRIVATE>
+
+: needs-predecessors ( cfg -- cfg' )
+ dup predecessors-valid?>>
+ [ compute-predecessors t >>predecessors-valid? ] unless ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays parser math math.order ;
+USING: accessors namespaces kernel parser assocs ;
IN: compiler.cfg.registers
-! Virtual registers, used by CFG and machine IRs
-TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
+! Virtual registers, used by CFG and machine IRs, are just integers
+SYMBOL: vreg-counter
-M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
+: next-vreg ( -- vreg )
+ ! This word cannot be called AFTER representation selection has run;
+ ! use next-vreg-rep in that case
+ \ vreg-counter counter ;
-M: vreg hashcode* nip n>> ;
+SYMBOL: representations
-SYMBOL: vreg-counter
+ERROR: bad-vreg vreg ;
+
+: rep-of ( vreg -- rep )
+ ! This word cannot be called BEFORE representation selection has run;
+ ! use any-rep for ##copy instructions and so on
+ representations get ?at [ bad-vreg ] unless ;
+
+: set-rep-of ( rep vreg -- )
+ representations get set-at ;
-: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+: next-vreg-rep ( rep -- vreg )
+ ! This word cannot be called BEFORE representation selection has run;
+ ! use next-vreg in that case
+ next-vreg [ set-rep-of ] keep ;
! Stack locations -- 'n' is an index starting from the top of the stack
! going down. So 0 is the top of the stack, 1 is what would be the top
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
-SYNTAX: V scan-word scan-word vreg boa parsed ;
SYNTAX: D scan-word <ds-loc> parsed ;
SYNTAX: R scan-word <rs-loc> parsed ;
: rename-value ( vreg -- vreg' )
renamings get ?at drop ;
-: fresh-value ( vreg -- vreg' )
- reg-class>> next-vreg ;
-
-RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ]
+RENAMING: rename [ rename-value ] [ rename-value ] [ drop next-vreg ]
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences arrays fry namespaces
+cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.representations.preferred
+
+GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: temp-vreg-reps ( insn -- reps )
+GENERIC: uses-vreg-reps ( insn -- reps )
+
+M: ##flushable defs-vreg-rep drop int-rep ;
+M: ##copy defs-vreg-rep rep>> ;
+M: output-float-insn defs-vreg-rep drop double-float-rep ;
+M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
+M: _fixnum-overflow defs-vreg-rep drop int-rep ;
+M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
+M: insn defs-vreg-rep drop f ;
+
+M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
+M: ##unary/temp temp-vreg-reps drop { int-rep } ;
+M: ##allot temp-vreg-reps drop { int-rep } ;
+M: ##dispatch temp-vreg-reps drop { int-rep } ;
+M: ##slot temp-vreg-reps drop { int-rep } ;
+M: ##set-slot temp-vreg-reps drop { int-rep } ;
+M: ##string-nth temp-vreg-reps drop { int-rep } ;
+M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
+M: ##compare temp-vreg-reps drop { int-rep } ;
+M: ##compare-imm temp-vreg-reps drop { int-rep } ;
+M: ##compare-float temp-vreg-reps drop { int-rep } ;
+M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
+M: _dispatch temp-vreg-reps drop { int-rep } ;
+M: insn temp-vreg-reps drop f ;
+
+M: ##copy uses-vreg-reps rep>> 1array ;
+M: ##unary uses-vreg-reps drop { int-rep } ;
+M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
+M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
+M: ##binary-imm uses-vreg-reps drop { int-rep } ;
+M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##effect uses-vreg-reps drop { int-rep } ;
+M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
+M: ##slot-imm uses-vreg-reps drop { int-rep } ;
+M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
+M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##dispatch uses-vreg-reps drop { int-rep } ;
+M: ##alien-getter uses-vreg-reps drop { int-rep } ;
+M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: _dispatch uses-vreg-reps drop { int-rep } ;
+M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
+M: insn uses-vreg-reps drop f ;
+
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
+
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
+
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+ '[
+ [ basic-block set ] [
+ [
+ _
+ [ each-def-rep ]
+ [ each-use-rep ]
+ [ each-temp-rep ] 2tri
+ ] each-non-phi
+ ] bi
+ ] each-basic-block ; inline
--- /dev/null
+USING: tools.test cpu.architecture
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+[ { double-float-rep double-float-rep } ] [
+ T{ ##add-float
+ { dst 5 }
+ { src1 3 }
+ { src2 4 }
+ } uses-vreg-reps
+] unit-test
+
+[ double-float-rep ] [
+ T{ ##alien-double
+ { dst 5 }
+ { src 3 }
+ } defs-vreg-rep
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry accessors sequences assocs sets namespaces
+arrays combinators make locals deques dlists
+cpu.architecture compiler.utilities
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.def-use
+compiler.cfg.utilities
+compiler.cfg.loop-detection
+compiler.cfg.renaming.functor
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+! Virtual register representation selection.
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+ 2array {
+ { { int-rep int-rep } [ int-rep ##copy ] }
+ { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
+ { { double-float-rep int-rep } [ ##unbox-float ] }
+ { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
+ } case ;
+
+<PRIVATE
+
+! For every vreg, compute possible representations.
+SYMBOL: possibilities
+
+: possible ( vreg -- reps ) possibilities get at ;
+
+: compute-possibilities ( cfg -- )
+ H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
+ [ keys ] assoc-map possibilities set ;
+
+! Compute vregs which must remain tagged for their lifetime.
+SYMBOL: always-boxed
+
+:: (compute-always-boxed) ( vreg rep assoc -- )
+ rep int-rep eq? [
+ int-rep vreg assoc set-at
+ ] when ;
+
+: compute-always-boxed ( cfg -- assoc )
+ H{ } clone [
+ '[
+ [
+ dup ##load-reference? [ drop ] [
+ [ _ (compute-always-boxed) ] each-def-rep
+ ] if
+ ] each-non-phi
+ ] each-basic-block
+ ] keep ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+ possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: increase-cost ( rep vreg -- )
+ ! Increase cost of keeping vreg in rep, making a choice of rep less
+ ! likely.
+ [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+
+: maybe-increase-cost ( possible vreg preferred -- )
+ pick eq? [ 2drop ] [ increase-cost ] if ;
+
+: representation-cost ( vreg preferred -- )
+ ! 'preferred' is a representation that the instruction can accept with no cost.
+ ! So, for each representation that's not preferred, increase the cost of keeping
+ ! the vreg in that representation.
+ [ drop possible ]
+ [ '[ _ _ maybe-increase-cost ] ]
+ 2bi each ;
+
+: compute-costs ( cfg -- costs )
+ init-costs [ representation-cost ] with-vreg-reps costs get ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+ [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+ [ compute-costs minimize-costs ]
+ [ compute-always-boxed ]
+ bi assoc-union
+ representations set ;
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+:: emit-def-conversion ( dst preferred required -- new-dst' )
+ ! If an instruction defines a register with representation 'required',
+ ! but the register has preferred representation 'preferred', then
+ ! we rename the instruction's definition to a new register, which
+ ! becomes the input of a conversion instruction.
+ dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
+
+:: emit-use-conversion ( src preferred required -- new-src' )
+ ! If an instruction uses a register with representation 'required',
+ ! but the register has preferred representation 'preferred', then
+ ! we rename the instruction's input to a new register, which
+ ! becomes the output of a conversion instruction.
+ required next-vreg-rep [ src required preferred emit-conversion ] keep ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+ needs-renaming? off
+ V{ } clone renaming-set set ;
+
+: no-renaming ( vreg -- )
+ dup 2array renaming-set get push ;
+
+: record-renaming ( from to -- )
+ 2array renaming-set get push needs-renaming? on ;
+
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+ vreg rep-of :> preferred
+ preferred required eq?
+ [ vreg no-renaming ]
+ [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: compute-renaming-set ( insn -- )
+ ! temp vregs don't need conversions since they're always in their
+ ! preferred representation
+ init-renaming-set
+ [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
+ [ , ]
+ [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
+ tri ;
+
+: converted-value ( vreg -- vreg' )
+ renaming-set get pop first2 [ assert= ] dip ;
+
+RENAMING: convert [ converted-value ] [ converted-value ] [ ]
+
+: perform-renaming ( insn -- )
+ needs-renaming? get [
+ renaming-set get reverse-here
+ [ convert-insn-uses ] [ convert-insn-defs ] bi
+ renaming-set get length 0 assert=
+ ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+SYMBOL: phi-mappings
+
+! compiler.cfg.cssa inserts conversions which convert phi inputs into
+! the representation of the output. However, we still have to do some
+! processing here, because if the only node that uses the output of
+! the phi instruction is another phi instruction then this phi node's
+! output won't have a representation assigned.
+M: ##phi conversions-for-insn
+ [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+
+M: vreg-insn conversions-for-insn
+ [ compute-renaming-set ] [ perform-renaming ] bi ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+ dup kill-block? [ drop ] [
+ [
+ [
+ [ conversions-for-insn ] each
+ ] V{ } make
+ ] change-instructions drop
+ ] if ;
+
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+ work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+ representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+ representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+ phi-mappings get keys rep-assigned add-to-work-list ;
+
+: process-phi-mapping ( dst -- )
+ ! If dst = phi(src1,src2,...) and dst's representation has been
+ ! determined, assign that representation to each one of src1,...
+ ! that does not have a representation yet, and process those, too.
+ dup phi-mappings get at* [
+ [ rep-of ] [ rep-not-assigned ] bi*
+ [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+ ] [ 2drop ] if ;
+
+: remaining-phi-mappings ( -- )
+ phi-mappings get keys rep-not-assigned
+ [ [ int-rep ] dip set-rep-of ] each ;
+
+: process-phi-mappings ( -- )
+ <hashed-dlist> work-list set
+ add-ready-phis
+ work-list get [ process-phi-mapping ] slurp-deque
+ remaining-phi-mappings ;
+
+: insert-conversions ( cfg -- )
+ H{ } clone phi-mappings set
+ [ conversions-for-block ] each-basic-block
+ process-phi-mappings ;
+
+PRIVATE>
+
+: select-representations ( cfg -- cfg' )
+ needs-loops
+
+ {
+ [ compute-possibilities ]
+ [ compute-representations ]
+ [ insert-conversions ]
+ [ ]
+ } cleave
+ representations get cfg get (>>reps) ;
\ No newline at end of file
[ change-instructions drop ] 2bi ; inline
: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
- dupd '[ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
+ dupd '[ _ optimize-basic-block ] each-basic-block ; inline
+
+: needs-post-order ( cfg -- cfg' )
+ dup post-order drop ;
\ No newline at end of file
reset-counters
V{
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
- T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 1 50 }
+ T{ ##add-imm f 2 2 10 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##load-immediate f V int-regs 3 3 }
+ T{ ##load-immediate f 3 3 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##load-immediate f V int-regs 3 4 }
+ T{ ##load-immediate f 3 4 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##replace f 3 D 0 }
T{ ##return }
} 3 test-bb
: test-ssa ( -- )
cfg new 0 get >>entry
- compute-predecessors
+ dup cfg set
construct-ssa
drop ;
[
V{
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
- T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 1 50 }
+ T{ ##add-imm f 3 2 10 }
T{ ##branch }
}
] [ 0 get instructions>> ] unit-test
[
V{
- T{ ##load-immediate f V int-regs 4 3 }
+ T{ ##load-immediate f 4 3 }
T{ ##branch }
}
] [ 1 get instructions>> ] unit-test
[
V{
- T{ ##load-immediate f V int-regs 5 4 }
+ T{ ##load-immediate f 5 4 }
T{ ##branch }
}
] [ 2 get instructions>> ] unit-test
[
V{
- T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##phi f 6 H{ { 1 4 } { 2 5 } } }
+ T{ ##replace f 6 D 0 }
T{ ##return }
}
] [
V{ } 0 test-bb
V{ } 1 test-bb
-V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
-V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
-V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
+V{ T{ ##peek f 0 D 0 } } 2 test-bb
+V{ T{ ##peek f 0 D 0 } } 3 test-bb
+V{ T{ ##replace f 0 D 0 } } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
[
V{
- T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
+ T{ ##replace f 3 D 0 }
}
] [
4 get instructions>>
compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions
+compiler.cfg.renaming
compiler.cfg.renaming.functor
compiler.cfg.ssa.construction.tdmsc ;
IN: compiler.cfg.ssa.construction
-! SSA construction. Predecessors must be computed first.
-
! The phi placement algorithm is implemented in
! compiler.cfg.ssa.construction.tdmsc.
H{ } clone stacks set ;
: gen-name ( vreg -- vreg' )
- [ reg-class>> next-vreg dup ] keep
+ [ next-vreg dup ] dip
dup pushed get 2dup key?
[ 2drop stacks get at set-last ]
[ conjoin stacks get push-at ]
: construct-ssa ( cfg -- cfg' )
{
- [ ]
[ compute-live-sets ]
- [ compute-dominance ]
[ compute-merge-sets ]
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
+ [ ]
} cleave ;
\ No newline at end of file
IN: compiler.cfg.ssa.construction.tdmsc.tests
: test-tdmsc ( -- )
- cfg new 0 get >>entry
- compute-predecessors
- dup compute-dominance
+ cfg new 0 get >>entry dup cfg set
compute-merge-sets ;
V{ } 0 test-bb
PRIVATE>
: compute-merge-sets ( cfg -- )
- dup cfg set
+ needs-dominance
+
H{ } clone visited set
[ compute-levels ]
[ init-merge-sets ]
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals
+USING: accessors assocs kernel locals fry
+cpu.architecture
compiler.cfg.rpo
-compiler.cfg.hats
compiler.cfg.utilities
-compiler.cfg.instructions ;
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations ;
IN: compiler.cfg.ssa.cssa
-! Convert SSA to conventional SSA.
+! Convert SSA to conventional SSA. This pass runs after representation
+! selection, so it must keep track of representations when introducing
+! new values.
-:: insert-copy ( bb src -- bb dst )
- i :> dst
- bb [ dst src ##copy ] add-instructions
+:: insert-copy ( bb src rep -- bb dst )
+ rep next-vreg-rep :> dst
+ bb [ dst src rep src rep-of emit-conversion ] add-instructions
bb dst ;
: convert-phi ( ##phi -- )
- [ [ insert-copy ] assoc-map ] change-inputs drop ;
+ dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
: construct-cssa ( cfg -- )
[ [ convert-phi ] each-phi ] each-basic-block ;
\ No newline at end of file
compiler.cfg.renaming
compiler.cfg.dominance
compiler.cfg.instructions
-compiler.cfg.ssa.liveness
+compiler.cfg.liveness.ssa
compiler.cfg.ssa.cssa
compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges
: eliminate-copy ( vreg1 vreg2 -- )
[ leader ] bi@
2dup eq? [ 2drop ] [
- [ update-leaders ] [ merge-classes ] 2bi
+ [ update-leaders ]
+ [ merge-classes ]
+ 2bi
] if ;
: introduce-vreg ( vreg -- )
] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
- dup cfg-has-phis? [
- dup construct-cssa
- dup precompute-liveness
- dup compute-defs
- dup compute-dominance
- dup compute-live-ranges
- dup prepare-coalescing
- process-copies
- dup perform-renaming
- ] when ;
+ needs-dominance
+
+ dup construct-cssa
+ dup compute-defs
+ compute-ssa-live-sets
+ dup compute-live-ranges
+ dup prepare-coalescing
+ process-copies
+ dup perform-renaming ;
\ No newline at end of file
USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.def-use compiler.cfg.dominance
-compiler.cfg.instructions compiler.cfg.ssa.liveness
+compiler.cfg.instructions compiler.cfg.liveness.ssa
compiler.cfg.registers compiler.cfg.predecessors
compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges cpu.architecture
: test-interference ( -- )
cfg new 0 get >>entry
- compute-predecessors
- dup precompute-liveness
+ compute-ssa-live-sets
dup compute-defs
- dup compute-dominance
compute-live-ranges ;
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##copy f V int-regs 1 V int-regs 0 }
- T{ ##copy f V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##copy f 1 0 }
+ T{ ##copy f 3 2 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##peek f V int-regs 4 D 0 }
- T{ ##peek f V int-regs 5 D 0 }
- T{ ##replace f V int-regs 3 D 0 }
- T{ ##peek f V int-regs 6 D 0 }
- T{ ##replace f V int-regs 5 D 0 }
+ T{ ##peek f 4 D 0 }
+ T{ ##peek f 5 D 0 }
+ T{ ##replace f 3 D 0 }
+ T{ ##peek f 6 D 0 }
+ T{ ##replace f 5 D 0 }
T{ ##return }
} 1 test-bb
[ ] [ test-interference ] unit-test
-[ f ] [ V int-regs 0 V int-regs 1 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 1 V int-regs 0 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 2 V int-regs 3 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 3 V int-regs 2 vregs-interfere? ] unit-test
-[ t ] [ V int-regs 0 V int-regs 2 vregs-interfere? ] unit-test
-[ t ] [ V int-regs 2 V int-regs 0 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 1 V int-regs 3 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 3 V int-regs 1 vregs-interfere? ] unit-test
-[ t ] [ V int-regs 3 V int-regs 4 vregs-interfere? ] unit-test
-[ t ] [ V int-regs 4 V int-regs 3 vregs-interfere? ] unit-test
-[ t ] [ V int-regs 3 V int-regs 5 vregs-interfere? ] unit-test
-[ t ] [ V int-regs 5 V int-regs 3 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 3 V int-regs 6 vregs-interfere? ] unit-test
-[ f ] [ V int-regs 6 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ 0 1 vregs-interfere? ] unit-test
+[ f ] [ 1 0 vregs-interfere? ] unit-test
+[ f ] [ 2 3 vregs-interfere? ] unit-test
+[ f ] [ 3 2 vregs-interfere? ] unit-test
+[ t ] [ 0 2 vregs-interfere? ] unit-test
+[ t ] [ 2 0 vregs-interfere? ] unit-test
+[ f ] [ 1 3 vregs-interfere? ] unit-test
+[ f ] [ 3 1 vregs-interfere? ] unit-test
+[ t ] [ 3 4 vregs-interfere? ] unit-test
+[ t ] [ 4 3 vregs-interfere? ] unit-test
+[ t ] [ 3 5 vregs-interfere? ] unit-test
+[ t ] [ 5 3 vregs-interfere? ] unit-test
+[ f ] [ 3 6 vregs-interfere? ] unit-test
+[ f ] [ 6 3 vregs-interfere? ] unit-test
\ No newline at end of file
compiler.cfg.ssa.interference.live-ranges ;
IN: compiler.cfg.ssa.interference
+! Interference testing using SSA properties. Actually the only SSA property
+! used here is that definitions dominate uses; because of this, the input
+! is allowed to have multiple definitions of each vreg as long as they're
+! all in the same basic block. This is needed because two-operand conversion
+! runs before coalescing, which uses SSA interference testing.
<PRIVATE
:: kill-after-def? ( vreg1 vreg2 bb -- ? )
[ 2drop 2drop f ]
} cond ;
-! Debug this stuff later
<PRIVATE
+! Debug this stuff later
+
: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
: quadratic-test ( seq1 seq2 -- ? )
: sort-vregs-by-bb ( vregs -- alist )
defs get
'[ dup _ at ] { } map>assoc
- [ [ second pre-of ] compare ] sort ;
+ [ second pre-of ] sort-with ;
: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences math
arrays compiler.cfg.def-use compiler.cfg.instructions
-compiler.cfg.ssa.liveness compiler.cfg.rpo ;
+compiler.cfg.liveness.ssa compiler.cfg.rpo compiler.cfg.dominance ;
IN: compiler.cfg.ssa.interference.live-ranges
! Live ranges for interference testing
SYMBOLS: local-def-indices local-kill-indices ;
-: record-def ( n vregs -- )
- dup [ local-def-indices get set-at ] [ 2drop ] if ;
+: record-def ( n vreg -- )
+ ! We allow multiple defs of a vreg as long as they're
+ ! all in the same basic block
+ dup [
+ local-def-indices get 2dup key?
+ [ 3drop ] [ set-at ] if
+ ] [ 2drop ] if ;
: record-uses ( n vregs -- )
local-kill-indices get '[ _ set-at ] with each ;
PRIVATE>
: compute-live-ranges ( cfg -- )
+ needs-dominance
+
H{ } clone def-indices set
H{ } clone kill-indices set
[ compute-local-live-ranges ] each-basic-block ;
compiler.cfg.debugger
compiler.cfg.instructions
compiler.cfg.predecessors
-compiler.cfg.registers ;
+compiler.cfg.registers
+compiler.cfg.dominance
+compiler.cfg.def-use ;
IN: compiler.cfg.ssa.liveness
[ t ] [ { 1 } 1 only? ] unit-test
[ f ] [ { 2 1 } 1 only? ] unit-test
[ f ] [ { 2 } 1 only? ] unit-test
-V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
-} 1 test-bb
+: test-liveness ( -- )
+ cfg new 0 get >>entry
+ dup compute-defs
+ dup compute-uses
+ needs-dominance
+ precompute-liveness ;
V{
- T{ ##replace f V int-regs 2 D 0 }
-} 2 test-bb
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
+} 0 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
-} 3 test-bb
+ T{ ##replace f 2 D 0 }
+} 1 test-bb
-1 { 2 3 } edges
+V{
+ T{ ##replace f 3 D 0 }
+} 2 test-bb
-cfg new 1 get >>entry 4 set
+0 { 1 2 } edges
-[ ] [ 4 get compute-predecessors drop ] unit-test
-[ ] [ 4 get precompute-liveness ] unit-test
+[ ] [ test-liveness ] unit-test
[ H{ } ] [ back-edge-targets get ] unit-test
-[ H{ } ] [ phi-outs get ] unit-test
-[ t ] [ 1 get R_q { 1 2 3 } [ get ] map unique = ] unit-test
+[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test
+[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test
[ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test
-[ t ] [ 3 get R_q { 3 } [ get ] map unique = ] unit-test
: self-T_q ( n -- ? )
get [ T_q ] [ 1array unique ] bi = ;
+[ t ] [ 0 self-T_q ] unit-test
[ t ] [ 1 self-T_q ] unit-test
[ t ] [ 2 self-T_q ] unit-test
-[ t ] [ 3 self-T_q ] unit-test
-
-[ f ] [ V int-regs 0 1 get live-in? ] unit-test
-[ t ] [ V int-regs 1 1 get live-in? ] unit-test
-[ t ] [ V int-regs 2 1 get live-in? ] unit-test
-[ t ] [ V int-regs 3 1 get live-in? ] unit-test
-
-[ f ] [ V int-regs 0 1 get live-out? ] unit-test
-[ f ] [ V int-regs 1 1 get live-out? ] unit-test
-[ t ] [ V int-regs 2 1 get live-out? ] unit-test
-[ t ] [ V int-regs 3 1 get live-out? ] unit-test
-
-[ f ] [ V int-regs 0 2 get live-in? ] unit-test
-[ f ] [ V int-regs 1 2 get live-in? ] unit-test
-[ t ] [ V int-regs 2 2 get live-in? ] unit-test
-[ f ] [ V int-regs 3 2 get live-in? ] unit-test
-
-[ f ] [ V int-regs 0 2 get live-out? ] unit-test
-[ f ] [ V int-regs 1 2 get live-out? ] unit-test
-[ f ] [ V int-regs 2 2 get live-out? ] unit-test
-[ f ] [ V int-regs 3 2 get live-out? ] unit-test
-
-[ f ] [ V int-regs 0 3 get live-in? ] unit-test
-[ f ] [ V int-regs 1 3 get live-in? ] unit-test
-[ f ] [ V int-regs 2 3 get live-in? ] unit-test
-[ t ] [ V int-regs 3 3 get live-in? ] unit-test
-
-[ f ] [ V int-regs 0 3 get live-out? ] unit-test
-[ f ] [ V int-regs 1 3 get live-out? ] unit-test
-[ f ] [ V int-regs 2 3 get live-out? ] unit-test
-[ f ] [ V int-regs 3 3 get live-out? ] unit-test
+
+[ f ] [ 0 0 get live-in? ] unit-test
+[ t ] [ 1 0 get live-in? ] unit-test
+[ t ] [ 2 0 get live-in? ] unit-test
+[ t ] [ 3 0 get live-in? ] unit-test
+
+[ f ] [ 0 0 get live-out? ] unit-test
+[ f ] [ 1 0 get live-out? ] unit-test
+[ t ] [ 2 0 get live-out? ] unit-test
+[ t ] [ 3 0 get live-out? ] unit-test
+
+[ f ] [ 0 1 get live-in? ] unit-test
+[ f ] [ 1 1 get live-in? ] unit-test
+[ t ] [ 2 1 get live-in? ] unit-test
+[ f ] [ 3 1 get live-in? ] unit-test
+
+[ f ] [ 0 1 get live-out? ] unit-test
+[ f ] [ 1 1 get live-out? ] unit-test
+[ f ] [ 2 1 get live-out? ] unit-test
+[ f ] [ 3 1 get live-out? ] unit-test
+
+[ f ] [ 0 2 get live-in? ] unit-test
+[ f ] [ 1 2 get live-in? ] unit-test
+[ f ] [ 2 2 get live-in? ] unit-test
+[ t ] [ 3 2 get live-in? ] unit-test
+
+[ f ] [ 0 2 get live-out? ] unit-test
+[ f ] [ 1 2 get live-out? ] unit-test
+[ f ] [ 2 2 get live-out? ] unit-test
+[ f ] [ 3 2 get live-out? ] unit-test
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{
- T{ ##phi f V int-regs 2 H{ { 2 V int-regs 0 } { 3 V int-regs 1 } } }
+ T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
} 4 test-bb
test-diamond
-cfg new 1 get >>entry 5 set
-
-[ ] [ 5 get compute-predecessors drop ] unit-test
-[ ] [ 5 get precompute-liveness ] unit-test
+[ ] [ test-liveness ] unit-test
-[ t ] [ V int-regs 0 1 get live-in? ] unit-test
-[ t ] [ V int-regs 1 1 get live-in? ] unit-test
-[ f ] [ V int-regs 2 1 get live-in? ] unit-test
+[ t ] [ 0 1 get live-in? ] unit-test
+[ t ] [ 1 1 get live-in? ] unit-test
+[ f ] [ 2 1 get live-in? ] unit-test
-[ t ] [ V int-regs 0 1 get live-out? ] unit-test
-[ t ] [ V int-regs 1 1 get live-out? ] unit-test
-[ f ] [ V int-regs 2 1 get live-out? ] unit-test
+[ t ] [ 0 1 get live-out? ] unit-test
+[ t ] [ 1 1 get live-out? ] unit-test
+[ f ] [ 2 1 get live-out? ] unit-test
-[ t ] [ V int-regs 0 2 get live-in? ] unit-test
-[ f ] [ V int-regs 1 2 get live-in? ] unit-test
-[ f ] [ V int-regs 2 2 get live-in? ] unit-test
+[ t ] [ 0 2 get live-in? ] unit-test
+[ f ] [ 1 2 get live-in? ] unit-test
+[ f ] [ 2 2 get live-in? ] unit-test
-[ t ] [ V int-regs 0 2 get live-out? ] unit-test
-[ f ] [ V int-regs 1 2 get live-out? ] unit-test
-[ f ] [ V int-regs 2 2 get live-out? ] unit-test
+[ f ] [ 0 2 get live-out? ] unit-test
+[ f ] [ 1 2 get live-out? ] unit-test
+[ f ] [ 2 2 get live-out? ] unit-test
-[ f ] [ V int-regs 0 3 get live-in? ] unit-test
-[ t ] [ V int-regs 1 3 get live-in? ] unit-test
-[ f ] [ V int-regs 2 3 get live-in? ] unit-test
+[ f ] [ 0 3 get live-in? ] unit-test
+[ t ] [ 1 3 get live-in? ] unit-test
+[ f ] [ 2 3 get live-in? ] unit-test
-[ f ] [ V int-regs 0 3 get live-out? ] unit-test
-[ t ] [ V int-regs 1 3 get live-out? ] unit-test
-[ f ] [ V int-regs 2 3 get live-out? ] unit-test
+[ f ] [ 0 3 get live-out? ] unit-test
+[ f ] [ 1 3 get live-out? ] unit-test
+[ f ] [ 2 3 get live-out? ] unit-test
-[ f ] [ V int-regs 0 4 get live-in? ] unit-test
-[ f ] [ V int-regs 1 4 get live-in? ] unit-test
-[ f ] [ V int-regs 2 4 get live-in? ] unit-test
+[ f ] [ 0 4 get live-in? ] unit-test
+[ f ] [ 1 4 get live-in? ] unit-test
+[ f ] [ 2 4 get live-in? ] unit-test
-[ f ] [ V int-regs 0 4 get live-out? ] unit-test
-[ f ] [ V int-regs 1 4 get live-out? ] unit-test
-[ f ] [ V int-regs 2 4 get live-out? ] unit-test
+[ f ] [ 0 4 get live-out? ] unit-test
+[ f ] [ 1 4 get live-out? ] unit-test
+[ f ] [ 2 4 get live-out? ] unit-test
! This is the CFG in Figure 3 from the paper
+V{ } 0 test-bb
V{ } 1 test-bb
+0 1 edge
V{ } 2 test-bb
1 2 edge
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
} 3 test-bb
V{ } 11 test-bb
2 { 3 11 } edges
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
} 4 test-bb
V{ } 8 test-bb
3 { 8 4 } edges
V{
- T{ ##replace f V int-regs 1 D 0 }
+ T{ ##replace f 1 D 0 }
} 9 test-bb
8 9 edge
V{
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f 2 D 0 }
} 5 test-bb
4 5 edge
V{ } 10 test-bb
10 8 edge
7 2 edge
-cfg new 1 get >>entry 0 set
-[ ] [ 0 get compute-predecessors drop ] unit-test
-[ ] [ 0 get precompute-liveness ] unit-test
+[ ] [ test-liveness ] unit-test
[ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test
[ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test
[ f ] [ 10 get back-edge-target? ] unit-test
[ f ] [ 11 get back-edge-target? ] unit-test
-[ f ] [ 1 11 [a,b] [ get phi-outs get at ] any? ] unit-test
-
-[ f ] [ V int-regs 0 1 get live-in? ] unit-test
-[ f ] [ V int-regs 1 1 get live-in? ] unit-test
-[ f ] [ V int-regs 2 1 get live-in? ] unit-test
+[ f ] [ 0 1 get live-in? ] unit-test
+[ f ] [ 1 1 get live-in? ] unit-test
+[ f ] [ 2 1 get live-in? ] unit-test
-[ f ] [ V int-regs 0 1 get live-out? ] unit-test
-[ f ] [ V int-regs 1 1 get live-out? ] unit-test
-[ f ] [ V int-regs 2 1 get live-out? ] unit-test
+[ f ] [ 0 1 get live-out? ] unit-test
+[ f ] [ 1 1 get live-out? ] unit-test
+[ f ] [ 2 1 get live-out? ] unit-test
-[ f ] [ V int-regs 0 2 get live-in? ] unit-test
-[ f ] [ V int-regs 1 2 get live-in? ] unit-test
-[ f ] [ V int-regs 2 2 get live-in? ] unit-test
+[ f ] [ 0 2 get live-in? ] unit-test
+[ f ] [ 1 2 get live-in? ] unit-test
+[ f ] [ 2 2 get live-in? ] unit-test
-[ f ] [ V int-regs 0 2 get live-out? ] unit-test
-[ f ] [ V int-regs 1 2 get live-out? ] unit-test
-[ f ] [ V int-regs 2 2 get live-out? ] unit-test
+[ f ] [ 0 2 get live-out? ] unit-test
+[ f ] [ 1 2 get live-out? ] unit-test
+[ f ] [ 2 2 get live-out? ] unit-test
-[ f ] [ V int-regs 0 3 get live-in? ] unit-test
-[ f ] [ V int-regs 1 3 get live-in? ] unit-test
-[ f ] [ V int-regs 2 3 get live-in? ] unit-test
+[ f ] [ 0 3 get live-in? ] unit-test
+[ f ] [ 1 3 get live-in? ] unit-test
+[ f ] [ 2 3 get live-in? ] unit-test
-[ t ] [ V int-regs 0 3 get live-out? ] unit-test
-[ t ] [ V int-regs 1 3 get live-out? ] unit-test
-[ t ] [ V int-regs 2 3 get live-out? ] unit-test
+[ t ] [ 0 3 get live-out? ] unit-test
+[ t ] [ 1 3 get live-out? ] unit-test
+[ t ] [ 2 3 get live-out? ] unit-test
-[ t ] [ V int-regs 0 4 get live-in? ] unit-test
-[ f ] [ V int-regs 1 4 get live-in? ] unit-test
-[ t ] [ V int-regs 2 4 get live-in? ] unit-test
+[ t ] [ 0 4 get live-in? ] unit-test
+[ f ] [ 1 4 get live-in? ] unit-test
+[ t ] [ 2 4 get live-in? ] unit-test
-[ f ] [ V int-regs 0 4 get live-out? ] unit-test
-[ f ] [ V int-regs 1 4 get live-out? ] unit-test
-[ t ] [ V int-regs 2 4 get live-out? ] unit-test
+[ f ] [ 0 4 get live-out? ] unit-test
+[ f ] [ 1 4 get live-out? ] unit-test
+[ t ] [ 2 4 get live-out? ] unit-test
-[ f ] [ V int-regs 0 5 get live-in? ] unit-test
-[ f ] [ V int-regs 1 5 get live-in? ] unit-test
-[ t ] [ V int-regs 2 5 get live-in? ] unit-test
+[ f ] [ 0 5 get live-in? ] unit-test
+[ f ] [ 1 5 get live-in? ] unit-test
+[ t ] [ 2 5 get live-in? ] unit-test
-[ f ] [ V int-regs 0 5 get live-out? ] unit-test
-[ f ] [ V int-regs 1 5 get live-out? ] unit-test
-[ t ] [ V int-regs 2 5 get live-out? ] unit-test
+[ f ] [ 0 5 get live-out? ] unit-test
+[ f ] [ 1 5 get live-out? ] unit-test
+[ t ] [ 2 5 get live-out? ] unit-test
-[ f ] [ V int-regs 0 6 get live-in? ] unit-test
-[ f ] [ V int-regs 1 6 get live-in? ] unit-test
-[ t ] [ V int-regs 2 6 get live-in? ] unit-test
+[ f ] [ 0 6 get live-in? ] unit-test
+[ f ] [ 1 6 get live-in? ] unit-test
+[ t ] [ 2 6 get live-in? ] unit-test
-[ f ] [ V int-regs 0 6 get live-out? ] unit-test
-[ f ] [ V int-regs 1 6 get live-out? ] unit-test
-[ t ] [ V int-regs 2 6 get live-out? ] unit-test
+[ f ] [ 0 6 get live-out? ] unit-test
+[ f ] [ 1 6 get live-out? ] unit-test
+[ t ] [ 2 6 get live-out? ] unit-test
-[ f ] [ V int-regs 0 7 get live-in? ] unit-test
-[ f ] [ V int-regs 1 7 get live-in? ] unit-test
-[ f ] [ V int-regs 2 7 get live-in? ] unit-test
+[ f ] [ 0 7 get live-in? ] unit-test
+[ f ] [ 1 7 get live-in? ] unit-test
+[ f ] [ 2 7 get live-in? ] unit-test
-[ f ] [ V int-regs 0 7 get live-out? ] unit-test
-[ f ] [ V int-regs 1 7 get live-out? ] unit-test
-[ f ] [ V int-regs 2 7 get live-out? ] unit-test
+[ f ] [ 0 7 get live-out? ] unit-test
+[ f ] [ 1 7 get live-out? ] unit-test
+[ f ] [ 2 7 get live-out? ] unit-test
-[ f ] [ V int-regs 0 8 get live-in? ] unit-test
-[ t ] [ V int-regs 1 8 get live-in? ] unit-test
-[ t ] [ V int-regs 2 8 get live-in? ] unit-test
+[ f ] [ 0 8 get live-in? ] unit-test
+[ t ] [ 1 8 get live-in? ] unit-test
+[ t ] [ 2 8 get live-in? ] unit-test
-[ f ] [ V int-regs 0 8 get live-out? ] unit-test
-[ t ] [ V int-regs 1 8 get live-out? ] unit-test
-[ t ] [ V int-regs 2 8 get live-out? ] unit-test
+[ f ] [ 0 8 get live-out? ] unit-test
+[ t ] [ 1 8 get live-out? ] unit-test
+[ t ] [ 2 8 get live-out? ] unit-test
-[ f ] [ V int-regs 0 9 get live-in? ] unit-test
-[ t ] [ V int-regs 1 9 get live-in? ] unit-test
-[ t ] [ V int-regs 2 9 get live-in? ] unit-test
+[ f ] [ 0 9 get live-in? ] unit-test
+[ t ] [ 1 9 get live-in? ] unit-test
+[ t ] [ 2 9 get live-in? ] unit-test
-[ f ] [ V int-regs 0 9 get live-out? ] unit-test
-[ t ] [ V int-regs 1 9 get live-out? ] unit-test
-[ t ] [ V int-regs 2 9 get live-out? ] unit-test
+[ f ] [ 0 9 get live-out? ] unit-test
+[ t ] [ 1 9 get live-out? ] unit-test
+[ t ] [ 2 9 get live-out? ] unit-test
-[ f ] [ V int-regs 0 10 get live-in? ] unit-test
-[ t ] [ V int-regs 1 10 get live-in? ] unit-test
-[ t ] [ V int-regs 2 10 get live-in? ] unit-test
+[ f ] [ 0 10 get live-in? ] unit-test
+[ t ] [ 1 10 get live-in? ] unit-test
+[ t ] [ 2 10 get live-in? ] unit-test
-[ f ] [ V int-regs 0 10 get live-out? ] unit-test
-[ t ] [ V int-regs 1 10 get live-out? ] unit-test
-[ t ] [ V int-regs 2 10 get live-out? ] unit-test
+[ f ] [ 0 10 get live-out? ] unit-test
+[ t ] [ 1 10 get live-out? ] unit-test
+[ t ] [ 2 10 get live-out? ] unit-test
-[ f ] [ V int-regs 0 11 get live-in? ] unit-test
-[ f ] [ V int-regs 1 11 get live-in? ] unit-test
-[ f ] [ V int-regs 2 11 get live-in? ] unit-test
+[ f ] [ 0 11 get live-in? ] unit-test
+[ f ] [ 1 11 get live-in? ] unit-test
+[ f ] [ 2 11 get live-in? ] unit-test
-[ f ] [ V int-regs 0 11 get live-out? ] unit-test
-[ f ] [ V int-regs 1 11 get live-out? ] unit-test
-[ f ] [ V int-regs 2 11 get live-out? ] unit-test
+[ f ] [ 0 11 get live-out? ] unit-test
+[ f ] [ 1 11 get live-out? ] unit-test
+[ f ] [ 2 11 get live-out? ] unit-test
! Targets of back edges
SYMBOL: back-edge-targets
-! hashtable of nodes => sets of vregs, where the vregs are inputs
-! to phi nodes in a successor node
-SYMBOL: phi-outs
-
: T_q ( q -- T_q )
T_q-sets get at ;
: back-edge-target? ( block -- ? )
back-edge-targets get key? ;
-: phi-out? ( vreg node -- ? )
- phi-outs get at key? ;
-
: next-R_q ( q -- R_q )
[ ] [ successors>> ] [ number>> ] tri
'[ number>> _ >= ] filter
[ back-edge-targets get conjoin ] [ drop ] if
] each ;
-: set-phi-out ( block vreg -- )
- swap phi-outs get [ drop H{ } clone ] cache conjoin ;
-
-: set-phi-outs ( q -- )
- instructions>> [
- dup ##phi? [
- inputs>> [ set-phi-out ] assoc-each
- ] [ drop ] if
- ] each ;
-
: init-R_q ( -- )
H{ } clone R_q-sets set
- H{ } clone back-edge-targets set
- H{ } clone phi-outs set ;
+ H{ } clone back-edge-targets set ;
: compute-R_q ( cfg -- )
init-R_q
post-order [
- [ set-R_q ]
- [ set-back-edges ]
- [ set-phi-outs ] tri
+ [ set-R_q ] [ set-back-edges ] bi
] each ;
! This algorithm for computing T_q uses equation (1)
PRIVATE>
: precompute-liveness ( cfg -- )
- ! Maybe dominance and def-use should be called before this, separately
- {
- [ compute-dominance ]
- [ compute-def-use ]
- [ compute-R_q ]
- [ compute-T_q ]
- } cleave ;
+ [ compute-R_q ] [ compute-T_q ] bi ;
<PRIVATE
[let | def [ vreg def-of ] |
{
{ [ node def eq? ] [ vreg uses-of def only? not ] }
- { [ vreg node phi-out? ] [ t ] }
{ [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
[ f ]
} cond
{ return integer }
{ total-size integer }
{ gc-root-size integer }
-spill-counts ;
+{ spill-area-size integer } ;
! Stack frame utilities
: param-base ( -- n )
stack-frame get [ params>> ] [ return>> ] bi + ;
-: spill-float-offset ( n -- offset )
- double-float-regs reg-size * ;
-
-: spill-integer-base ( -- n )
- stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
+: spill-offset ( n -- offset )
param-base + ;
-: spill-integer-offset ( n -- offset )
- cells spill-integer-base + ;
-
-: spill-area-size ( stack-frame -- n )
- spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
-
: gc-root-base ( -- n )
- stack-frame get spill-area-size
- param-base + ;
+ stack-frame get spill-area-size>> param-base + ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
-: gc-roots-size ( live-values -- n )
- keys [ reg-class>> reg-size ] sigma ;
-
: (stack-frame-size) ( stack-frame -- n )
[
{
- [ spill-area-size ]
- [ gc-root-size>> ]
[ params>> ]
[ return>> ]
+ [ gc-root-size>> ]
+ [ spill-area-size>> ]
} cleave
] sum-outputs ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel fry accessors sequences make math
+USING: namespaces assocs kernel fry accessors sequences make math locals
combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
-compiler.cfg.stacks.global compiler.cfg.stacks.height ;
+compiler.cfg.stacks.global compiler.cfg.stacks.height
+compiler.cfg.predecessors ;
IN: compiler.cfg.stacks.finalize
! This pass inserts peeks and replaces.
-: inserting-peeks ( from to -- assoc )
- peek-in swap [ peek-out ] [ avail-out ] bi
- assoc-union assoc-diff ;
-
-: inserting-replaces ( from to -- assoc )
- [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
- assoc-union assoc-diff ;
+:: inserting-peeks ( from to -- assoc )
+ ! A peek is inserted on an edge if the destination anticipates
+ ! the stack location, the source does not anticipate it and
+ ! it is not available from the source in a register.
+ to anticip-in
+ from anticip-out from avail-out assoc-union
+ assoc-diff ;
+
+:: inserting-replaces ( from to -- assoc )
+ ! A replace is inserted on an edge if two conditions hold:
+ ! - the location is not dead at the destination, OR
+ ! the location is live at the destination but not available
+ ! at the destination
+ ! - the location is pending in the source but not the destination
+ from pending-out to pending-in assoc-diff
+ to dead-in to live-in to anticip-in assoc-diff assoc-diff
+ assoc-diff ;
: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
! If both blocks are subroutine calls, don't bother
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
- 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
+ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty
] if ;
[ predecessors>> ] keep '[ _ visit-edge ] each ;
: finalize-stack-shuffling ( cfg -- cfg' )
+ needs-predecessors
+
dup [ visit-block ] each-basic-block
+
cfg-changed ;
\ No newline at end of file
compiler.cfg.stacks.local ;
IN: compiler.cfg.stacks.global
-! Peek analysis. Peek-in is the set of all locations anticipated at
-! the start of a basic block.
-BACKWARD-ANALYSIS: peek
+: transfer-peeked-locs ( assoc bb -- assoc' )
+ [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ;
-M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
+! A stack location is anticipated at a location if every path from
+! the location to an exit block will read the stack location
+! before writing it.
+BACKWARD-ANALYSIS: anticip
-! Replace analysis. Replace-in is the set of all locations which
-! will be overwritten at some point after the start of a basic block.
-FORWARD-ANALYSIS: replace
+M: anticip-analysis transfer-set drop transfer-peeked-locs ;
-M: replace-analysis transfer-set drop replace-set assoc-union ;
+! A stack location is live at a location if some path from
+! the location to an exit block will read the stack location
+! before writing it.
+BACKWARD-ANALYSIS: live
-! Availability analysis. Avail-out is the set of all locations
-! in registers at the end of a basic block.
+M: live-analysis transfer-set drop transfer-peeked-locs ;
+
+M: live-analysis join-sets 2drop assoc-combine ;
+
+! A stack location is available at a location if all paths from
+! the entry block to the location load the location into a
+! register.
FORWARD-ANALYSIS: avail
-M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
+M: avail-analysis transfer-set
+ drop [ peek-set assoc-union ] [ replace-set assoc-union ] bi ;
+
+! A stack location is pending at a location if all paths from
+! the entry block to the location write the location.
+FORWARD-ANALYSIS: pending
+
+M: pending-analysis transfer-set
+ drop replace-set assoc-union ;
-! Kill analysis. Kill-in is the set of all locations
-! which are going to be overwritten.
-BACKWARD-ANALYSIS: kill
+! A stack location is dead at a location if no paths from the
+! location to the exit block read the location before writing it.
+BACKWARD-ANALYSIS: dead
-M: kill-analysis transfer-set drop kill-set assoc-union ;
+M: dead-analysis transfer-set
+ drop
+ [ kill-set assoc-union ]
+ [ replace-set assoc-union ] bi ;
! Main word
: compute-global-sets ( cfg -- cfg' )
{
- [ compute-peek-sets ]
- [ compute-replace-sets ]
+ [ compute-anticip-sets ]
+ [ compute-live-sets ]
+ [ compute-pending-sets ]
+ [ compute-dead-sets ]
[ compute-avail-sets ]
- [ compute-kill-sets ]
[ ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
compiler.cfg.parallel-copy ;
IN: compiler.cfg.stacks.local
-! Local stack analysis. We build local peek and replace sets for every basic
-! block while constructing the CFG.
+! Local stack analysis. We build three sets for every basic block
+! in the CFG:
+! - peek-set: all stack locations that the block reads before writing
+! - replace-set: all stack locations that the block writes
+! - kill-set: all stack locations which become unavailable after the
+! block ends because of the stack height being decremented
+! This is done while constructing the CFG.
SYMBOLS: peek-sets replace-sets kill-sets ;
SYMBOL: locs>vregs
-: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
TUPLE: current-height
: compute-local-kill-set ( -- assoc )
basic-block get current-height get
[ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
- [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ]
- [ drop local-replace-set get at ] 2tri
- [ append unique dup ] dip update ;
+ [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
+ append unique ;
: begin-local-analysis ( -- )
H{ } clone local-peek-set set
: end-stack-analysis ( -- )
cfg get
- compute-predecessors
compute-global-sets
finalize-stack-shuffling
drop ;
-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
- compute-predecessors
compute-uninitialized-sets ;
V{
} 0 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##replace f V int-regs 0 D 2 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 0 D 1 }
+ T{ ##replace f 0 D 2 }
T{ ##inc-r f 1 }
} 1 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##inc-d f 1 }
} 2 test-bb
: finish ( -- pair ) ds-loc get rs-loc get 2array ;
: (join-sets) ( seq1 seq2 -- seq )
- 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ;
+ 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
: (uninitialized-locs) ( seq quot -- seq' )
[ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
drop [ prepare ] dip visit-block finish ;
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-in dup [
[ [ <ds-loc> ] (uninitialized-locs) ]
[ [ <rs-loc> ] (uninitialized-locs) ]
bi* append
- ] when ;
\ No newline at end of file
+ ] when ;
compiler.cfg.utilities ;
IN: compiler.cfg.tco
-! Tail call optimization. You must run compute-predecessors after this
+! Tail call optimization.
: return? ( bb -- ? )
skip-empty-blocks
] [ drop ] if ;
: optimize-tail-calls ( cfg -- cfg' )
- dup cfg set
dup [ optimize-tail-call ] each-basic-block
- cfg-changed ;
\ No newline at end of file
+
+ cfg-changed predecessors-changed ;
\ No newline at end of file
-IN: compiler.cfg.two-operand.tests
-USING: compiler.cfg.two-operand compiler.cfg.instructions
+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
[
V{
- T{ ##copy f V int-regs 1 V int-regs 2 }
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 3 }
+ T{ ##copy f 1 2 int-rep }
+ T{ ##sub f 1 1 3 }
}
] [
+ H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+ } clone representations set
{
- T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 }
+ T{ ##sub f 1 2 3 }
} (convert-two-operand)
] unit-test
[
V{
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
+ T{ ##copy f 1 2 double-float-rep }
+ T{ ##sub-float f 1 1 3 }
}
] [
+ H{
+ { 1 double-float-rep }
+ { 2 double-float-rep }
+ { 3 double-float-rep }
+ } clone representations set
{
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
+ T{ ##sub-float f 1 2 3 }
} (convert-two-operand)
] unit-test
[
V{
- T{ ##copy f V int-regs 4 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 2 }
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 4 }
+ T{ ##copy f 1 2 double-float-rep }
+ T{ ##mul-float f 1 1 1 }
}
] [
+ H{
+ { 1 double-float-rep }
+ { 2 double-float-rep }
+ } clone representations set
{
- T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
+ T{ ##mul-float f 1 2 2 }
} (convert-two-operand)
] unit-test
compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
-! This pass runs after SSA coalescing and normalizes instructions
-! to fit the x86 two-address scheme. Possibilities are:
-
-! 1) x = x op y
-! 2) x = y op x
-! 3) x = y op z
-
-! In case 1, there is nothing to do.
-
-! In case 2, we convert to
-! z = y
-! z = z op x
-! x = z
-
-! In case 3, we convert to
+! This pass runs before SSA coalescing and normalizes instructions
+! to fit the x86 two-address scheme. Since the input is in SSA,
+! it suffices to convert
+!
+! x = y op z
+!
+! to
+!
! x = y
! x = x op z
-
-! In case 2 and case 3, linear scan coalescing will eliminate a
-! copy if the value y is never used again.
-
+!
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! since x86 has LEA and IMUL instructions which are effectively
! three-operand addition and multiplication, respectively.
GENERIC: convert-two-operand* ( insn -- )
: emit-copy ( dst src -- )
- dup reg-class>> {
- { int-regs [ ##copy ] }
- { double-float-regs [ ##copy-float ] }
- } case ; inline
-
-: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline
-
-: case-1 ( insn -- ) , ; inline
-
-: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline
-
-: case-2 ( insn -- )
- dup dst>> reg-class>> next-vreg
- [ swap src2>> emit-copy ]
- [ drop [ src2>> ] [ src1>> ] bi emit-copy ]
- [ >>src2 dup dst>> >>src1 , ]
- 2tri ; inline
-
-: case-3 ( insn -- )
- [ [ dst>> ] [ src1>> ] bi emit-copy ]
- [ dup dst>> >>src1 , ]
- bi ; inline
+ dup rep-of ##copy ; inline
M: two-operand-insn convert-two-operand*
- {
- { [ dup case-1? ] [ case-1 ] }
- { [ dup case-2? ] [ case-2 ] }
- [ case-3 ]
- } cond ; inline
+ [ [ dst>> ] [ src1>> ] bi emit-copy ]
+ [
+ dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when
+ dup dst>> >>src1 ,
+ ] bi ;
M: ##not convert-two-operand*
- dup [ dst>> ] [ src>> ] bi = [
- [ [ dst>> ] [ src>> ] bi ##copy ]
- [ dup dst>> >>src ]
- bi
- ] unless , ;
+ [ [ dst>> ] [ src>> ] bi emit-copy ]
+ [ dup dst>> >>src , ]
+ bi ;
M: insn convert-two-operand* , ;
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block
- cfg-changed ;
+
+ cfg-changed predecessors-changed ;
[ instructions>> ] dip
'[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
+: each-non-phi ( bb quot: ( insn -- ) -- )
+ [ instructions>> ] dip
+ '[ dup ##phi? [ drop ] _ if ] each ; inline
+
: predecessor ( bb -- pred )
predecessors>> first ; inline
fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise math.order classes vectors
compiler.cfg
-compiler.cfg.hats
+compiler.cfg.registers
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.value-numbering.expressions
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
- i \ ##compare-imm new-insn ;
+ next-vreg \ ##compare-imm new-insn ;
: rewrite-redundant-comparison? ( insn -- ? )
{
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
- { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
+ { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] }
+ { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+ { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
] dip
swap-compare
[ vreg>constant ] dip
- i \ ##compare-imm new-insn ; inline
+ next-vreg \ ##compare-imm new-insn ; inline
: >boolean-insn ( insn ? -- insn' )
[ dst>> ] dip
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
-: simplify-unbox ( in boxer -- vn/expr/f )
- over op>> eq? [ in>> ] [ drop f ] if ; inline
-
-: simplify-unbox-float ( in -- vn/expr/f )
- \ ##box-float simplify-unbox ; inline
-
: simplify-unbox-alien ( in -- vn/expr/f )
- \ ##box-alien simplify-unbox ; inline
+ dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
M: unary-expr simplify*
#! Note the copy propagation: a copy always simplifies to
#! its source VN.
[ in>> vn>expr ] [ op>> ] bi {
{ \ ##copy [ ] }
- { \ ##copy-float [ ] }
- { \ ##unbox-float [ simplify-unbox-float ] }
{ \ ##unbox-alien [ simplify-unbox-alien ] }
{ \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
[ 2drop f ]
-IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
cpu.architecture tools.test kernel math combinators.short-circuit
-accessors sequences compiler.cfg.predecessors locals
-compiler.cfg.dce compiler.cfg.ssa.destruction
-compiler.cfg assocs vectors arrays layouts namespaces ;
+accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
+compiler.cfg.ssa.destruction compiler.cfg.loop-detection
+compiler.cfg.representations compiler.cfg assocs vectors arrays
+layouts namespaces ;
+IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns )
[
! Folding constants together
[
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##load-reference f V int-regs 1 -0.0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##load-reference f V int-regs 1 -0.0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##copy f V int-regs 1 V int-regs 0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##load-reference f V int-regs 1 0.0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 0.0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-reference f V int-regs 0 t }
- T{ ##copy f V int-regs 1 V int-regs 0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 t }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f V int-regs 0 t }
- T{ ##load-reference f V int-regs 1 t }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 t }
+ T{ ##load-reference f 1 t }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
} value-numbering-step
] unit-test
! Compare propagation
[
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##copy f V int-regs 6 V int-regs 4 }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc> }
+ T{ ##copy f 6 4 any-rep }
+ T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc> }
+ T{ ##compare-imm f 6 4 5 cc/= }
+ T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
- T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc<= }
+ T{ ##compare f 6 2 1 cc> }
+ T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc<= }
+ T{ ##compare-imm f 6 4 5 cc= }
+ T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 8 D 0 }
- T{ ##peek f V int-regs 9 D -1 }
- T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
- T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
- T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
- T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
- T{ ##replace f V int-regs 14 D 0 }
+ T{ ##peek f 8 D 0 }
+ T{ ##peek f 9 D -1 }
+ T{ ##unbox-float f 10 8 }
+ T{ ##unbox-float f 11 9 }
+ T{ ##compare-float f 12 10 11 cc< }
+ T{ ##compare-float f 14 10 11 cc>= }
+ T{ ##replace f 14 D 0 }
}
] [
{
- T{ ##peek f V int-regs 8 D 0 }
- T{ ##peek f V int-regs 9 D -1 }
- T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
- T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
- T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
- T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
- T{ ##replace f V int-regs 14 D 0 }
+ T{ ##peek f 8 D 0 }
+ T{ ##peek f 9 D -1 }
+ T{ ##unbox-float f 10 8 }
+ T{ ##unbox-float f 11 9 }
+ T{ ##compare-float f 12 10 11 cc< }
+ T{ ##compare-imm f 14 12 5 cc= }
+ T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 29 D -1 }
- T{ ##peek f V int-regs 30 D -2 }
- T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
- T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare f 33 29 30 cc<= }
+ T{ ##compare-branch f 29 30 cc<= }
}
] [
{
- T{ ##peek f V int-regs 29 D -1 }
- T{ ##peek f V int-regs 30 D -2 }
- T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
- T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare f 33 29 30 cc<= }
+ T{ ##compare-imm-branch f 33 5 cc/= }
} value-numbering-step trim-temps
] unit-test
! Immediate operand conversion
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 -100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##sub f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##sub f 1 0 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 3 }
}
] [
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+ T{ ##peek f 1 D 0 }
+ T{ ##mul-imm f 2 1 8 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm f 2 0 100 cc<= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare f 2 0 1 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm f 2 0 100 cc>= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare f 2 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm-branch f V int-regs 0 100 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm-branch f 0 100 cc<= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-branch f 0 1 cc<= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm-branch f V int-regs 0 100 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm-branch f 0 100 cc>= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-branch f 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
! Reassociation
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 150 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 150 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 50 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 50 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##sub f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 -150 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 -100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 -150 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##sub f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##sub f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and-imm f 4 0 32 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and-imm f 4 0 32 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or-imm f 4 0 118 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or-imm f 4 0 118 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor f 4 3 2 }
} value-numbering-step
] unit-test
! Simplification
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##add f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##sub f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##or f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##xor f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##copy f V int-regs 2 V int-regs 0 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##mul f 2 0 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
! Constant folding
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 4 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 4 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##add f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 -2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 -2 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##sub f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 6 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 6 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##mul f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##load-immediate f V int-regs 3 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##load-immediate f 3 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##and f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##load-immediate f V int-regs 3 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##load-immediate f 3 3 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##or f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 1 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##xor f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 3 8 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 3 8 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##shl-imm f 3 1 3 }
} value-numbering-step
] unit-test
cell 8 = [
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -1 }
- T{ ##load-immediate f V int-regs 3 HEX: ffffffffffff }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##load-immediate f 3 HEX: ffffffffffff }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -1 }
- T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##shr-imm f 3 1 16 }
} value-numbering-step
] unit-test
] when
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -8 }
- T{ ##load-immediate f V int-regs 3 -4 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -8 }
+ T{ ##load-immediate f 3 -4 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -8 }
- T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -8 }
+ T{ ##sar-imm f 3 1 1 }
} value-numbering-step
] unit-test
cell 8 = [
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 65536 }
- T{ ##load-immediate f V int-regs 2 140737488355328 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 65536 }
+ T{ ##load-immediate f 2 140737488355328 }
+ T{ ##add f 3 0 2 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 65536 }
- T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 65536 }
+ T{ ##shl-imm f 2 1 31 }
+ T{ ##add f 3 0 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 140737488355328 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 140737488355328 }
+ T{ ##add f 3 0 2 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 140737488355328 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 140737488355328 }
+ T{ ##add f 3 0 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 2147483647 }
- T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 }
- T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 2147483647 }
+ T{ ##add-imm f 3 0 2147483647 }
+ T{ ##add-imm f 4 3 2147483647 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 2147483647 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 2147483647 }
+ T{ ##add f 3 0 2 }
+ T{ ##add f 4 3 2 }
} value-numbering-step
] unit-test
] when
! Branch folding
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-immediate f V int-regs 3 5 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-immediate f 3 5 }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 1 2 cc= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-reference f V int-regs 3 t }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 1 2 cc/= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-reference f V int-regs 3 t }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 1 2 cc< }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-immediate f V int-regs 3 5 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-immediate f 3 5 }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 2 1 cc< }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 5 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 5 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc< }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc<= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 5 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 5 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc> }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc>= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 5 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 5 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc/= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 1 2 cc= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 1 2 cc/= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 1 2 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 2 1 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
1
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc<= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
1
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc> }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc>= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
1
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc/= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
- T{ ##compare-imm-branch f V int-regs 1 5 cc/= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc<= }
+ T{ ##compare-imm-branch f 1 5 cc/= }
} test-branch-folding
] unit-test
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc< }
} 1 test-bb
V{
- T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f 1 1 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
+ T{ ##replace f 3 D 0 }
T{ ##return }
} 4 test-bb
test-diamond
[ ] [
- cfg new 0 get >>entry
+ cfg new 0 get >>entry dup cfg set
value-numbering
- compute-predecessors
+ select-representations
destruct-ssa drop
] unit-test
[ 2 ] [ 4 get instructions>> length ] unit-test
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-branch f 1 1 cc< }
} 1 test-bb
V{
- T{ ##copy f V int-regs 2 V int-regs 0 }
+ T{ ##copy f 2 0 any-rep }
T{ ##branch }
} 2 test-bb
V{
- T{ ##phi f V int-regs 3 V{ } }
+ T{ ##phi f 3 V{ } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##replace f 3 D 0 }
T{ ##return }
} 4 test-bb
-1 get V int-regs 1 2array
-2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+1 get 1 2array
+2 get 0 2array 2array 3 get instructions>> first (>>inputs)
test-diamond
[ ] [
cfg new 0 get >>entry
- compute-predecessors
value-numbering
- compute-predecessors
eliminate-dead-code
drop
] unit-test
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
- T{ ##peek { dst V int-regs 15 } { loc D 0 } }
- T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } }
+ T{ ##peek { dst 15 } { loc D 0 } }
+ T{ ##copy { dst 16 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 17 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 18 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 19 } { src 15 } { rep any-rep } }
T{ ##compare
- { dst V int-regs 20 }
- { src1 V int-regs 18 }
- { src2 V int-regs 19 }
+ { dst 20 }
+ { src1 18 }
+ { src2 19 }
{ cc cc= }
- { temp V int-regs 22 }
+ { temp 22 }
}
- T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } }
+ T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
T{ ##compare-imm-branch
- { src1 V int-regs 21 }
+ { src1 21 }
{ src2 5 }
{ cc cc/= }
}
} 1 test-bb
V{
- T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } }
- T{ ##load-reference { dst V int-regs 25 } { obj t } }
+ T{ ##copy { dst 23 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 24 } { src 15 } { rep any-rep } }
+ T{ ##load-reference { dst 25 } { obj t } }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace { src V int-regs 25 } { loc D 0 } }
+ T{ ##replace { src 25 } { loc D 0 } }
T{ ##epilogue }
T{ ##return }
} 3 test-bb
V{
- T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } }
+ T{ ##copy { dst 26 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 27 } { src 15 } { rep any-rep } }
T{ ##add
- { dst V int-regs 28 }
- { src1 V int-regs 26 }
- { src2 V int-regs 27 }
+ { dst 28 }
+ { src1 26 }
+ { src2 27 }
}
T{ ##branch }
} 4 test-bb
V{
- T{ ##replace { src V int-regs 28 } { loc D 0 } }
+ T{ ##replace { src 28 } { loc D 0 } }
T{ ##epilogue }
T{ ##return }
} 5 test-bb
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors
sorting sets sequences
+cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
-! Local value numbering. Predecessors must be recomputed after this
+! Local value numbering.
+
: >copy ( insn -- insn/##copy )
dup dst>> dup vreg>vn vn>vreg
- 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
+ 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
: rewrite-loop ( insn -- insn' )
dup rewrite [ rewrite-loop ] [ ] ?if ;
[ process-instruction ] map ;
: value-numbering ( cfg -- cfg' )
- [ value-numbering-step ] local-optimization cfg-changed ;
+ [ value-numbering-step ] local-optimization
+
+ cfg-changed predecessors-changed ;
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test vectors compiler.cfg kernel accessors
-compiler.cfg.utilities ;
+compiler.cfg.utilities namespaces sequences ;
IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns )
[
V{
- T{ ##peek f V int-regs 4 D 0 f }
- T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
- T{ ##load-immediate f V int-regs 9 8 f }
- T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
- T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f }
- T{ ##replace f V int-regs 7 D 0 f }
+ T{ ##peek f 4 D 0 f }
+ T{ ##allot f 7 24 array 8 f }
+ T{ ##load-immediate f 9 8 f }
+ T{ ##set-slot-imm f 9 7 1 3 f }
+ T{ ##set-slot-imm f 4 7 2 3 f }
+ T{ ##replace f 7 D 0 f }
T{ ##branch }
}
] [
{
- T{ ##peek f V int-regs 4 D 0 }
- T{ ##allot f V int-regs 7 24 array V int-regs 8 }
- T{ ##load-immediate f V int-regs 9 8 }
- T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
- T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
- T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 }
- T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
- T{ ##replace f V int-regs 7 D 0 }
+ T{ ##peek f 4 D 0 }
+ T{ ##allot f 7 24 array 8 }
+ T{ ##load-immediate f 9 8 }
+ T{ ##set-slot-imm f 9 7 1 3 }
+ T{ ##write-barrier f 7 10 11 }
+ T{ ##set-slot-imm f 4 7 2 3 }
+ T{ ##write-barrier f 7 12 13 }
+ T{ ##replace f 7 D 0 }
} test-write-barrier
] unit-test
[
V{
- T{ ##load-immediate f V int-regs 4 24 }
- T{ ##peek f V int-regs 5 D -1 }
- T{ ##peek f V int-regs 6 D -2 }
- T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
- T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ T{ ##load-immediate f 4 24 }
+ T{ ##peek f 5 D -1 }
+ T{ ##peek f 6 D -2 }
+ T{ ##set-slot-imm f 5 6 3 2 }
+ T{ ##write-barrier f 6 7 8 }
T{ ##branch }
}
] [
{
- T{ ##load-immediate f V int-regs 4 24 }
- T{ ##peek f V int-regs 5 D -1 }
- T{ ##peek f V int-regs 6 D -2 }
- T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
- T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ T{ ##load-immediate f 4 24 }
+ T{ ##peek f 5 D -1 }
+ T{ ##peek f 6 D -2 }
+ T{ ##set-slot-imm f 5 6 3 2 }
+ T{ ##write-barrier f 6 7 8 }
} test-write-barrier
] unit-test
[
V{
- T{ ##peek f V int-regs 19 D -3 }
- T{ ##peek f V int-regs 22 D -2 }
- T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
- T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
- T{ ##peek f V int-regs 28 D -1 }
- T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
+ T{ ##peek f 19 D -3 }
+ T{ ##peek f 22 D -2 }
+ T{ ##set-slot-imm f 22 19 3 2 }
+ T{ ##write-barrier f 19 24 25 }
+ T{ ##peek f 28 D -1 }
+ T{ ##set-slot-imm f 28 19 4 2 }
T{ ##branch }
}
] [
{
- T{ ##peek f V int-regs 19 D -3 }
- T{ ##peek f V int-regs 22 D -2 }
- T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
- T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
- T{ ##peek f V int-regs 28 D -1 }
- T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
- T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
+ T{ ##peek f 19 D -3 }
+ T{ ##peek f 22 D -2 }
+ T{ ##set-slot-imm f 22 19 3 2 }
+ T{ ##write-barrier f 19 24 25 }
+ T{ ##peek f 28 D -1 }
+ T{ ##set-slot-imm f 28 19 4 2 }
+ T{ ##write-barrier f 19 30 3 }
} test-write-barrier
] 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{ ##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
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.dataflow-analysis fry combinators.short-circuit ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
M: insn eliminate-write-barrier drop t ;
+FORWARD-ANALYSIS: safe
+
+: has-allocation? ( bb -- ? )
+ instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
+
+M: safe-analysis transfer-set
+ drop [ H{ } assoc-clone-like ] dip
+ instructions>> over '[
+ dup ##write-barrier? [
+ src>> _ conjoin
+ ] [ drop ] if
+ ] each ;
+
+M: safe-analysis join-sets
+ drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
+
: 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 ;
: eliminate-write-barriers ( cfg -- cfg' )
+ dup compute-safe-sets
dup [ write-barriers-step ] each-basic-block ;
-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
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
-M: ##copy generate-insn dst/src %copy ;
-M: ##copy-float generate-insn dst/src %copy-float ;
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
+M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
+
+M: ##unbox-float generate-insn dst/src %unbox-float ;
+M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
+M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp operand n>> %reload-integer
+ temp operand n>> int-rep %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
+: save-data-regs ( data-regs -- ) [ first3 %spill ] each ;
+
GENERIC# load-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
- temp operand n>> %spill-integer ;
+ temp operand n>> int-rep %spill ;
M: object load-gc-root drop %load-gc-root ;
: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
+: load-data-regs ( data-regs -- ) [ first3 %reload ] each ;
+
M: _gc generate-insn
"no-gc" define-label
{
[ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ]
[ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
- [ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ]
- [ gc-root-count>> %call-gc ]
- [ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ]
+ [ data-values>> save-data-regs ]
+ [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
+ [ tagged-values>> length %call-gc ]
+ [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
+ [ data-values>> load-data-regs ]
} cleave
"no-gc" resolve-label ;
%alien-global ;
! ##alien-invoke
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
+GENERIC: next-fastcall-param ( reg-class -- )
-GENERIC: inc-reg-class ( register-class -- )
+: ?dummy-stack-params ( rep -- )
+ dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
-: ?dummy-stack-params ( reg-class -- )
- dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
+: ?dummy-int-params ( rep -- )
+ dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-: ?dummy-int-params ( reg-class -- )
- dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-
-: ?dummy-fp-params ( reg-class -- )
+: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs inc ] when ;
-M: int-regs inc-reg-class
- [ reg-class-variable inc ]
- [ ?dummy-stack-params ]
- [ ?dummy-fp-params ]
- tri ;
+M: int-rep next-fastcall-param
+ int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-M: float-regs inc-reg-class
- [ reg-class-variable inc ]
- [ ?dummy-stack-params ]
- [ ?dummy-int-params ]
- tri ;
+M: single-float-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-GENERIC: reg-class-full? ( class -- ? )
+M: double-float-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+GENERIC: reg-class-full? ( reg-class -- ? )
M: stack-params reg-class-full? drop t ;
-M: object reg-class-full?
- [ reg-class-variable get ] [ param-regs length ] bi >= ;
+M: reg-class reg-class-full?
+ [ get ] [ param-regs length ] bi >= ;
-: spill-param ( reg-class -- n reg-class )
+: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
- [ reg-size cell align stack-params +@ ] dip
- stack-params ;
+ [ rep-size cell align stack-params +@ ] dip
+ stack-params dup ;
-: fastcall-param ( reg-class -- n reg-class )
- [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+: alloc-fastcall-param ( rep -- n reg-class rep )
+ [ reg-class-of [ get ] [ inc ] [ ] tri ] keep ;
-: alloc-parameter ( parameter -- reg reg-class )
- c-type-reg-class dup reg-class-full?
- [ spill-param ] [ fastcall-param ] if
- [ param-reg ] keep ;
+: alloc-parameter ( parameter -- reg rep )
+ c-type-rep dup reg-class-of reg-class-full?
+ [ alloc-stack-param ] [ alloc-fastcall-param ] if
+ [ param-reg ] dip ;
: (flatten-int-type) ( size -- seq )
cell /i "void*" c-type <repetition> ;
: reverse-each-parameter ( parameters quot -- )
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
-: reset-freg-counts ( -- )
+: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
- [ reset-freg-counts call ] with-scope ; inline
+ [ reset-fastcall-counts call ] with-scope ; inline
: move-parameters ( node word -- )
#! Moves values from C stack to registers (if word is
alien-parameters [ box-parameter ] each-parameter ;
: registers>objects ( node -- )
+ ! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
"nest_stacks" f %alien-invoke
>binary-branch< %compare-float-branch ;
M: _spill generate-insn
- [ src>> ] [ n>> ] [ class>> ] tri {
- { int-regs [ %spill-integer ] }
- { double-float-regs [ %spill-float ] }
- } case ;
+ [ src>> ] [ n>> ] [ rep>> ] tri %spill ;
M: _reload generate-insn
- [ dst>> ] [ n>> ] [ class>> ] tri {
- { int-regs [ %reload-integer ] }
- { double-float-regs [ %reload-float ] }
- } case ;
-
-M: _copy generate-insn
- [ dst>> ] [ src>> ] [ class>> ] tri {
- { int-regs [ %copy ] }
- { double-float-regs [ %copy-float ] }
- } case ;
-
-M: _spill-counts generate-insn drop ;
+ [ dst>> ] [ n>> ] [ rep>> ] tri %reload ;
+
+M: _spill-area-size generate-insn drop ;
compiler.tree.builder
compiler.tree.optimizer
+compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
compiler.cfg.mr
: backend ( tree word -- )
build-cfg [
- optimize-cfg
- build-mr
+ [ optimize-cfg build-mr ] with-cfg
generate
save-asm
] each ;
: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
- + + 1+
+ + + 1 +
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
ffi_test_48
-] unit-test
\ No newline at end of file
+] unit-test
-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 ) ;
[ ] [ [ ] 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
\ No newline at end of file
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
[ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
[ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
[ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
- [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
\ No newline at end of file
+ [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+
+! Global stack analysis dataflow equations are wrong
+: some-word ( a -- b ) 2 + ;
+: global-dcn-bug-1 ( a b -- c d )
+ dup [ [ drop 1 ] dip ] [ [ some-word ] dip ] if
+ dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
+
+[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
+[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
\ No newline at end of file
-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
-IN: compiler.tests.generic
USING: tools.test math kernel compiler.units definitions ;
+IN: compiler.tests.generic
GENERIC: bad ( -- )
M: integer bad ;
[ 0 bad ] must-fail
[ "" bad ] must-fail
-[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
\ No newline at end of file
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
[ associate >alist modify-code-heap ] keep ;
: compile-test-cfg ( -- word )
- cfg new
- 0 get >>entry
+ cfg new 0 get >>entry
+ dup cfg set
+ dup fake-representations representations get >>reps
compile-cfg ;
: compile-test-bb ( insns -- result )
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##inc-d f 1 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##branch }
} [ clone ] map append 1 test-bb
V{
! loading immediates
[ f ] [
V{
- T{ ##load-immediate f V int-regs 0 5 }
+ T{ ##load-immediate f 0 5 }
} compile-test-bb
] unit-test
[ "hello" ] [
V{
- T{ ##load-reference f V int-regs 0 "hello" }
+ T{ ##load-reference f 0 "hello" }
} compile-test-bb
] unit-test
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##slot f 0 0 1 $[ array tag-number ] 2 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##set-slot f 0 0 1 $[ array tag-number ] 2 }
} compile-test-bb
dup first eq?
] unit-test
[ t ] [
V{
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
} compile-test-bb
dup first eq?
] unit-test
[ 8 ] [
V{
- T{ ##load-immediate f V int-regs 0 4 }
- T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 }
+ T{ ##load-immediate f 0 4 }
+ T{ ##shl f 0 0 0 }
} compile-test-bb
] unit-test
[ 4 ] [
V{
- T{ ##load-immediate f V int-regs 0 4 }
- T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ T{ ##load-immediate f 0 4 }
+ T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ 31 ] [
V{
- T{ ##load-reference f V int-regs 1 B{ 31 67 52 } }
- T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 }
- T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 }
- T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ T{ ##load-reference f 1 B{ 31 67 52 } }
+ T{ ##unbox-any-c-ptr f 0 1 2 }
+ T{ ##alien-unsigned-1 f 0 0 }
+ T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ CHAR: l ] [
V{
- T{ ##load-reference f V int-regs 0 "hello world" }
- T{ ##load-immediate f V int-regs 1 3 }
- T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 }
- T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ T{ ##load-reference f 0 "hello world" }
+ T{ ##load-immediate f 1 3 }
+ T{ ##string-nth f 0 0 1 2 }
+ T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-immediate f V int-regs 0 16 }
- T{ ##add-imm f V int-regs 0 V int-regs 0 -8 }
+ T{ ##load-immediate f 0 16 }
+ T{ ##add-imm f 0 0 -8 }
} compile-test-bb
] unit-test
[ 100 ] [
V{
- T{ ##load-immediate f V int-regs 0 100 }
- T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f 0 100 }
+ T{ ##integer>bignum f 0 0 1 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-reference f V int-regs 0 ALIEN: 8 }
- T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 }
+ T{ ##load-reference f 0 ALIEN: 8 }
+ T{ ##unbox-any-c-ptr f 0 0 1 }
} compile-test-bb
] unit-test
! 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 ;
[ 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 ;
! 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 ;
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+! Interval inference issue
+[ f ] [
+ 10 70
+ [
+ dup 70 >=
+ [ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ]
+ [ 2drop 70 ] if
+ 70 >=
+ ] compile-call
+] unit-test
+
! Modular arithmetic bug
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
\ bad-dispatch-position-test forget
\ bad-dispatch-position-test* forget
] with-compilation-unit
-] unit-test
\ No newline at end of file
+] unit-test
-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> ;
-IN: compiler.tests.pic-problem-1
USING: kernel sequences prettyprint memory tools.test ;
+IN: compiler.tests.pic-problem-1
TUPLE: x ;
CONSTANT: blah T{ x }
-[ T{ x } ] [ blah ] unit-test
\ No newline at end of file
+[ T{ x } ] [ blah ] unit-test
-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 ;
: 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
-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
-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 >>
-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
-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 )
-IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
+IN: compiler.tests.redefine4
: declaration-test-1 ( -- a ) 3 ; flushable
-IN: compiler.tests.reload
USE: vocabs.loader
+IN: compiler.tests.reload
! "parser" reload
! "sequences" reload
-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
-IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
+IN: compiler.tests.tuples
TUPLE: color red green blue ;
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: build-sub-tree
-{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } }
+{ $values { "in-d" "a sequence of values" } { "out-d" "a sequence of values" } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } }
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ;
-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
: build-tree ( word/quot -- nodes )
[ f ] dip build-tree-with ;
-:: build-sub-tree ( #call word/quot -- nodes/f )
+:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
#! We don't want methods on mixins to have a declaration for that mixin.
#! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site.
f specialize-method? [
[
- #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+ in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
{
{ [ dup not ] [ ] }
- { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
- [ in-d #call out-d>> #copy suffix ]
+ { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
+ [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
- ] with-variable ;
-
+ ] with-variable ;
\ No newline at end of file
+++ /dev/null
-IN: compiler.tree.checker.tests
-USING: compiler.tree.checker tools.test ;
-
-
grouping stack-checker.branches
compiler.tree
compiler.tree.def-use
+compiler.tree.recursive
compiler.tree.combinators ;
IN: compiler.tree.checker
-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
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
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
[ 12 swap nth ] keep
14 ndrop
] cleaned-up-tree nodes>quot
-] unit-test
\ No newline at end of file
+] unit-test
GENERIC: delete-node ( node -- )
M: #call-recursive delete-node
- dup label>> [ [ eq? not ] with filter ] change-calls drop ;
+ dup label>> calls>> [ node>> eq? not ] with filter-here ;
M: #return-recursive delete-node
label>> f >>return drop ;
[ ]
} cond ;
-M: #declare cleanup* drop f ;
-
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
_
-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
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 ;
USING: accessors arrays assocs sequences kernel locals fry
combinators stack-checker.backend
compiler.tree
+compiler.tree.recursive
compiler.tree.dead-code.branches
compiler.tree.dead-code.liveness
compiler.tree.dead-code.simple ;
-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.
\ No newline at end of file
+[ <reversed> [ print ] each ] optimizer-report.
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker
+compiler.tree.identities
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
H{ } clone intrinsics-called set
0 swap [
- [ 1+ ] dip
+ [ 1 + ] dip
dup #call? [
word>> {
{ [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
normalize
propagate
cleanup
+ apply-identities
compute-def-use
remove-dead-code
compute-def-use
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
-M: #declare node-uses-values declaration>> keys ;
+M: #declare node-uses-values drop f ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
+! A map from values to classes. Only for #introduce outputs
+SYMBOL: value-classes
+
+: value-class ( value -- class ) value-classes get at ;
+
+: set-value-class ( class value -- ) value-classes get set-at ;
+
! A map from values to one of the following:
! - f -- initial status, assigned to values we have not seen yet;
! may potentially become an allocation later
--- /dev/null
+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? ;
+
+[ t ] [
+ [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+ test-checker
+] unit-test
+
+[ t ] [
+ [ complex boa [ real>> ] [ imaginary>> ] bi ]
+ test-checker
+] unit-test
+
+[ t ] [
+ [ [ complex boa [ real>> ] [ imaginary>> ] bi ] when ]
+ test-checker
+] unit-test
+
+[ f ] [
+ [ swap 1 2 ? ]
+ test-checker
+] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.tuple math math.private accessors
-combinators kernel compiler.tree compiler.tree.combinators
-compiler.tree.propagation.info ;
+USING: classes classes.tuple math math.private accessors sequences
+combinators.short-circuit kernel compiler.tree
+compiler.tree.combinators compiler.tree.propagation.info ;
IN: compiler.tree.escape-analysis.check
GENERIC: run-escape-analysis* ( node -- ? )
+: unbox-inputs? ( nodes -- ? )
+ {
+ [ length 2 >= ]
+ [ first #introduce? ]
+ [ second #declare? ]
+ } 1&& ;
+
+: run-escape-analysis? ( nodes -- ? )
+ { [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ;
+
M: #push run-escape-analysis*
- literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
+ literal>> class immutable-tuple-class? ;
M: #call run-escape-analysis*
- {
- { [ dup immutable-tuple-boa? ] [ t ] }
- [ f ]
- } cond nip ;
+ immutable-tuple-boa? ;
-M: node run-escape-analysis* drop f ;
+M: #recursive run-escape-analysis*
+ child>> run-escape-analysis? ;
-: run-escape-analysis? ( nodes -- ? )
- [ run-escape-analysis* ] contains-node? ;
+M: #branch run-escape-analysis*
+ children>> [ run-escape-analysis? ] any? ;
+
+M: node run-escape-analysis* drop f ;
-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
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
-kernel.private ;
+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?
dup literal>> class immutable-tuple-class?
[ (count-unboxed-allocations) ] [ drop ] if ;
+M: #introduce count-unboxed-allocations*
+ out-d>> [ escaping-allocation? [ 1 + ] unless ] each ;
+
M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
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
[ 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
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
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
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
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
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
TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! New feature!
+
+[ 1 ] [ [ { complex } declare real>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [
+ [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+ count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ { vector } declare length>> ]
+ count-unboxed-allocations
+] unit-test
init-escaping-values
H{ } clone allocations set
H{ } clone slot-accesses set
+ H{ } clone value-classes set
dup (escape-analysis)
compute-escaping-allocations ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences
+USING: kernel sequences fry math namespaces
compiler.tree
compiler.tree.def-use
compiler.tree.escape-analysis.allocations ;
GENERIC: escape-analysis* ( node -- )
+SYMBOL: next-node
+
+: each-with-next ( seq quot: ( elt -- ) -- )
+ dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
+
: (escape-analysis) ( node -- )
[
[ node-defs-values introduce-values ]
[ escape-analysis* ]
bi
- ] each ;
+ ] each-with-next ;
-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
USING: kernel sequences math combinators accessors namespaces
fry disjoint-sets
compiler.tree
+compiler.tree.recursive
compiler.tree.combinators
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.branches
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi
- [ out-d>> escaping-values get '[ _ equate ] 2each ] with each
+ [ node>> out-d>> escaping-values get '[ _ equate ] 2each ] with each
] bi ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences classes.tuple
classes.tuple.private arrays math math.private slots.private
combinators deques search-deques namespaces fry classes
-classes.algebra stack-checker.state
+classes.algebra assocs stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
+M: #declare escape-analysis* drop ;
+
M: #terminate escape-analysis* drop ;
M: #renaming escape-analysis* inputs/outputs copy-values ;
-M: #introduce escape-analysis* out-d>> unknown-allocations ;
+: declared-class ( value -- class/f )
+ next-node get dup #declare? [ declaration>> at ] [ 2drop f ] if ;
+
+: record-param-allocation ( value class -- )
+ dup immutable-tuple-class? [
+ [ swap set-value-class ] [
+ all-slots [
+ [ <slot-value> dup ] [ class>> ] bi*
+ record-param-allocation
+ ] map swap record-allocation
+ ] 2bi
+ ] [ drop unknown-allocation ] if ;
+
+M: #introduce escape-analysis*
+ out-d>> [ dup declared-class record-param-allocation ] each ;
DEFER: record-literal-allocation
: object-slots ( object -- slots/f )
{
{ [ dup class immutable-tuple-class? ] [ tuple-slots ] }
- { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
[ drop f ]
} cond ;
! 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 strings sbufs
+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 ;
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test
[ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test
+
+[ t ] [
+ [ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
+ { >fixnum } inlined?
+] unit-test
-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
+++ /dev/null
-USING: compiler.tree.optimizer tools.test ;
-IN: compiler.tree.optimizer.tests
-
-
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
-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
[ t ] [
null-info 3 <literal-info> value-info<=
] unit-test
+
+[ t t ] [
+ f <literal-info>
+ fixnum 0 40 [a,b] <class/interval-info>
+ value-info-union
+ \ f class-not <class-info>
+ value-info-intersect
+ [ class>> fixnum class= ]
+ [ interval>> 0 40 [a,b] = ] bi
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals
-namespaces sequences words combinators byte-arrays strings
-arrays layouts cpu.architecture compiler.tree.propagation.copy ;
+classes.tuple.private kernel accessors math math.intervals namespaces
+sequences sequences.private words combinators memoize
+combinators.short-circuit byte-arrays strings arrays layouts
+cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
CONSTANT: object-info T{ value-info f object full-interval }
-: class-interval ( class -- interval )
- dup real class<=
- [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
-
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
UNION: fixed-length array byte-array string ;
: init-literal-info ( info -- info )
- [-inf,inf] >>interval
+ empty-interval >>interval
dup literal>> class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
[ drop ]
} cond ; inline
+: empty-set? ( info -- ? )
+ {
+ [ class>> null-class? ]
+ [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
+ } 1|| ;
+
+: min-value ( class -- n )
+ {
+ { fixnum [ most-negative-fixnum ] }
+ { array-capacity [ 0 ] }
+ [ drop -1/0. ]
+ } case ;
+
+: max-value ( class -- n )
+ {
+ { fixnum [ most-positive-fixnum ] }
+ { array-capacity [ max-array-capacity ] }
+ [ drop 1/0. ]
+ } case ;
+
+: class-interval ( class -- i )
+ {
+ { fixnum [ fixnum-interval ] }
+ { array-capacity [ array-capacity-interval ] }
+ [ drop full-interval ]
+ } case ;
+
+: wrap-interval ( interval class -- interval' )
+ {
+ { [ over empty-interval eq? ] [ drop ] }
+ { [ over full-interval eq? ] [ nip class-interval ] }
+ { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
+ [ drop ]
+ } cond ;
+
+: init-interval ( info -- info )
+ dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
+ dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
+
: init-value-info ( info -- info )
dup literal?>> [
init-literal-info
] [
- dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
+ dup empty-set? [
null >>class
empty-interval >>interval
] [
- [ [-inf,inf] or ] change-interval
- dup class>> integer class<= [ [ integral-closure ] change-interval ] when
+ init-interval
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if
init-value-info ; foldable
: <class-info> ( class -- info )
- dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
- <class/interval-info> ; foldable
+ f <class/interval-info> ; foldable
: <interval-info> ( interval -- info )
<value-info>
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 ;
: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
+: open-code-#call ( #call word/quot -- nodes/f )
+ [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
+
: splicing-body ( #call quot/word -- nodes/f )
- build-sub-tree dup [ analyze-recursive normalize ] when ;
+ open-code-#call dup [ analyze-recursive normalize ] when ;
! Dispatch elimination
: undo-inlining ( #call -- ? )
compiler.tree.propagation.transforms ;
IN: compiler.tree.propagation.known-words
-\ fixnum
-most-negative-fixnum most-positive-fixnum [a,b]
-"interval" set-word-prop
-
-\ array-capacity
-0 max-array-capacity [a,b]
-"interval" set-word-prop
-
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
-: fits? ( interval class -- ? )
- "interval" word-prop interval-subset? ;
+: fits-in-fixnum? ( interval -- ? )
+ fixnum-interval interval-subset? ;
: binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@
[ [ interval>> ] bi@ ] dip call ; inline
: won't-overflow? ( class interval -- ? )
- [ fixnum class<= ] [ fixnum fits? ] bi* and ;
+ [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
: may-overflow ( class interval -- class' interval' )
over null-class? [
[ object-info ] [ f <literal-info> ] if ;
: info-intervals-intersect? ( info1 info2 -- ? )
- [ interval>> ] bi@ intervals-intersect? ;
+ 2dup [ class>> real class<= ] both?
+ [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ;
{ number= bignum= float= } [
[
{ >integer integer }
} [
- '[
- _
- [ nip ] [
- [ interval>> ] [ class-interval ] bi*
- interval-intersect
- ] 2bi
- <class/interval-info>
- ] "outputs" set-word-prop
+ '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
] assoc-each
{ numerator denominator }
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
- [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
+ [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each
] final-literals
] unit-test
+[ V{ t } ] [ [ 40 mod 40 < ] final-literals ] unit-test
+
+[ V{ f } ] [ [ 40 mod 0 >= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ 40 rem 0 >= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test
+
[ V{ string } ] [
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes
] unit-test
] 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 } ] [
] 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
[ 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
[ { integer } declare 127 bitand ] final-info first interval>>
] unit-test
+[ V{ t } ] [
+ [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals
+] unit-test
+
[ V{ bignum } ] [
- [ { bignum } declare dup 1- bitxor ] final-classes
+ [ { bignum } declare dup 1 - bitxor ] final-classes
] unit-test
[ V{ bignum integer } ] [
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
[ ] [ [ 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
[ 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
+
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
+
+! Coercions need to update intervals
+[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
+
+[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
-IN: compiler.tree.propagation.recursive.tests
USING: tools.test compiler.tree.propagation.recursive
-math.intervals kernel ;
+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 } }
- T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+ T{ interval f { 0 t } { 0 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+ T{ interval f { 1 t } { 1 t } }
+ T{ interval f { 0 t } { 0 t } }
+ fixnum generalize-counter-interval
] unit-test
[ T{ interval f { -1/0. t } { 10 t } } ] [
T{ interval f { -1 t } { -1 t } }
- T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+ T{ interval f { 10 t } { 10 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { $[ most-negative-fixnum ] t } { 10 t } } ] [
+ T{ interval f { -1 t } { -1 t } }
+ T{ interval f { 10 t } { 10 t } }
+ fixnum generalize-counter-interval
] unit-test
[ t ] [
T{ interval f { 1 t } { 268435455 t } }
T{ interval f { -268435456 t } { 268435455 t } } tuck
- generalize-counter-interval =
+ integer generalize-counter-interval =
+] unit-test
+
+[ t ] [
+ T{ interval f { 1 t } { 268435455 t } }
+ T{ interval f { -268435456 t } { 268435455 t } } tuck
+ fixnum generalize-counter-interval =
+] unit-test
+
+[ full-interval ] [
+ T{ interval f { -5 t } { 3 t } }
+ T{ interval f { 2 t } { 11 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ $[ fixnum-interval ] ] [
+ T{ interval f { -5 t } { 3 t } }
+ T{ interval f { 2 t } { 11 t } }
+ fixnum generalize-counter-interval
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors arrays fry math.intervals
-combinators namespaces
+USING: kernel sequences accessors arrays fry math math.intervals
+layouts combinators namespaces locals
stack-checker.inlining
compiler.tree
compiler.tree.combinators
in-d>> [ value-info ] map ;
: recursive-stacks ( #enter-recursive -- stacks initial )
- [ label>> calls>> [ node-input-infos ] map flip ]
+ [ label>> calls>> [ node>> node-input-infos ] map flip ]
[ latest-input-infos ] bi ;
-: generalize-counter-interval ( interval initial-interval -- interval' )
+:: generalize-counter-interval ( interval initial-interval class -- interval' )
{
- { [ 2dup interval-subset? ] [ empty-interval ] }
- { [ over empty-interval eq? ] [ empty-interval ] }
- { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
- { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
- [ [-inf,inf] ]
- } cond interval-union nip ;
+ { [ interval initial-interval interval-subset? ] [ initial-interval ] }
+ { [ interval empty-interval eq? ] [ initial-interval ] }
+ {
+ [ interval initial-interval interval>= t eq? ]
+ [ class max-value [a,a] initial-interval interval-union ]
+ }
+ {
+ [ interval initial-interval interval<= t eq? ]
+ [ class min-value [a,a] initial-interval interval-union ]
+ }
+ [ class class-interval ]
+ } cond ;
: generalize-counter ( info' initial -- info )
2dup [ not ] either? [ drop ] [
2dup [ class>> null-class? ] either? [ drop ] [
[ clone ] dip
- [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+ [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
[ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
[ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
tri
{ [ 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* ;
: rem-custom-inlining ( #call -- quot/f )
second value-info literal>> dup integer?
- [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+ [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
{
mod-integer-integer
} 1&& ;
: lookup-table-seq ( assoc -- table )
- [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+ [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
: lookup-table-quot ( seq -- newquot )
lookup-table-seq
-IN: compiler.tree.recursive.tests
-USING: compiler.tree.recursive tools.test
-kernel combinators.short-circuit math sequences accessors
+USING: tools.test kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.recursive
+compiler.tree.recursive.private ;
+IN: compiler.tree.recursive.tests
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
] curry contains-node? ;
: loop-test-1 ( a -- )
- dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+ dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-1 ] build-tree analyze-recursive
] unit-test
: loop-test-2 ( a b -- a' )
- dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+ dup [ 1+ loop-test-2 1 - ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree analyze-recursive
\ loop-test-3 label-is-not-loop?
] unit-test
-: loop-test-4 ( a -- )
- dup [
- loop-test-4
- ] [
- drop
- ] if ; inline recursive
-
[ f ] [
[ [ [ ] map ] map ] build-tree analyze-recursive
[
DEFER: a''
-: b'' ( -- )
+: b'' ( a -- b )
a'' ; inline recursive
-: a'' ( -- )
- b'' a'' ; inline recursive
+: a'' ( a -- b )
+ dup [ b'' a'' ] when ; inline recursive
[ t ] [
[ a'' ] build-tree analyze-recursive
\ a'' label-is-not-loop?
] unit-test
+[ t ] [
+ [ a'' ] build-tree analyze-recursive
+ \ b'' label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b'' ] build-tree analyze-recursive
+ \ a'' label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b'' ] build-tree analyze-recursive
+ \ b'' label-is-not-loop?
+] unit-test
+
: loop-in-non-loop ( x quot: ( i -- ) -- )
over 0 > [
[ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
build-tree analyze-recursive
\ (each-integer) label-is-loop?
] unit-test
+
+DEFER: a'''
+
+: b''' ( -- )
+ blah [ b''' ] [ a''' b''' ] if ; inline recursive
+
+: a''' ( -- )
+ blah [ b''' ] [ a''' ] if ; inline recursive
+
+[ t ] [
+ [ b''' ] build-tree analyze-recursive
+ \ a''' label-is-loop?
+] unit-test
+
+DEFER: b4
+
+: a4 ( a -- b ) dup [ b4 ] when ; inline recursive
+
+: b4 ( a -- b ) dup [ a4 reverse ] when ; inline recursive
+
+[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test
+[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test
+[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test
+[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs arrays namespaces accessors sequences deques
-search-deques dlists compiler.tree compiler.tree.combinators ;
+USING: kernel assocs arrays namespaces accessors sequences deques fry
+search-deques dlists combinators.short-circuit make sets compiler.tree ;
IN: compiler.tree.recursive
-! Collect label info
-GENERIC: collect-label-info ( node -- )
+TUPLE: call-site tail? node label ;
-M: #return-recursive collect-label-info
- dup label>> (>>return) ;
+: recursive-phi-in ( #enter-recursive -- seq )
+ [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ;
-M: #call-recursive collect-label-info
- dup label>> calls>> push ;
+<PRIVATE
-M: #recursive collect-label-info
- label>> V{ } clone >>calls drop ;
+TUPLE: call-graph-node tail? label children calls ;
-M: node collect-label-info drop ;
-
-! A loop is a #recursive which only tail calls itself, and those
-! calls are nested inside other loops only. We optimistically
-! assume all #recursive nodes are loops, disqualifying them as
-! we see evidence to the contrary.
: (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ;
: tail-calls ( tail? node -- seq )
[
- [ #phi? ]
- [ #return? ]
- [ #return-recursive? ]
- tri or or
+ {
+ [ #phi? ]
+ [ #return? ]
+ [ #return-recursive? ]
+ } 1||
] map (tail-calls) ;
-SYMBOL: loop-heights
-SYMBOL: loop-calls
-SYMBOL: loop-stack
-SYMBOL: work-list
+SYMBOLS: children calls ;
+
+GENERIC: node-call-graph ( tail? node -- )
-GENERIC: collect-loop-info* ( tail? node -- )
+: (build-call-graph) ( tail? nodes -- )
+ [ tail-calls ] keep
+ [ node-call-graph ] 2each ;
-: non-tail-label-info ( nodes -- )
- [ f swap collect-loop-info* ] each ;
+: build-call-graph ( nodes -- labels calls )
+ [
+ V{ } clone children set
+ V{ } clone calls set
+ [ t ] dip (build-call-graph)
+ children get
+ calls get
+ ] with-scope ;
-: (collect-loop-info) ( tail? nodes -- )
- [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+M: #return-recursive node-call-graph
+ nip dup label>> (>>return) ;
-: remember-loop-info ( label -- )
- loop-stack get length swap loop-heights get set-at ;
+M: #call-recursive node-call-graph
+ [ dup label>> call-site boa ] keep
+ [ drop calls get push ]
+ [ label>> calls>> push ] 2bi ;
-M: #recursive collect-loop-info*
+M: #recursive node-call-graph
+ [ label>> V{ } clone >>calls drop ]
[
- [
- label>>
- [ swap 2array loop-stack [ swap suffix ] change ]
- [ remember-loop-info ]
- [ t >>loop? drop ]
- tri
- ]
- [ t swap child>> (collect-loop-info) ] bi
- ] with-scope ;
+ [ label>> ] [ child>> build-call-graph ] bi
+ call-graph-node boa children get push
+ ] bi ;
-: current-loop-nesting ( label -- alist )
- loop-stack get swap loop-heights get at tail ;
+M: #branch node-call-graph
+ children>> [ (build-call-graph) ] with each ;
-: disqualify-loop ( label -- )
- work-list get push-front ;
+M: node node-call-graph 2drop ;
-M: #call-recursive collect-loop-info*
- label>>
- swap [ dup disqualify-loop ] unless
- dup current-loop-nesting
- [ keys [ loop-calls get push-at ] with each ]
- [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
- bi ;
+SYMBOLS: not-loops recursive-nesting ;
-M: #if collect-loop-info*
- children>> [ (collect-loop-info) ] with each ;
+: not-a-loop ( label -- ) not-loops get conjoin ;
-M: #dispatch collect-loop-info*
- children>> [ (collect-loop-info) ] with each ;
+: not-a-loop? ( label -- ? ) not-loops get key? ;
-M: node collect-loop-info* 2drop ;
+: non-tail-calls ( call-graph-node -- seq )
+ calls>> [ tail?>> not ] filter ;
+
+: visit-back-edges ( call-graph -- )
+ [
+ [ non-tail-calls [ label>> not-a-loop ] each ]
+ [ children>> visit-back-edges ]
+ bi
+ ] each ;
+
+SYMBOL: changed?
+
+: check-cross-frame-call ( call-site -- )
+ label>> dup not-a-loop? [ drop ] [
+ recursive-nesting get <reversed> [
+ 2dup label>> eq? [ 2drop f ] [
+ [ label>> not-a-loop? ] [ tail?>> not ] bi or
+ [ not-a-loop changed? on ] [ drop ] if t
+ ] if
+ ] with all? drop
+ ] if ;
+
+: detect-cross-frame-calls ( call-graph -- )
+ ! Suppose we have a nesting of recursives A --> B --> C
+ ! B tail-calls A, and C non-tail-calls B. Then A cannot be
+ ! a loop, it needs its own procedure, since the call from
+ ! C to A crosses a call-frame boundary.
+ [
+ [ recursive-nesting get push ]
+ [ calls>> [ check-cross-frame-call ] each ]
+ [ children>> detect-cross-frame-calls ] tri
+ recursive-nesting get pop*
+ ] each ;
+
+: while-changing ( quot: ( -- ) -- )
+ changed? off
+ [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
+ inline recursive
+
+: detect-loops ( call-graph -- )
+ H{ } clone not-loops set
+ V{ } clone recursive-nesting set
+ [ visit-back-edges ]
+ [ '[ _ detect-cross-frame-calls ] while-changing ]
+ bi ;
+
+: mark-loops ( call-graph -- )
+ [
+ [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
+ [ children>> mark-loops ]
+ bi
+ ] each ;
-: collect-loop-info ( node -- )
- { } loop-stack set
- H{ } clone loop-calls set
- H{ } clone loop-heights set
- <hashed-dlist> work-list set
- t swap (collect-loop-info) ;
+PRIVATE>
-: disqualify-loops ( -- )
- work-list get [
- dup loop?>> [
- [ f >>loop? drop ]
- [ loop-calls get at [ disqualify-loop ] each ]
- bi
- ] [ drop ] if
- ] slurp-deque ;
+SYMBOL: call-graph
: analyze-recursive ( nodes -- nodes )
- dup [ collect-label-info ] each-node
- dup collect-loop-info disqualify-loops ;
+ dup build-call-graph drop
+ [ call-graph set ]
+ [ detect-loops ]
+ [ mark-loops ]
+ tri ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
-: recursive-phi-in ( #enter-recursive -- seq )
- [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
: ends-with-terminate? ( nodes -- ? )
[ f ] [ last #terminate? ] if-empty ;
-IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree
compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization compiler.tree.propagation
compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
+IN: compiler.tree.tuple-unboxing.tests
: test-unboxing ( quot -- )
build-tree
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs accessors kernel combinators
+USING: namespaces assocs accessors kernel kernel.private combinators
classes.algebra sequences slots.private fry vectors
classes.tuple.private math math.private arrays
-stack-checker.branches
+stack-checker.branches stack-checker.values
compiler.utilities
compiler.tree
+compiler.tree.builder
+compiler.tree.cleanup
compiler.tree.combinators
+compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.escape-analysis.simple
compiler.tree.escape-analysis.allocations ;
} case ;
M: #declare unbox-tuples*
- #! We don't look at declarations after propagation anyway.
- f >>declaration ;
+ #! We don't look at declarations after escape analysis anyway.
+ drop f ;
M: #copy unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
+: value-declaration ( value -- quot )
+ value-class [ 1array '[ _ declare ] ] [ [ ] ] if* ;
+
+: unbox-parameter-quot ( allocation -- quot )
+ dup unboxed-allocation {
+ { [ dup not ] [ 2drop [ ] ] }
+ { [ dup array? ] [
+ [ value-declaration ] [
+ [
+ [ unbox-parameter-quot ] [ 2 + '[ _ slot ] ] bi*
+ prepose
+ ] map-index
+ ] bi* '[ @ _ cleave ]
+ ] }
+ } cond ;
+
+: unbox-parameters-quot ( values -- quot )
+ [ unbox-parameter-quot ] map
+ dup [ [ ] = ] all? [ drop [ ] ] [ '[ _ spread ] ] if ;
+
+: unbox-parameters-nodes ( new-values old-values -- nodes )
+ [ flatten-values ] [ unbox-parameters-quot ] bi build-sub-tree ;
+
+: new-and-old-values ( values -- new-values old-values )
+ [ length [ <value> ] replicate ] keep ;
+
+: unbox-hairy-introduce ( #introduce -- nodes )
+ dup out-d>> new-and-old-values
+ [ drop >>out-d ] [ unbox-parameters-nodes ] 2bi
+ swap prefix propagate ;
+
+M: #introduce unbox-tuples*
+ ! For every output that is unboxed, insert slot accessors
+ ! to convert the stack value into its unboxed form
+ dup out-d>> [ unboxed-allocation ] any? [
+ unbox-hairy-introduce
+ ] when ;
+
! These nodes never participate in unboxing
: assert-not-unboxed ( values -- )
dup array?
M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
-M: #introduce unbox-tuples* dup out-d>> assert-not-unboxed ;
-
M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
dup
'[
@ [
- dup array?
+ dup [ array? ] [ vector? ] bi or
[ _ push-all ] [ _ push ] if
] when*
]
yield-hook [ [ ] ] initialize
-: alist-max ( alist -- pair )
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
+: alist-most ( alist quot -- pair )
+ [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
+
+: alist-min ( alist -- pair ) [ before? ] alist-most ;
+
+: alist-max ( alist -- pair ) [ after? ] alist-most ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
{ code } ;\r
\r
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;\r
-: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;\r
-: next-code ( code -- ) [ 1+ ] change-code drop ;\r
+: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;\r
+: next-code ( code -- ) [ 1 + ] change-code drop ;\r
\r
:: all-patterns ( huff n -- seq )\r
n log2 huff size>> - :> free-bits\r
k swap - dup k! 0 >
]
[ ] produce swap suffix
- { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
}
: nth* ( n seq -- elt )
- [ length 1- swap - ] [ nth ] bi ;
+ [ length 1 - swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
- [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+ [ first2 '[ _ 1 - bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors tools.test compression.lzw ;
-IN: compression.lzw.tests
-IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
concurrency.mailboxes threads sequences accessors arrays\r
math.parser ;\r
+IN: concurrency.combinators.tests\r
\r
[ [ drop ] parallel-each ] must-infer\r
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as\r
\r
[ "1a" "4b" "3c" ] [\r
2\r
- { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave\r
+ { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave\r
[ number>string ] 3 parallel-napply\r
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread\r
] unit-test\r
: count-down ( count-down -- )\r
dup n>> dup zero?\r
[ count-down-already-done ]\r
- [ 1- >>n count-down-check ] if ;\r
+ [ 1 - >>n count-down-check ] if ;\r
\r
: await-timeout ( count-down timeout -- )\r
[ promise>> ] dip ?promise-timeout ?linked t assert= ;\r
-IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
io.files.temp io.directories arrays io.sockets system
combinators threads math sequences concurrency.messaging
continuations accessors prettyprint ;
FROM: concurrency.messaging => receive send ;
+IN: concurrency.distributed.tests
: test-node ( -- addrspec )
{
-IN: concurrency.exchangers.tests\r
USING: tools.test concurrency.exchangers\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
FROM: sequences => 3append ;\r
+IN: concurrency.exchangers.tests\r
\r
:: exchanger-test ( -- string )\r
[let |\r
-IN: concurrency.flags.tests\r
USING: tools.test concurrency.flags concurrency.combinators\r
kernel threads locals accessors calendar ;\r
+IN: concurrency.flags.tests\r
\r
:: flag-test-1 ( -- val )\r
[let | f [ <flag> ] |\r
-IN: concurrency.futures.tests\r
USING: concurrency.futures kernel tools.test threads ;\r
+IN: concurrency.futures.tests\r
\r
[ 50 ] [\r
[ 50 ] future ?future\r
-IN: concurrency.locks.tests\r
USING: tools.test concurrency.locks concurrency.count-downs\r
concurrency.messaging concurrency.mailboxes locals kernel\r
threads sequences calendar accessors ;\r
+IN: concurrency.locks.tests\r
\r
:: lock-test-0 ( -- v )\r
[let | v [ V{ } clone ]\r
<PRIVATE\r
\r
: add-reader ( lock -- )\r
- [ 1+ ] change-reader# drop ;\r
+ [ 1 + ] change-reader# drop ;\r
\r
: acquire-read-lock ( lock timeout -- )\r
over writer>>\r
writers>> notify-1 ;\r
\r
: remove-reader ( lock -- )\r
- [ 1- ] change-reader# drop ;\r
+ [ 1 - ] change-reader# drop ;\r
\r
: release-read-lock ( lock -- )\r
dup remove-reader\r
-IN: concurrency.mailboxes.tests\r
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions\r
vectors sequences threads tools.test math kernel strings namespaces\r
continuations calendar destructors ;\r
+IN: concurrency.mailboxes.tests\r
\r
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
\r
[\r
<mailbox> 1 seconds mailbox-get-timeout\r
] [ wait-timeout? ] must-fail-with\r
-
\ No newline at end of file
+ \r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: concurrency.mailboxes\r
USING: dlists deques threads sequences continuations\r
destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
debugger debugger.threads locals fry ;\r
+IN: concurrency.mailboxes\r
\r
TUPLE: mailbox threads data disposed ;\r
\r
-IN: concurrency.promises.tests\r
USING: vectors concurrency.promises kernel threads sequences\r
tools.test ;\r
+IN: concurrency.promises.tests\r
\r
[ V{ 50 50 50 } ] [\r
0 <vector>\r
: acquire-timeout ( semaphore timeout -- )\r
over count>> zero?\r
[ dupd wait-to-acquire ] [ drop ] if\r
- [ 1- ] change-count drop ;\r
+ [ 1 - ] change-count drop ;\r
\r
: acquire ( semaphore -- )\r
f acquire-timeout ;\r
\r
: release ( semaphore -- )\r
- [ 1+ ] change-count\r
+ [ 1 + ] change-count\r
threads>> notify-1 ;\r
\r
:: with-semaphore-timeout ( semaphore timeout quot -- )\r
-IN: cords.tests
USING: cords strings tools.test kernel sequences ;
+IN: cords.tests
[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test
[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-foundation.numbers ;
-IN: core-foundation.numbers.tests
: (reset-timer) ( timer counter -- )
yield {
{ [ dup 0 = ] [ now ((reset-timer)) ] }
- { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
+ { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
{ [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
[ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
} cond ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-foundation.utilities ;
-IN: core-foundation.utilities.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-graphics.types ;
-IN: core-graphics.types.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text.fonts ;
-IN: core-text.fonts.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text.utilities ;
-IN: core-text.utilities.tests
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel kernel.private math
memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
-! A pseudo-register class for parameters spilled on the stack
-SINGLETON: stack-params
-
-GENERIC: reg-size ( register-class -- n )
+! Representations -- these are like low-level types
-M: int-regs reg-size drop cell ;
+! Unknown representation; this is used for ##copy instructions which
+! get eliminated later
+SINGLETON: any-rep
-M: single-float-regs reg-size drop 4 ;
+! Integer registers can contain data with one of these three representations
+! tagged-rep: tagged pointer or fixnum
+! int-rep: untagged fixnum, not a pointer
+SINGLETONS: tagged-rep int-rep ;
-M: double-float-regs reg-size drop 8 ;
+! Floating point registers can contain data with
+! one of these representations
+SINGLETONS: single-float-rep double-float-rep ;
-M: stack-params reg-size drop cell ;
+UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ;
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
+! Register classes
+SINGLETONS: int-regs float-regs ;
-! Return values of this class go here
-GENERIC: return-reg ( register-class -- reg )
+UNION: reg-class int-regs float-regs ;
+CONSTANT: reg-classes { int-regs float-regs }
-! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( register-class -- regs )
+! A pseudo-register class for parameters spilled on the stack
+SINGLETON: stack-params
-GENERIC: param-reg ( n register-class -- reg )
+: reg-class-of ( rep -- reg-class )
+ {
+ { tagged-rep [ int-regs ] }
+ { int-rep [ int-regs ] }
+ { single-float-rep [ float-regs ] }
+ { double-float-rep [ float-regs ] }
+ { stack-params [ stack-params ] }
+ } case ;
+
+: rep-size ( rep -- n )
+ {
+ { tagged-rep [ cell ] }
+ { int-rep [ cell ] }
+ { single-float-rep [ 4 ] }
+ { double-float-rep [ 8 ] }
+ { stack-params [ cell ] }
+ } case ;
-M: object param-reg param-regs nth ;
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
HOOK: two-operand? cpu ( -- ? )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
-HOOK: %copy cpu ( dst src -- )
-HOOK: %copy-float cpu ( dst src -- )
+HOOK: %copy cpu ( dst src rep -- )
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill-integer cpu ( src n -- )
-HOOK: %spill-float cpu ( src n -- )
-HOOK: %reload-integer cpu ( dst n -- )
-HOOK: %reload-float cpu ( dst n -- )
+HOOK: %spill cpu ( src n rep -- )
+HOOK: %reload cpu ( dst n rep -- )
HOOK: %loop-entry cpu ( -- )
! FFI stuff
+! Return values of this class go here
+GENERIC: return-reg ( reg-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: param-regs ( reg-class -- regs )
+
+M: stack-params param-regs drop f ;
+
+GENERIC: param-reg ( n reg-class -- reg )
+
+M: reg-class param-reg param-regs nth ;
+
+M: stack-params param-reg drop ;
+
! Is this integer small enough to appear in value template
! slots?
HOOK: small-enough? cpu ( n -- ? )
HOOK: %prepare-unbox cpu ( -- )
-HOOK: %unbox cpu ( n reg-class func -- )
+HOOK: %unbox cpu ( n rep func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
-HOOK: %box cpu ( n reg-class func -- )
+HOOK: %box cpu ( n rep func -- )
HOOK: %box-long-long cpu ( n func -- )
HOOK: %box-large-struct cpu ( n c-type -- )
-GENERIC: %save-param-reg ( stack reg reg-class -- )
+HOOK: %save-param-reg cpu ( stack reg rep -- )
-GENERIC: %load-param-reg ( stack reg reg-class -- )
+HOOK: %load-param-reg cpu ( stack reg rep -- )
HOOK: %prepare-alien-invoke cpu ( -- )
HOOK: %callback-return cpu ( params -- )
M: object %callback-return drop %return ;
-
-M: stack-params param-reg drop ;
-
-M: stack-params param-regs drop f ;
-IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ;
FROM: cpu.ppc.assembler => B ;
+IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
! key = class\r
5 4 MR\r
! key &= cache.length - 1\r
- 5 5 mega-cache-size get 1- bootstrap-cell * ANDI\r
+ 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
! cache += array-start-offset\r
3 3 array-start-offset ADDI\r
! cache += key\r
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
- { double-float-regs $[ 0 29 [a,b] ] }
+ { float-regs $[ 0 29 [a,b] ] }
} ;
CONSTANT: scratch-reg 30
temp dst 1 bignum@ STW
! Compute sign
temp src MR
- temp temp cell-bits 1- SRAWI
+ temp temp cell-bits 1 - SRAWI
temp temp 1 ANDI
! Store sign
temp dst 2 bignum@ STW
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-GENERIC: STF ( src dst off reg-class -- )
+M: single-float-rep %save-param-reg drop 1 rot local@ STFS ;
+M: single-float-rep %load-param-reg 1 rot local@ LFS ;
-M: single-float-regs STF drop STFS ;
-M: double-float-regs STF drop STFD ;
+M: double-float-rep %save-param-reg drop 1 rot local@ STFD ;
+M: double-float-rep %load-param-reg 1 rot local@ LFD ;
-M: float-regs %save-param-reg [ 1 rot local@ ] dip STF ;
-
-GENERIC: LF ( dst src off reg-class -- )
-
-M: single-float-regs LF drop LFS ;
-M: double-float-regs LF drop LFD ;
-
-M: float-regs %load-param-reg [ 1 rot local@ ] dip LF ;
-
-M: stack-params %load-param-reg ( stack reg reg-class -- )
+M: stack-params %load-param-reg ( stack reg rep -- )
drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
-M: stack-params %save-param-reg ( stack reg reg-class -- )
+M: stack-params %save-param-reg ( stack reg rep -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
-M: ppc %unbox ( n reg-class func -- )
+M: ppc %unbox ( n rep func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+ over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the function
"to_value_struct" f %alien-invoke ;
-M: ppc %box ( n reg-class func -- )
+M: ppc %box ( n rep func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
- [ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if ] dip
+ [ over [ 0 over reg-class-of param-reg swap %load-param-reg ] [ 2drop ] if ] dip
f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned, and we do
-! this on all platforms, sacrificing some stack space for
-! code simplicity.
+! OS X requires that the stack be 16-byte aligned.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
- { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+ { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 temp-reg-1 ECX ;
-M: x86.32 temp-reg-2 EDX ;
+M: x86.32 temp-reg ECX ;
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
-M: int-regs push-return-reg return-reg PUSH ;
-
-M: int-regs load-return-reg
- return-reg swap next-stack@ MOV ;
-
-M: int-regs store-return-reg
- [ stack@ ] [ return-reg ] bi* MOV ;
-
M: float-regs param-regs drop { } ;
-: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
-
-M: float-regs push-return-reg
- stack-reg swap reg-size
- [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
+GENERIC: push-return-reg ( rep -- )
+GENERIC: load-return-reg ( n rep -- )
+GENERIC: store-return-reg ( n rep -- )
-: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
+M: int-rep push-return-reg drop EAX PUSH ;
+M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
+M: int-rep store-return-reg drop stack@ EAX MOV ;
-M: float-regs load-return-reg
- [ next-stack@ ] [ reg-size ] bi* FLD ;
+M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: single-float-rep load-return-reg drop next-stack@ FLDS ;
+M: single-float-rep store-return-reg drop stack@ FSTPS ;
-M: float-regs store-return-reg
- [ stack@ ] [ reg-size ] bi* FSTP ;
+M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-float-rep load-return-reg drop next-stack@ FLDL ;
+M: double-float-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
0 PUSH rc-absolute-cell rel-this
3 cells - decr-stack-reg ;
-M: object %load-param-reg 3drop ;
+M: x86.32 %load-param-reg 3drop ;
-M: object %save-param-reg 3drop ;
+M: x86.32 %save-param-reg 3drop ;
-: (%box) ( n reg-class -- )
+: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
-M:: x86.32 %box ( n reg-class func -- )
- n reg-class (%box)
- reg-class reg-size [
- reg-class push-return-reg
+M:: x86.32 %box ( n rep func -- )
+ n rep (%box)
+ rep rep-size [
+ rep push-return-reg
func f %alien-invoke
] with-aligned-stack ;
EAX ESI [] MOV
ESI 4 SUB ;
-: (%unbox) ( func -- )
+: call-unbox-func ( func -- )
4 [
! Push parameter
EAX PUSH
f %alien-invoke
] with-aligned-stack ;
-M: x86.32 %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n rep func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
- (%unbox)
+ call-unbox-func
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
- (%unbox)
+ call-unbox-func
! Store the return value on the C stack
[
dup stack@ EAX MOV
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
- { double-float-regs {
+ { float-regs {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
M: float-regs return-reg drop XMM0 ;
M: x86.64 %prologue ( n -- )
- temp-reg-1 0 MOV rc-absolute-cell rel-this
+ temp-reg 0 MOV rc-absolute-cell rel-this
dup PUSH
- temp-reg-1 PUSH
+ temp-reg PUSH
stack-reg swap 3 cells - SUB ;
-M: stack-params %load-param-reg
+M: stack-params copy-register*
drop
- [ R11 swap param@ MOV ] dip
- param@ R11 MOV ;
+ {
+ { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
+ { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
+ } cond ;
-M: stack-params %save-param-reg
- drop
- R11 swap next-stack@ MOV
- param@ R11 MOV ;
+M: x86 %save-param-reg [ param@ ] 2dip copy-register ;
+
+M: x86 %load-param-reg [ swap param@ ] dip copy-register ;
: with-return-regs ( quot -- )
[
param-reg-1 R14 [] MOV
R14 cell SUB ;
-M: x86.64 %unbox ( n reg-class func -- )
+M:: x86.64 %unbox ( n rep func -- )
! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+ func f %alien-invoke
+ ! Store the return value on the C stack if this is an
+ ! alien-invoke, otherwise leave it the return register if
+ ! this is the end of alien-callback
+ n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
M: x86.64 %unbox-long-long ( n func -- )
- int-regs swap %unbox ;
+ [ int-rep ] dip %unbox ;
: %unbox-struct-field ( c-type i -- )
! Alien must be in param-reg-1.
- R11 swap cells [+] swap reg-class>> {
+ R11 swap cells [+] swap rep>> reg-class-of {
{ int-regs [ int-regs get pop swap MOV ] }
- { double-float-regs [ float-regs get pop swap MOVSD ] }
+ { float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
-: load-return-value ( reg-class -- )
- 0 over param-reg swap return-reg
- 2dup eq? [ 2drop ] [ MOV ] if ;
-
-M: x86.64 %box ( n reg-class func -- )
- rot [
- rot [ 0 swap param-reg ] keep %load-param-reg
+: load-return-value ( rep -- )
+ [ [ 0 ] dip reg-class-of param-reg ]
+ [ reg-class-of return-reg ]
+ [ ]
+ tri copy-register ;
+
+M:: x86.64 %box ( n rep func -- )
+ n [
+ n
+ 0 rep reg-class-of param-reg
+ rep %load-param-reg
] [
- swap load-return-value
- ] if*
- f %alien-invoke ;
+ rep load-return-value
+ ] if
+ func f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
- int-regs swap %box ;
+ [ int-rep ] dip %box ;
-: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
+: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
: %box-struct-field ( c-type i -- )
- box-struct-field@ swap reg-class>> {
+ box-struct-field@ swap c-type-rep reg-class-of {
{ int-regs [ int-regs get pop MOV ] }
- { double-float-regs [ float-regs get pop MOVSD ] }
+ { float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
compiler.cfg.registers ;
IN: cpu.x86.64.unix
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs param-regs
+ drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
+stack-params "__stack_value" c-type (>>rep) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
- [ c-type c-type-reg-class ] map
+ [ c-type c-type-rep reg-class-of ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
M: x86.64 dummy-fp-params? f ;
-M: x86.64 temp-reg-1 R8 ;
-
-M: x86.64 temp-reg-2 R9 ;
+M: x86.64 temp-reg R8 ;
M: x86.64 dummy-fp-params? t ;
-M: x86.64 temp-reg-1 RAX ;
-
-M: x86.64 temp-reg-2 RCX ;
+M: x86.64 temp-reg RAX ;
<<
"longlong" "ptrdiff_t" typedef
: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
+<PRIVATE
+
: (PSRLW-imm) ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
: (PSRAW-imm) ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
: (PSLLW-imm) ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ;
: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ;
+PRIVATE>
+
: PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ;
: PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ;
: PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ;
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
-<PRIVATE
-
-GENERIC: extended? ( op -- ? )
-
-M: object extended? drop f ;
-
PREDICATE: register < word
"register" word-prop ;
+<PRIVATE
+
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
+GENERIC: extended? ( op -- ? )
+
+M: object extended? drop f ;
+
M: register extended? "register" word-prop 7 > ;
! Addressing modes
temp2 temp1 MOV
bootstrap-cell 8 = [ temp2 1 SHL ] when
! key &= cache.length - 1
- temp2 mega-cache-size get 1- bootstrap-cell * AND
+ temp2 mega-cache-size get 1 - bootstrap-cell * AND
! cache += array-start-offset
temp0 array-start-offset ADD
! cache += key
! make a copy
mod-arg div-arg MOV
! sign-extend
- mod-arg bootstrap-cell-bits 1- SAR
+ mod-arg bootstrap-cell-bits 1 - SAR
! divide
temp3 IDIV ;
-IN: cpu.x86.features.tests
USING: cpu.x86.features tools.test kernel sequences math system ;
+IN: cpu.x86.features.tests
cpu x86? [
[ t ] [ sse2? { t f } member? ] unit-test
[ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
-] when
\ No newline at end of file
+] when
: param@ ( n -- op ) reserved-area-size + stack@ ;
-: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
-
-: spill-float@ ( n -- op ) spill-float-offset param@ ;
+: spill@ ( n -- op ) spill-offset param@ ;
: gc-root@ ( n -- op ) gc-root-offset param@ ;
M: x86 stack-frame-size ( stack-frame -- i )
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
+! Must be a volatile register not used for parameter passing, for safe
+! use in calls in and out of C
+HOOK: temp-reg cpu ( -- reg )
+! Fastcall calling convention
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
M: x86 %not drop NOT ;
M: x86 %log2 BSR ;
-: ?MOV ( dst src -- )
- 2dup = [ 2drop ] [ MOV ] if ; inline
-
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
dst 3 bignum@ src MOV
! Compute sign
temp src MOV
- temp cell-bits 1- SAR
+ temp cell-bits 1 - SAR
temp 1 AND
! Store sign
dst 2 bignum@ temp MOV
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
-M: x86 %copy ( dst src -- ) ?MOV ;
+GENERIC: copy-register* ( dst src rep -- )
-M: x86 %copy-float ( dst src -- )
- 2dup = [ 2drop ] [ MOVSD ] if ;
+M: int-rep copy-register* drop MOV ;
+M: tagged-rep copy-register* drop MOV ;
+M: single-float-rep copy-register* drop MOVSS ;
+M: double-float-rep copy-register* drop MOVSD ;
+
+: copy-register ( dst src rep -- )
+ 2over eq? [ 3drop ] [ copy-register* ] if ;
+
+M: x86 %copy ( dst src rep -- ) copy-register ;
M: x86 %unbox-float ( dst src -- )
float-offset [+] MOVSD ;
[ quot call ] with-save/restore
] if ; inline
+: ?MOV ( dst src -- )
+ 2dup = [ 2drop ] [ MOV ] if ; inline
+
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
{ cc/= [ JNE ] }
} case ;
-M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
-M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
-
-M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ;
-M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
+M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
+M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
-M: int-regs %save-param-reg drop [ param@ ] dip MOV ;
-M: int-regs %load-param-reg drop swap param@ MOV ;
-
-GENERIC: MOVSS/D ( dst src reg-class -- )
-
-M: single-float-regs MOVSS/D drop MOVSS ;
-M: double-float-regs MOVSS/D drop MOVSD ;
-
-M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ;
-M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ;
-
-GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( n reg-class -- )
-GENERIC: store-return-reg ( n reg-class -- )
-
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp-reg-1 "stack_chain" f %alien-global
- temp-reg-1 temp-reg-1 [] MOV
- temp-reg-1 [] stack-reg MOV
- temp-reg-1 [] cell SUB
- temp-reg-1 2 cells [+] ds-reg MOV
- temp-reg-1 3 cells [+] rs-reg MOV ;
+ temp-reg "stack_chain" f %alien-global
+ temp-reg temp-reg [] MOV
+ temp-reg [] stack-reg MOV
+ temp-reg [] cell SUB
+ temp-reg 2 cells [+] ds-reg MOV
+ temp-reg 3 cells [+] rs-reg MOV ;
M: x86 value-struct? drop t ;
M: random-id-generator eval-generator ( singleton -- obj )
drop
system-random-generator get [
- 63 [ random-bits ] keep 1- set-bit
+ 63 [ random-bits ] keep 1 - set-bit
] with-random ;
: interval-comparison ( ? str -- str )
} define-persistent
[ bignum-test drop-table ] ignore-errors
[ ] [ bignum-test ensure-table ] unit-test
- [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
+ [ ] [ 63 2^ 1 - dup dup <bignum-test> insert-tuple ] unit-test ;
! sqlite only
! [ T{ bignum-test f 1
-IN: debugger.tests\r
USING: debugger kernel continuations tools.test ;\r
+IN: debugger.tests\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
\r
[ f ] [ { } vm-error? ] unit-test\r
-[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
+[ f ] [ { "A" "B" } vm-error? ] unit-test\r
error-continuation get name>> assoc-stack ;
: :res ( n -- * )
- 1- restarts get-global nth f restarts set-global restart ;
+ 1 - restarts get-global nth f restarts set-global restart ;
: :1 ( -- * ) 1 :res ;
: :2 ( -- * ) 2 :res ;
: restart. ( restart n -- )
[
- 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
+ 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
name>> %
] "" make print ;
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
- "Maximum: " write fourth 1- . ;
+ "Maximum: " write fourth 1 - . ;
: c-string-error. ( obj -- )
"Cannot convert to C string: " write third . ;
"SIGUSR1" "SIGUSR2"
}
-: signal-name ( n -- str/f ) 1- signal-names ?nth ;
+: signal-name ( n -- str/f ) 1 - signal-names ?nth ;
: signal-name. ( n -- )
signal-name [ " (" ")" surround write ] when* ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test definitions.icons ;
-IN: definitions.icons.tests
TUPLE: hey value ;
C: <hey> hey
-CONSULT: alpha hey value>> 1+ ;
-CONSULT: beta hey value>> 1- ;
+CONSULT: alpha hey value>> 1 + ;
+CONSULT: beta hey value>> 1 - ;
[ 2 ] [ 1 <hey> one ] unit-test
[ 2 ] [ 1 <hey> two ] unit-test
-IN: disjoint-sets.testes
USING: tools.test disjoint-sets namespaces slots.private ;
+IN: disjoint-sets.testes
SYMBOL: +blah+
-405534154 +blah+ 1 set-slot
ranks>> at ; inline
: inc-rank ( a disjoint-set -- )
- ranks>> [ 1+ ] change-at ; inline
+ ranks>> [ 1 + ] change-at ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
-IN: documents.tests
USING: documents documents.private accessors sequences
namespaces tools.test make arrays kernel fry ;
+IN: documents.tests
! Tests
[ drop ] [ doc-line length ] 2bi 2array ;
: doc-lines ( from to document -- slice )
- [ 1+ ] [ value>> ] bi* <slice> ;
+ [ 1 + ] [ value>> ] bi* <slice> ;
: start-on-line ( from line# document -- n1 )
drop over first =
[ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
: last-line# ( document -- line )
- value>> length 1- ;
+ value>> length 1 - ;
CONSTANT: doc-start { 0 0 }
over length 1 = [
nip first2
] [
- first swap length 1- + 0
+ first swap length 1 - + 0
] if
] dip last length + 2array ;
0 swap [ append ] change-nth ;
: append-last ( str seq -- )
- [ length 1- ] keep [ prepend ] change-nth ;
+ [ length 1 - ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
[ first2 swap ] dip nth swap ;
: (set-doc-range) ( doc-lines from to lines -- changed-lines )
[ prepare-insert ] 3keep
- [ [ first ] bi@ 1+ ] dip
+ [ [ first ] bi@ 1 + ] dip
replace-slice ;
: entire-doc ( document -- start end document )
: prev ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ pick { 0 0 } = ] [ 2drop ] }
- { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
+ { [ pick second zero? ] [ drop [ first 1 - ] dip line-end ] }
[ call ]
} cond ; inline
: next ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ 2over doc-end = ] [ 2drop ] }
- { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
+ { [ 2over line-end? ] [ 2drop first 1 + 0 2array ] }
[ call ]
} cond ; inline
M: one-word-elt prev-elt
drop
- [ [ 1- ] dip f prev-word ] modify-col ;
+ [ [ 1 - ] dip f prev-word ] modify-col ;
M: one-word-elt next-elt
drop
M: word-elt prev-elt
drop
- [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
+ [ [ [ 1 - ] dip blank-at? prev-word ] modify-col ]
prev ;
M: word-elt next-elt
ARTICLE: "editor" "Editor integration"
"Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment."
{ $subsection edit }
-"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ", for example:"
+"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ":"
{ $code "USE: editors.emacs" }
+"If you intend to always use the same editor, it helps to have it load during stage 2 bootstrap. Place the code to load and possibly configure it in the " { $link "factor-boot-rc" } "."
+$nl
"Editor integration vocabularies store a quotation in a global variable when loaded:"
{ $subsection edit-hook }
"If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:"
: edit-vocab ( name -- )
>vocab-link edit ;
-GENERIC: error-file ( error -- file )
-
-GENERIC: error-line ( error -- line )
-
-M: lexer-error error-file
- error>> error-file ;
-
-M: lexer-error error-line
- [ error>> error-line ] [ line>> ] bi or ;
-
-M: source-file-error error-file
- [ error>> error-file ] [ file>> ] bi or ;
-
-M: source-file-error error-line
- error>> error-line ;
-
-M: condition error-file
- error>> error-file ;
-
-M: condition error-line
- error>> error-line ;
-
-M: object error-file
- drop f ;
-
-M: object error-line
- drop f ;
-
-: (:edit) ( error -- )
+: edit-error ( error -- )
[ error-file ] [ error-line ] bi
2dup and [ edit-location ] [ 2drop ] if ;
: :edit ( -- )
- error get (:edit) ;
-
-: edit-error ( error -- )
- [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+ error get edit-error ;
: edit-each ( seq -- )
[
--- /dev/null
+USING: help.syntax ;
+IN: editors.gvim
+ABOUT: { "vim" "vim" }
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.macvim
: macvim ( file line -- )
[ "mate" , "-a" , "-l" , number>string , , ] { } make
run-detached drop ;
-[ textmate ] edit-hook set-global
+[ textmate ] edit-hook set-global
\ No newline at end of file
-USING: definitions editors help help.markup help.syntax io io.files
- io.pathnames words ;
+USING: definitions editors help help.markup help.syntax
+io io.files io.pathnames words ;
IN: editors.vim
+ABOUT: { "vim" "vim" }
+
ARTICLE: { "vim" "vim" } "Vim support"
-"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
+"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } "."
$nl
-"If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
-{ $code
-"USING: modules namespaces ;"
-"REQUIRES: libs/vim ;"
-"USE: vim"
-"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
+"The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"vim\"" } ". Which is not very useful, as it starts vim in the same terminal where you started factor."
+{ $list
+ { "If you want to use gvim instead or are on a Windows platform use " { $vocab-link "editors.gvim" } "." }
+ { "If you want to start vim in an extra terminal, use something like this:" { $code "{ \"urxvt\" \"-e\" \"vim\" } vim-path set-global" } "Replace " { $snippet "urxvt" } " by your terminal of choice." }
}
-"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
$nl
-"You may also wish to install Vim support files to enable syntax hilighting and other features. These are in the " { $link resource-path } " in " { $snippet "misc/vim" } "." ;
+"You may also wish to install Vim support files to enable syntax hilighting and other features. These are in the " { $link resource-path } " in " { $snippet "misc/vim" } "."
+{ $see-also "editor" }
+;
USING: definitions io io.launcher kernel math math.parser
namespaces parser prettyprint sequences editors accessors
-make ;
+make strings ;
IN: editors.vim
SYMBOL: vim-path
M: vim vim-command
[
- vim-path get ,
+ vim-path get dup string? [ , ] [ % ] if
[ , ] [ number>string "+" prepend , ] bi*
] { } make ;
-IN: eval.tests
USING: eval tools.test ;
+IN: eval.tests
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
[ "USE: math 2 2 +" eval( -- ) ] must-fail
parse-paragraph paragraph boa ;
: cut-half-slice ( string i -- before after-slice )
- [ head ] [ 1+ short tail-slice ] 2bi ;
+ [ head ] [ 1 + short tail-slice ] 2bi ;
: find-cut ( string quot -- before after delimiter )
dupd find
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
USING: calendar kernel formatting tools.test ;
-
IN: formatting.tests
[ "%s" printf ] must-infer
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
USING: accessors arrays assocs calendar combinators fry kernel
generalizations io io.streams.string macros math math.functions
math.parser peg.ebnf quotations sequences splitting strings
unicode.categories unicode.case vectors combinators.smart ;
-
IN: formatting
<PRIVATE
: fix-sign ( string -- string )
dup CHAR: 0 swap index 0 =
[ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
- [ dup 1- rot dup [ nth ] dip swap
+ [ dup 1 - rot dup [ nth ] dip swap
{
- { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
- { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+ { CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] }
+ { CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] }
[ drop swap drop ]
} case
] [ drop ] if
[ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
- 10 swap ^ [ * round ] keep / ; inline
+ 10^ [ * round ] keep / ; inline
: >exp ( x -- exp base )
[
abs 0 swap
[ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
[ dup 10.0 >=
- [ 10.0 / [ 1+ ] dip ]
- [ 10.0 * [ 1- ] dip ] if
+ [ 10.0 / [ 1 + ] dip ]
+ [ 10.0 * [ 1 - ] dip ] if
] while
] keep 0 < [ neg ] when ;
-IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
sequences eval accessors ;
+IN: fry.tests
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
: check-fry ( quot -- quot )
dup { load-local load-locals get-local drop-locals } intersect
- empty? [ >r/r>-in-fry-error ] unless ;
+ [ >r/r>-in-fry-error ] unless-empty ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
check-fry
[ [ deep-fry ] each ] [ ] make
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
- { _ } split [ spread>quot ] [ length 1- ] bi ;
+ { _ } split [ spread>quot ] [ length 1 - ] bi ;
PRIVATE>
-IN: functors.tests
USING: functors tools.test math words kernel multiline parser
io.streams.string generic ;
+IN: functors.tests
<<
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.parser combinators effects effects.parser
-fry generic generic.parser generic.standard interpolate
-io.streams.string kernel lexer locals.parser locals.rewrite.closures
-locals.types make namespaces parser quotations sequences vocabs.parser
-words words.symbol ;
+USING: accessors arrays classes.mixin classes.parser
+classes.singleton classes.tuple classes.tuple.parser
+combinators effects.parser fry generic generic.parser
+generic.standard interpolate io.streams.string kernel lexer
+locals.parser locals.types macros make namespaces parser
+quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
complete-effect parsed
\ define-simple-generic* parsed ;
+SYNTAX: `MACRO:
+ scan-param parsed
+ parse-declared*
+ \ define-macro parsed ;
+
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
+ { "MACRO:" POSTPONE: `MACRO: }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
HELP: page-action
{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
-HELP: param
-{ $values
- { "name" string }
- { "value" string }
-}
-{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
-{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
-
-HELP: params
-{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
-{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
-
HELP: validate-integer-id
{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
{ $examples
ARTICLE: "furnace.actions.config" "Furnace action configuration"
"Actions have the following slots:"
{ $table
- { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } }
+ { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error. A more general facility can be found in the " { $vocab-link "http.server.rewrite" } " vocabulary." } }
{ { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } }
{ { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } }
{ { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } }
"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ;
ARTICLE: "furnace.actions.impl" "Furnace actions implementation"
-"The following words are used by the action implementation and there is rarely any reason to call them directly:"
-{ $subsection new-action }
-{ $subsection param }
-{ $subsection params } ;
+"The following parametrized constructor should be called from constructors for subclasses of " { $link action } ":"
+{ $subsection new-action } ;
ARTICLE: "furnace.actions" "Furnace actions"
"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle."
html.templates.chloe.compiler ;\r
IN: furnace.actions\r
\r
-SYMBOL: params\r
-\r
SYMBOL: rest\r
\r
TUPLE: action rest init authorize display validate submit ;\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: param ( name -- value )\r
- params get at ;\r
-\r
CONSTANT: revalidate-url-key "__u"\r
\r
: revalidate-url ( -- url/f )\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: handle-rest ( path action -- assoc )\r
- rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
+: handle-rest ( path action -- )\r
+ rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;\r
\r
: init-action ( path action -- )\r
begin-form\r
- handle-rest\r
- request get request-params assoc-union params set ;\r
+ handle-rest ;\r
\r
M: action call-responder* ( path action -- response )\r
[ init-action ] keep\r
+++ /dev/null
-USING: furnace.auth tools.test ;
-IN: furnace.auth.tests
-
+++ /dev/null
-IN: furnace.auth.features.edit-profile.tests
-USING: tools.test furnace.auth.features.edit-profile ;
-
-
+++ /dev/null
-IN: furnace.auth.features.recover-password
-USING: tools.test furnace.auth.features.recover-password ;
-
-
+++ /dev/null
-IN: furnace.auth.features.registration.tests
-USING: tools.test furnace.auth.features.registration ;
-
-
+++ /dev/null
-IN: furnace.auth.login.tests\r
-USING: tools.test furnace.auth.login ;\r
-\r
-\r
USING: accessors namespaces kernel combinators.short-circuit
db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
-
IN: furnace.auth.login.permits
TUPLE: permit < server-state session uid ;
-IN: furnace.auth.providers.assoc.tests\r
USING: furnace.actions furnace.auth furnace.auth.providers \r
furnace.auth.providers.assoc furnace.auth.login\r
tools.test namespaces accessors kernel ;\r
+IN: furnace.auth.providers.assoc.tests\r
\r
<action> "Test" <login-realm>\r
<users-in-memory> >>users\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: furnace.auth.providers.assoc\r
USING: accessors assocs kernel furnace.auth.providers ;\r
+IN: furnace.auth.providers.assoc\r
\r
TUPLE: users-in-memory assoc ;\r
\r
-IN: furnace.auth.providers.db.tests\r
USING: furnace.actions\r
furnace.auth\r
furnace.auth.login\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
io.files io.files.temp io.directories accessors kernel ;\r
+IN: furnace.auth.providers.db.tests\r
\r
<action> "test" <login-realm> realm set\r
\r
+++ /dev/null
-IN: furnace.db.tests
-USING: tools.test furnace.db ;
-
-
-IN: furnace.tests
USING: http http.server.dispatchers http.server.responses
http.server furnace furnace.utilities tools.test kernel
namespaces accessors io.streams.string urls xml.writer ;
+IN: furnace.tests
+
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> ( -- dispatcher ) funny-dispatcher new-dispatcher ;
-IN: furnace.sessions.tests\r
USING: tools.test http furnace.sessions furnace.actions\r
http.server http.server.responses math namespaces make kernel\r
accessors io.sockets io.servers.connection prettyprint\r
io.streams.string io.files io.files.temp io.directories\r
splitting destructors sequences db db.tuples db.sqlite\r
continuations urls math.parser furnace furnace.utilities ;\r
+IN: furnace.sessions.tests\r
\r
: with-session ( session quot -- )\r
[\r
\r
M: foo call-responder*\r
2drop\r
- "x" [ 1+ ] schange\r
+ "x" [ 1 + ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
: url-responder-mock-test ( -- string )\r
\r
"auth-test.db" temp-file <sqlite-db> [\r
\r
- <request> init-request\r
+ <request> "GET" >>method init-request\r
session ensure-table\r
\r
"127.0.0.1" 1234 <inet4> remote-address set\r
\r
[ 9 ] [ "x" sget sq ] unit-test\r
\r
- [ ] [ "x" [ 1- ] schange ] unit-test\r
+ [ ] [ "x" [ 1 - ] schange ] unit-test\r
\r
[ 4 ] [ "x" sget sq ] unit-test\r
\r
{ $values { "referrer/f" { $maybe string } } }
{ $description "Outputs the current request's referrer URL." } ;
-HELP: request-params
-{ $values { "request" request } { "assoc" assoc } }
-{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
-
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "Resolves a responder-relative URL." } ;
{ $subsection exit-with }
"Other useful words:"
{ $subsection hidden-form-field }
-{ $subsection request-params }
{ $subsection client-state }
{ $subsection user-agent } ;
CONSTANT: nested-forms-key "__n"
-: request-params ( request -- assoc )
- dup method>> {
- { "GET" [ url>> query>> ] }
- { "HEAD" [ url>> query>> ] }
- { "POST" [ post-data>> params>> ] }
- } case ;
-
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
+USING: ui game-input tools.test kernel system threads calendar
+combinators.short-circuit ;
IN: game-input.tests
-USING: ui game-input tools.test kernel system threads calendar ;
-os windows? os macosx? or [
+os { [ windows? ] [ macosx? ] } 1|| [
[ ] [ open-game-input ] unit-test
[ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
-] when
\ No newline at end of file
+] when
game-input-opened? [
(open-game-input)
] unless
- game-input-opened [ 1+ ] change-global
+ game-input-opened [ 1 + ] change-global
reset-mouse ;
: close-game-input ( -- )
game-input-opened [
dup zero? [ game-input-not-open ] when
- 1-
+ 1 -
] change-global
game-input-opened? [
(close-game-input)
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
: record-button ( state hid-value element -- )
- [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement {
'[ _ { } nsequence ] ;
MACRO: nsum ( n -- )
- 1- [ + ] n*quot ;
+ 1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
- [ 1- swap bounds-check 2drop ]
+ [ 1 - swap bounds-check 2drop ]
[ firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )
- 1- [ dup ] [ '[ _ dip swap ] ] repeat ;
+ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: nover ( n -- )
dup 1 + '[ _ npick ] n*quot ;
dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- )
- 1- [ ] [ '[ _ dip swap ] ] repeat ;
+ 1 - [ ] [ '[ _ dip swap ] ] repeat ;
MACRO: -nrot ( n -- )
- 1- [ ] [ '[ swap _ dip ] ] repeat ;
+ 1 - [ ] [ '[ swap _ dip ] ] repeat ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
- 1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
+ 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
-IN: globs.tests
USING: tools.test globs ;
+IN: globs.tests
[ f ] [ "abd" "fdf" glob-matches? ] unit-test
[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
- { $unchecked-example "dup n groups concat sequence= ." "t" }
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } dup" "2 <groups> concat sequence= ." "t"
+ }
}
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
- { $unchecked-example "dup n clumps unclip-last [ [ first ] map ] dip append sequence= ." "t" }
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } dup" "2 <clumps> unclip-last [ [ first ] map ] dip append sequence= ." "t"
+ }
}
}
"A combinator built using clumps:"
TUPLE: abstract-groups < chunking-seq ;
M: abstract-groups length
- [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+ [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
M: abstract-groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
+ [ seq>> length ] [ n>> ] bi - 1 + ;
M: abstract-clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
+ [ n>> + 1 - ] [ seq>> ] bi set-length ;
M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
-: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
\ No newline at end of file
+: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
] each
: sort-entries ( entries -- entries' )
- [ [ key>> ] compare ] sort ;
+ [ key>> ] sort-with ;
: delete-test ( n -- obj1 obj2 )
[
: right ( n -- m ) 1 shift 2 + ; inline
-: up ( n -- m ) 1- 2/ ; inline
+: up ( n -- m ) 1 - 2/ ; inline
: data-nth ( n heap -- entry )
data>> nth-unsafe ; inline
M: heap heap-delete ( entry heap -- )
[ entry>index ] keep
- 2dup heap-size 1- = [
+ 2dup heap-size 1 - = [
nip data-pop*
] [
[ nip data-pop ] 2keep
-IN: help.apropos.tests
USING: help.apropos tools.test ;
+IN: help.apropos.tests
[ ] [ "swp" apropos ] unit-test
{ $code ": sq ( x -- y ) dup * ;" }
"(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)"
$nl
-"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
+"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word and a stack effect declaration must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
$nl
"Factor is all about code reuse through short and logical colon definitions. Breaking up a problem into small pieces which are easy to test is called " { $emphasis "factoring." }
$nl
}
"Note that words must be defined before being referenced. The following is generally invalid:"
{ $code
- ": frob accelerate particles ;"
- ": accelerate accelerator on ;"
- ": particles [ (particles) ] each ;"
+ ": frob ( what -- ) accelerate particles ;"
+ ": accelerate ( -- ) accelerator on ;"
+ ": particles ( what -- ) [ (particles) ] each ;"
}
-"You would have to place the first definition after the two others for the parser to accept the file."
+"You would have to place the first definition after the two others for the parser to accept the file. If you have a set of mutually recursive words, you can use " { $link POSTPONE: DEFER: } "."
{ $references
{ }
"word-search"
"Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast."
{ "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." }
}
-"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
+"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such as manual memory management, pointer arithmetic, and inline assembly code."
$nl
"Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
+ { "Also, " { $link dup } " and related shuffle words don't copy entire objects or arrays; they only duplicate the reference to them. If you want to guard an object against mutation, use " { $link clone } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
-IN: help.crossref.tests
USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ;
+IN: help.crossref.tests
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
-IN: help.handbook.tests
USING: help tools.test ;
+IN: help.handbook.tests
[ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" print-topic ] unit-test
-IN: help.tests
USING: tools.test help kernel ;
+IN: help.tests
[ 3 throw ] must-fail
[ ] [ :help ] unit-test
-[ ] [ f print-topic ] unit-test
\ No newline at end of file
+[ ] [ f print-topic ] unit-test
-IN: help.html.tests
USING: help.html tools.test help.topics kernel ;
+IN: help.html.tests
[ ] [ "xml" >link help>html drop ] unit-test
-[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
\ No newline at end of file
+[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
+ all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ;
: all-topics ( -- topics )
[
load-index swap >lower
'[ [ drop _ ] dip >lower subseq? ] assoc-filter
[ swap result boa ] { } assoc>map
- [ [ title>> ] compare ] sort ;
+ [ title>> ] sort-with ;
: article-apropos ( string -- results )
"articles.idx" offline-apropos ;
{ $code "USE: tools.scaffold" }
"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
-"If you look at the output, you will see that a few files were created in your “work” directory. The following phrase will print the full path of your work directory:"
+"If you look at the output, you will see that a few files were created in your “work” directory, and that the new source file was loaded."
+$nl
+"The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
"The work directory is one of several " { $link "vocabs.roots" } " where Factor searches for vocabularies. It is possible to define new vocabulary roots; see " { $link "add-vocab-roots" } ". To keep things simple in this tutorial, we'll just use the work directory, though."
$nl
-"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
-$nl
-"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
-{ $code "IN: palindrome" }
-"We will add new definitions after the " { $link POSTPONE: IN: } " form."
+"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". Open this file in your text editor."
$nl
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
{ $code
- "! Copyright (C) 2008 <your name here>"
+ "! Copyright (C) 2009 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
+ "USING: ;"
"IN: palindrome"
}
+"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word. We will add new definitions after the " { $link POSTPONE: IN: } " form."
+$nl
+"In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:"
+{ $code "USE: palindrome" }
+"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:"
+{ $code "\"palindrome\" reload" }
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
$nl
"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
$nl
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-browse } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
$nl
-"So now, add the following at the start of the source file:"
+"Go back to the third line in your source file and change it to:"
{ $code "USING: kernel ;" }
"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the listener's input area, and press " { $operation com-browse } "."
$nl
ARTICLE: "first-program-test" "Testing your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
{ $code
- "! Copyright (C) 2008 <your name here>"
+ "! Copyright (C) 2009 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
- "IN: palindrome"
"USING: kernel sequences ;"
+ "IN: palindrome"
""
": palindrome? ( str -- ? ) dup reverse = ;"
}
-"We will now test our new word in the listener. First we have add the palindrome vocabulary to the listener's vocabulary search path:"
-{ $code "USE: palindrome"}
+"We will now test our new word in the listener. If you haven't done so already, add the palindrome vocabulary to the listener's vocabulary search path:"
+{ $code "USE: palindrome" }
"Next, push a string on the stack:"
{ $code "\"hello\"" }
"Note that the stack display in the listener now shows this string. Having supplied the input, we call our word:"
$nl
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
-"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
+"Add the following two lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
- "USING: palindrome tools.test ;"
"[ f ] [ \"hello\" palindrome? ] unit-test"
"[ t ] [ \"racecar\" palindrome? ] unit-test"
}
{ $code "\"palindrome\" test" }
"The next step is to, of course, fix our code so that the unit test can pass."
$nl
-"We begin by writing a word called " { $snippet "normalize" } " which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener."
+"We begin by writing a word which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener."
$nl
"Start by pushing a character on the stack; notice that characters are really just integers:"
{ $code "CHAR: a" }
{ $code "[ Letter? ] filter >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" }
-"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
+"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link >lower } " and " { $link Letter? } " can be used in the source file."
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
-IN: help.vocabs.tests
USING: help.vocabs tools.test help.markup help vocabs ;
+IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
-[ ] [ "classes" vocab print-topic ] unit-test
\ No newline at end of file
+[ ] [ "classes" vocab print-topic ] unit-test
dup [ array? ] all? [ first ] when length ;
SYNTAX: HINTS:
- scan-object
+ scan-object dup wrapper? [ wrapped>> ] when
[ changed-definition ]
[ parse-definition { } like "specializer" set-word-prop ] bi ;
-IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
FROM: html.components => inspector ;
+IN: html.components.tests
[ ] [ begin-form ] unit-test
-IN: html.forms.tests
USING: kernel sequences tools.test assocs html.forms validators accessors
namespaces ;
FROM: html.forms => values ;
+IN: html.forms.tests
: with-validation ( quot -- messages )
[
[ value ] dip '[
[
form [ clone ] change
- 1+ "index" set-value
+ 1 + "index" set-value
"value" set-value
@
] with-scope
[ value ] dip '[
[
begin-form
- 1+ "index" set-value
+ 1 + "index" set-value
from-object
@
] with-scope
M: template-lexer skip-word
[
{
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup nth CHAR: " = ] [ drop 1 + ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
[ f skip ]
} cond
USING: http.client http.client.private http tools.test
namespaces urls ;
+IN: http.client.tests
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test http.client.post-data ;
-IN: http.client.post-data.tests
-IN: http.parsers.tests
USING: http http.parsers tools.test ;
+IN: http.parsers.tests
[ { } ] [ "" parse-cookie ] unit-test
[ { } ] [ "" parse-set-cookie ] unit-test
[ { T{ cookie { name "__s" } { value "12345567" } } } ]
[ "__s=12345567;" parse-cookie ]
-unit-test
\ No newline at end of file
+unit-test
-IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
+IN: http.server.redirection.tests
[
<request>
--- /dev/null
+IN: http.server.rewrite
+USING: help.syntax help.markup http.server ;
+
+HELP: rewrite
+{ $class-description "The class of directory rewrite responders. The slots are as follows:"
+{ $list
+ { { $slot "default" } " - the responder to call if no file name is provided." }
+ { { $slot "child" } " - the responder to call if a file name is provided." }
+ { { $slot "param" } " - the name of a request parameter which will store the first path component of the file name passed to the responder." }
+} } ;
+
+HELP: <rewrite>
+{ $values { "rewrite" rewrite } }
+{ $description "Creates a new " { $link rewrite } " responder." }
+{ $examples
+ { $code
+ "<rewrite>"
+ " <display-post-action> >>default"
+ " <display-comment-action> >>child"
+ " \"comment_id\" >>param"
+ }
+} ;
+
+HELP: vhost-rewrite
+{ $class-description "The class of virtual host rewrite responders. The slots are as follows:"
+{ $list
+ { { $slot "default" } " - the responder to call if no host name prefix is provided." }
+ { { $slot "child" } " - the responder to call if a host name prefix is provided." }
+ { { $slot "param" } " - the name of a request parameter which will store the first host name component of the host name passed to the responder." }
+ { { $slot "suffix" } " - the domain name suffix which will be chopped off the end of the request's host name in order to produce the parameter." }
+} } ;
+
+HELP: <vhost-rewrite>
+{ $values { "vhost-rewrite" vhost-rewrite } }
+{ $description "Creates a new " { $link vhost-rewrite } " responder." }
+{ $examples
+ { $code
+ "<vhost-rewrite>"
+ " <show-blogs-action> >>default"
+ " <display-blog-action> >>child"
+ " \"blog_id\" >>param"
+ " \"blogs.vegan.net\" >>suffix"
+ }
+} ;
+
+ARTICLE: "http.server.rewrite.overview" "Rewrite responder overview"
+"Rewrite responders take the file name and turn it into a request parameter named by the " { $slot "param" } " slot before delegating to a child responder. If a file name is provided, it calls the responder in the " { $slot "child" } " slot. If no file name is provided, they call the default responder in the " { $slot "default" } " slot."
+$nl
+"For example, suppose you want to have the following website schema:"
+{ $list
+{ { $snippet "/posts/" } " - show a list of posts" }
+{ { $snippet "/posts/factor_language" } " - show thread with ID " { $snippet "factor_language" } }
+{ { $snippet "/posts/factor_language/1" } " - show first comment in the thread with ID " { $snippet "factor_language" } }
+{ { $snippet "/animals" } ", ... - a bunch of other actions" } }
+"One way to achieve this would be to have a nesting of responders as follows:"
+{ $list
+{ "A dispatcher at the top level" }
+ { "A " { $link rewrite } " as a child of the dispatcher under the name " { $snippet "posts" } ". The rewrite has the " { $slot "param" } " slot set to, say, " { $snippet "post_id" } ". The " { $slot "default" } " slot is set to a Furnace action which displays a list of posts." }
+ { "The child slot is set to a second " { $link rewrite } " instance, with " { $snippet "param" } " set to " { $snippet "comment_id" } ", the " { $slot "default" } " slot set to an action which displays a post identified by the " { $snippet "post_id" } " parameter, and the " { $snippet "child" } " slot set to an action which displays the comment identified by the " { $snippet "comment_id" } " parameter." } }
+"Note that parameters can be extracted from the request using the " { $link param } " word, but most of the time you want to use " { $vocab-link "furnace.actions" } " instead." ;
+
+ARTICLE: "http.server.rewrite" "URL rewrite responders"
+"The " { $vocab-link "http.server.rewrite" } " vocabulary defines two responder types which can help make website URLs more human-friendly."
+{ $subsection "http.server.rewrite.overview" }
+"Directory rewrite responders:"
+{ $subsection rewrite }
+{ $subsection <rewrite> }
+"Virtual host rewrite responders -- these chop off the value in the " { $snippet "suffix" } " slot from the tail of the host name, and use the rest as the parameter value:"
+{ $subsection vhost-rewrite }
+{ $subsection <vhost-rewrite> } ;
+
+ABOUT: "http.server.rewrite"
\ No newline at end of file
--- /dev/null
+USING: accessors arrays http.server http.server.rewrite kernel
+namespaces tools.test urls ;
+IN: http.server.rewrite.tests
+
+TUPLE: rewrite-test-default ;
+
+M: rewrite-test-default call-responder*
+ drop "DEFAULT!" 2array ;
+
+TUPLE: rewrite-test-child ;
+
+M: rewrite-test-child call-responder*
+ drop "rewritten-param" param 2array ;
+
+V{ } clone responder-nesting set
+H{ } clone params set
+
+<rewrite>
+ rewrite-test-child new >>child
+ rewrite-test-default new >>default
+ "rewritten-param" >>param
+"rewrite" set
+
+[ { { } "DEFAULT!" } ] [ { } "rewrite" get call-responder ] unit-test
+[ { { } "xxx" } ] [ { "xxx" } "rewrite" get call-responder ] unit-test
+[ { { "blah" } "xxx" } ] [ { "xxx" "blah" } "rewrite" get call-responder ] unit-test
+
+<vhost-rewrite>
+ rewrite-test-child new >>child
+ rewrite-test-default new >>default
+ "rewritten-param" >>param
+ "blogs.vegan.net" >>suffix
+"rewrite" set
+
+[ { { } "DEFAULT!" } ] [
+ URL" http://blogs.vegan.net" url set
+ { } "rewrite" get call-responder
+] unit-test
+
+[ { { } "DEFAULT!" } ] [
+ URL" http://www.blogs.vegan.net" url set
+ { } "rewrite" get call-responder
+] unit-test
+
+[ { { } "erg" } ] [
+ URL" http://erg.blogs.vegan.net" url set
+ { } "rewrite" get call-responder
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors http.server http.server.dispatchers kernel
+namespaces sequences splitting urls ;
+IN: http.server.rewrite
+
+TUPLE: rewrite param child default ;
+
+: <rewrite> ( -- rewrite )
+ rewrite new ;
+
+M: rewrite call-responder*
+ over empty? [ default>> ] [
+ [ [ first ] [ param>> ] bi* set-param ]
+ [ [ rest ] [ child>> ] bi* ]
+ 2bi
+ ] if
+ call-responder* ;
+
+TUPLE: vhost-rewrite suffix param child default ;
+
+: <vhost-rewrite> ( -- vhost-rewrite )
+ vhost-rewrite new ;
+
+: sub-domain? ( vhost-rewrite url -- subdomain ? )
+ swap suffix>> dup [
+ [ host>> canonical-host ] [ "." prepend ] bi* ?tail
+ ] [ 2drop f f ] if ;
+
+M: vhost-rewrite call-responder*
+ dup url get sub-domain?
+ [ over param>> set-param child>> ] [ drop default>> ] if
+ call-responder ;
-USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ;
+USING: help.markup help.syntax io.streams.string quotations strings urls
+http vocabs.refresh math io.servers.connection assocs ;
IN: http.server
HELP: trivial-responder
HELP: http-insomniac
{ $description "Starts a thread which rotates the logs and e-mails a summary of HTTP requests every 24 hours. See " { $link "logging.insomniac" } "." } ;
+HELP: request-params
+{ $values { "request" request } { "assoc" assoc } }
+{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
+
+HELP: param
+{ $values
+ { "name" string }
+ { "value" string }
+}
+{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
+
+HELP: params
+{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
+
ARTICLE: "http.server.requests" "HTTP request variables"
"The following variables are set by the HTTP server at the beginning of a request."
{ $subsection request }
{ $subsection url }
{ $subsection post-request? }
{ $subsection responder-nesting }
+{ $subsection params }
+"Utility words:"
+{ $subsection param }
+{ $subsection set-param }
+{ $subsection request-params }
"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
combinators vocabs.refresh tools.time math math.parser present
-io vectors
+vectors hashtables
+io
io.sockets
io.sockets.secure
io.encodings
: split-path ( string -- path )
"/" split harvest ;
+: request-params ( request -- assoc )
+ dup method>> {
+ { "GET" [ url>> query>> ] }
+ { "HEAD" [ url>> query>> ] }
+ { "POST" [ post-data>> params>> ] }
+ } case ;
+
+SYMBOL: params
+
+: param ( name -- value )
+ params get at ;
+
+: set-param ( value name -- )
+ params get set-at ;
+
: init-request ( request -- )
- [ request set ] [ url>> url set ] bi
+ [ request set ]
+ [ url>> url set ]
+ [ request-params >hashtable params set ] tri
V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
-IN: http.server.static.tests
USING: http.server.static tools.test xml.writer ;
+IN: http.server.static.tests
-[ ] [ "resource:basis" directory>html write-xml ] unit-test
\ No newline at end of file
+[ ] [ "resource:basis" directory>html write-xml ] unit-test
] with each^2 ;
: sign-extend ( bits v -- v' )
- swap [ ] [ 1- 2^ < ] 2bi
- [ -1 swap shift 1+ + ] [ drop ] if ;
+ swap [ ] [ 1 - 2^ < ] 2bi
+ [ -1 swap shift 1 + + ] [ drop ] if ;
: read1-jpeg-dc ( decoder -- dc )
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
0 :> k!
[
color ac-huff-table>> read1-jpeg-ac
- [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+ [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri
{ 0 0 } = not
k 63 < and
] loop
array>> [ value ] map ;\r
\r
: <interval-map> ( specification -- map )\r
- all-intervals [ [ first second ] compare ] sort\r
+ all-intervals [ first second ] sort-with\r
>intervals ensure-disjoint interval-map boa ;\r
\r
: <interval-set> ( specification -- map )\r
[\r
alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip\r
[| oldkey oldval key val | ! Underneath is start\r
- oldkey 1+ key =\r
+ oldkey 1 + key =\r
oldval val = and\r
[ oldkey 2array oldval 2array , key ] unless\r
key val\r
: something ( array -- num )
{
- { [ dup 1+ 2array ] [ 3 * ] }
+ { [ dup 1 + 2array ] [ 3 * ] }
{ [ 3array ] [ + + ] }
} switch ;
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
-[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
-[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test
+[ 0 ] [ { 1 2 } [ [ 1 + 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1 + ] bi@ ] input<sequence ] undo ] unit-test
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel words summary slots quotations
+USING: accessors kernel locals words summary slots quotations
sequences assocs math arrays stack-checker effects
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
+! conditionals
+
+:: undo-if-empty ( result a b -- seq )
+ a call( -- b ) result = [ { } ] [ result b [undo] call( a -- b ) ] if ;
+
+:: undo-if* ( result a b -- boolean )
+ b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ;
+
+\ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse
+
+\ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse
+
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
reverse [ [ [undo] ] dip compose ] { } assoc>map
recover-chain ;
-MACRO: switch ( quot-alist -- ) [switch] ;
+MACRO: switch ( quot-alist -- ) [switch] ;
\ No newline at end of file
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
: num-fds ( mx -- n )
- [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
+ [ reads>> max-fd ] [ writes>> max-fd ] bi max 1 + ;
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
-IN: io.backend.windows.privileges.tests\r
USING: io.backend.windows.privileges tools.test ;\r
+IN: io.backend.windows.privileges.tests\r
\r
[ [ ] with-privileges ] must-infer\r
<PRIVATE
: encode-if< ( char stream encoding max -- )
- nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
+ nip 1 - pick < [ encode-error ] [ stream-write1 ] if ; inline
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
128 encode-if< ;
M: ascii decode-char
- 128 decode-if< ;
\ No newline at end of file
+ 128 decode-if< ;
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
- n multiple rem dup 0 = [
- drop n
+ n multiple rem [
+ n
] [
multiple swap - n +
- ] if ;
+ ] if-zero ;
TUPLE: windows-file-info < file-info attributes ;
file-info ;
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
"DWORD" <c-object>
"DWORD" <c-object>
"DWORD" <c-object>
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
[ GetVolumeInformation win32-error=0/f ] 7 nkeep
drop 5 nrot drop
[ utf16n alien>string ] 4 ndip
] if ;
: find-first-volume ( -- string handle )
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string/f )
- MAX_PATH 1+ [ <byte-array> tuck ] keep
+ MAX_PATH 1 + [ <byte-array> tuck ] keep
FindNextVolume 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
- [ [ 1- ] [ follow-link ] bi* (follow-links) ]
+ [ [ 1 - ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
IN: io.files.links.unix.tests
: make-test-links ( n path -- )
- [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
+ [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
: count-trailing-backslashes ( str n -- str n )
[ "\\" ?tail ] dip swap [
- 1+ count-trailing-backslashes
+ 1 + count-trailing-backslashes
] when ;
: fix-trailing-backslashes ( str -- str' )
TUPLE: dummy-monitor < monitor ;
M: dummy-monitor dispose
- drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
+ drop dummy-monitor-disposed get [ 1 + ] change-i drop ;
M: mock-io-backend (monitor)
nip
over exists? [
dummy-monitor new-monitor
- dummy-monitor-created get [ 1+ ] change-i drop
+ dummy-monitor-created get [ 1 + ] change-i drop
] [
"Does not exist" throw
] if ;
PRIVATE>
: run-pipeline ( seq -- results )
- [ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
+ [ length dup zero? [ drop { } ] [ 1
- <pipes> ] if ] keep
[
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
password [ B{ 0 } password! ] unless
[let | len [ password strlen ] |
- buf password len 1+ size min memcpy
+ buf password len 1 + size min memcpy
len
]
] alien-callback ;
[ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
- dup zero? [ drop ] [ gai_strerror throw ] if ;
+ [ gai_strerror throw ] unless-zero ;
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
\r
<PRIVATE\r
: levenshtein-step ( insert delete change same? -- next )\r
- 0 1 ? + [ [ 1+ ] bi@ ] dip min min ;\r
+ 0 1 ? + [ [ 1 + ] bi@ ] dip min min ;\r
\r
: lcs-step ( insert delete change same? -- next )\r
1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
\r
:: loop-step ( i j matrix old new step -- )\r
- i j 1+ matrix nth nth ! insertion\r
- i 1+ j matrix nth nth ! deletion\r
+ i j 1 + matrix nth nth ! insertion\r
+ i 1 + j matrix nth nth ! deletion\r
i j matrix nth nth ! replace/retain\r
i old nth j new nth = ! same?\r
step call\r
- i 1+ j 1+ matrix nth set-nth ; inline\r
+ i 1 + j 1 + matrix nth set-nth ; inline\r
\r
: lcs-initialize ( |str1| |str2| -- matrix )\r
[ drop 0 <array> ] with map ;\r
[ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
- [let | matrix [ old length 1+ new length 1+ init call ] |\r
+ [let | matrix [ old length 1 + new length 1 + init call ] |\r
old length [| i |\r
new length\r
[| j | i j matrix old new step loop-step ] each\r
TUPLE: trace-state old new table i j ;\r
\r
: old-nth ( state -- elt )\r
- [ i>> 1- ] [ old>> ] bi nth ;\r
+ [ i>> 1 - ] [ old>> ] bi nth ;\r
\r
: new-nth ( state -- elt )\r
- [ j>> 1- ] [ new>> ] bi nth ;\r
+ [ j>> 1 - ] [ new>> ] bi nth ;\r
\r
: top-beats-side? ( state -- ? )\r
- [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]\r
- [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
+ [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth nth ]\r
+ [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
\r
: retained? ( state -- ? )\r
{\r
\r
: do-retain ( state -- state )\r
dup old-nth retain boa ,\r
- [ 1- ] change-i [ 1- ] change-j ;\r
+ [ 1 - ] change-i [ 1 - ] change-j ;\r
\r
: inserted? ( state -- ? )\r
{\r
} 1&& ;\r
\r
: do-insert ( state -- state )\r
- dup new-nth insert boa , [ 1- ] change-j ;\r
+ dup new-nth insert boa , [ 1 - ] change-j ;\r
\r
: deleted? ( state -- ? )\r
{\r
} 1&& ;\r
\r
: do-delete ( state -- state )\r
- dup old-nth delete boa , [ 1- ] change-i ;\r
+ dup old-nth delete boa , [ 1 - ] change-i ;\r
\r
: (trace-diff) ( state -- )\r
{\r
} cond ;\r
\r
: trace-diff ( old new table -- diff )\r
- [ ] [ first length 1- ] [ length 1- ] tri trace-state boa\r
+ [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa\r
[ (trace-diff) ] { } make reverse ;\r
PRIVATE>\r
\r
{ 9 } [
<linked-hash>
- { [ 3 * ] [ 1- ] } "first" pick set-at
- { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ { [ 3 * ] [ 1 - ] } "first" pick set-at
+ { [ [ 1 - ] bi@ ] [ 2 / ] } "second" pick set-at
4 6 pick values [ first call ] each
+ swap values <reversed> [ second call ] each
] unit-test
2 "by" pick set-at
3 "cx" pick set-at
>alist
-] unit-test
\ No newline at end of file
+] unit-test
cons>> car ;
M: lazy-take cdr ( lazy-take -- cdr )
- [ n>> 1- ] keep
+ [ n>> 1 - ] keep
cons>> cdr ltake ;
M: lazy-take nil? ( lazy-take -- ? )
C: lfrom-by lazy-from-by
: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
+ [ 1 + ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
n>> ;
[ index>> ] [ seq>> nth ] bi ;
M: sequence-cons cdr ( sequence-cons -- cdr )
- [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ;
+ [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ;
M: sequence-cons nil? ( sequence-cons -- ? )
drop f ;
] unit-test
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
- { 1 2 3 4 } sequence>list [ 1+ ] lmap
+ { 1 2 3 4 } sequence>list [ 1 + ] lmap
] unit-test
{ 15 } [
] if ; inline recursive
: llength ( list -- n )
- 0 [ drop 1+ ] foldl ;
+ 0 [ drop 1 + ] foldl ;
: lreverse ( list -- newlist )
nil [ swap cons ] foldl ;
IN: scratchpad
<< CONSTANT: five 5 >>
-{ $[ five dup 1+ dup 2 + ] } .
+{ $[ five dup 1 + dup 2 + ] } .
"> "{ 5 6 8 }" }
} ;
IN: scratchpad
CONSTANT: five 5
-{ $ five $[ five dup 1+ dup 2 + ] } .
+{ $ five $[ five dup 1 + dup 2 + ] } .
"> "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $code
":: counter ( -- )"
" [let | value! [ 0 ] |"
- " [ value 1+ dup value! ]"
- " [ value 1- dup value! ] ] ;"
+ " [ value 1 + dup value! ]"
+ " [ value 1 - dup value! ] ] ;"
}
"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array."
$nl
[ 5 ] [ 10 xyzzy ] unit-test
:: let*-test-1 ( a -- b )
- [let* | b [ a 1+ ]
- c [ b 1+ ] |
+ [let* | b [ a 1 + ]
+ c [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
:: let*-test-2 ( a -- b )
- [let* | b [ a 1+ ]
- c! [ b 1+ ] |
+ [let* | b [ a 1 + ]
+ c! [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
:: let*-test-3 ( a -- b )
- [let* | b [ a 1+ ]
- c! [ b 1+ ] |
- c 1+ c! a b c 3array ] ;
+ [let* | b [ a 1 + ]
+ c! [ b 1 + ] |
+ c 1 + c! a b c 3array ] ;
[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
[ 3 ] [ 3 [| | :> a! a ] call ] unit-test
-[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
+[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
over exists? [ move-file ] [ 2drop ] if ;\r
\r
: advance-log ( path n -- )\r
- [ 1- log# ] 2keep log# ?move-file ;\r
+ [ 1 - log# ] 2keep log# ?move-file ;\r
\r
: rotate-log ( service -- )\r
dup close-log\r
C: <bits> bits
: make-bits ( number -- bits )
- dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
+ [ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline
M: bits length length>> ;
INSTANCE: bits immutable-sequence
: unbits ( seq -- number )
- <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;
+ <reversed> 0 [ [ 1 shift ] dip [ 1 + ] when ] reduce ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
-{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
+{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
{ $subsection exp }
{ $subsection cis }
{ $subsection log }
+{ $subsection log10 }
"Raising a number to a power:"
{ $subsection ^ }
+{ $subsection 10^ }
"Converting between rectangular and polar form:"
{ $subsection abs }
{ $subsection absq }
{ $values { "x" number } { "y" number } }
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+HELP: log10
+{ $values { "x" number } { "y" number } }
+{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+
HELP: sqrt
{ $values { "x" number } { "y" number } }
{ $description "Square root function." } ;
{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." }
{ $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ;
+HELP: 10^
+{ $values { "x" number } { "y" number } }
+{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ;
+
HELP: gcd
{ $values { "x" integer } { "y" integer } { "a" integer } { "d" integer } }
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
- dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
+ [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
: (^mod) ( n x y -- z )
make-bits 1 [
: divisor? ( m n -- ? )
mod 0 = ;
+ERROR: non-trivial-divisor n ;
+
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
- [ "Non-trivial divisor found" throw ] if ; foldable
+ [ non-trivial-divisor ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [
M: complex log >polar swap flog swap rect> ;
+: 10^ ( x -- y ) 10 swap ^ ; inline
+
+: log10 ( x -- y ) log 10 log / ; inline
+
GENERIC: cos ( x -- y ) foldable
M: complex cos
: round ( x -- y ) dup sgn 2 / + truncate ; inline
: floor ( x -- y )
- dup 1 mod dup zero?
- [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
+ dup 1 mod
+ [ ] [ dup 0 < [ - 1 - ] [ - ] if ] if-zero ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
: floor-to ( x step -- y )
- dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ;
+ [ [ / floor ] [ * ] bi ] unless-zero ;
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators
-accessors math.constants ;
+accessors math.constants fry ;
IN: math.intervals.tests
[ empty-interval ] [ 2 2 (a,b) ] unit-test
+[ empty-interval ] [ 2 2.0 (a,b) ] unit-test
+
[ empty-interval ] [ 2 2 [a,b) ] unit-test
[ empty-interval ] [ 2 2 (a,b] ] unit-test
0 1 (a,b) 0 1 [a,b] interval-subset?
] unit-test
+[ t ] [
+ full-interval -1/0. 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+ -1/0. 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
+[ f ] [
+ full-interval 0 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+ 0 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
[ f ] [
0 0 1 (a,b) interval-contains?
] unit-test
[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
+[ f ] [ 0 10 [a,b] 0.0 [a,a] interval< ] unit-test
+
+[ f ] [ 0.0 10 [a,b] 0 [a,a] interval< ] unit-test
+
[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
+! Accuracy of interval-mod
+[ t ] [ full-interval 40 40 [a,b] interval-mod -40 40 (a,b) interval-subset?
+] unit-test
+
! Interval random tester
: random-element ( interval -- n )
dup full-interval eq? [
} case
] if ;
-: random-unary-op ( -- pair )
+: unary-ops ( -- alist )
{
{ bitnot interval-bitnot }
{ abs interval-abs }
}
"math.ratios.private" vocab [
{ recip interval-recip } suffix
- ] when
- random ;
+ ] when ;
-: unary-test ( -- ? )
- random-interval random-unary-op ! 2dup . .
+: unary-test ( op -- ? )
+ [ random-interval ] dip
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
second execute( a -- b ) interval-contains?
] if ;
-[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
+unary-ops [
+ [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
+] each
-: random-binary-op ( -- pair )
+: binary-ops ( -- alist )
{
{ + interval+ }
{ - interval- }
{ bitand interval-bitand }
{ bitor interval-bitor }
{ bitxor interval-bitxor }
- ! { shift interval-shift }
{ min interval-min }
{ max interval-max }
}
"math.ratios.private" vocab [
{ / interval/ } suffix
- ] when
- random ;
+ ] when ;
-: binary-test ( -- ? )
- random-interval random-interval random-binary-op ! 3dup . . .
+: binary-test ( op -- ? )
+ [ random-interval random-interval ] dip
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
second execute( a b -- c ) interval-contains?
] if ;
-[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
+binary-ops [
+ [ [ t ] ] dip '[ 8000 iota [ drop _ binary-test ] all? ] unit-test
+] each
-: random-comparison ( -- pair )
+: comparison-ops ( -- alist )
{
{ < interval< }
{ <= interval<= }
{ > interval> }
{ >= interval>= }
- } random ;
+ } ;
-: comparison-test ( -- ? )
- random-interval random-interval random-comparison
+: comparison-test ( op -- ? )
+ [ random-interval random-interval ] dip
[ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
-[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
+comparison-ops [
+ [ [ t ] ] dip '[ 8000 iota [ drop _ comparison-test ] all? ] unit-test
+] each
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
-: random-commutative-op ( -- op )
+: commutative-ops ( -- seq )
{
interval+ interval*
interval-bitor interval-bitand interval-bitxor
interval-max interval-min
- } random ;
-
-[ t ] [
- 80000 iota [
- drop
- random-interval-or-empty random-interval-or-empty
- random-commutative-op
- [ execute ] [ swapd execute ] 3bi =
- ] all?
-] unit-test
+ } ;
+
+commutative-ops [
+ [ [ t ] ] dip '[
+ 8000 iota [
+ drop
+ random-interval-or-empty random-interval-or-empty _
+ [ execute ] [ swapd execute ] 3bi =
+ ] all?
+ ] unit-test
+] each
-! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
-combinators generic layouts ;
+combinators generic layouts memoize ;
IN: math.intervals
SYMBOL: empty-interval
TUPLE: interval { from read-only } { to read-only } ;
+: closed-point? ( from to -- ? )
+ 2dup [ first ] bi@ number=
+ [ [ second ] both? ] [ 2drop f ] if ;
+
: <interval> ( from to -- interval )
- 2dup [ first ] bi@ {
- { [ 2dup > ] [ 2drop 2drop empty-interval ] }
- { [ 2dup = ] [
- 2drop 2dup [ second ] both?
+ {
+ { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] }
+ { [ 2dup [ first ] bi@ number= ] [
+ 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
- [ 2drop interval boa ]
+ { [ 2dup [ { -1/0. t } = ] [ { 1/0. t } = ] bi* and ] [
+ 2drop full-interval
+ ] }
+ [ interval boa ]
} cond ;
: open-point ( n -- endpoint ) f 2array ;
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
-: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
+MEMO: fixnum-interval ( -- interval )
+ most-negative-fixnum most-positive-fixnum [a,b] ; inline
+
+MEMO: array-capacity-interval ( -- interval )
+ 0 max-array-capacity [a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline
[ 2dup [ first ] bi@ ] dip call [
2drop t
] [
- 2dup [ first ] bi@ = [
+ 2dup [ first ] bi@ number= [
[ second ] bi@ not or
] [
2drop f
] if
] if ; inline
+: endpoint= ( p1 p2 -- ? )
+ [ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] 2bi and ;
+
: endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ;
-: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] 2keep = or ;
+: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] [ endpoint= ] 2bi or ;
: endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ;
-: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] 2keep = or ;
+: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] [ endpoint= ] 2bi or ;
: endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ;
] [
interval>points
2dup [ second ] both?
- [ [ first ] bi@ = ]
+ [ [ first ] bi@ number= ]
[ 2drop f ] if
] if ;
[ (interval-abs) points>interval ]
} cond ;
-: interval-mod ( i1 i2 -- i3 )
- #! Inaccurate.
- [
- [
- nip interval-abs to>> first [ neg ] keep (a,b)
- ] interval-division-op
- ] do-empty-interval ;
-
-: interval-rem ( i1 i2 -- i3 )
- #! Inaccurate.
- [
- [
- nip interval-abs to>> first 0 swap [a,b)
- ] interval-division-op
- ] do-empty-interval ;
-
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ]
[ nip interval-singleton? ]
- [ [ from>> ] bi@ = ]
+ [ [ from>> ] bi@ endpoint= ]
2tri and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ]
[ drop interval-singleton? ]
- [ [ to>> ] bi@ = ]
+ [ [ to>> ] bi@ endpoint= ]
2tri and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
- [ from>> ] dip to>> = ;
+ [ from>> ] [ to>> ] bi* endpoint= ;
: right-endpoint-<= ( i1 i2 -- ? )
- [ to>> ] dip from>> = ;
+ [ to>> ] [ from>> ] bi* endpoint= ;
: interval<= ( i1 i2 -- ? )
{
: interval>= ( i1 i2 -- ? )
swap interval<= ;
+: interval-mod ( i1 i2 -- i3 )
+ {
+ { [ over empty-interval eq? ] [ swap ] }
+ { [ dup empty-interval eq? ] [ ] }
+ { [ dup full-interval eq? ] [ ] }
+ [ interval-abs to>> first [ neg ] keep (a,b) ]
+ } cond
+ swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ;
+
+: (rem-range) ( i -- i' ) interval-abs to>> first 0 swap [a,b) ;
+
+: interval-rem ( i1 i2 -- i3 )
+ {
+ { [ over empty-interval eq? ] [ drop ] }
+ { [ dup empty-interval eq? ] [ nip ] }
+ { [ dup full-interval eq? ] [ 2drop [0,inf] ] }
+ [ nip (rem-range) ]
+ } cond ;
+
: interval-bitand-pos ( i1 i2 -- ? )
[ to>> first ] bi@ min 0 swap [a,b] ;
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
[ first-col ] keep
- dup 1+ rows-from clear-col ;
+ dup 1 + rows-from clear-col ;
: find-row ( row# quot -- i elt )
[ rows-from ] dip find ; inline
: (echelon) ( col# row# -- )
over cols < over rows < and [
- 2dup pivot-row [ over do-row 1+ ] when*
- [ 1+ ] dip (echelon)
+ 2dup pivot-row [ over do-row 1 + ] when*
+ [ 1 + ] dip (echelon)
] [
2drop
] if ;
CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 }
: bit-pos ( n -- byte/f mask/f )
- 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
+ 30 /mod masks nth-unsafe [ drop f f ] when-zero ;
: marked-unsafe? ( n arr -- ? )
[ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
: marked-prime? ( n arr -- ? )
2dup upper-bound 2 swap between? [ bounds-error ] unless
- over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
\ No newline at end of file
+ over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
: count-factor ( n d -- n' c )
[ 1 ] 2dip [ /i ] keep
- [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
+ [ dupd /mod zero? ] curry [ nip [ 1 + ] dip ] while drop
swap ;
: write-factor ( n d -- n' d' )
: totient ( n -- t )
{
{ [ dup 2 < ] [ drop 0 ] }
- [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
+ [ dup unique-factors [ 1 [ 1 - * ] reduce ] [ product ] bi / * ]
} cond ; foldable
: divisors ( n -- seq )
[ 3 ] [ 10/3 truncate ] unit-test
[ -3 ] [ -10/3 truncate ] unit-test
-[ -1/2 ] [ 1/2 1- ] unit-test
-[ 3/2 ] [ 1/2 1+ ] unit-test
+[ -1/2 ] [ 1/2 1 - ] unit-test
+[ 3/2 ] [ 1/2 1 + ] unit-test
[ 1.0 ] [ 0.5 1/2 + ] unit-test
[ 1.0 ] [ 1/2 0.5 + ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel kernel.private math math.functions math.private ;
+USING: accessors kernel kernel.private math math.functions
+math.private sequences summary ;
IN: math.ratios
: 2>fraction ( a/b c/d -- a c b d )
PRIVATE>
+ERROR: division-by-zero x ;
+
+M: division-by-zero summary
+ drop "Division by zero" ;
+
M: integer /
- dup zero? [
- "Division by zero" throw
+ [
+ division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip [ /i ] curry bi@ fraction>
- ] if ;
+ ] if-zero ;
M: ratio hashcode*
nip >fraction [ hashcode ] bi@ bitxor ;
--- /dev/null
+IN: math.vectors.specialization.tests
+USING: compiler.tree.debugger math.vectors tools.test kernel
+kernel.private math specialized-arrays.double
+specialized-arrays.complex-float
+specialized-arrays.float ;
+
+[ V{ t } ] [
+ [ { double-array double-array } declare distance 0.0 < not ] final-literals
+] unit-test
+
+[ V{ float } ] [
+ [ { float-array float } declare v*n norm ] final-classes
+] unit-test
+
+[ V{ number } ] [
+ [ { complex-float-array complex-float-array } declare v. ] final-classes
+] unit-test
+
+[ V{ real } ] [
+ [ { complex-float-array complex } declare v*n norm ] final-classes
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel make sequences effects kernel.private accessors
+combinators math math.intervals math.vectors namespaces assocs fry
+splitting classes.algebra generalizations
+compiler.tree.propagation.info ;
+IN: math.vectors.specialization
+
+SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
+
+: signature-for-schema ( array-type elt-type schema -- signature )
+ [
+ {
+ { +vector+ [ drop ] }
+ { +scalar+ [ nip ] }
+ { +nonnegative+ [ nip ] }
+ } case
+ ] with with map ;
+
+: (specialize-vector-word) ( word array-type elt-type schema -- word' )
+ signature-for-schema
+ [ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f <word> ]
+ [ [ , \ declare , def>> % ] [ ] make ]
+ [ drop stack-effect ]
+ 2tri
+ [ define-declared ] [ 2drop ] 3bi ;
+
+: output-infos ( array-type elt-type schema -- value-infos )
+ [
+ {
+ { +vector+ [ drop <class-info> ] }
+ { +scalar+ [ nip <class-info> ] }
+ { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
+ } case
+ ] with with map ;
+
+: record-output-signature ( word array-type elt-type schema -- word )
+ output-infos
+ [ drop ]
+ [ drop ]
+ [ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri
+ "outputs" set-word-prop ;
+
+CONSTANT: vector-words
+H{
+ { [v-] { +vector+ +vector+ -> +vector+ } }
+ { distance { +vector+ +vector+ -> +nonnegative+ } }
+ { n*v { +scalar+ +vector+ -> +vector+ } }
+ { n+v { +scalar+ +vector+ -> +vector+ } }
+ { n-v { +scalar+ +vector+ -> +vector+ } }
+ { n/v { +scalar+ +vector+ -> +vector+ } }
+ { norm { +vector+ -> +nonnegative+ } }
+ { norm-sq { +vector+ -> +nonnegative+ } }
+ { normalize { +vector+ -> +vector+ } }
+ { v* { +vector+ +vector+ -> +vector+ } }
+ { v*n { +vector+ +scalar+ -> +vector+ } }
+ { v+ { +vector+ +vector+ -> +vector+ } }
+ { v+n { +vector+ +scalar+ -> +vector+ } }
+ { v- { +vector+ +vector+ -> +vector+ } }
+ { v-n { +vector+ +scalar+ -> +vector+ } }
+ { v. { +vector+ +vector+ -> +scalar+ } }
+ { v/ { +vector+ +vector+ -> +vector+ } }
+ { v/n { +vector+ +scalar+ -> +vector+ } }
+ { vceiling { +vector+ -> +vector+ } }
+ { vfloor { +vector+ -> +vector+ } }
+ { vmax { +vector+ +vector+ -> +vector+ } }
+ { vmin { +vector+ +vector+ -> +vector+ } }
+ { vneg { +vector+ -> +vector+ } }
+ { vtruncate { +vector+ -> +vector+ } }
+}
+
+SYMBOL: specializations
+
+specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
+
+: add-specialization ( new-word signature word -- )
+ specializations get at set-at ;
+
+: word-schema ( word -- schema ) vector-words at ;
+
+: inputs ( schema -- seq ) { -> } split first ;
+
+: outputs ( schema -- seq ) { -> } split second ;
+
+: specialize-vector-word ( word array-type elt-type -- word' )
+ pick word-schema
+ [ inputs (specialize-vector-word) ]
+ [ outputs record-output-signature ] 3bi ;
+
+: input-signature ( word -- signature ) def>> first ;
+
+: specialize-vector-words ( array-type elt-type -- )
+ [ vector-words keys ] 2dip
+ '[
+ [ _ _ specialize-vector-word ] keep
+ [ dup input-signature ] dip
+ add-specialization
+ ] each ;
+
+: find-specialization ( classes word -- word/f )
+ specializations get at
+ [ first [ class<= ] 2all? ] with find
+ swap [ second ] when ;
+
+: vector-word-custom-inlining ( #call -- word/f )
+ [ in-d>> [ value-info class>> ] map ] [ word>> ] bi
+ find-specialization ;
+
+vector-words keys [
+ [ vector-word-custom-inlining ]
+ "custom-inlining" set-word-prop
+] each
\ No newline at end of file
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+<PRIVATE
+
: 2tetra@ ( p q r s t u v w quot -- )
dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+PRIVATE>
+
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
[ 89 ] [ 10 fib ] unit-test
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ;
dup bytes>> length 256 < [ fill-bytes ] when ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
- dupd [ length ] bi@ 1- - short cut-slice swap ;
+ dupd [ length ] bi@ 1 - - short cut-slice swap ;
: dump-until-separator ( multipart -- multipart )
dup
\r
3 <model> "x" set\r
"x" get [ 2 * ] <arrow> dup "z" set\r
-[ 1+ ] <arrow> "y" set\r
+[ 1
+ ] <arrow> "y" set
\r [ ] [ "y" get activate-model ] unit-test\r
[ t ] [ "z" get "x" get connections>> memq? ] unit-test\r
[ 7 ] [ "y" get value>> ] unit-test\r
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors models models.arrow inverse kernel ;
+IN: models.illusion
+
+TUPLE: illusion < arrow ;
+
+: <illusion> ( model quot -- illusion )
+ illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
+ swap >>quot over >>model [ add-dependency ] keep ;
+
+: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ;
+
+: backtalk ( value object -- )
+ [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
+
+M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
--- /dev/null
+Two Way Arrows
\ No newline at end of file
M: model model-activated drop ;
: ref-model ( model -- n )
- [ 1+ ] change-ref ref>> ;
+ [ 1 + ] change-ref ref>> ;
: unref-model ( model -- n )
- [ 1- ] change-ref ref>> ;
+ [ 1 - ] change-ref ref>> ;
: activate-model ( model -- )
dup ref-model 1 = [
\r
TUPLE: an-observer { i integer } ;\r
\r
-M: an-observer model-changed nip [ 1+ ] change-i drop ;\r
+M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
\r
[ 1 0 ] [\r
[let* | m1 [ 1 <model> ]\r
o1 i>>\r
o2 i>>\r
]\r
-] unit-test
\ No newline at end of file
+] unit-test\r
: parse-multiline-string ( end-text -- str )
[
lexer get
- [ 1+ swap (parse-multiline-string) ]
+ [ 1 + swap (parse-multiline-string) ]
change-column drop
] "" make ;
: gl-function-number ( -- n )
+gl-function-number-counter+ get-global
- dup 1+ +gl-function-number-counter+ set-global ;
+ dup 1 + +gl-function-number-counter+ set-global ;
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
dup zero? [
2drop epsilon
] [
- [ exactly-n ] [ 1- at-most-n ] 2bi 2choice
+ [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice
] if ;
: at-least-n ( parser n -- parser' )
: next-id ( -- n )
#! Return the next unique id for a parser
id get-global [
- dup 1+ id set-global
+ dup 1 + id set-global
] [
1 id set-global 0
] if* ;
IN: persistent.hashtables.config
: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
-: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable
-: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline
+: radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable
+: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline
{
{ [ 2dup root>> eq? ] [ nip ] }
{ [ over not ] [ 2drop T{ persistent-hash } ] }
- [ count>> 1- persistent-hash boa ]
+ [ count>> 1 - persistent-hash boa ]
} cond ;
M: persistent-hash >alist [ root>> >alist% ] { } make ;
persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.bitmap
-: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline
+: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
[let* | shift [ bitmap-node shift>> ]
[ 1array ] dip node boa ;
: 2node ( first second -- node )
- [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+ [ 2array ] [ drop level>> 1 + ] 2bi node boa ;
: new-child ( new-child node -- node' expansion/f )
dup full? [ tuck level>> 1node ] [ node-add f ] if ;
: new-last ( val seq -- seq' )
- [ length 1- ] keep new-nth ;
+ [ length 1 - ] keep new-nth ;
: node-set-last ( child node -- node' )
clone [ new-last ] change-children ;
clone
dup tail>> full?
[ ppush-new-tail ] [ ppush-tail ] if
- [ 1+ ] change-count ;
+ [ 1 + ] change-count ;
: node-set-nth ( val i node -- node' )
clone [ new-nth ] change-children ;
clone
dup tail>> children>> length 1 >
[ ppop-tail ] [ ppop-new-tail ] if
- ] dip 1- >>count
+ ] dip 1 - >>count
]
} case ;
] [
CHAR: y = [
over zero?
- [ 2drop t ] [ [ 1- ] dip consonant? not ] if
+ [ 2drop t ] [ [ 1 - ] dip consonant? not ] if
] [
2drop t
] if
: skip-vowels ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless
+ 2dup consonant? [ [ 1 + ] dip skip-vowels ] unless
] when ;
: skip-consonants ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ [ 1+ ] dip skip-consonants ] when
+ 2dup consonant? [ [ 1 + ] dip skip-consonants ] when
] when ;
: (consonant-seq) ( n i str -- n )
skip-vowels
2dup bounds-check? [
- [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip
+ [ 1 + ] [ 1 + ] [ ] tri* skip-consonants [ 1 + ] dip
(consonant-seq)
] [
2drop
over 1 < [
2drop f
] [
- 2dup nth [ over 1- over nth ] dip = [
+ 2dup nth [ over 1 - over nth ] dip = [
consonant?
] [
2drop f
{ [ "bl" ?tail ] [ "ble" append ] }
{ [ "iz" ?tail ] [ "ize" append ] }
{
- [ dup length 1- over double-consonant? ]
+ [ dup length 1 - over double-consonant? ]
[ dup "lsz" last-is? [ but-last-slice ] unless ]
}
{
: ll->l ( str -- newstr )
{
{ [ dup last CHAR: l = not ] [ ] }
- { [ dup length 1- over double-consonant? not ] [ ] }
+ { [ dup length 1 - over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
} cond ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
- 1+ cut [ (remove-breakpoints) ] bi@
+ 1 + cut [ (remove-breakpoints) ] bi@
[ -> ] glue
] [
drop
] each
] with-row
] each
- ] tabular-output nl ;
\ No newline at end of file
+ ] tabular-output nl ;
line-limit? [
"..." write pprinter get return
] when
- pprinter get [ 1+ ] change-line-count drop
+ pprinter get [ 1 + ] change-line-count drop
nl do-indent
] if ;
TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ \ text new-section
+ over length 1 + \ text new-section
swap >>style
swap >>string ;
: group-flow ( seq -- newseq )
[
dup length [
- 2dup 1- swap ?nth prev set
- 2dup 1+ swap ?nth next set
+ 2dup 1 - swap ?nth prev set
+ 2dup 1 + swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split harvest ;
: take-some ( seqs -- seqs seq )
0 over [ length + dup 76 >= ] find drop nip
- [ 1- cut-slice swap ] [ f swap ] if* concat ;
+ [ 1 - cut-slice swap ] [ f swap ] if* concat ;
: divide-lines ( strings -- strings )
[ dup ] [ take-some ] produce nip ;
(>>i) ;
M: random-dummy random-32* ( obj -- r )
- [ dup 1+ ] change-i drop ;
+ [ dup 1 + ] change-i drop ;
: y ( n seq -- y )
[ nth-unsafe 31 mask-bit ]
- [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
+ [ [ 1 + ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
: mt[k] ( offset n seq -- )
[
[
seq>>
[ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
- [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
bi
] [ 0 >>i drop ] bi ; inline
: init-mt-formula ( i seq -- f(seq[i]) )
- dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
+ dupd nth dup -30 shift bitxor 1812433253 * + 1 + 32 bits ; inline
: init-mt-rest ( seq -- )
- n 1- swap '[
- _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
+ n 1 - swap '[
+ _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi
] each ; inline
: init-mt-seq ( seed -- seq )
M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
[ seq>> nth-unsafe mt-temper ]
- [ [ 1+ ] change-i drop ] tri ;
+ [ [ 1 + ] change-i drop ] tri ;
[
[ 32 random-bits ] with-system-random
<PRIVATE
: random-integer ( n -- n' )
- dup log2 7 + 8 /i 1+
+ dup log2 7 + 8 /i 1 +
[ random-bytes >byte-array byte-array>bignum ]
[ 3 shift 2^ ] bi / * >integer ;
: randomize ( seq -- seq )
dup length [ dup 1 > ]
- [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
+ [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
: delete-random ( seq -- elt )
: to-times ( term n -- ast )
dup zero?
[ 2drop epsilon ]
- [ dupd 1- to-times 2array <concatenation> <maybe> ]
+ [ dupd 1 - to-times 2array <concatenation> <maybe> ]
if ;
M: from-to <times>
drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
M: ^ question>quot
- drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ;
M: $unix question>quot
drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ;
M: ^unix question>quot
- drop [ { [ drop zero? ] [ [ 1- ] dip ?nth CHAR: \n = ] } 2|| ] ;
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ;
M: word-break question>quot
drop [ word-break-at? ] ;
M: lookbehind question>quot ! Returns ( index string -- ? )
term>> <reversed-option>
ast>dfa dfa>reverse-shortest-word
- '[ [ 1- ] dip f _ execute ] ;
+ '[ [ 1 - ] dip f _ execute ] ;
: check-string ( string -- string )
! Make this configurable
:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
i string regexp quot call dup [| j |
j i j
- reverse? [ swap [ 1+ ] bi@ ] when
+ reverse? [ swap [ 1 + ] bi@ ] when
string
] [ drop f f f f ] if ; inline
: search-range ( i string reverse? -- seq )
- [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline
+ [ drop dup 1 + -1 ] [ length 1 ] if range boa ; inline
:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
f f f f
[ subseq ] map-matches ;
: count-matches ( string regexp -- n )
- [ 0 ] 2dip [ 3drop 1+ ] each-match ;
+ [ 0 ] 2dip [ 3drop 1 + ] each-match ;
<PRIVATE
dup skip-blank [
[ index-from ] 2keep
[ swapd subseq ]
- [ 2drop 1+ ] 3bi
+ [ 2drop 1 + ] 3bi
] change-lexer-column ;
: parse-noblank-token ( lexer -- str/f )
"prettyprint" vocab [
"regexp.prettyprint" require
-] when
\ No newline at end of file
+] when
M: complex-sequence length
seq>> length -1 shift ;
M: complex-sequence nth-unsafe
- complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ;
+ complex@ [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi rect> ;
M: complex-sequence set-nth-unsafe
complex@
[ [ real-part ] [ ] [ ] tri* set-nth-unsafe ]
- [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ;
+ [ [ imaginary-part ] [ 1 + ] [ ] tri* set-nth-unsafe ] 3bi ;
! The last case is needed because a very large number would
! otherwise be confused with a small number.
: serialize-cell ( n -- )
- dup zero? [ drop 0 write1 ] [
+ [ 0 write1 ] [
dup HEX: 7e <= [
HEX: 80 bitor write1
] [
- dup log2 8 /i 1+
+ dup log2 8 /i 1 +
dup HEX: 7f >= [
HEX: ff write1
dup serialize-cell
] if
>be write
] if
- ] if ;
+ ] if-zero ;
: deserialize-cell ( -- n )
read1 {
drop CHAR: n write1 ;
M: integer (serialize) ( obj -- )
- dup zero? [
- drop CHAR: z write1
+ [
+ CHAR: z write1
] [
dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
serialize-cell
- ] if ;
+ ] if-zero ;
M: float (serialize) ( obj -- )
CHAR: F write1
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
- binary [ serialize ] with-byte-writer ;
\ No newline at end of file
+ binary [ serialize ] with-byte-writer ;
<PRIVATE
:: insert ( seq quot: ( elt -- elt' ) n -- )
n zero? [
- n n 1- [ seq nth quot call ] bi@ >= [
- n n 1- seq exchange
- seq quot n 1- insert
+ n n 1 - [ seq nth quot call ] bi@ >= [
+ n n 1 - seq exchange
+ seq quot n 1 - insert
] unless
] unless ; inline recursive
PRIVATE>
HINTS: (double-array) { 2 } { 3 } ;
-HINTS: vneg { array } { double-array } ;
-HINTS: v*n { array object } { double-array float } ;
-HINTS: n*v { array object } { float double-array } ;
-HINTS: v/n { array object } { double-array float } ;
-HINTS: n/v { object array } { float double-array } ;
-HINTS: v+ { array array } { double-array double-array } ;
-HINTS: v- { array array } { double-array double-array } ;
-HINTS: v* { array array } { double-array double-array } ;
-HINTS: v/ { array array } { double-array double-array } ;
-HINTS: vmax { array array } { double-array double-array } ;
-HINTS: vmin { array array } { double-array double-array } ;
-HINTS: v. { array array } { double-array double-array } ;
-HINTS: norm-sq { array } { double-array } ;
-HINTS: norm { array } { double-array } ;
-HINTS: normalize { array } { double-array } ;
-HINTS: distance { array array } { double-array double-array } ;
-
! Type functions
USING: words classes.algebra compiler.tree.propagation.info
math.intervals ;
-{ v+ v- v* v/ vmax vmin } [
- [
- [ class>> double-array class<= ] both?
- double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ n*v n/v } [
- [
- nip class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ v*n v/n } [
- [
- drop class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ vneg normalize } [
- [
- class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
\ norm-sq [
class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
] "outputs" set-word-prop
-\ v. [
- [ class>> double-array class<= ] both?
- float object ? <class-info>
-] "outputs" set-word-prop
-
\ distance [
[ class>> double-array class<= ] both?
[ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private prettyprint.custom
-kernel words classes math parser alien.c-types byte-arrays
-accessors summary ;
+kernel words classes math math.vectors.specialization parser
+alien.c-types byte-arrays accessors summary ;
IN: specialized-arrays.functor
ERROR: bad-byte-array-length byte-array type ;
INSTANCE: A sequence
+A T c-type-boxed-class specialize-vector-words
+
;FUNCTOR
[ length ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each
] { } make
- dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
+ dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
swap
] dip
- '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
+ '[ first2 [ 1 + ] bi@ _ _ boa ] map ; inline
PRIVATE>
drop
[ downward-slices ]
[ stable-slices ]
- [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+ [ upward-slices ] tri 3append [ from>> ] sort-with
]
} case ;
continuations assocs combinators compiler.errors accessors math.order
definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
-stack-checker.recursive-state ;
+stack-checker.recursive-state summary ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
-: bad-call ( -- )
- "call must be given a callable" time-bomb ;
+ERROR: bad-call obj ;
+
+M: bad-call summary
+ drop "call must be given a callable" ;
: infer-literal-quot ( literal -- )
dup recursive-quotation? [
[ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
- drop bad-call
+ value>> \ bad-call boa time-bomb
] if
] if ;
\ compose [ infer-compose ] "special" set-word-prop
+ERROR: bad-executable obj ;
+
+M: bad-executable summary
+ drop "execute must be given a word" ;
+
: infer-execute ( -- )
pop-literal nip
dup word? [
apply-object
] [
- drop
- "execute must be given a word" time-bomb
+ \ bad-executable boa time-bomb
] if ;
\ execute [ infer-execute ] "special" set-word-prop
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> second 1+ { tuple } <effect>
+ peek-d literal value>> second 1 + { tuple } <effect>
apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
+++ /dev/null
-
-: spill-integer-base ( -- n )
- stack-frame get spill-counts>> double-float-regs swap at
- double-float-regs reg-size * ;
-
-: spill-integer@ ( n -- offset )
- cells spill-integer-base + param@ ;
-
-: spill-float@ ( n -- offset )
- double-float-regs reg-size * param@ ;
-
-: (stack-frame-size) ( stack-frame -- n )
- [
- {
- [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
- [ gc-roots>> cells ]
- [ params>> ]
- [ return>> ]
- } cleave
- ] sum-outputs ;
\ No newline at end of file
: from-to ( index begin suffix-array -- from/f to/f )
swap '[ _ head? not ]
- [ find-last-from drop dup [ 1+ ] when ]
+ [ find-last-from drop dup [ 1 + ] when ]
[ find-from drop ] 3bi ;
: <funky-slice> ( from/f to/f seq -- slice )
! erg's bug
GENERIC: some-generic ( a -- b )
-M: integer some-generic 1+ ;
+M: integer some-generic 1 + ;
[ 4 ] [ 3 some-generic ] unit-test
[ 4 ] [ 3 some-generic ] unit-test
-[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1 - ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
: some-code ( -- )
f my-generic drop ;
-[ ] [ some-code ] unit-test
\ No newline at end of file
+[ ] [ some-code ] unit-test
:: (fuzzy) ( accum i full ch -- accum i full ? )
ch i full index-from [
:> i i accum push
- accum i 1+ full t
+ accum i 1 + full t
] [
f -1 full f
] if* ;
[
2dup number=
[ drop ] [ nip V{ } clone pick push ] if
- 1+
+ 1 +
] keep pick last push
] each ;
: score-1 ( i full -- n )
{
{ [ over zero? ] [ 2drop 10 ] }
- { [ 2dup length 1- number= ] [ 2drop 4 ] }
- { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
- { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
+ { [ 2dup length 1 - number= ] [ 2drop 4 ] }
+ { [ 2dup [ 1 - ] dip nth Letter? not ] [ 2drop 10 ] }
+ { [ 2dup [ 1 + ] dip nth Letter? not ] [ 2drop 4 ] }
[ 2drop 1 ]
} cond ;
{ } { "math.partial-dispatch" } strip-vocab-globals %
+ { } { "math.vectors.specialization" } strip-vocab-globals %
+
{ } { "peg" } strip-vocab-globals %
] when
CONSTANT: +listener-input+ "<Listener input>"
-M: source-file-error summary
+: error-location ( error -- string )
[
- [ file>> [ % ": " % ] [ +listener-input+ % ] if* ]
- [ line#>> [ # ] when* ] bi
+ [ file>> [ % ] [ +listener-input+ % ] if* ]
+ [ line#>> [ ": " % # ] when* ] bi
] "" make ;
+M: source-file-error summary error>> summary ;
+
M: source-file-error error.
- [ summary print nl ]
+ [ error-location print nl ]
[ asset>> [ "Asset: " write short. nl ] when* ]
[ error>> error. ]
tri ;
'[ _ ndup _ narray _ prefix ] ;
: experiment. ( seq -- )
- [ first write ": " write ] [ rest . ] bi ;
+ [ first write ": " write ] [ rest . flush ] bi ;
:: experiment ( word: ( -- error ? ) line# -- )
word <experiment> :> e
M: test-failure error. ( error -- )
{
- [ summary print nl ]
+ [ error-location print nl ]
[ asset>> [ experiment. nl ] when* ]
[ error>> error. ]
[ traceback-button. ]
lf>crlf [
utf16n string>alien
EmptyClipboard win32-error=0/f
- GMEM_MOVEABLE over length 1+ GlobalAlloc
+ GMEM_MOVEABLE over length 1 + GlobalAlloc
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
<PRIVATE
-: page-elt ( editor -- editor element ) dup visible-lines 1- <page-elt> ;
+: page-elt ( editor -- editor element ) dup visible-lines 1
- <page-elt> ;
PRIVATE>
: this-line-and-next ( document line -- start end )
[ nip 0 swap 2array ]
- [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ]
+ [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ]
2bi ;
: last-line? ( document line -- ? )
[ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
: available-space ( pref-dim gap dims -- avail )
- length 1+ * [-] ; inline
+ length 1 + * [-] ; inline
: -center) ( pref-dim gap filled-cell dims -- )
[ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline
[ <frame-grid> ] dip new-grid ; inline
: <frame> ( cols rows -- frame )
- frame new-frame ;
\ No newline at end of file
+ frame new-frame ;
mock-gadget new 0 >>graft-called 0 >>ungraft-called ;
M: mock-gadget graft*
- [ 1+ ] change-graft-called drop ;
+ [ 1 + ] change-graft-called drop ;
M: mock-gadget ungraft*
- [ 1+ ] change-ungraft-called drop ;
+ [ 1 + ] change-ungraft-called drop ;
! We can't print to output-stream here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
3 [
<mock-gadget> over <model> >>model
"g" get over add-gadget drop
- swap 1+ number>string set
+ swap 1 + number>string set
] each ;
: status-flags ( -- seq )
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
\ No newline at end of file
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
: line>y ( n gadget -- y ) line-height * >integer ;
: validate-line ( m gadget -- n )
- control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
+ control-value [ drop f ] [ length 1 - min 0 max ] if-empty ;
: valid-line? ( n gadget -- ? )
- control-value length 1- 0 swap between? ;
+ control-value length 1 - 0 swap between? ;
: visible-line ( gadget quot -- n )
'[
[ loc>> ] visible-line ;
: last-visible-line ( gadget -- n )
- [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1+ ;
+ [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ;
: each-slice-index ( from to seq quot -- )
[ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
2bi 2array ;
: visible-lines ( gadget -- n )
- [ visible-dim second ] [ line-height ] bi /i ;
\ No newline at end of file
+ [ visible-dim second ] [ line-height ] bi /i ;
: <operations-menu> ( target hook -- menu )
over object-operations
[ primary-operation? ] partition
- [ reverse ] [ [ [ command-name ] compare ] sort ] bi*
+ [ reverse ] [ [ command-name ] sort-with ] bi*
{ ---- } glue <commands-menu> ;
: show-operations-menu ( gadget target hook -- )
column-line-color
selection-required?
single-click?
-selected-value
+selection
min-rows
min-cols
max-rows
{ $subsection column-titles } ;
ARTICLE: "ui.gadgets.tables.selection" "Table row selection"
-"At any given time, a single row in the table may be selected."
-$nl
"A few slots in the table gadget concern row selection:"
{ $table
- { { $slot "selected-value" } { " - if set to a model, the currently selected row's value, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
- { { $slot "selected-index" } " - the index of the currently selected row." }
+ { { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
+ { { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } }
{ { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } }
+ { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } }
}
"Some words for row selection:"
-{ $subsection selected-row }
-{ $subsection (selected-row) } ;
+{ $subsection selected-rows }
+{ $subsection (selected-rows) }
+{ $subsection selected } ;
ARTICLE: "ui.gadgets.tables.actions" "Table row actions"
"When the user double-clicks on a row, or presses " { $command table "row" row-action } " while a row is selected, optional action and hook quotations are invoked. The action receives the row value and the hook receives the table gadget itself. These quotations are stored in the " { $slot "action" } " and " { $snippet "hook" } " slots of a table, respectively."
IN: ui.gadgets.tables.tests
USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
-models namespaces tools.test kernel combinators ;
+models namespaces tools.test kernel combinators prettyprint arrays ;
SINGLETON: test-renderer
[ selected-row drop ]
} cleave
] with-grafted-gadget
-] unit-test
\ No newline at end of file
+] unit-test
+
+SINGLETON: silly-renderer
+
+M: silly-renderer row-columns drop unparse 1array ;
+
+M: silly-renderer column-titles drop { "Foo" } ;
+
+: test-table-2 ( -- table )
+ { 1 2 f } <model> silly-renderer <table> ;
+
+[ f f ] [
+ test-table dup [
+ selected-row
+ ] with-grafted-gadget
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors colors.constants fry kernel math
-math.functions math.rectangles math.order math.vectors namespaces
-opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
-ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-models math.ranges combinators
-combinators.short-circuit fonts locals strings ;
+USING: accessors assocs hashtables arrays colors colors.constants fry
+kernel math math.functions math.ranges math.rectangles math.order
+math.vectors namespaces opengl sequences ui.gadgets
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
+ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images
+ui.gadgets.menus ui.gadgets.line-support models combinators
+combinators.short-circuit fonts locals strings sets sorting ;
IN: ui.gadgets.tables
! Row rendererer protocol
{ mouse-color initial: COLOR: black }
column-line-color
selection-required?
-selected-index selected-value
+selection
+selection-index
+selected-indices
mouse-index
{ takes-focus? initial: t }
-focused? ;
+focused?
+multiple-selection? ;
+
+<PRIVATE
+
+: add-selected-index ( table n -- table )
+ over selected-indices>> conjoin ;
+
+: multiple>single ( values -- value/f ? )
+ dup assoc-empty? [ drop f f ] [ values first t ] if ;
+
+: selected-index ( table -- n )
+ selected-indices>> multiple>single drop ;
+
+: set-selected-index ( table n -- table )
+ dup associate >>selected-indices ;
+
+PRIVATE>
+
+: selected ( table -- index/indices )
+ [ selected-indices>> ] [ multiple-selection?>> ] bi
+ [ multiple>single drop ] unless ;
: new-table ( rows renderer class -- table )
new-line-gadget
swap >>renderer
swap >>model
- f <model> >>selected-value
sans-serif-font >>font
focus-border-color >>focus-border-color
- transparent >>column-line-color ; inline
+ transparent >>column-line-color
+ f <model> >>selection-index
+ f <model> >>selection
+ H{ } clone >>selected-indices ;
: <table> ( rows renderer -- table ) table new-table ;
: row-bounds ( table row -- loc dim )
row-rect rect-bounds ; inline
-: draw-selected-row ( table -- )
+: draw-selected-rows ( table -- )
{
- { [ dup selected-index>> not ] [ drop ] }
+ { [ dup selected-indices>> assoc-empty? ] [ drop ] }
[
- [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
- row-bounds gl-fill-rect
+ [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
+ [ swap row-bounds gl-fill-rect ] curry each
]
} cond ;
: draw-focused-row ( table -- )
{
{ [ dup focused?>> not ] [ drop ] }
- { [ dup selected-index>> not ] [ drop ] }
+ { [ dup selected-index not ] [ drop ] }
[
- [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
+ [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri
row-bounds gl-rect
]
} cond ;
dup renderer>> column-alignment
[ ] [ column-widths>> length 0 <repetition> ] ?if ;
-:: row-font ( row index table -- font )
+:: row-font ( row ind table -- font )
table font>> clone
row table renderer>> row-color [ >>foreground ] when*
- index table selected-index>> = [ table selection-color>> >>background ] when ;
+ ind table selected-indices>> key?
+ [ table selection-color>> >>background ] when ;
: draw-columns ( columns widths alignment font gap -- )
'[ [ _ ] 3dip _ draw-column ] 3each ;
dup control-value empty? [ drop ] [
dup line-height \ line-height [
{
- [ draw-selected-row ]
+ [ draw-selected-rows ]
[ draw-lines ]
[ draw-column-lines ]
[ draw-focused-row ]
PRIVATE>
-: (selected-row) ( table -- value/f ? )
- [ selected-index>> ] keep nth-row ;
+: (selected-rows) ( table -- assoc )
+ [ selected-indices>> ] keep
+ '[ _ nth-row drop ] assoc-map ;
+
+: selected-rows ( table -- assoc )
+ [ selected-indices>> ] [ ] [ renderer>> ] tri
+ '[ _ nth-row drop _ row-value ] assoc-map ;
+
+: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
-: selected-row ( table -- value/f ? )
- [ (selected-row) ] keep
- swap [ renderer>> row-value t ] [ 2drop f f ] if ;
+: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
<PRIVATE
-: update-selected-value ( table -- )
- [ selected-row drop ] [ selected-value>> ] bi set-model ;
+: set-table-model ( model value multiple? -- )
+ [ values ] [ multiple>single drop ] if swap set-model ;
+
+: update-selected ( table -- )
+ [
+ [ selection>> ]
+ [ selected-rows ]
+ [ multiple-selection?>> ] tri
+ set-table-model
+ ]
+ [
+ [ selection-index>> ]
+ [ selected-indices>> ]
+ [ multiple-selection?>> ] tri
+ set-table-model
+ ] bi ;
: show-row-summary ( table n -- )
over nth-row
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
: find-row-index ( value table -- n/f )
- [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
+ [ model>> value>> ] [ renderer>> ] bi
+ '[ _ row-value eq? ] with find drop ;
-: initial-selected-index ( table -- n/f )
+: (update-selected-indices) ( table -- set )
+ [ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep
+ '[ _ find-row-index ] map sift unique f assoc-like ;
+
+: initial-selected-indices ( table -- set )
{
[ model>> value>> empty? not ]
[ selection-required?>> ]
- [ drop 0 ]
+ [ drop { 0 } unique ]
} 1&& ;
-: (update-selected-index) ( table -- n/f )
- [ selected-value>> value>> ] keep over
- [ find-row-index ] [ 2drop f ] if ;
-
-: update-selected-index ( table -- n/f )
+: update-selected-indices ( table -- set )
{
- [ (update-selected-index) ]
- [ initial-selected-index ]
+ [ (update-selected-indices) ]
+ [ initial-selected-indices ]
} 1|| ;
M: table model-changed
- nip dup update-selected-index {
- [ >>selected-index f >>mouse-index drop ]
- [ show-row-summary ]
- [ drop update-selected-value ]
+ nip dup update-selected-indices {
+ [ >>selected-indices f >>mouse-index drop ]
+ [ multiple>single drop show-row-summary ]
+ [ drop update-selected ]
[ drop relayout ]
} 2cleave ;
: thin-row-rect ( table row -- rect )
row-rect [ { 0 1 } v* ] change-dim ;
+: scroll-to-row ( table n -- )
+ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
+
+: add-selected-row ( table n -- )
+ [ scroll-to-row ]
+ [ add-selected-index relayout-1 ] 2bi ;
+
: (select-row) ( table n -- )
- [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
- [ >>selected-index relayout-1 ]
+ [ scroll-to-row ]
+ [ set-selected-index relayout-1 ]
2bi ;
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
-: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+: if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
[ [ mouse-row ] keep 2dup valid-line? ]
[ ] [ '[ nip @ ] ] tri* if ; inline
+: (table-button-down) ( quot table -- )
+ dup takes-focus?>> [ dup request-focus ] when swap
+ '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
+
: table-button-down ( table -- )
- dup takes-focus?>> [ dup request-focus ] when
- [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
+ [ (select-row) ] swap (table-button-down) ;
+
+: continued-button-down ( table -- )
+ dup multiple-selection?>>
+ [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
+
+: thru-button-down ( table -- )
+ dup multiple-selection?>> [
+ [ 2dup over selected-index (a,b) swap
+ [ swap add-selected-index drop ] curry each add-selected-row ]
+ swap (table-button-down)
+ ] [ table-button-down ] if ;
PRIVATE>
: table-button-up ( table -- )
dup [ mouse-row ] keep valid-line? [
- dup row-action? [ row-action ] [ update-selected-value ] if
+ dup row-action? [ row-action ] [ update-selected ] if
] [ drop ] if ;
PRIVATE>
: select-row ( table n -- )
over validate-line
[ (select-row) ]
- [ drop update-selected-value ]
+ [ drop update-selected ]
[ show-row-summary ]
2tri ;
<PRIVATE
: prev/next-row ( table n -- )
- [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
+ [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ;
: previous-row ( table -- )
-1 prev/next-row ;
0 select-row ;
: last-row ( table -- )
- dup control-value length 1- select-row ;
+ dup control-value length 1 - select-row ;
: prev/next-page ( table n -- )
- over visible-lines 1- * prev/next-row ;
+ over visible-lines 1 - * prev/next-row ;
: previous-page ( table -- )
-1 prev/next-page ;
{ mouse-enter show-mouse-help }
{ mouse-leave hide-mouse-help }
{ motion show-mouse-help }
- { T{ button-down } table-button-down }
+ { T{ button-down f { S+ } 1 } thru-button-down }
+ { T{ button-down f { A+ } 1 } continued-button-down }
{ T{ button-up } table-button-up }
+ { T{ button-up f { S+ } } table-button-up }
+ { T{ button-down } table-button-down }
{ gain-focus focus-table }
{ lose-focus unfocus-table }
{ T{ drag } table-button-down }
dup renderer>> column-titles
[ <column-headers> ] [ drop f ] if ;
-PRIVATE>
\ No newline at end of file
+PRIVATE>
:: gradient-vertices ( direction dim colors -- seq )
direction dim v* dim over v- swap
- colors length dup 1- v/n [ v*n ] with map
+ colors length dup 1 - v/n [ v*n ] with map
swap [ over v+ 2array ] curry map
concat concat >float-array ;
[ colors>> draw-gradient ]
} cleave ;
-M: gradient pen-background 2drop transparent ;
\ No newline at end of file
+M: gradient pen-background 2drop transparent ;
\r
M: uniscribe-renderer x>offset ( x font string -- n )\r
[ 2drop 0 ] [\r
- cached-script-string x>line-offset 0 = [ 1+ ] unless\r
+ cached-script-string x>line-offset 0 = [ 1 + ] unless\r
] if-empty ;\r
\r
M: uniscribe-renderer offset>x ( n font string -- x )\r
: com-help ( debugger -- ) error>> error-help-window ;
-: com-edit ( debugger -- ) error>> (:edit) ;
+: com-edit ( debugger -- ) error>> edit-error ;
\ com-edit H{ { +listener+ t } } define-command
! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
{ { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } }
{ { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
- { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
{ { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
+ { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
} ;
ABOUT: "ui.tools.error-list"
60 >>min-cols
60 >>max-cols
t >>selection-required?
- error-list source-file>> >>selected-value ;
+ error-list source-file>> >>selection ;
SINGLETON: error-renderer
60 >>min-cols
60 >>max-cols
t >>selection-required?
- error-list error>> >>selected-value ;
+ error-list error>> >>selection ;
TUPLE: error-display < track ;
{ 5 5 } >>gap
error-list <error-list-toolbar> f track-add
error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
- error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
- error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+ error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/4 track-add
+ error-list error-display>> "Details" <labeled-gadget> 1/2 track-add
{ 5 5 } <filled-border> 1 track-add ;
M: error-list-gadget focusable-child*
make-mirror [ <slot-description> ] { } assoc>map ;
M: hashtable make-slot-descriptions
- call-next-method [ [ key-string>> ] compare ] sort ;
+ call-next-method [ key-string>> ] sort-with ;
: <inspector-table> ( model -- table )
[ make-slot-descriptions ] <arrow> inspector-renderer <table>
V{ } clone 0 history boa ;
: history-add ( history -- input )
- dup elements>> length 1+ >>index
+ dup elements>> length 1 + >>index
[ document>> doc-string [ <input> ] [ empty? ] bi ] keep
'[ [ _ elements>> push ] keep ] unless ;
[ set-doc-string ] [ clear-undo drop ] 2bi ;
: change-history-index ( history i -- )
- over elements>> length 1-
+ over elements>> length 1 -
'[ _ + _ min 0 max ] change-index drop ;
: history-recall ( history i -- )
M: interactor dispose drop ;
: go-to-error ( interactor error -- )
- [ line>> 1- ] [ column>> ] bi 2array
+ [ line>> 1 - ] [ column>> ] bi 2array
over set-caret
mark>caret ;
[ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
\ No newline at end of file
+ [ com-end ] [ call-next-method ] bi ;
horizontal <track>
{ 3 3 } >>gap
profiler vocabs>> vocab-renderer <profiler-table>
- profiler vocab>> >>selected-value
+ profiler vocab>> >>selection
10 >>min-rows
10 >>max-rows
"Vocabularies" <labeled-gadget>
horizontal <track>
{ 3 3 } >>gap
profiler <generic-model> word-renderer <profiler-table>
- profiler generic>> >>selected-value
+ profiler generic>> >>selection
"Generic words" <labeled-gadget>
1/2 track-add
profiler <class-model> word-renderer <profiler-table>
- profiler class>> >>selected-value
+ profiler class>> >>selection
"Classes" <labeled-gadget>
1/2 track-add
1/2 track-add
] [
[
[ traverse-step traverse-from-path ]
- [ tuck children>> swap first 1+ tail-slice % ] 2bi
+ [ tuck children>> swap first 1 + tail-slice % ] 2bi
] make-node
] if
] if ;
traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- )
- [ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
+ [ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
: traverse-post ( topath gadget -- )
traverse-step traverse-to-path ;
M: gadget leaves* conjoin ;
-: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
\ No newline at end of file
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
#! etc.
swap 2array windows get-global push
windows get-global dup length 1 >
- [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
+ [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
windows [ [ first = not ] with filter ] change-global ;
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
- nip swap length or 1+ ;
+ nip swap length or 1 + ;
: first-grapheme-from ( start str -- i )
over tail-slice first-grapheme + ;
swap [ format/extended? not ] find-from drop ;
: walk-up ( str i -- j )
- dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
+ dupd 1 + (walk-up) [ 1 + (walk-up) ] [ drop f ] if* ;
: (walk-down) ( str i -- j )
swap [ format/extended? not ] find-last-from drop ;
: walk-down ( str i -- j )
- dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
+ dupd (walk-down) [ 1 - (walk-down) ] [ drop f ] if* ;
: word-break? ( str i table-entry -- ? )
{
: first-word ( str -- i )
[ unclip-slice word-break-prop over <enum> ] keep
'[ swap _ word-break-next ] assoc-find 2drop
- nip swap length or 1+ ;
+ nip swap length or 1 + ;
: >words ( str -- words )
[ first-word ] >pieces ;
<PRIVATE
: nth-next ( i str -- str[i-1] str[i] )
- [ [ 1- ] keep ] dip '[ _ nth ] bi@ ;
+ [ [ 1 - ] keep ] dip '[ _ nth ] bi@ ;
PRIVATE>
:: assert= ( test spec quot -- )
spec [
[
- [ 1- test nth ] bi@
+ [ 1 - test nth ] bi@
[ 1quotation ] [ quot curry ] bi* unit-test
] with each
] assoc-each ;
! Normalization -- Composition
: initial-medial? ( str i -- ? )
- { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
+ { [ swap nth initial? ] [ 1 + swap ?nth medial? ] } 2&& ;
: --final? ( str i -- ? )
2 + swap ?nth final? ;
: compose-jamo ( str i -- str i )
2dup initial-medial? [
2dup --final? [ imf, ] [ im, ] if
- ] [ 2dup swap nth , 1+ ] if ;
+ ] [ 2dup swap nth , 1 + ] if ;
: pass-combining ( str -- str i )
dup [ non-starter? not ] find drop
: get-str ( state i -- ch )
swap [ i>> + ] [ str>> ] bi ?nth ; inline
: current ( state -- ch ) 0 get-str ; inline
-: to ( state -- state ) [ 1+ ] change-i ; inline
+: to ( state -- state ) [ 1 + ] change-i ; inline
: push-after ( ch state -- state ) [ ?push ] change-after ; inline
:: try-compose ( state new-char current-class -- state )
:: (compose) ( str i -- )
i str ?nth [
dup jamo? [ drop str i compose-jamo ] [
- i 1+ str ?nth combining-class
- [ str i 1+ compose-combining ] [ , str i 1+ ] if
+ i 1 + str ?nth combining-class
+ [ str i 1 + compose-combining ] [ , str i 1 + ] if
] if (compose)
] when* ; inline recursive
#! first group is -1337, legacy unix code
-1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
<int> [ getgrouplist io-error ] 2keep
- [ 4 tail-slice ] [ *int 1- ] bi* >groups ;
+ [ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
PRIVATE>
HEX: ff00 bitand -8 shift ; inline
: WIFSIGNALED ( status -- ? )
- HEX: 7f bitand 1+ -1 shift 0 > ; inline
+ HEX: 7f bitand 1 + -1 shift 0 > ; inline
: WCOREFLAG ( -- value )
HEX: 80 ; inline
: <front-node> ( elt front -- node )
[
unroll-factor 0 <array>
- [ unroll-factor 1- swap set-nth ] keep f
+ [ unroll-factor 1 - swap set-nth ] keep f
] dip [ node boa dup ] keep
dup [ (>>prev) ] [ 2drop ] if ; inline
] [ dup front>> >>back ] if* drop ; inline
: push-front/new ( elt list -- )
- unroll-factor 1- >>front-pos
+ unroll-factor 1 - >>front-pos
[ <front-node> ] change-front
normalize-back ; inline
: push-front/existing ( elt list front -- )
- [ [ 1- ] change-front-pos ] dip
+ [ [ 1 - ] change-front-pos ] dip
[ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
M: unrolled-list push-front*
: pop-front/existing ( list front -- )
[ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
- [ 1+ ] change-front-pos
+ [ 1 + ] change-front-pos
drop ; inline
M: unrolled-list pop-front*
dup front>> [ empty-unrolled-list ] unless*
- over front-pos>> unroll-factor 1- eq?
+ over front-pos>> unroll-factor 1 - eq?
[ pop-front/new ] [ pop-front/existing ] if ;
: <back-node> ( elt back -- node )
normalize-front ; inline
: push-back/existing ( elt list back -- )
- [ [ 1+ ] change-back-pos ] dip
- [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline
+ [ [ 1 + ] change-back-pos ] dip
+ [ back-pos>> 1 - ] [ data>> ] bi* set-nth-unsafe ; inline
M: unrolled-list push-back*
dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
M: unrolled-list peek-back
dup back>>
- [ [ back-pos>> 1- ] dip data>> nth-unsafe ]
+ [ [ back-pos>> 1 - ] dip data>> nth-unsafe ]
[ empty-unrolled-list ]
if* ;
dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
: pop-back/existing ( list back -- )
- [ [ 1- ] change-back-pos ] dip
+ [ [ 1 - ] change-back-pos ] dip
[ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
drop ; inline
2dup length 2 - >= [
2drop
] [
- [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
+ [ 1 + dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup nth dup CHAR: % = [
drop url-decode-% [ 3 + ] dip
] [
- , [ 1+ ] dip
+ , [ 1 + ] dip
] if url-decode-iter
] if ;
[ f ] [ foo ] unit-test\r
[ ] [ 3 to: foo ] unit-test\r
[ 3 ] [ foo ] unit-test\r
-[ ] [ \ foo [ 1+ ] change-value ] unit-test\r
+[ ] [ \ foo [ 1 + ] change-value ] unit-test\r
[ 4 ] [ foo ] unit-test\r
M: vlist ppush
>vlist<
2dup length = [ unshare ] unless
- [ [ 1+ swap ] dip push ] keep vlist boa ;
+ [ [ 1 + swap ] dip push ] keep vlist boa ;
ERROR: empty-vlist-error ;
M: vlist ppop
[ empty-vlist-error ]
- [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+ [ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ;
M: vlist clone
[ length>> ] [ vector>> >vector ] bi vlist boa ;
: valist-at ( key i array -- value ? )
over 0 >= [
3dup nth-unsafe = [
- [ 1+ ] dip nth-unsafe nip t
+ [ 1 + ] dip nth-unsafe nip t
] [
[ 2 - ] dip valist-at
] if
PRIVATE>\r
\r
: (load) ( prefix -- failures )\r
- child-vocabs-recursive no-roots no-prefixes\r
+ [ child-vocabs-recursive no-roots no-prefixes ]\r
+ [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi\r
filter-unportable\r
require-all ;\r
\r
<PRIVATE
: sort-vocabs ( seq -- seq' )
- [ [ vocab-name ] compare ] sort ;
+ [ vocab-name ] sort-with ;
: pprint-using ( seq -- )
[ "syntax" vocab = not ] filter
"windows.com.wrapper.callbacks" create-vocab drop
: (next-vtbl-counter) ( -- n )
- +vtbl-counter+ [ 1+ dup ] change ;
+ +vtbl-counter+ [ 1 + dup ] change ;
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
_
- [ alien-unsigned-4 1+ dup ]
+ [ alien-unsigned-4 1 + dup ]
[ set-alien-unsigned-4 ]
2bi
] ;
length "void*" heap-size * '[
_
[ drop ]
- [ alien-unsigned-4 1- dup ]
+ [ alien-unsigned-4 1 - dup ]
[ set-alien-unsigned-4 ]
2tri
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
- [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ]
+ [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
[\r
- 2dup f 0 DragQueryFile 1+ ! get size of filename buffer\r
+ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
dup "WCHAR" <c-array>\r
[ swap DragQueryFile drop ] keep\r
alien>u16-string\r
GetLastError n>win32-error-string ;
: (win32-error) ( n -- )
- dup zero? [
- drop
- ] [
- win32-error-string throw
- ] if ;
+ [ win32-error-string throw ] unless-zero ;
: win32-error ( -- )
GetLastError (win32-error) ;
: line-offset>x ( n script-string -- x )
2dup string>> length = [
ssa>> ! ssa
- swap 1- ! icp
+ swap 1 - ! icp
TRUE ! fTrailing
] [
ssa>>
: number<-> ( doc -- dup )
0 over [
dup var>> [
- over >>var [ 1+ ] dip
+ over >>var [ 1 + ] dip
] unless drop
] each-interpolated drop ;
swap
[ version-1.0?>> over text? not ]
[ check>> ] bi and [
- spot get [ 1+ ] change-column drop
+ spot get [ 1 + ] change-column drop
disallowed-char
] [ drop ] if
] [ drop ] if* ;
: record ( spot char -- spot )
over char>> [
CHAR: \n =
- [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if
+ [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if
>>column
] [ drop ] if ;
: take-string ( match -- string )
dup length <circular-string>
spot get '[ 2dup _ string-matches? ] take-until nip
- dup length rot length 1- - head
+ dup length rot length 1 - - head
get-char [ missing-close ] unless next ;
: expect ( string -- )
: next-token, ( len id -- )
[ position get 2dup + ] dip token,
- position get + dup 1- position set last-offset set ;
+ position get + dup 1 - position set last-offset set ;
: push-context ( rules -- )
context [ <line-context> ] change ;
M: object new-sequence drop 0 <array> ;
-M: f new-sequence drop dup zero? [ drop f ] [ 0 <array> ] if ;
+M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ;
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
-IN: assocs.tests
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations specialized-arrays.double ;
+IN: assocs.tests
[ t ] [ H{ } dup assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
H{ { 1 3 } { 2 5 } }
H{ { 1 7 } { 5 6 } }
} assoc-refine
-] unit-test
\ No newline at end of file
+] unit-test
{ "set-retainstack" "kernel" (( rs -- )) }
{ "set-callstack" "kernel" (( cs -- )) }
{ "exit" "system" (( n -- )) }
- { "data-room" "memory" (( -- cards generations )) }
- { "code-room" "memory" (( -- code-free code-total )) }
+ { "data-room" "memory" (( -- cards decks generations )) }
+ { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
-IN: byte-arrays.tests\r
USING: tools.test byte-arrays sequences kernel ;\r
+IN: byte-arrays.tests\r
\r
[ 6 B{ 1 2 3 } ] [\r
6 B{ 1 2 3 } resize-byte-array\r
\r
[ -10 B{ } resize-byte-array ] must-fail\r
\r
-[ B{ 123 } ] [ 123 1byte-array ] unit-test
\ No newline at end of file
+[ B{ 123 } ] [ 123 1byte-array ] unit-test\r
-IN: byte-vectors.tests\r
USING: tools.test byte-vectors vectors sequences kernel\r
prettyprint ;\r
+IN: byte-vectors.tests\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
+++ /dev/null
-IN: checksums.tests
-USING: checksums tools.test ;
-
[ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
- #! normalize-path (file-reader) is equivalen to
+ #! normalize-path (file-reader) is equivalent to
#! binary <file-reader>. We use the lower-level form
#! so that we can move io.encodings.binary to basis/.
[ normalize-path (file-reader) ] dip checksum-stream ;
{ $subsection classes-intersect? }\r
{ $subsection min-class }\r
"Low-level implementation detail:"\r
-{ $subsection class-types }\r
{ $subsection flatten-class }\r
{ $subsection flatten-builtin-class }\r
{ $subsection class-types }\r
: class= ( first second -- ? )\r
[ class<= ] [ swap class<= ] 2bi and ;\r
\r
+ERROR: topological-sort-failed ;\r
+\r
: largest-class ( seq -- n elt )\r
dup [ [ class< ] with any? not ] curry find-last\r
- [ "Topological sort failed" throw ] unless* ;\r
+ [ topological-sort-failed ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
- [ [ name>> ] compare ] sort >vector\r
+ [ name>> ] sort-with >vector\r
[ dup empty? not ]\r
[ dup largest-class [ over delete-nth ] dip ]\r
produce nip ;\r
-IN: classes.builtin.tests
USING: tools.test words sequences kernel memory accessors ;
+IN: classes.builtin.tests
[ f ] [
[ word? ] instances
[ swap classes-intersect? ]
} cond ;
-M: anonymous-intersection (flatten-class)
- participants>> [ flatten-builtin-class ] map
- [
- builtins get sift [ (flatten-class) ] each
- ] [
- [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
- ] if-empty ;
-
-M: anonymous-complement (flatten-class)
- drop builtins get sift [ (flatten-class) ] each ;
+: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ;
+
+M: anonymous-complement (flatten-class) drop full-cover ;
--- /dev/null
+USING: kernel tools.test generic generic.standard ;
+IN: classes.intersection.tests
+
+TUPLE: a ;
+TUPLE: a1 < a ; TUPLE: a2 < a ; TUPLE: a3 < a2 ;
+MIXIN: b
+INSTANCE: a3 b
+INSTANCE: a1 b
+INTERSECTION: c a2 b ;
+
+GENERIC: x ( a -- b )
+
+M: c x drop c ;
+M: a x drop a ;
+
+[ a ] [ T{ a } x ] unit-test
+[ a ] [ T{ a1 } x ] unit-test
+[ a ] [ T{ a2 } x ] unit-test
+
+[ t ] [ T{ a3 } c? ] unit-test
+[ t ] [ T{ a3 } \ x effective-method M\ c x eq? nip ] unit-test
+[ c ] [ T{ a3 } x ] unit-test
+
+! More complex case
+TUPLE: t1 ;
+TUPLE: t2 < t1 ; TUPLE: t3 < t1 ;
+TUPLE: t4 < t2 ; TUPLE: t5 < t2 ;
+
+UNION: m t4 t5 t3 ;
+INTERSECTION: i t2 m ;
+
+GENERIC: g ( a -- b )
+
+M: i g drop i ;
+M: t4 g drop t4 ;
+
+[ t4 ] [ T{ t4 } g ] unit-test
+[ i ] [ T{ t5 } g ] unit-test
\ No newline at end of file
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences kernel assocs combinators classes
+USING: words accessors sequences kernel assocs combinators classes
classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;
+
+! Horribly inefficient and inaccurate
+: intersect-flattened-classes ( seq1 seq2 -- seq3 )
+ ! Only keep those in seq1 that intersect something in seq2.
+ [ [ classes-intersect? ] with any? ] curry filter ;
+
+M: anonymous-intersection (flatten-class)
+ participants>> [ full-cover ] [
+ [ flatten-class keys ]
+ [ intersect-flattened-classes ] map-reduce
+ [ dup set ] each
+ ] if-empty ;
PREDICATE: tuple-c < tuple-b slot>> ;
-GENERIC: ptest ( tuple -- )
-M: tuple-a ptest drop ;
-M: tuple-c ptest drop ;
+GENERIC: ptest ( tuple -- x )
+M: tuple-a ptest drop tuple-a ;
+M: tuple-c ptest drop tuple-c ;
-[ ] [ tuple-b new ptest ] unit-test
+[ tuple-a ] [ tuple-b new ptest ] unit-test
+[ tuple-c ] [ tuple-b new t >>slot ptest ] unit-test
+
+PREDICATE: tuple-d < tuple-a slot>> ;
+
+GENERIC: ptest' ( tuple -- x )
+M: tuple-a ptest' drop tuple-a ;
+M: tuple-d ptest' drop tuple-d ;
+
+[ tuple-a ] [ tuple-b new ptest' ] unit-test
+[ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test
-IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
arrays classes.tuple eval multiline ;
+IN: classes.tuple.parser.tests
TUPLE: test-1 ;
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
-] [ error>> unexpected-eof? ] must-fail-with
\ No newline at end of file
+] [ error>> unexpected-eof? ] must-fail-with
{ $subsection POSTPONE: SLOT: }
"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
$nl
-"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots:"
-{ $snippet "SLOT: length" "SLOT: underlying" }
+"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots: " { $snippet "SLOT: length" } " and " { $snippet "SLOT: underlying" } ". "
"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations."
$nl
"For example, compare the definitions of the " { $link sbuf } " class,"
{ $list
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
+ { { $snippet "\"layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
} } ;
HELP: define-tuple-predicate
{ $values { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link cond } " to " { $snippet "assoc" } "."
$nl
-"the generated quotation is more efficient than the naive implementation of " { $link cond } ", though, since it expands into a series of conditionals, and no iteration through " { $snippet "assoc" } " has to be performed." }
+"The generated quotation is more efficient than the naive implementation of " { $link cond } ", though, since it expands into a series of conditionals, and no iteration through " { $snippet "assoc" } " has to be performed." }
{ $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
HELP: case>quot
] if ;
: <buckets> ( initial length -- array )
- next-power-of-2 swap [ nip clone ] curry map ;
+ next-power-of-2 iota swap [ nip clone ] curry map ;
: distribute-buckets ( alist initial quot -- buckets )
swapd [ [ dup first ] dip call 2array ] curry map
HELP: with-destructors
{ $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error. Destructors are run in reverse order from the order in which they were registered." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
{ $code
-IN: effects.tests
USING: effects tools.test prettyprint accessors sequences ;
+IN: effects.tests
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
-[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
\ No newline at end of file
+[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
: parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] produce nip ;
+ERROR: stack-effect-omits-dashes effect ;
+
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
- [ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
+ [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
: complete-effect ( -- effect )
"(" expect ")" parse-effect ;
$nl
"Here is an example:"
{ $code
- "GENERIC: explain"
+ "GENERIC: explain ( object -- )"
"M: object explain drop \"an object\" print ;"
"M: number explain drop \"a number\" print ;"
"M: sequence explain drop \"a sequence\" print ;"
"The linear order is the following, from least-specific to most-specific:"
{ $code "{ object sequence number }" }
"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
-{ $code "M: integer explain drop \"a sequence\" print ;" }
+{ $code "M: integer explain drop \"an integer\" print ;" }
"Now, the linear order is the following, from least-specific to most-specific:"
{ $code "{ object sequence number integer }" }
"The " { $link order } " word can be useful to clarify method dispatch order:"
-IN: generic.math.tests
USING: generic.math math tools.test kernel ;
+IN: generic.math.tests
! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
-IN: generic.single.tests
USING: tools.test math math.functions math.constants generic.standard
generic.single strings sequences arrays kernel accessors words
specialized-arrays.double byte-arrays bit-arrays parser namespaces
make quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors.double
definitions generic sets graphs assocs grouping see eval ;
+IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )
! Corner case
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
-must-fail-with
\ No newline at end of file
+must-fail-with
default get <array> [ <enum> swap update ] keep ;
: lo-tag-number ( class -- n )
- "type" word-prop dup num-tags get member?
+ "type" word-prop dup num-tags get iota member?
[ drop object tag-number ] unless ;
M: tag-dispatch-engine compile-engine
: keep-going? ( assoc -- ? )
assumed get swap second first class<= ;
+ERROR: unreachable ;
+
: prune-redundant-predicates ( assoc -- default assoc' )
{
- { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup empty? ] [ drop [ unreachable ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]
-IN: hashtables.tests
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
+IN: hashtables.tests
[ f ] [ "hi" V{ 1 2 3 } at ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
-[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
\ No newline at end of file
+[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
-IN: io.backend.tests
USING: tools.test io.backend kernel ;
+IN: io.backend.tests
[ ] [ "a" normalize-path drop ] unit-test
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
+: >le ( x n -- byte-array ) iota [ nth-byte ] with B{ } map-as ;
: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
PRIVATE>
: code-point-length ( n -- x )
- dup zero? [ drop 1 ] [
+ [ 1 ] [
log2 {
{ [ dup 0 6 between? ] [ 1 ] }
{ [ dup 7 10 between? ] [ 2 ] }
{ [ dup 11 15 between? ] [ 3 ] }
{ [ dup 16 20 between? ] [ 4 ] }
} cond nip
- ] if ;
+ ] if-zero ;
: code-point-offsets ( string -- indices )
0 [ code-point-length + ] accumulate swap suffix ;
" 16 group"
"] with-disposal"
}
-"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
+"This code is robust, however it is more complex than it needs to be. This is where the default stream words come in; using them, the above can be rewritten as follows:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
{ $subsection write1 }
{ $subsection write }
"If the default output stream is a character stream (" { $link stream-element-type } " outputs " { $link +character+ } "), lines of text can be written:"
-{ $subsection readln }
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
- [ [ 1+ ] change-index drop ] bi ;
+ [ [ 1 + ] change-index drop ] bi ;
{ $subsection until }
"To execute one iteration of a loop, use the following word:"
{ $subsection do }
-"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns first on the first iteration. To ensure the body executes at least once, use " { $link do } ":"
+"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns false on the first iteration. To ensure the body executes at least once, use " { $link do } ":"
{ $code
"[ P ] [ Q ] do while"
}
-IN: system.tests\r
USING: layouts math tools.test ;\r
+IN: system.tests\r
\r
[ t ] [ cell integer? ] unit-test\r
[ t ] [ bootstrap-cell integer? ] unit-test\r
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
-io vectors arrays math.parser combinators continuations ;
+io vectors arrays math.parser combinators continuations
+source-files.errors ;
IN: lexer
TUPLE: lexer text line line-text line-length column ;
ERROR: unexpected want got ;
-PREDICATE: unexpected-tab < unexpected
- got>> CHAR: \t = ;
-
: forbid-tab ( c -- c )
- [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
: skip ( i seq ? -- n )
over length
TUPLE: lexer-error line column line-text error ;
+M: lexer-error error-file error>> error-file ;
+M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
+
: <lexer-error> ( msg -- error )
\ lexer-error new
lexer get
$nl
"On the other hand, using " { $link make } " instead of a single call to " { $link surround } " is overkill. The below headings summarize the most important cases where other idioms are more appropriate than " { $link make } "."
{ $heading "Make versus combinators" }
-"Sometimes, usages of " { $link make } " are better expressed with " { $link "sequences-combinators" } ". For example, instead of calling a combinator with a quotation which executes " { $link , } " exactly once on each iteration, oftena combinator encapsulating that specific idiom exists and can be used."
+"Sometimes, usages of " { $link make } " are better expressed with " { $link "sequences-combinators" } ". For example, instead of calling a combinator with a quotation which executes " { $link , } " exactly once on each iteration, often a combinator encapsulating that specific idiom exists and can be used."
$nl
"For example,"
{ $code "[ [ 42 * , ] each ] { } make" }
over zero? [
2drop 0.0
] [
- dup zero? [
- 2drop 1/0.
+ [
+ drop 1/0.
] [
pre-scale
/f-loop over odd?
[ zero? [ 1 + ] unless ] [ drop ] if
post-scale
- ] if
+ ] if-zero
] if ; inline
M: bignum /f ( m n -- f )
{ $description
"Outputs one of the following:"
{ $list
- "-1 if " { $snippet "x" } " is negative"
- "0 if " { $snippet "x" } " is equal to 0"
- "1 if " { $snippet "x" } " is positive"
+ { "-1 if " { $snippet "x" } " is negative" }
+ { "0 if " { $snippet "x" } " is equal to 0" }
+ { "1 if " { $snippet "x" } " is positive" }
}
} ;
PRIVATE>
+ERROR: log2-expects-positive x ;
+
: log2 ( x -- n )
dup 0 <= [
- "log2 expects positive inputs" throw
+ log2-expects-positive
] [
(log2)
] if ; inline
{ $subsection "order-specifiers" }
"Utilities for comparing objects:"
{ $subsection after? }
-{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
[
dup 0 < negative? set
abs 1 /mod
- [ dup zero? [ drop "" ] [ (>base) sign append ] if ]
+ [ [ "" ] [ (>base) sign append ] if-zero ]
[
[ numerator (>base) ]
[ denominator (>base) ] bi
HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: data-room ( -- cards generations )
-{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
+HELP: data-room ( -- cards decks generations )
+{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ;
-HELP: code-room ( -- code-free code-total )
-{ $values { "code-free" "bytes free in the code heap" } { "code-total" "total bytes in the code heap" } }
+HELP: code-room ( -- code-total code-used code-free largest-free-block )
+{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } }
{ $description "Queries the runtime for memory usage information." } ;
HELP: size ( obj -- n )
ARTICLE: "parsing-words" "Parsing words"
"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
$nl
-"Parsing words are defined using the a defining word:"
+"Parsing words are defined using the defining word:"
{ $subsection POSTPONE: SYNTAX: }
"Parsing words have uppercase names by convention. Here is the simplest possible parsing word; it prints a greeting at parse time:"
{ $code "SYNTAX: HELLO \"Hello world\" print ;" }
}
} ;
-{ if-empty when-empty unless-empty } related-words
+HELP: if-zero
+{ $values { "n" number } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the number is zero. A zero is dropped and " { $snippet "quot1" } " is called. Otherwise, if the number is not zero, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ "3 [ \"zero\" ] [ sq ] if-zero ."
+ "9"
+} ;
+
+HELP: when-zero
+{ $values
+ { "n" number } { "quot" "the first quotation of an " { $link if-zero } } }
+{ $description "Makes an implicit check if the sequence is empty. A zero is dropped and the " { $snippet "quot" } " is called." }
+{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:"
+ { $example
+ "USING: sequences prettyprint ;"
+ "0 [ 4 ] [ ] if-zero ."
+ "4"
+ }
+ { $example
+ "USING: sequences prettyprint ;"
+ "0 [ 4 ] when-zero ."
+ "4"
+ }
+} ;
+
+HELP: unless-zero
+{ $values
+ { "n" number } { "quot" "the second quotation of an " { $link if-empty } } }
+{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." }
+{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:"
+ { $example
+ "USING: sequences math prettyprint ;"
+ "3 [ ] [ sq ] if-empty ."
+ "9"
+ }
+ { $example
+ "USING: sequences math prettyprint ;"
+ "3 [ sq ] unless-zero ."
+ "9"
+ }
+} ;
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $examples "Get random numbers until zero is reached:"
{ $unchecked-example
"USING: random sequences prettyprint math ;"
- "100 [ random dup zero? [ drop f ] when ] follow ."
+ "100 [ random [ f ] when-zero ] follow ."
"{ 100 86 34 32 24 11 7 2 }"
} } ;
$nl
"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
+ARTICLE: "sequences-if" "Control flow with sequences"
+"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided."
+$nl
+"Checking if a sequence is empty:"
+{ $subsection if-empty }
+{ $subsection when-empty }
+{ $subsection unless-empty }
+"Checking if a number is zero:"
+{ $subsection if-zero }
+{ $subsection when-zero }
+{ $subsection unless-zero } ;
+
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
"Using sequences for looping:"
{ $subsection "sequences-integers" }
{ $subsection "math.ranges" }
+"Using sequences for control flow:"
+{ $subsection "sequences-if" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
: empty? ( seq -- ? ) length 0 = ; inline
+<PRIVATE
+
+: (if-empty) ( seq quot1 quot2 quot3 -- )
+ [ [ drop ] prepose ] [ ] tri* if ; inline
+
+PRIVATE>
+
: if-empty ( seq quot1 quot2 -- )
- [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+ [ dup empty? ] (if-empty) ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline
: unless-empty ( seq quot -- ) [ ] swap if-empty ; inline
+: if-zero ( n quot1 quot2 -- )
+ [ dup zero? ] (if-empty) ; inline
+
+: when-zero ( n quot -- ) [ ] if-zero ; inline
+
+: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
+
: delete-all ( seq -- ) 0 swap set-length ;
: first ( seq -- first ) 0 swap nth ; inline
<PRIVATE
+ERROR: integer-length-expected obj ;
+
: check-length ( n -- n )
#! Ricing.
- dup integer? [ "length not an integer" throw ] unless ; inline
+ dup integer? [ integer-length-expected ] unless ; inline
: ((copy)) ( dst i src j n -- dst i src j n )
dup -roll [
: reduce ( seq identity quot -- result )
swapd each ; inline
+: map-integers ( len quot exemplar -- newseq )
+ [ over ] dip [ [ collect ] keep ] new-like ; inline
+
: map-as ( seq quot exemplar -- newseq )
- [ over length ] dip [ [ map-into ] keep ] new-like ; inline
+ [ (each) ] dip map-integers ; inline
: map ( seq quot -- newseq )
over map-as ; inline
[ -rot ] dip 2each ; inline
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
- [ (2each) ] dip map-as ; inline
+ [ (2each) ] dip map-integers ; inline
: 2map ( seq1 seq2 quot -- newseq )
pick 2map-as ; inline
(3each) each ; inline
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
- [ (3each) ] dip map-as ; inline
+ [ (3each) ] dip map-integers ; inline
: 3map ( seq1 seq2 seq3 quot -- newseq )
[ pick ] dip swap 3map-as ; inline
3tri ;
: reverse-here ( seq -- )
- [ length 2/ ] [ length ] [ ] tri
+ [ length 2/ iota ] [ length ] [ ] tri
[ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
<PRIVATE
: (start) ( subseq seq n -- subseq seq ? )
- pick length [
+ pick length iota [
[ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
] all? nip ; inline
PRIVATE>
: start* ( subseq seq n -- i )
- pick length pick length swap - 1 +
+ pick length pick length swap - 1 + iota
[ (start) ] find-from
swap [ 3drop ] dip ;
-IN: slots.tests
USING: math accessors slots strings generic.single kernel
tools.test generic words parser eval math.functions ;
+IN: slots.tests
TUPLE: r/w-test foo ;
"Sorting a sequence with a custom comparator:"
{ $subsection sort }
"Sorting a sequence with common comparators:"
+{ $subsection sort-with }
+{ $subsection inv-sort-with }
{ $subsection natural-sort }
{ $subsection sort-keys }
{ $subsection sort-values } ;
HELP: sort
{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements into a new array using a stable sort." }
+{ $description "Sorts the elements of " { $snippet "seq" } " into a new array using a stable sort." }
{ $notes "The algorithm used is the merge sort." } ;
+HELP: sort-with
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } }
+{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence." } ;
+
+HELP: inv-sort-with
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } }
+{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence and inverting the results." } ;
+
HELP: sort-keys
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link <=> } " word." } ;
+{ $description "Sorts the elements of " { $snippet "seq" } " comparing first elements of pairs using the " { $link <=> } " word." } ;
HELP: sort-values
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link <=> } " word." } ;
+{ $description "Sorts the elements of " { $snippet "seq" } " comparing second elements of pairs using the " { $link <=> } " word." } ;
HELP: natural-sort
{ $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } }
{ $values { "seq" "a sequence" } { "n" integer } }
{ $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;
-{ <=> compare natural-sort sort-keys sort-values } related-words
+{ <=> compare natural-sort sort-with inv-sort-with sort-keys sort-values } related-words
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
-: sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
+: sort-with ( seq quot -- sortedseq )
+ [ compare ] curry sort ; inline
+: inv-sort-with ( seq quot -- sortedseq )
+ [ compare invert-comparison ] curry sort ; inline
-: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
+: sort-keys ( seq -- sortedseq ) [ first ] sort-with ;
+
+: sort-values ( seq -- sortedseq ) [ second ] sort-with ;
: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math.order sorting sequences definitions
-namespaces arrays splitting io math.parser math init ;
+namespaces arrays splitting io math.parser math init continuations ;
IN: source-files.errors
+GENERIC: error-file ( error -- file )
+GENERIC: error-line ( error -- line )
+
+M: object error-file drop f ;
+M: object error-line drop f ;
+
+M: condition error-file error>> error-file ;
+M: condition error-line error>> error-line ;
+
TUPLE: source-file-error error asset file line# ;
+M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
+M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
+
: sort-errors ( errors -- alist )
- [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+ [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
: group-by-source-file ( errors -- assoc )
H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1 + swap (split) ]
- [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
+ [ swap [ tail ] unless-zero , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;
HELP: define-declared
{ $values { "word" word } { "def" quotation } { "effect" effect } }
{ $description "Defines a word and declares its stack effect." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "word" } ;
HELP: define-temp
HELP: define-inline
{ $values { "word" word } { "def" quotation } { "effect" effect } }
{ $description "Defines a word and makes it " { $link POSTPONE: inline } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "word" } ;
\r
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
-: dimension ( array -- x ) length 1- ; inline \r
+: dimension ( array -- x ) length 1 - ; inline \r
: change-last ( seq quot -- ) \r
[ [ dimension ] keep ] dip change-nth ; inline\r
\r
: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
position-point VERY-SMALL-NUM neg > ;\r
: project-vector ( seq -- seq ) \r
- pv> [ head ] [ 1+ tail ] 2bi append ; \r
+ pv> [ head ] [ 1 + tail ] 2bi append ; \r
: get-intersection ( matrice -- seq ) \r
[ 1 tail* ] map flip first ;\r
\r
: compute-adjacencies ( solid -- solid )\r
dup dimension>> [ >= ] curry \r
[ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1- ] while drop ;\r
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
\r
: find-adjacencies ( solid -- solid ) \r
erase-old-adjacencies \r
[ [ non-empty-solid? ] filter ] change-solids ;\r
\r
: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> \r
+ swap dimension>> 1 - <space> \r
swap >>dimension swap >>solids ;\r
\r
: get-silhouette ( solid -- silhouette ) \r
! { [ dup 0 = ] [ 2drop { { } } ] }\r
! { [ over empty? ] [ 2drop { } ] }\r
! { [ t ] [ \r
-! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
! [ (combinations) ] 2bi append\r
! ] }\r
! } cond ;\r
{ [ over 1 = ] [ 3drop columnize ] }\r
{ [ over 0 = ] [ 2drop 2drop { } ] }\r
{ [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1- among [ append ] with map ] \r
+ [ 1 - among [ append ] with map ] \r
[ among append ] 2bi\r
] }\r
{ [ 2dup = ] [ 3drop 1array ] }\r
: do-row ( exchange-with row# -- )\r
[ exchange-rows ] keep\r
[ first-col ] keep\r
- dup 1+ rows-from clear-col ;\r
+ dup 1 + rows-from clear-col ;\r
\r
: find-row ( row# quot -- i elt )\r
[ rows-from ] dip find ; inline\r
\r
: (echelon) ( col# row# -- )\r
over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1+ ] when*\r
- [ 1+ ] dip (echelon)\r
+ 2dup pivot-row [ over do-row 1 + ] when*\r
+ [ 1 + ] dip (echelon)\r
] [\r
2drop\r
] if ;\r
: four ( -- x )
!BROKEN this code is broken
- 2 2 + 1+ ;
+ 2 2 + 1 + ;
: five ( -- x )
!TODO return 5
remaining 1 <= [
listener call f
] [
- remaining 1-
+ remaining 1 -
0
value' 10 *
used mask bitor
] any? ; inline recursive
:: count-numbers ( max listener -- )
- 10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
+ 10 iota [ 1 + 1 1 0 max listener (count-numbers) ] any? drop ;
inline
:: beust ( -- )
[let | i! [ 0 ] |
- 5000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1 + i! ] count-numbers
i number>string " unique numbers." append print
] ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+concurrency.mailboxes fry io kernel make math math.parser
+math.text.english sequences threads ;
+IN: benchmark.chameneos-redux
+
+SYMBOLS: red yellow blue ;
+
+ERROR: bad-color-pair pair ;
+
+TUPLE: creature n color count self-count mailbox ;
+
+TUPLE: meeting-place count mailbox ;
+
+: <meeting-place> ( count -- meeting-place )
+ meeting-place new
+ swap >>count
+ <mailbox> >>mailbox ;
+
+: <creature> ( n color -- creature )
+ creature new
+ swap >>color
+ swap >>n
+ 0 >>count
+ 0 >>self-count
+ <mailbox> >>mailbox ;
+
+: make-creatures ( colors -- seq )
+ [ length iota ] [ ] bi [ <creature> ] 2map ;
+
+: complement-color ( color1 color2 -- color3 )
+ 2dup = [ drop ] [
+ 2array {
+ { { red yellow } [ blue ] }
+ { { red blue } [ yellow ] }
+ { { yellow red } [ blue ] }
+ { { yellow blue } [ red ] }
+ { { blue red } [ yellow ] }
+ { { blue yellow } [ red ] }
+ [ bad-color-pair ]
+ } case
+ ] if ;
+
+: color-string ( color1 color2 -- string )
+ [
+ [ [ name>> ] bi@ " + " glue % " -> " % ]
+ [ complement-color name>> % ] 2bi
+ ] "" make ;
+
+: print-color-table ( -- )
+ { blue red yellow } dup
+ '[ _ '[ color-string print ] with each ] each ;
+
+: try-meet ( meeting-place creature -- )
+ over count>> 0 < [
+ 2drop
+ ] [
+ [ swap mailbox>> mailbox-put ]
+ [ nip mailbox>> mailbox-get drop ]
+ [ try-meet ] 2tri
+ ] if ;
+
+: creature-meeting ( seq -- )
+ first2 {
+ [ [ [ 1 + ] change-count ] bi@ 2drop ]
+ [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ]
+ [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ]
+ [ [ mailbox>> f swap mailbox-put ] bi@ ]
+ } 2cleave ;
+
+: run-meeting-place ( meeting-place -- )
+ [ 1 - ] change-count
+ dup count>> 0 < [
+ mailbox>> mailbox-get-all
+ [ f swap mailbox>> mailbox-put ] each
+ ] [
+ [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ]
+ [ run-meeting-place ] bi
+ ] if ;
+
+: number>chameneos-string ( n -- string )
+ number>string string>digits [ number>text ] { } map-as " " join ;
+
+: chameneos-redux ( n colors -- )
+ [ <meeting-place> ] [ make-creatures ] bi*
+ {
+ [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ]
+ [ [ '[ _ _ try-meet ] in-thread ] with each ]
+ [ drop run-meeting-place ]
+
+ [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ]
+ [ nip 0 [ count>> + ] reduce bl number>chameneos-string print ]
+ } 2cleave ;
+
+! 6000000 for shootout, too slow right now
+
+: chameneos-redux-main ( -- )
+ print-color-table
+ 60000 [
+ { blue red yellow } chameneos-redux
+ ] [
+ { blue red yellow red yellow blue red yellow red blue } chameneos-redux
+ ] bi ;
+
+MAIN: chameneos-redux-main
: count ( quot: ( -- ? ) -- n )
#! Call quot until it returns false, return number of times
#! it was true
- [ 0 ] dip '[ _ dip swap [ [ 1+ ] when ] keep ] loop ; inline
+ [ 0 ] dip '[ _ dip swap [ [ 1 + ] when ] keep ] loop ; inline
: count-flips ( perm -- flip# )
'[
[ CHAR: 0 + write1 ] each nl ; inline
: fannkuch-step ( counter max-flips perm -- counter max-flips )
- pick 30 < [ [ 1+ ] [ ] [ dup write-permutation ] tri* ] when
+ pick 30 < [ [ 1 + ] [ ] [ dup write-permutation ] tri* ] when
count-flips max ; inline
: fannkuch ( n -- )
[
- [ 0 0 ] dip [ 1+ ] B{ } map-as
+ [ 0 0 ] dip [ 1 + ] B{ } map-as
[ fannkuch-step ] each-permutation nip
] keep
"Pfannkuchen(" write pprint ") = " write . ;
:: split-lines ( n quot -- )
n line-length /mod
[ [ line-length quot call ] times ] dip
- dup zero? [ drop ] quot if ; inline
+ quot unless-zero ; inline
: write-random-fasta ( seed n chars floats desc id -- seed )
write-description
dup i>> 1 <= [
drop 1 <box>
] [
- i>> 1- <box>
+ i>> 1 - <box>
dup tuple-fib
swap
- i>> 1- <box>
+ i>> 1 - <box>
tuple-fib
swap i>> swap i>> + <box>
] if ; inline recursive
-IN: benchmark.fib6\r
USING: math kernel alien ;\r
+IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
"int" { "int" } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
- 1- dup fib swap 1- fib +\r
+ 1 - dup fib swap 1- fib +\r
] if\r
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
USING: math sequences kernel ;
IN: benchmark.gc1
-: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ;
+: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ;
-MAIN: gc1
\ No newline at end of file
+MAIN: gc1
: tally ( x exemplar -- b )
clone tuck
[
- [ [ 1+ ] [ 1 ] if* ] change-at
+ [ [ 1 + ] [ 1 ] if* ] change-at
] curry each ;
: small-groups ( x n -- b )
swap
- [ length swap - 1+ ] 2keep
+ [ length swap - 1 + ] 2keep
[ [ over + ] dip subseq ] 2curry map ;
: handle-table ( inputs n -- )
: <color-map> ( nb-cols -- map )
dup [
- 360 * swap 1+ / sat val
+ 360 * swap 1 + / sat val
1 <hsva> >rgba scale-rgb
] with map ;
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
bodies [| body i |
body each-quot call
- bodies i 1+ tail-slice [
+ bodies i 1 + tail-slice [
body pair-quot call
] each
] each-index ; inline
-IN: benchmark.nsieve-bits
USING: math math.parser sequences sequences.private kernel
bit-arrays make io ;
+IN: benchmark.nsieve-bits
: clear-flags ( step i seq -- )
2dup length >= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve-bits)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve-bits)
] [
2drop
] if ; inline recursive
: nsieve-bits ( m -- count )
- 0 2 rot 1+ <bit-array> dup set-bits (nsieve-bits) ;
+ 0 2 rot 1 + <bit-array> dup set-bits (nsieve-bits) ;
: nsieve-bits. ( m -- )
[ "Primes up to " % dup # " " % nsieve-bits # ] "" make
: nsieve-bits-main ( n -- )
dup 2^ 10000 * nsieve-bits.
- dup 1- 2^ 10000 * nsieve-bits.
+ dup 1 - 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
2dup length < [
2dup nth-unsafe 0 > [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1+ <byte-array> dup [ drop 1 ] change-each (nsieve) ;
+ 0 2 rot 1 + <byte-array> dup [ drop 1 ] change-each (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
-IN: benchmark.nsieve
USING: math math.parser sequences sequences.private kernel
arrays make io ;
+IN: benchmark.nsieve
: clear-flags ( step i seq -- )
2dup length >= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1+ t <array> (nsieve) ;
+ 0 2 rot 1
+ t <array> (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
IN: benchmark.partial-sums
! Helper words
-: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline
+: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1 + @ + ] each ; inline
: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
: cube ( x -- y ) dup dup * * ; inline
-: -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline
+: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline
! The functions
-: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline
+: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1 - ^ ] summing-floats ; inline
: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline
-: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline
+: 1/k(k+1) ( n -- y ) [ dup 1 + * recip ] summing-floats ; inline
: flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline
: cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline
: harmonic ( n -- y ) [ recip ] summing-floats ; inline
: riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline
: alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline
-: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline
+: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1 - ] bi / ] summing-integers ; inline
: partial-sums ( n -- results )
[
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
+HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
M: group intersect-scene ( hit ray group -- hit )
[ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
+HINTS: M\ group intersect-scene { hit ray group } ;
+
CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )
: ack ( m n -- x )
{
- { [ over zero? ] [ nip 1+ ] }
- { [ dup zero? ] [ drop 1- 1 ack ] }
- [ [ drop 1- ] [ 1- ack ] 2bi ack ]
+ { [ over zero? ] [ nip 1 + ] }
+ { [ dup zero? ] [ drop 1 - 1 ack ] }
+ [ [ drop 1 - ] [ 1 - ack ] 2bi ack ]
} cond ; inline recursive
: tak ( x y z -- t )
2over <= [
2nip
] [
- [ rot 1- -rot tak ]
- [ -rot 1- -rot tak ]
- [ 1- -rot tak ]
+ [ rot 1 - -rot tak ]
+ [ -rot 1 - -rot tak ]
+ [ 1 - -rot tak ]
3tri
tak
] if ; inline recursive
: recursive ( n -- )
[ 3 swap ack . flush ]
[ 27.0 + fib . flush ]
- [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
+ [ 1 - [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
3 fib . flush
3.0 2.0 1.0 tak . flush ;
: tuple-array-benchmark ( -- )
100 [
drop 5000 <point-array> [
- [ 1+ ] change-x
- [ 1- ] change-y
- [ 1+ 2 / ] change-z
+ [ 1 + ] change-x
+ [ 1 - ] change-y
+ [ 1 + 2 / ] change-z
] map [ z>> ] sigma
] sigma . ;
-MAIN: tuple-array-benchmark
\ No newline at end of file
+MAIN: tuple-array-benchmark
--- /dev/null
+! Copyright (C) Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.accessors alien.c-types alien.syntax byte-arrays
+destructors generalizations hints kernel libc locals math math.order
+sequences sequences.private ;
+IN: benchmark.yuv-to-rgb
+
+C-STRUCT: yuv_buffer
+ { "int" "y_width" }
+ { "int" "y_height" }
+ { "int" "y_stride" }
+ { "int" "uv_width" }
+ { "int" "uv_height" }
+ { "int" "uv_stride" }
+ { "void*" "y" }
+ { "void*" "u" }
+ { "void*" "v" } ;
+
+:: fake-data ( -- rgb yuv )
+ [let* | w [ 1600 ]
+ h [ 1200 ]
+ buffer [ "yuv_buffer" <c-object> ]
+ rgb [ w h * 3 * <byte-array> ] |
+ w buffer set-yuv_buffer-y_width
+ h buffer set-yuv_buffer-y_height
+ h buffer set-yuv_buffer-uv_height
+ w buffer set-yuv_buffer-y_stride
+ w buffer set-yuv_buffer-uv_stride
+ w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y
+ w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u
+ w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v
+ rgb buffer
+ ] ;
+
+: clamp ( n -- n )
+ 255 min 0 max ; inline
+
+: stride ( line yuv -- uvy yy )
+ [ yuv_buffer-uv_stride swap 2/ * >fixnum ]
+ [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
+
+: compute-y ( yuv uvy yy x -- y )
+ + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
+
+: compute-v ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline
+
+: compute-u ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline
+
+:: compute-yuv ( yuv uvy yy x -- y u v )
+ yuv uvy yy x compute-y
+ yuv uvy yy x compute-u
+ yuv uvy yy x compute-v ; inline
+
+: compute-blue ( y u v -- b )
+ drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
+
+: compute-green ( y u v -- g )
+ [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift clamp ;
+ inline
+
+: compute-red ( y u v -- g )
+ nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
+
+: compute-rgb ( y u v -- b g r )
+ [ compute-blue ] [ compute-green ] [ compute-red ] 3tri ;
+ inline
+
+: store-rgb ( index rgb b g r -- index )
+ [ pick 0 + pick set-nth-unsafe ]
+ [ pick 1 + pick set-nth-unsafe ]
+ [ pick 2 + pick set-nth-unsafe ] tri*
+ drop ; inline
+
+: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
+ compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+
+: yuv>rgb-row ( index rgb yuv y -- index )
+ over stride
+ pick yuv_buffer-y_width >fixnum
+ [ yuv>rgb-pixel ] with with with with each ; inline
+
+: yuv>rgb ( rgb yuv -- )
+ [ 0 ] 2dip
+ dup yuv_buffer-y_height >fixnum
+ [ yuv>rgb-row ] with with each
+ drop ;
+
+HINTS: yuv>rgb byte-array byte-array ;
+
+: yuv>rgb-benchmark ( -- )
+ [ fake-data yuv>rgb ] with-destructors ;
+
+MAIN: yuv>rgb-benchmark
: next-draw ( gadget -- )
dup [ draw-seq>> ] [ draw-n>> ] bi
- 1+ swap length mod
+ 1 + swap length mod
>>draw-n relayout-1 ;
: make-draws ( gadget -- draw-seq )
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors c.lexer kernel sequence-parser tools.test ;
+IN: c.lexer.tests
+
+[ 36 ]
+[
+ " //jofiejoe\n //eoieow\n/*asdf*/\n "
+ <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "asdfasdf" ] [
+ "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+ "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "//asdfasdf\nomg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "omg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+ "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "asdf" "eoieoei" ] [
+ "//asdf\neoieoei" <sequence-parser>
+ [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit
+generalizations kernel locals math.order math.ranges
+sequence-parser sequences sorting.functor sorting.slots
+unicode.categories ;
+IN: c.lexer
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace-eol
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
+ sequence-parser n>> :> start-n
+ sequence-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ sequence-parser current quote-char = [
+ sequence-parser advance* string
+ ] [
+ start-n sequence-parser (>>n) f
+ ] if ;
+
+: (take-token) ( sequence-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( sequence-parser escape-char quote-char -- string/f )
+ sequence-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
+
+: take-token ( sequence-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
+
+: c-identifier-begin? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ { CHAR: _ } 3append member? ;
+
+: c-identifier-ch? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 0 CHAR: 9 [a,b]
+ { CHAR: _ } 4 nappend member? ;
+
+: (take-c-identifier) ( sequence-parser -- string/f )
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+ [ (take-c-identifier) ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-c-integer ( sequence-parser -- string/f )
+ [
+ dup take-integer [
+ swap
+ { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
+ take-longest [ append ] when*
+ ] [
+ drop f
+ ] if*
+ ] with-sequence-parser ;
+
+CONSTANT: c-punctuators
+ {
+ "[" "]" "(" ")" "{" "}" "." "->"
+ "++" "--" "&" "*" "+" "-" "~" "!"
+ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+ "?" ":" ";" "..."
+ "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+ "," "#" "##"
+ "<:" ":>" "<%" "%>" "%:" "%:%:"
+ }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+ c-punctuators take-longest ;
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
-combinators.short-circuit ;
+combinators.short-circuit c.lexer ;
IN: c.preprocessor
: initial-library-paths ( -- seq )
TUPLE: test-disp-cent value disposed ;
! A phony destructor that adds 1 to the value so we can make sure it got called.
-M: test-disp-cent dispose* dup value>> 1+ >>value drop ;
+M: test-disp-cent dispose* dup value>> 1 + >>value drop ;
DISPOSABLE-CENTRAL: t-d-c
: test-t-d-c ( -- n )
test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ;
-[ 4 ] [ test-t-d-c ] unit-test
\ No newline at end of file
+[ 4 ] [ test-t-d-c ] unit-test
--- /dev/null
+USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser hashtables ;
+IN: closures
+SYMBOL: |
+
+! Selective Binding
+: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ;
+SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ;
+! Common ones
+SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ;
+
+! Namespace Binding
+: bind-to-namespace ( quot -- quot' ) '[ namespace [ _ bind ] curry ] ;
+SYNTAX: NS[ parse-quotation bind-to-namespace over push-all ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license
-USING: accessors compiler.cfg.rpo compiler.cfg.dominance
-compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer
-io io.encodings.ascii io.files io.files.unique io.launcher kernel
-math.parser sequences assocs arrays make namespaces ;
-IN: compiler.cfg.graphviz
-
-: render-graph ( edges -- )
- "cfg" "dot" make-unique-file
- [
- ascii [
- "digraph CFG {" print
- [ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each
- "}" print
- ] with-file-writer
- ]
- [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
- [ ".png" append { "open" } swap suffix try-process ]
- tri ;
-
-: cfg-edges ( cfg -- edges )
- [
- [
- dup successors>> [
- 2array ,
- ] with each
- ] each-basic-block
- ] { } make ;
-
-: render-cfg ( cfg -- ) cfg-edges render-graph ;
-
-: dom-edges ( cfg -- edges )
- [
- compute-predecessors
- compute-dominance
- dom-childrens get [
- [
- 2array ,
- ] with each
- ] assoc-each
- ] { } make ;
-
-: render-dom ( cfg -- ) dom-edges render-graph ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
+USING: accessors compiler.tree.builder compiler.cfg compiler.cfg.rpo
+compiler.cfg.dominance compiler.cfg.dominance.private
+compiler.cfg.predecessors compiler.cfg.debugger compiler.cfg.optimizer
+compiler.cfg.utilities compiler.tree.recursive images.viewer
+images.png io io.encodings.ascii io.files io.files.unique io.launcher
+kernel math.parser sequences assocs arrays make math namespaces
+quotations combinators locals words ;
+IN: compiler.graphviz
+
+: quotes ( str -- str' ) "\"" "\"" surround ;
+
+: graph, ( quot title -- )
+ [
+ quotes "digraph " " {" surround ,
+ call
+ "}" ,
+ ] { } make , ; inline
+
+: render-graph ( quot -- )
+ { } make
+ "cfg" ".dot" make-unique-file
+ dup "Wrote " prepend print
+ [ [ concat ] dip ascii set-file-lines ]
+ [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
+ [ ".png" append "open" swap 2array try-process ]
+ tri ; inline
+
+: attrs>string ( seq -- str )
+ [ "" ] [ "," join "[" "]" surround ] if-empty ;
+
+: edge,* ( from to attrs -- )
+ [
+ [ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri*
+ ";" %
+ ] "" make , ;
+
+: edge, ( from to -- )
+ { } edge,* ;
+
+: bb-edge, ( from to -- )
+ [ number>> number>string ] bi@ edge, ;
+
+: node-style, ( str attrs -- )
+ [ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ;
+
+: cfg-title ( cfg/mr -- string )
+ [
+ "=== word: " %
+ [ word>> name>> % ", label: " % ]
+ [ label>> name>> % ]
+ bi
+ ] "" make ;
+
+: cfg-vertex, ( bb -- )
+ [ number>> number>string ]
+ [ kill-block? { "color=grey" "style=filled" } { } ? ]
+ bi node-style, ;
+
+: cfgs ( cfgs -- )
+ [
+ [
+ [ [ cfg-vertex, ] each-basic-block ]
+ [
+ [
+ dup successors>> [
+ bb-edge,
+ ] with each
+ ] each-basic-block
+ ] bi
+ ] over cfg-title graph,
+ ] each ;
+
+: optimized-cfg ( quot -- cfgs )
+ {
+ { [ dup cfg? ] [ 1array ] }
+ { [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] }
+ { [ dup word? ] [ test-cfg [ optimize-cfg ] map ] }
+ [ ]
+ } cond ;
+
+: render-cfg ( cfg -- )
+ optimized-cfg [ cfgs ] render-graph ;
+
+: dom-trees ( cfgs -- )
+ [
+ [
+ needs-dominance drop
+ dom-childrens get [
+ [
+ bb-edge,
+ ] with each
+ ] assoc-each
+ ] over cfg-title graph,
+ ] each ;
+
+: render-dom ( cfg -- )
+ optimized-cfg [ dom-trees ] render-graph ;
+
+SYMBOL: word-counts
+SYMBOL: vertex-names
+
+: vertex-name ( call-graph-node -- string )
+ label>> vertex-names get [
+ word>> name>>
+ dup word-counts get [ 0 or 1 + dup ] change-at number>string " #" glue
+ ] cache ;
+
+: vertex-attrs ( obj -- string )
+ tail?>> { "style=bold,label=\"tail\"" } { } ? ;
+
+: call-graph-edge, ( from to attrs -- )
+ [ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ;
+
+: (call-graph-back-edges) ( string calls -- )
+ [ { "color=red" } call-graph-edge, ] with each ;
+
+: (call-graph-edges) ( string children -- )
+ [
+ {
+ [ { } call-graph-edge, ]
+ [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
+ [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
+ [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
+ } cleave
+ ] with each ;
+
+: call-graph-edges ( call-graph-node -- )
+ H{ } clone word-counts set
+ H{ } clone vertex-names set
+ [ "ROOT" ] dip (call-graph-edges) ;
+
+: render-call-graph ( tree -- )
+ dup quotation? [ build-tree ] when
+ analyze-recursive drop
+ [ [ call-graph get call-graph-edges ] "Call graph" graph, ]
+ render-graph ;
\ No newline at end of file
[ drop 1 coyield* 2 coyield* 3 coterminate ] cocreate ;
: test2 ( -- co )
- [ 1+ coyield* ] cocreate ;
+ [ 1 + coyield* ] cocreate ;
test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
[ test2 42 over coresume . dup *coresume . drop ] must-fail
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume [ dup *coresume [ *coresume ] dip ] dip ] unit-test
-{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
+{ 4+2/3 } [ [ 1 + coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- [ [ log2 1+ ] [ / 2 * ] bi* ]
+ [ [ log2 1 + ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;
"./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline
: to64 ( v n -- string )
- [ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ]
+ [ [ -6 shift ] [ 6 2^ 1 - bitand lookup-table ] bi ]
replicate nip ; inline
PRIVATE>
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
- [ 1- ] bi@ *
+ [ 1 - ] bi@ *
dup public-key gcd nip 1 = [
rot drop
] [
H{ } clone swap [ swap [ etag-add ] keep ] each ;
: lines>bytes ( seq n -- bytes )
- head 0 [ length 1+ + ] reduce ;
+ head 0 [ length 1 + + ] reduce ;
: file>lines ( path -- lines )
ascii file-lines ;
1 HEX: 7f <string> %
second dup number>string %
1 CHAR: , <string> %
- 1- lines>bytes number>string %
+ 1 - lines>bytes number>string %
] "" make ;
: etag-length ( vector -- n )
[ etag-strings ] dip ascii set-file-lines ;
: etags ( path -- )
- [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
\ No newline at end of file
+ [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
>from-sequence< nth-unsafe ;
M: from-sequence cursor-advance
- [ 1+ ] change-n drop ;
+ [ 1 + ] change-n drop ;
: >input ( seq -- cursor )
0 from-sequence boa ; inline
--- /dev/null
+USING: accessors sequences generalizations io.encodings.utf8 db.postgresql parser combinators vocabs.parser db.sqlite
+io.files ;
+IN: db.info
+! having sensative (and likely to change) information directly in source code seems a bad idea
+: get-info ( -- lines ) current-vocab name>> "vocab:" "/dbinfo.txt" surround utf8 file-lines ;
+SYNTAX: get-psql-info <postgresql-db> get-info 5 firstn
+ {
+ [ >>host ]
+ [ >>port ]
+ [ >>username ]
+ [ [ f ] [ ] if-empty >>password ]
+ [ >>database ]
+ } spread parsed ;
+
+SYNTAX: get-sqlite-info get-info first <sqlite-db> parsed ;
\ No newline at end of file
-USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ;\r
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see\r
+math.ratios ;\r
IN: descriptive.tests\r
\r
DESCRIPTIVE: divide ( num denom -- fraction ) / ;\r
\r
[ 3 ] [ 9 3 divide ] unit-test\r
-[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test\r
\r
-[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test\r
+[\r
+ T{ descriptive-error f\r
+ { { "num" 3 } { "denom" 0 } }\r
+ T{ division-by-zero f 3 }\r
+ divide\r
+ }\r
+] [\r
+ [ 3 0 divide ] [ ] recover\r
+] unit-test\r
+\r
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ]\r
+[ \ divide [ see ] with-string-writer ] unit-test\r
\r
DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\r
\r
[ 3 ] [ 9 3 divide* ] unit-test\r
-[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
+\r
+[\r
+ T{ descriptive-error f\r
+ { { "num" 3 } { "denom" 0 } }\r
+ T{ division-by-zero f 3 }\r
+ divide*\r
+ }\r
+] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
\r
[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! have-delegates?
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: tools.deploy.config ;
H{
- { deploy-unicode? f }
+ { deploy-name "drills" }
+ { deploy-c-types? t }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? t }
{ deploy-threads? t }
+ { deploy-reflection 6 }
+ { deploy-word-defs? t }
{ deploy-math? t }
- { deploy-name "drills" }
{ deploy-ui? t }
- { "stop-after-last-window?" t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { deploy-io 2 }
- { deploy-word-defs? f }
- { deploy-reflection 1 }
+ { deploy-word-props? t }
+ { deploy-io 3 }
}
-USING: accessors arrays cocoa.dialogs combinators continuations
+USING: arrays cocoa.dialogs combinators continuations
fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
wrap.strings system ;
-
+EXCLUDE: accessors => change-model ;
IN: drills.deployed
SYMBOLS: it startLength ;
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
-USING: accessors arrays cocoa.dialogs combinators continuations
+USING: arrays cocoa.dialogs combinators continuations
fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
wrap.strings ;
+EXCLUDE: accessors => change-model ;
IN: drills
SYMBOLS: it startLength ;
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
{ [ [ first ] card ]
KEY EC_KEY_get0_public_key dup
[| PUB |
KEY EC_KEY_get0_group :> GROUP
- GROUP EC_GROUP_get_degree bits>bytes 1+ :> LEN
+ GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
LEN <byte-array> :> BIN
GROUP PUB POINT_CONVERSION_COMPRESSED BIN LEN f
EC_POINT_point2oct ssl-error
LEN *uint SIG resize ;
: ecdsa-verify ( dgst sig -- ? )
- ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
\ No newline at end of file
+ ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel parser vocabs.parser words ;
+IN: enter
+! main words are usually only used for entry, doing initialization, etc
+! it makes sense, then to define it all at once, rather than factoring it out into a seperate word
+! and then declaring it main
+SYNTAX: ENTER: gensym [ parse-definition (( -- )) define-declared ] keep current-vocab (>>main) ;
\ No newline at end of file
+++ /dev/null
-USING: kernel file-trees ;
-IN: file-trees.tests
-{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
-"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals namespaces prettyprint sequences
-ui.frp vectors ;
-IN: file-trees
-
-TUPLE: tree node children ;
-CONSULT: sequence-protocol tree children>> ;
-
-: <tree> ( start -- tree ) V{ } clone
- [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
-
-DEFER: (tree-insert)
-
-: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
-:: (tree-insert) ( path-rest path-head tree-children -- )
- tree-children [ node>> path-head node>> = ] find nip
- [ path-rest swap tree-insert ]
- [
- path-head tree-children push
- path-rest [ path-head tree-insert ] unless-empty
- ] if* ;
-: create-tree ( file-list -- tree ) [ path-components ] map
- t <tree> [ [ tree-insert ] curry each ] keep ;
-
-: <dir-table> ( tree-model -- table )
- <frp-list*> [ node>> 1array ] >>quot
- [ selected-value>> <switch> ]
- [ swap >>model ] bi ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Syntax for modifying gadget fonts
\ No newline at end of file
--- /dev/null
+USING: help.syntax help.markup ;
+IN: fonts.syntax
+
+HELP: FONT:
+{ $syntax "\"testing\" <label> FONT: 18 serif bold ... ;" }
+{ $description "Used after a gadget to change font settings. Attributes can be in any order: the first number is set as the size, the style attributes like bold and italic will set the bold? and italic? slots, and font-names like serif or monospace will set the name slot." } ;
\ No newline at end of file
--- /dev/null
+USING: accessors arrays variants combinators io.styles
+kernel math parser sequences fry ;
+IN: fonts.syntax
+
+VARIANT: fontname serif monospace ;
+
+: install ( object quot -- quot/? ) over [ curry ] [ 2drop [ ] ] if ;
+
+: >>name* ( object fontname -- object ) name>> >>name ;
+
+SYNTAX: FONT: \ ; parse-until {
+ [ [ number? ] find nip [ >>size ] install ]
+ [ [ italic = ] find nip [ >>italic? ] install ]
+ [ [ bold = ] find nip [ >>bold? ] install ]
+ [ [ fontname? ] find nip [ >>name* ] install ]
+} cleave 4array concat '[ dup font>> @ drop ] over push-all ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: arrays vectors combinators effects kernel math sequences splitting
+strings.parser parser fry sequences.extras ;
+IN: fries
+: str-fry ( str on -- quot ) split
+ [ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+: gen-fry ( str on -- quot ) split
+ [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+
+SYNTAX: i" parse-string rest "_" str-fry over push-all ;
+SYNTAX: i{ \ } parse-until >array { _ } gen-fry over push-all ;
+SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry over push-all ;
--- /dev/null
+Generalized Frying
\ No newline at end of file
dup dup >vocab-link where normalize-loc 4array ;
: sort-xrefs ( seq -- seq' )
- [ [ first ] dip first <=> ] sort ;
+ [ first ] sort-with ;
: format-xrefs ( seq -- seq' )
[ word? ] filter [ word>xref ] map ;
: current-words ( -- seq )
manifest get
- [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
- assoc-union keys ;
+ [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ [ words>> ] map ] bi@
+ append H{ } [ assoc-union ] reduce keys ;
: vocabs-words ( names -- seq )
prune [ (vocab-words) ] map concat ;
USING: accessors calendar continuations destructors kernel math
-math.order namespaces system threads ui ui.gadgets.worlds ;
+math.order namespaces system threads ui ui.gadgets.worlds
+sequences ;
IN: game-loop
TUPLE: game-loop
<PRIVATE
: redraw ( loop -- )
- [ 1+ ] change-frame-number
+ [ 1 + ] change-frame-number
[ tick-slice ] [ delegate>> ] bi draw* ;
: tick ( loop -- )
delegate>> tick* ;
: increment-tick ( loop -- )
- [ 1+ ] change-tick-number
+ [ 1 + ] change-tick-number
dup tick-length>> [ + ] curry change-last-tick
drop ;
: ?tick ( loop count -- )
- dup zero? [ drop millis >>last-tick drop ] [
+ [ millis >>last-tick drop ] [
over [ since-last-tick ] [ tick-length>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ]
+ [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
[ 2drop ] if
- ] if ;
+ ] if-zero ;
: (run-loop) ( loop -- )
dup running?>>
C: <multi-index-range> multi-index-range
TUPLE: index-elements
- { ptr gpu-data-ptr read-only }
+ { ptr read-only }
{ count integer read-only }
{ index-type index-type read-only } ;
[ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
: bind-named-output-attachments ( program-instance framebuffer attachments -- )
- rot '[ [ first _ swap output-index ] bi@ <=> ] sort [ second ] map
+ rot '[ first _ swap output-index ] sort-with [ second ] map
bind-unnamed-output-attachments ;
: bind-output-attachments ( program-instance framebuffer attachments -- )
: (mint) ( tuple counter -- tuple )
2dup set-suffix checksummed-bits pick
- valid-guess? [ drop ] [ 1+ (mint) ] if ;
+ valid-guess? [ drop ] [ 1 + (mint) ] if ;
PRIVATE>
: find-nth ( seq quot n -- i elt )
[ <enum> >alist ] 2dip -rot
- '[ _ [ second @ ] find-from rot drop swap 1+ ]
+ '[ _ [ second @ ] find-from rot drop swap 1 + ]
[ f 0 ] 2dip times drop first2 ; inline
: find-first-name ( vector string -- i/f tag/f )
: find-between* ( vector i/f tag/f -- vector )
over integer? [
[ tail-slice ] [ name>> ] bi*
- dupd find-matching-close drop dup [ 1+ ] when
+ dupd find-matching-close drop dup [ 1 + ] when
[ head ] [ first ] if*
] [
3drop V{ } clone
0 [ [ 7 shift ] dip bitor ] reduce ;
: synchsafe>seq ( n -- seq )
- dup 1+ log2 1+ 7 / ceiling
+ dup 1 + log2 1 + 7 / ceiling
[ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ;
: filter-text-data ( data -- filtered )
: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
dup 0 > [
[ drop call( host port -- stream ) ]
- [ drop 15 sleep 1- do-connect ]
+ [ drop 15 sleep 1 - do-connect ]
recover
] [ 2drop 2drop f ] if ;
C: <segment> segment
: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
+ [ number>> 1 + ] keep (>>number) ;
: clamp-length ( n seq -- n' )
0 swap length clamp ;
: (random-segments) ( segments n -- segments )
dup 0 > [
- [ dup last random-segment over push ] dip 1- (random-segments)
+ [ dup last random-segment over push ] dip 1 - (random-segments)
] [ drop ] if ;
CONSTANT: default-segment-radius 1
rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+ swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
over clamp-length swap nth ;
: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
+ number>> 1 + get-segment ;
: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
+ number>> 1 - get-segment ;
: heading-segment ( segments current-segment heading -- segment )
#! the next segment on the given heading
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel ui.gadgets.borders ui.gestures ;
+IN: key-handlers
+
+TUPLE: key-handler < border handlers ;
+: <keys> ( gadget -- key-handler ) key-handler new-border { 0 0 } >>size ;
+
+M: key-handler handle-gesture
+ tuck handlers>> at [ call( gadget -- ) f ] [ drop t ] if* ;
\ No newline at end of file
: inversions ( seq -- n )
0 swap [ length ] keep [
- [ nth ] 2keep swap 1+ tail-slice (inversions) +
+ [ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
: duplicates? ( seq -- ? )
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
+ dup 0 [ length max ] reduce 1 + [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1)
- [ ?nth ] [ [ 1+ ] dip ?nth ] 2bi
+ [ ?nth ] [ [ 1 + ] dip ?nth ] 2bi
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
] if ;
: graded-triple ( seq n -- triple )
- 3 [ 1- + ] with map swap [ ?nth ] curry map ;
+ 3 [ 1 - + ] with map swap [ ?nth ] curry map ;
: graded-triples ( seq -- triples )
dup length [ graded-triple ] with map ;
! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.constants math.functions
- math.vectors sequences ;
+USING: combinators.short-circuit kernel math math.constants
+math.functions math.vectors sequences ;
IN: math.analysis
<PRIVATE
: stirling-fact ( n -- fact )
[ pi 2 * * sqrt ]
[ [ e / ] keep ^ ]
- [ 12 * recip 1+ ] tri * * ;
+ [ 12 * recip 1 + ] tri * * ;
MACRO: chain-rule ( word -- e )
[ input-length '[ _ duals>nweave ] ]
[ "derivative" word-prop ]
- [ input-length 1+ '[ _ nspread ] ]
+ [ input-length 1 + '[ _ nspread ] ]
tri
'[ [ @ _ @ ] sum-outputs ] ;
! Specialize math functions to operate on dual numbers.
[ all-words [ "derivative" word-prop ] filter
- [ define-dual ] each ] with-compilation-unit
\ No newline at end of file
+ [ define-dual ] each ] with-compilation-unit
<PRIVATE
: weighted ( x y a -- z )
- tuck [ * ] [ 1- neg * ] 2bi* + ;
+ tuck [ * ] [ 1 - neg * ] 2bi* + ;
: a ( n -- a )
- 1+ 2 swap / ;
+ 1 + 2 swap / ;
PRIVATE>
: lprimes ( -- list ) 2 [ next-prime ] lfrom-by ;
: lprimes-from ( n -- list )
- dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
+ dup 3 < [ drop lprimes ] [ 1 - next-prime [ next-prime ] lfrom-by ] if ;
HELP: number>text
{ $values { "n" integer } { "str" string } }
{ $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." }
-{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ;
+{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"twelve thousand, three hundred and forty-five\"" } } ;
USING: math.functions math.text.english tools.test ;
IN: math.text.english.tests
-[ "Zero" ] [ 0 number>text ] unit-test
-[ "Twenty-One" ] [ 21 number>text ] unit-test
-[ "One Hundred" ] [ 100 number>text ] unit-test
-[ "One Hundred and One" ] [ 101 number>text ] unit-test
-[ "One Thousand and One" ] [ 1001 number>text ] unit-test
-[ "One Thousand, One Hundred and One" ] [ 1101 number>text ] unit-test
-[ "One Million, One Thousand and One" ] [ 1001001 number>text ] unit-test
-[ "One Million, One Thousand, One Hundred and One" ] [ 1001101 number>text ] unit-test
-[ "One Million, One Hundred and Eleven Thousand, One Hundred and Eleven" ] [ 1111111 number>text ] unit-test
-[ "One Duotrigintillion" ] [ 10 99 ^ number>text ] unit-test
+[ "zero" ] [ 0 number>text ] unit-test
+[ "twenty-one" ] [ 21 number>text ] unit-test
+[ "one hundred" ] [ 100 number>text ] unit-test
+[ "one hundred and one" ] [ 101 number>text ] unit-test
+[ "one thousand and one" ] [ 1001 number>text ] unit-test
+[ "one thousand, one hundred and one" ] [ 1101 number>text ] unit-test
+[ "one million, one thousand and one" ] [ 1001001 number>text ] unit-test
+[ "one million, one thousand, one hundred and one" ] [ 1001101 number>text ] unit-test
+[ "one million, one hundred and eleven thousand, one hundred and eleven" ] [ 1111111 number>text ] unit-test
+[ "one duotrigintillion" ] [ 10 99 ^ number>text ] unit-test
-[ "Negative One Hundred and Twenty-Three" ] [ -123 number>text ] unit-test
+[ "negative one hundred and twenty-three" ] [ -123 number>text ] unit-test
<PRIVATE
: small-numbers ( n -- str )
- { "Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine"
- "Ten" "Eleven" "Twelve" "Thirteen" "Fourteen" "Fifteen" "Sixteen"
- "Seventeen" "Eighteen" "Nineteen" } nth ;
+ {
+ "zero" "one" "two" "three" "four" "five" "six"
+ "seven" "eight" "nine" "ten" "eleven" "twelve"
+ "thirteen" "fourteen" "fifteen" "sixteen" "seventeen"
+ "eighteen" "nineteen"
+ } nth ;
: tens ( n -- str )
- { f f "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
-
+ {
+ f f "twenty" "thirty" "forty" "fifty" "sixty"
+ "seventy" "eighty" "ninety"
+ } nth ;
+
: scale-numbers ( n -- str ) ! up to 10^99
- { f "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
- "Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion"
- "Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion"
- "Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion"
- "Vigintillion" "Unvigintillion" "Duovigintillion" "Trevigintillion"
- "Quattuorvigintillion" "Quinvigintillion" "Sexvigintillion"
- "Septvigintillion" "Octovigintillion" "Novemvigintillion" "Trigintillion"
- "Untrigintillion" "Duotrigintillion" } nth ;
+ {
+ f "thousand" "million" "billion" "trillion" "quadrillion"
+ "quintillion" "sextillion" "septillion" "octillion"
+ "nonillion" "decillion" "undecillion" "duodecillion"
+ "tredecillion" "quattuordecillion" "quindecillion"
+ "sexdecillion" "septendecillion" "octodecillion" "novemdecillion"
+ "vigintillion" "unvigintillion" "duovigintillion" "trevigintillion"
+ "quattuorvigintillion" "quinvigintillion" "sexvigintillion"
+ "septvigintillion" "octovigintillion" "novemvigintillion"
+ "trigintillion" "untrigintillion" "duotrigintillion"
+ } nth ;
SYMBOL: and-needed?
: set-conjunction ( seq -- )
first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
: negative-text ( n -- str )
- 0 < "Negative " "" ? ;
+ 0 < "negative " "" ? ;
: hundreds-place ( n -- str )
100 /mod over 0 = [
2drop ""
] [
- [ small-numbers " Hundred" append ] dip
+ [ small-numbers " hundred" append ] dip
0 = [ " and " append ] unless
] if ;
] if ;
: (number>text) ( n -- str )
- [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
+ [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
PRIVATE>
} cond ;
: over-1000000 ( n -- str )
- 3digit-groups [ 1+ units nth n-units ] map-index sift
+ 3 digit-groups [ 1 + units nth n-units ] map-index sift
reverse " " join ;
: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
USING: help.markup help.syntax ;
IN: math.text.utils
-HELP: 3digit-groups
-{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
-{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ;
+HELP: digit-groups
+{ $values { "n" "a positive integer" } { "k" "a positive integer" } { "seq" "a sequence" } }
+{ $description "Decompose a number into groups of " { $snippet "k" } " digits and return them in a sequence starting with the least significant grouped digits first." } ;
USING: math.text.utils tools.test ;
-[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test
+[ { 1 999 2 } ] [ 2999001 3 digit-groups ] unit-test
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel fry math.functions math sequences ;
IN: math.text.utils
-: 3digit-groups ( n -- seq )
- [ dup 0 > ] [ 1000 /mod ] produce nip ;
+: digit-groups ( n k -- seq )
+ [ dup 0 > ] swap '[ _ 10^ /mod ] produce nip ;
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-io 2 }
- { deploy-unicode? t }
+ { deploy-name "Merger" }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
- { deploy-ui? t }
- { deploy-reflection 1 }
- { deploy-name "Merger" }
- { deploy-word-props? f }
+ { deploy-unicode? f }
{ deploy-threads? t }
+ { deploy-reflection 1 }
{ deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-ui? t }
+ { deploy-word-props? f }
+ { deploy-io 2 }
}
-USING: accessors arrays fry io.directories kernel models sequences sets ui
+USING: accessors arrays fry io.directories kernel
+models sequences sets ui
ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
math.rectangles cocoa.dialogs ;
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models models.arrow sequences monads ;
+IN: models.combinators
+
+HELP: merge
+{ $values { "models" "a list of models" } { "model" basic-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: filter-model
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
+
+HELP: fold
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: switch-models
+{ $values { "model1" model } { "model2" model } { "model'" model } }
+{ $description "Creates a model that starts with the behavior of model2 and switches to the behavior of model1 on its update" } ;
+
+HELP: <mapped>
+{ $values { "model" model } { "quot" "applied to model's value on updates" } { "model" model } }
+{ $description "An expanded version of " { $link <arrow> } ". Use " { $link fmap } " instead." } ;
+
+HELP: when-model
+{ $values { "model" model } { "quot" "called on the model if the quot yields true" } { "cond" "a quotation called on the model's value, yielding a boolean value" } }
+{ $description "Calls quot when model updates if its value meets the condition set in cond" } ;
+
+HELP: with-self
+{ $values { "quot" "quotation that recieves its own return value" } { "model" model } }
+{ $description "Fixed points for models: the quot reacts to the same model to gives" } ;
+
+HELP: #1
+{ $values { "model" model } { "model'" model } }
+{ $description "Moves a model to the top of its dependencies' connections, thus being notified before the others" } ;
+
+ARTICLE: "models.combinators" "Extending models"
+"The " { $vocab-link "models.combinators" } " library expands models to have discrete start and end times. "
+"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
+"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
+
+ABOUT: "models.combinators"
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel models models.product monads
+sequences sequences.extras ;
+FROM: syntax => >> ;
+IN: models.combinators
+
+TUPLE: multi-model < model important? ;
+GENERIC: (model-changed) ( model observer -- )
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
+M: multi-model model-activated dup dependencies>> [ value>> ] find nip
+ [ swap model-changed ] [ drop ] if* ;
+
+: #1 ( model -- model' ) t >>important? ;
+
+IN: models
+: notify-connections ( model -- )
+ dup connections>> dup [ dup multi-model? [ important?>> ] [ drop f ] if ] find-all
+ [ second tuck [ remove ] dip prefix ] each
+ [ model-changed ] with each ;
+IN: models.combinators
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: merge ( models -- model ) basic-model <multi-model> ;
+: 2merge ( model1 model2 -- model ) 2array merge ;
+: <basic> ( value -- model ) basic-model new-model ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+ [ set-model ] [ 2drop ] if ;
+: filter-model ( model quot -- filter-model ) [ 1array \ filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model quot base values ;
+M: fold-model (model-changed) 2dup base>> =
+ [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
+ [ [ [ value>> ] [ values>> ] bi* push ]
+ [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
+ ] if ;
+M: fold-model model-activated drop ;
+: new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
+: fold ( model oldval quot -- model ) rot 1array new-fold-model swap >>quot
+ swap >>value ;
+: fold* ( model oldmodel quot -- model ) over [ [ 2array new-fold-model ] dip >>quot ]
+ dip [ >>base ] [ value>> >>value ] bi ;
+
+TUPLE: updater-model < multi-model values updates ;
+M: updater-model (model-changed) [ tuck updates>> =
+ [ [ values>> value>> ] keep set-model ]
+ [ drop ] if ] keep f swap (>>value) ;
+: updates ( values updates -- model ) [ 2array updater-model <multi-model> ] 2keep
+ [ >>values ] [ >>updates ] bi* ;
+
+SYMBOL: switch
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model (model-changed) 2dup switcher>> =
+ [ [ value>> ] dip over switch = [ nip [ original>> ] keep f >>on model-changed ] [ t >>on set-model ] if ]
+ [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
+: switch-models ( model1 model2 -- model' ) swap [ 2array switch-model <multi-model> ] 2keep
+ [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: >behavior ( event -- behavior ) t >>value ;
+
+TUPLE: mapped-model < multi-model model quot ;
+: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
+ <multi-model> swap >>quot swap >>model ;
+: <mapped> ( model quot -- model ) mapped-model new-mapped-model ;
+M: mapped-model (model-changed)
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+TUPLE: side-effect-model < mapped-model ;
+M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
+
+TUPLE: quot-model < mapped-model ;
+M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
+
+TUPLE: action-value < basic-model parent ;
+: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
+M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
+
+TUPLE: action < multi-model quot ;
+M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
+ [ swap add-connection ] 2keep model-changed ;
+: <action> ( model quot -- action-model ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
+
+TUPLE: collection < multi-model ;
+: <collection> ( models -- product ) collection <multi-model> ;
+M: collection (model-changed)
+ nip
+ dup dependencies>> [ value>> ] all?
+ [ dup [ value>> ] product-value swap set-model ]
+ [ drop ] if ;
+M: collection model-activated dup (model-changed) ;
+
+! for side effects
+TUPLE: (when-model) < multi-model quot cond ;
+: when-model ( model quot cond -- model ) rot 1array (when-model) <multi-model> swap >>cond swap >>quot ;
+M: (when-model) (model-changed) [ quot>> ] 2keep
+ [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
+
+! only used in construction
+: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
+
+USE: models.combinators.templates
+<< { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
--- /dev/null
+Model combination and manipulation
\ No newline at end of file
--- /dev/null
+USING: kernel sequences functors fry macros generalizations ;
+IN: models.combinators.templates
+FROM: models.combinators => <collection> #1 ;
+FUNCTOR: fmaps ( W -- )
+W IS ${W}
+w-n DEFINES ${W}-n
+w-2 DEFINES 2${W}
+w-3 DEFINES 3${W}
+w-4 DEFINES 4${W}
+w-n* DEFINES ${W}-n*
+w-2* DEFINES 2${W}*
+w-3* DEFINES 3${W}*
+w-4* DEFINES 4${W}*
+WHERE
+MACRO: w-n ( int -- quot ) dup '[ [ _ narray <collection> ] dip [ _ firstn ] prepend W ] ;
+: w-2 ( a b quot -- mapped ) 2 w-n ; inline
+: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
+: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
+MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ] prepend W ] ;
+: w-2* ( a b quot -- mapped ) 2 w-n* ; inline
+: w-3* ( a b c quot -- mapped ) 3 w-n* ; inline
+: w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline
+;FUNCTOR
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors kernel models threads calendar ;
+IN: models.conditional
+
+TUPLE: conditional < model condition thread ;
+
+M: conditional model-changed
+ [
+ [ dup
+ [ condition>> call( -- ? ) ]
+ [ thread>> self = not ] bi or
+ [ [ value>> ] dip set-model f ]
+ [ 2drop t ] if 100 milliseconds sleep
+ ] 2curry "models.conditional" spawn-server
+ ] keep (>>thread) ;
+
+: <conditional> ( condition -- model )
+ f conditional new-model swap >>condition ;
+
+M: conditional model-activated [ model>> ] keep model-changed ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup modules.rpc-server modules.using ;
+IN: modules.rpc-server
+HELP: service
+{ $syntax "IN: my-vocab service" }
+{ $description "Allows words defined in the vocabulary to be used as remote procedure calls by " { $link POSTPONE: USING*: } } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators continuations effects
+io.encodings.binary io.servers.connection kernel namespaces
+sequences serialize sets threads vocabs vocabs.parser init io ;
+IN: modules.rpc-server
+
+<PRIVATE
+TUPLE: rpc-request args vocabspec wordname ;
+SYMBOL: serving-vocabs serving-vocabs [ V{ } clone ] initialize
+
+: getter ( -- ) deserialize dup serving-vocabs get-global index
+ [ vocab-words [ stack-effect ] { } assoc-map-as ]
+ [ \ no-vocab boa ] if serialize flush ;
+
+: doer ( -- ) deserialize dup vocabspec>> serving-vocabs get-global index
+ [ [ args>> ] [ wordname>> ] [ vocabspec>> vocab-words ] tri at [ execute ] curry with-datastack ]
+ [ vocabspec>> \ no-vocab boa ] if serialize flush ;
+
+PRIVATE>
+SYNTAX: service current-vocab name>> serving-vocabs get-global adjoin ;
+
+: start-rpc-server ( -- )
+ binary <threaded-server>
+ "rpcs" >>name 9012 >>insecure
+ [ deserialize {
+ { "getter" [ getter ] }
+ { "doer" [ doer ] }
+ { "loader" [ deserialize vocab serialize flush ] }
+ } case ] >>handler
+ start-server ;
--- /dev/null
+Serve factor words as rpcs
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry generalizations io.encodings.binary
+io.sockets kernel locals namespaces parser sequences serialize
+vocabs vocabs.parser words io ;
+IN: modules.rpc
+
+TUPLE: rpc-request args vocabspec wordname ;
+
+: send-with-check ( message -- reply/* )
+ serialize flush deserialize dup no-vocab? [ throw ] when ;
+
+:: define-remote ( str effect addrspec vocabspec -- )
+ str create-in effect [ in>> length ] [ out>> length ] bi
+ '[ _ narray vocabspec str rpc-request boa addrspec 9012 <inet> binary
+ [ "doer" serialize send-with-check ] with-client _ firstn ]
+ effect define-declared ;
+
+:: remote-vocab ( addrspec vocabspec -- vocab )
+ vocabspec "-remote" append dup vocab [ dup set-current-vocab
+ vocabspec addrspec 9012 <inet> binary [ "getter" serialize send-with-check ] with-client
+ [ first2 addrspec vocabspec define-remote ] each
+ ] unless ;
+
+: remote-load ( addr vocabspec -- voabspec ) [ swap
+ 9012 <inet> binary [ "loader" serialize serialize flush deserialize ] with-client ] keep
+ [ dictionary get-global set-at ] keep ;
\ No newline at end of file
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+Improved module import syntax with network transparency
\ No newline at end of file
--- /dev/null
+USING: help.syntax help.markup strings modules.using ;
+IN: modules.using
+ARTICLE: { "modules.using" "use" } "Using the modules.using vocab"
+"This vocabulary defines " { $link POSTPONE: USING*: } " as an alternative to " { $link POSTPONE: USING: } " which makes qualified imports easier. "
+"Secondly, it allows loading vocabularies from remote servers, as long as the remote vocabulary can be accessed at compile time. "
+"Finally, the word can treat words in remote vocabularies as remote procedure calls. Any inputs are passed to the imported words as normal, and the result will appear on the stack- the only difference is that the word isn't called locally." ;
+ABOUT: { "modules.using" "use" }
+
+HELP: USING*:
+{ $syntax "USING: rpc-server::module fetch-sever:module { module qualified-name } { module => word ... } { qualified-module } { module EXCEPT word ... } { module word => importname } ;" }
+{ $description "Adds vocabularies to the search path. Vocabularies can be loaded off a server or called as an rpc if preceded by a valid hostname. Bracketed pairs facilitate all types of qualified imports on both remote and local modules." } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel modules.rpc peg peg-lexer peg.ebnf sequences
+strings vocabs.parser ;
+IN: modules.using
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+module = rpc | remote | tokenpart
+;EBNF
+
+ON-BNF: USING*:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>"|"EXCEPT").
+modspec = sym => [[ modulize ]]
+qualified-with = modspec sym => [[ first2 add-qualified ignore ]]
+qualified = modspec => [[ dup add-qualified ignore ]]
+from = modspec "=>" sym+ => [[ first3 nip add-words-from ignore ]]
+exclude = modspec "EXCEPT" sym+ => [[ first3 nip add-words-excluding ignore ]]
+rename = modspec sym "=>" sym => [[ first4 nip swapd add-renamed-word ignore ]]
+long = "{" ( from | exclude | rename | qualified-with | qualified ) "}" => [[ drop ignore ]]
+short = modspec => [[ use-vocab ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
] unit-test
LAZY: nats-from ( n -- list )
- dup 1+ nats-from cons ;
+ dup 1 + nats-from cons ;
: nats ( -- list ) 0 nats-from ;
! Functors
GENERIC# fmap 1 ( functor quot -- functor' )
+GENERIC# <$ 1 ( functor quot -- functor' )
+GENERIC# $> 1 ( functor quot -- functor' )
! Monads
M: monad fail monad-of fail ;
: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
+: bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
:: lift-m2 ( m1 m2 f monad -- m3 )
[
[ dup string>number [ nip ] [ not-an-integer ] if* ] bi@
] keep length
- 10 swap ^ / + swap [ neg ] when ;
+ 10^ / + swap [ neg ] when ;
SYNTAX: DECIMAL: scan parse-decimal parsed ;
ui.gadgets.worlds ui.render accessors combinators literals ;
IN: opengl.demo-support
-CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: FOV $[ 2.0 sqrt 1 + ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0
: sorted-pair-methods ( word -- alist )
"pair-generic-methods" word-prop >alist
- [ [ first method-sort-key ] bi@ >=< ] sort ;
+ [ first method-sort-key ] inv-sort-with ;
: pair-generic-definition ( word -- def )
[ sorted-pair-methods [ first2 pair-method-cond ] map ]
2drop epsilon
] [
2dup exactly-n
- -rot 1- at-most-n <|>
+ -rot 1 - at-most-n <|>
] if ;
: at-least-n ( parser n -- parser' )
:: prepare-pos ( v i -- c l )
[let | n [ i v head-slice ] |
- v CHAR: \n n last-index -1 or 1+ -
- n [ CHAR: \n = ] count 1+
+ v CHAR: \n n last-index -1 or 1 + -
+ n [ CHAR: \n = ] count 1 +
] ;
: store-pos ( v a -- )
[ swap hash>> set-at ]
} case ;
-:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1- + c + ;
+:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1 - + c + ;
M: lex-hash at*
swap {
{ input [ drop lexer get text>> "\n" join t ] }
- { pos [ drop lexer get [ text>> ] [ line>> 1- ] [ column>> 1+ ] tri at-pos t ] }
+ { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] }
[ swap hash>> at* ]
} case ;
spaces = space* => [[ drop ignore ]]
chunk = (!(space) .)+ => [[ >string ]]
expr = spaces chunk
-;EBNF
\ No newline at end of file
+;EBNF
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays byte-arrays calendar classes
+classes.tuple classes.tuple.parser combinators db db.queries
+db.tuples db.types kernel math nmake parser sequences strings
+strings.parser unicode.case urls words ;
+IN: persistency
+
+TUPLE: persistent id ;
+
+: add-types ( table -- table' ) [ dup array? [ [ first dup >upper ] [ second ] bi 3array ]
+ [ dup >upper FACTOR-BLOB 3array ] if
+ ] map { "id" "ID" +db-assigned-id+ } prefix ;
+
+: remove-types ( table -- table' ) [ dup array? [ first ] when ] map ;
+
+SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ remove-types define-tuple-class ]
+ [ nip [ dup name>> >upper ] [ add-types ] bi* define-persistent ] 3bi ;
+
+: define-db ( database class -- ) swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
+
+: query>tuple ( tuple/query -- tuple ) dup query? [ tuple>> ] when ;
+: w/db ( query quot -- ) [ dup query>tuple class "database" word-prop ] dip with-db ; inline
+: get-tuples ( query -- tuples ) [ select-tuples ] w/db ;
+: get-tuple ( query -- tuple ) [ select-tuple ] w/db ;
+: store-tuple ( tuple -- ) [ insert-tuple ] w/db ;
+: modify-tuple ( tuple -- ) [ update-tuple ] w/db ;
+: remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
+
+TUPLE: pattern value ; C: <pattern> pattern
+SYNTAX: %" parse-string <pattern> parsed ;
+M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;
<PRIVATE
: sum-divisible-by ( target n -- m )
- [ /i dup 1+ * ] keep * 2 /i ;
+ [ /i dup 1 + * ] keep * 2 /i ;
PRIVATE>
! --------
: euler012 ( -- answer )
- 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] while nth-triangle ;
+ 8 [ dup nth-triangle tau* 500 < ] [ 1 + ] while nth-triangle ;
! [ euler012 ] 10 ave-time
! 6573 ms ave run time - 346.27 SD (10 trials)
<PRIVATE
: next-collatz ( n -- n )
- dup even? [ 2 / ] [ 3 * 1+ ] if ;
+ dup even? [ 2 / ] [ 3 * 1 + ] if ;
: longest ( seq seq -- seq )
2dup [ length ] bi@ > [ drop ] [ nip ] if ;
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ divisor? ] [ / even? ] } 2&& ;
+ 1 - 3 { [ divisor? ] [ / even? ] } 2&& ;
PRIVATE>
ascii file-contents [ quotable? ] filter "," split ;
: name-scores ( seq -- seq )
- [ 1+ swap alpha-value * ] map-index ;
+ [ 1 + swap alpha-value * ] map-index ;
PRIVATE>
<PRIVATE
: (digit-fib) ( n term -- term )
- 2dup fib number>string length > [ 1+ (digit-fib) ] [ nip ] if ;
+ 2dup fib number>string length > [ 1 + (digit-fib) ] [ nip ] if ;
: digit-fib ( n -- term )
1 (digit-fib) ;
<PRIVATE
: digit-fib* ( n -- term )
- 1- 5 log10 2 / + phi log10 / ceiling >integer ;
+ 1 - 5 log10 2 / + phi log10 / ceiling >integer ;
PRIVATE>
1 1000 (a,b) [ prime? ] filter [ 1 swap / ] map ;
: (mult-order) ( n a m -- k )
- 3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ;
+ 3dup ^ swap mod 1 = [ 2nip ] [ 1 + (mult-order) ] if ;
PRIVATE>
dup sq -rot * + + ;
: (consecutive-primes) ( b a n -- m )
- 3dup quadratic prime? [ 1+ (consecutive-primes) ] [ 2nip ] if ;
+ 3dup quadratic prime? [ 1 + (consecutive-primes) ] [ 2nip ] if ;
: consecutive-primes ( a b -- m )
swap 0 (consecutive-primes) ;
PRIVATE>
: euler030 ( -- answer )
- 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
+ 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1 - ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
: (circular?) ( seq n -- ? )
dup 0 > [
2dup rotate 10 digits>integer
- prime? [ 1- (circular?) ] [ 2drop f ] if
+ prime? [ 1 - (circular?) ] [ 2drop f ] if
] [
2drop t
] if ;
: circular? ( seq -- ? )
- dup length 1- (circular?) ;
+ dup length 1 - (circular?) ;
PRIVATE>
pick length 8 > [
2drop 10 digits>integer
] [
- [ * number>digits over push-all ] 2keep 1+ (concat-product)
+ [ * number>digits over push-all ] 2keep 1 + (concat-product)
] if ;
: concat-product ( n -- m )
p-count get length ;
: adjust-p-count ( n -- )
- max-p 1- over <range> p-count get
- [ [ 1+ ] change-nth ] curry each ;
+ max-p 1 - over <range> p-count get
+ [ [ 1 + ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
: (concat-upto) ( n limit str -- str )
2dup length > [
- pick number>string over push-all rot 1+ -rot (concat-upto)
+ pick number>string over push-all rot 1 + -rot (concat-upto)
] [
2nip
] if ;
SBUF" " clone 1 -rot (concat-upto) ;
: nth-integer ( n str -- m )
- [ 1- ] dip nth 1string string>number ;
+ [ 1 - ] dip nth 1string string>number ;
PRIVATE>
: (triangle-upto) ( limit n -- )
2dup nth-triangle > [
- dup nth-triangle , 1+ (triangle-upto)
+ dup nth-triangle , 1 + (triangle-upto)
] [
2drop
] if ;
<PRIVATE
: triangle? ( n -- ? )
- 8 * 1+ sqrt 1- 2 / 1 mod zero? ;
+ 8 * 1 + sqrt 1 - 2 / 1 mod zero? ;
PRIVATE>
<PRIVATE
: subseq-divisible? ( n index seq -- ? )
- [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
+ [ 1 - dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
: interesting? ( seq -- ? )
{
<PRIVATE
: nth-pentagonal ( n -- seq )
- dup 3 * 1- * 2 / ;
+ dup 3 * 1 - * 2 / ;
: sum-and-diff? ( m n -- ? )
[ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
<PRIVATE
: nth-hexagonal ( n -- m )
- dup 2 * 1- * ;
+ dup 2 * 1 - * ;
DEFER: next-solution
dup pentagonal? [ nip ] [ drop next-solution ] if ;
: next-solution ( n -- m )
- 1+ dup nth-hexagonal (next-solution) ;
+ 1 + dup nth-hexagonal (next-solution) ;
PRIVATE>
dup perfect-squares [ 2 * - ] with map [ prime? ] any? ;
: next-odd-composite ( n -- m )
- dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ;
+ dup odd? [ 2 + ] [ 1 + ] if dup prime? [ next-odd-composite ] when ;
: disprove-conjecture ( n -- m )
dup fits-conjecture? [ next-odd-composite disprove-conjecture ] when ;
swap - nip
] [
dup prime? [ [ drop 0 ] 2dip ] [
- 2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if
- ] if 1+ (consecutive)
+ 2dup unique-factors length = [ [ 1 + ] 2dip ] [ [ drop 0 ] 2dip ] if
+ ] if 1 + (consecutive)
] if ;
: consecutive ( goal test -- n )
sieve get nth 0 = ;
: multiples ( n -- seq )
- sieve get length 1- over <range> ;
+ sieve get length 1 - over <range> ;
: increment-counts ( n -- )
- multiples [ sieve get [ 1+ ] change-nth ] each ;
+ multiples [ sieve get [ 1 + ] change-nth ] each ;
: prime-tau-upto ( limit -- seq )
dup initialize-sieve 2 swap [a,b) [
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges project-euler.common sequences ;
+USING: kernel math math.functions math.ranges
+project-euler.common sequences ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
! --------
: euler048 ( -- answer )
- 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
+ 1000 [1,b] [ dup ^ ] sigma 10 10^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
: count-digits ( n -- byte-array )
10 <byte-array> [
- '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+ '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
] keep ;
HINTS: count-digits fixnum ;
2dup [ first ] bi@ > [ drop ] [ nip ] if ;
: continue? ( pair seq -- ? )
- [ first ] [ length 1- ] bi* < ;
+ [ first ] [ length 1 - ] bi* < ;
: (find-longest) ( best seq limit -- best )
[ longest-prime longest ] 2keep 2over continue? [
<PRIVATE
: map-nx ( n x -- seq )
- [ 1+ * ] with map ; inline
+ [ 1 + * ] with map ; inline
: all-same-digits? ( seq -- ? )
[ number>digits natural-sort ] map all-equal? ;
: next-all-same ( x n -- n )
dup candidate? [
2dup swap map-nx all-same-digits?
- [ nip ] [ 1+ next-all-same ] if
+ [ nip ] [ 1 + next-all-same ] if
] [
- 1+ next-all-same
+ 1 + next-all-same
] if ;
PRIVATE>
! (n-2)² + 4(n-1) = odd squares, no need to calculate
: prime-corners ( n -- m )
- 3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ;
+ 3 [1,b] swap '[ _ [ 1 - * ] keep 2 - sq + prime? ] count ;
: total-corners ( n -- m )
- 1- 2 * ; foldable
+ 1 - 2 * ; foldable
: ratio-below? ( count length -- ? )
- total-corners 1+ / PERCENT_PRIME < ;
+ total-corners 1 + / PERCENT_PRIME < ;
: next-layer ( count length -- count' length' )
2 + [ prime-corners + ] keep ;
} cond product ;
: primorial-upto ( limit -- m )
- 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+ 1 swap '[ dup primorial _ <= ] [ 1 + dup primorial ] produce
nip penultimate ;
PRIVATE>
p-count get length ;
: adjust-p-count ( n -- )
- max-p 1- over <range> p-count get
- [ [ 1+ ] change-nth ] curry each ;
+ max-p 1 - over <range> p-count get
+ [ [ 1 + ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
over zero? [
3drop
] [
- [ [ 1- 2array ] dip at ]
+ [ [ 1 - 2array ] dip at ]
[ [ use 2array ] dip at + ]
[ [ 2array ] dip set-at ] 3tri
] if ;
: (euler076) ( n -- m )
dup init
[ [ ways ] curry each-subproblem ]
- [ [ dup 2array ] dip at 1- ] 2bi ;
+ [ [ dup 2array ] dip at 1 - ] 2bi ;
PRIVATE>
567 [1,b] [ chain-ending ] map ;
: fast-chain-ending ( seq n -- m )
- dup 567 > [ next-link ] when 1- swap nth ;
+ dup 567 > [ next-link ] when 1 - swap nth ;
PRIVATE>
! --------
: euler097 ( -- answer )
- 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
+ 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1 + ;
! [ euler097 ] 100 ave-time
! 0 ms ave run timen - 0.22 SD (100 trials)
flip first2 swap [ log ] map v* ;
: solve ( seq -- index )
- simplify [ supremum ] keep index 1+ ;
+ simplify [ supremum ] keep index 1 + ;
PRIVATE>
: euler100 ( -- answer )
1 1
- [ dup dup 1- * 2 * 10 24 ^ <= ]
+ [ dup dup 1 - * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] while nip ;
! TODO: solution needs generalization
<PRIVATE
: nth* ( n seq -- elt/0 )
- [ length swap - 1- ] keep ?nth 0 or ;
+ [ length swap - 1 - ] keep ?nth 0 or ;
: next ( colortile seq -- )
[ nth* ] [ last + ] [ push ] tri ;
: ways ( length colortile -- permutations )
- V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ;
+ V{ 1 } clone [ [ next ] 2curry times ] keep last 1 - ;
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
<PRIVATE
: sum-1toN ( n -- sum )
- dup 1+ * 2/ ; inline
+ dup 1 + * 2/ ; inline
: >base7 ( x -- y )
[ dup 0 > ] [ 7 /mod ] produce nip ;
: (use-digit) ( prev x index -- next )
- [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
+ [ [ 1 + * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
: (euler148) ( x -- y )
>base7 0 [ (use-digit) ] reduce-index ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
- x 1+ [| y |
+ x 1 + [| y |
m x - [0,b) [| z |
x z + table nth-unsafe
- [ y z + 1+ swap nth-unsafe ]
+ [ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
] map partial-sum-infimum
] map-infimum
--- /dev/null
+USING: project-euler.151 tools.test ;
+IN: project-euler.151.tests
+
+[ 12138569781349/26138246400000 ] [ euler151 ] unit-test
: (pick-sheet) ( seq i -- newseq )
[
- <=> sgn
+ <=>
{
- { -1 [ ] }
- { 0 [ 1- ] }
- { 1 [ 1+ ] }
+ { +lt+ [ ] }
+ { +eq+ [ 1 - ] }
+ { +gt+ [ 1 + ] }
} case
] curry map-index ;
: (euler151) ( x -- y )
table get [ {
{ { 0 0 0 1 } [ 0 ] }
- { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
- { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
- { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
+ { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1 + ] }
+ { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
+ { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
[ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
{ 1 1 1 1 } (euler151)
] with-scope ;
-! TODO: doesn't work currently, problem in area of 'with map' in (euler151)
-
! [ euler151 ] 100 ave-time
! ? ms run time - 100 trials
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- [ 2/ [ fn ] [ 1- fn ] bi + ]
+ [ 2/ [ fn ] [ 1 - fn ] bi + ]
} cond ;
: euler169 ( -- result )
: compute ( vec ratio -- )
{
- { [ dup integer? ] [ 1- 0 add-bits ] }
+ { [ dup integer? ] [ 1 - 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
[ [ 1 mod compute ] 2keep >integer 0 add-bits ]
} cond ;
pick [ next ] [ next ] bi
[ = ] [
pick equate
- [ 1+ ] dip
+ [ 1 + ] dip
] 2unless? (p186)
] [
drop nip
PRIVATE>
:: P_m ( m -- P_m )
- m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+ m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ;
: euler190 ( -- answer )
2 15 [a,b] [ P_m truncate ] sigma ;
[ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
: generate ( n -- seq )
- 1- { 1 } [ (generate) ] iterate concat prune ;
+ 1 - { 1 } [ (generate) ] iterate concat prune ;
: squarefree ( n -- ? )
factors all-unique? ;
: first-row ( n -- t )
[ <failure> <success> <failure> ] dip
- 1- [| a b c | b c <block> a b ] times 2drop ;
+ 1 - [| a b c | b c <block> a b ] times 2drop ;
GENERIC: total ( t -- n )
M: block total [ total ] dup choice + ;
M: end total ways>> ;
: solve ( width height -- ways )
- [ first-row ] dip 1- [ next-row ] times total ;
+ [ first-row ] dip 1 - [ next-row ] times total ;
PRIVATE>
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations fry io kernel make math math.functions math.parser
- math.statistics memory tools.time ;
+USING: continuations fry io kernel make math math.functions
+math.parser math.statistics memory tools.time ;
IN: project-euler.ave-time
: nth-place ( x n -- y )
- 10 swap ^ [ * round >integer ] keep /f ;
+ 10^ [ * round >integer ] keep /f ;
: collect-benchmarks ( quot n -- seq )
[
'[ _ gc benchmark 1000 / , ] tuck
'[ _ _ with-datastack drop ]
]
- [ 1- ] tri* swap times call
+ [ 1 - ] tri* swap times call
] { } make ; inline
: ave-time ( quot n -- )
<PRIVATE
: max-children ( seq -- seq )
- [ dup length 1- [ nth-pair max , ] with each ] { } make ;
+ [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
PRIVATE>
: alpha-value ( str -- n )
- >lower [ CHAR: a - 1+ ] sigma ;
+ >lower [ CHAR: a - 1 + ] sigma ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map concat ;
-: log10 ( m -- n )
- log 10 log / ;
-
: mediant ( a/c b/d -- (a+b)/(c+d) )
2>fraction [ + ] 2bi@ / ;
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
: number-length ( n -- m )
- log10 floor 1+ >integer ;
+ log10 floor 1 + >integer ;
: nth-prime ( n -- n )
- 1- lprimes lnth ;
+ 1 - lprimes lnth ;
: nth-triangle ( n -- n )
- dup 1+ * 2 / ;
+ dup 1 + * 2 / ;
: palindrome? ( n -- ? )
number>string dup reverse = ;
number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
- dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+ dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ;
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
! The divisor function, counts the number of divisors
: tau ( m -- n )
- group-factors flip second 1 [ 1+ * ] reduce ;
+ group-factors flip second 1 [ 1 + * ] reduce ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n )
- factor-2s dup [ 1+ ]
+ factor-2s dup [ 1 + ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
dupd divisor? [ [ 2 + ] dip ] when
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays colors.constants combinators
+db.sqlite db.tuples db.types kernel locals math
+monads persistency sequences sequences.extras ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.labels
+ui.gadgets.scrollers ui.pens.solid io.files.temp ;
+FROM: sets => prune ;
+IN: recipes
+
+STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } { genre { VARCHAR 100 } } ;
+: <recipe> ( title genre text -- recipe ) recipe new swap >>txt swap >>genre swap >>title 0 >>votes ;
+"recipes.db" temp-file <sqlite-db> recipe define-db
+: top-recipes ( offset search -- recipes ) <query> T{ recipe } rot >>title >>tuple
+ "votes" >>order 30 >>limit swap >>offset get-tuples ;
+: top-genres ( -- genres ) f f top-recipes [ genre>> ] map prune 4 short head-slice ;
+
+: interface ( -- book ) [
+ [
+ [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
+ [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
+ { 5 0 } >>gap COLOR: gray <solid> >>interior ,
+ $ RECIPES $
+ ] <vbox> ,
+ [
+ [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
+ $ BODY $
+ $ BUTTON $
+ ] <vbox> ,
+ ] <book*> { 350 245 } >>pref-dim ;
+
+:: recipe-browser ( -- ) [ [
+ interface
+ <table*> :> tbl
+ "okay" <model-border-btn> BUTTON -> :> ok
+ IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
+ IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
+ IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
+ IMG-MODEL-BTN: back -> [ -30 ] <$
+ IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
+ <spacer> <model-field*> ->% 1 :> search
+ submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
+ viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> ALL ->
+ tbl selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
+ 4array merge
+ [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
+ ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
+ [ text>> T{ recipe } swap >>genre get-tuples ] fmap
+ tbl swap ups 2merge >>model
+ [ [ title>> ] [ genre>> ] bi 2array ] >>quot
+ { "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
+ submit [ "" dup dup <recipe> ] <$ 2array merge
+ { [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
+ [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
+ [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
+ } cleave
+ [ <recipe> ] 3fmap
+ [ [ 1 ] <$ ]
+ [ quot ok updates #1 [ call( recipe -- ) 0 ] 2fmap ] bi
+ 2merge 0 <basic> switch-models >>model
+ ] with-interface "recipes" open-window ] with-ui ;
+
+MAIN: recipe-browser
\ No newline at end of file
--- /dev/null
+Database backed recipe sharing
\ No newline at end of file
--- /dev/null
+USING: io io.encodings.utf8 io.launcher kernel sequences ;
+IN: run-desc
+: run-desc ( desc -- result ) utf8 [ contents [ but-last ] [ f ] if* ] with-process-reader ;
[ "cd" ]
[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-[ f ]
-[
- "\"abc\" asdf" <sequence-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
- "\"abc\\\"def\" asdf" <sequence-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
- "\"abc\" asdf" <sequence-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
- "\"abc asdf" <sequence-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
- "\"abc asdf" <sequence-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <sequence-parser> take-token ] unit-test
-
-[ f ]
-[ "" <sequence-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
[ f ]
[ "" <sequence-parser> take-rest ] unit-test
[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
-[ "asdfasdf" ] [
- "/*asdfasdf*/" <sequence-parser> take-c-comment
-] unit-test
-
-[ "k" ] [
- "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "omg" ] [
- "//asdfasdf\nomg" <sequence-parser>
- [ take-c++-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "omg" ] [
- "omg" <sequence-parser>
- [ take-c++-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "/*asdfasdf" ] [
- "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "asdf" "eoieoei" ] [
- "//asdf\neoieoei" <sequence-parser>
- [ take-c++-comment ] [ take-rest ] bi
-] unit-test
-
-[ f "33asdf" ]
-[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
-
-[ "asdf" ]
-[ "asdf" <sequence-parser> take-c-identifier ] unit-test
-
-[ "_asdf" ]
-[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
-
-[ "_asdf400" ]
-[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
-
-[ "123" ]
-[ "123jjj" <sequence-parser> take-c-integer ] unit-test
-
-[ "123uLL" ]
-[ "123uLL" <sequence-parser> take-c-integer ] unit-test
-
-[ "123ull" ]
-[ "123ull" <sequence-parser> take-c-integer ] unit-test
-
-[ "123u" ]
-[ "123u" <sequence-parser> take-c-integer ] unit-test
-
-[ 36 ]
-[
- " //jofiejoe\n //eoieow\n/*asdf*/\n "
- <sequence-parser> skip-whitespace/comments n>>
-] unit-test
-
[ f ]
[ "\n" <sequence-parser> take-integer ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting math.parser math.ranges
-generalizations sorting.functor math.order sorting.slots ;
+USING: accessors circular combinators.short-circuit fry io
+kernel locals math math.order sequences sorting.functor
+sorting.slots unicode.categories ;
IN: sequence-parser
TUPLE: sequence-parser sequence n ;
] take-until :> found
growing sequence sequence= [
found dup length
- growing length 1- - head
+ growing length 1 - - head
sequence-parser [ growing length - 1 + ] change-n drop
! sequence-parser advance drop
] [
: skip-whitespace-eol ( sequence-parser -- sequence-parser )
[ [ current " \t\r" member? not ] take-until drop ] keep ;
-: take-c-comment ( sequence-parser -- seq/f )
- [
- dup "/*" take-sequence [
- "*/" take-until-sequence*
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
-: take-c++-comment ( sequence-parser -- seq/f )
- [
- dup "//" take-sequence [
- [
- [
- { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
- ] take-until
- ] [
- advance drop
- ] bi
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
-: skip-whitespace/comments ( sequence-parser -- sequence-parser )
- skip-whitespace-eol
- {
- { [ dup take-c-comment ] [ skip-whitespace/comments ] }
- { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
- [ ]
- } cond ;
-
-: take-define-identifier ( sequence-parser -- string )
- skip-whitespace/comments
- [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-
: take-rest-slice ( sequence-parser -- sequence/f )
[ sequence>> ] [ n>> ] bi
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
: parse-sequence ( sequence quot -- )
[ <sequence-parser> ] dip call ; inline
-:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
- sequence-parser n>> :> start-n
- sequence-parser advance
- [
- {
- [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
- [ current quote-char = not ]
- } 1||
- ] take-while :> string
- sequence-parser current quote-char = [
- sequence-parser advance* string
- ] [
- start-n sequence-parser (>>n) f
- ] if ;
-
-: (take-token) ( sequence-parser -- string )
- skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-
-:: take-token* ( sequence-parser escape-char quote-char -- string/f )
- sequence-parser skip-whitespace
- dup current {
- { quote-char [ escape-char quote-char take-quoted-string ] }
- { f [ drop f ] }
- [ drop (take-token) ]
- } case ;
-
-: take-token ( sequence-parser -- string/f )
- CHAR: \ CHAR: " take-token* ;
-
: take-integer ( sequence-parser -- n/f )
[ current digit? ] take-while ;
sequence-parser [ n + ] change-n drop
] if ;
-: c-identifier-begin? ( ch -- ? )
- CHAR: a CHAR: z [a,b]
- CHAR: A CHAR: Z [a,b]
- { CHAR: _ } 3append member? ;
-
-: c-identifier-ch? ( ch -- ? )
- CHAR: a CHAR: z [a,b]
- CHAR: A CHAR: Z [a,b]
- CHAR: 0 CHAR: 9 [a,b]
- { CHAR: _ } 4 nappend member? ;
-
-: (take-c-identifier) ( sequence-parser -- string/f )
- dup current c-identifier-begin? [
- [ current c-identifier-ch? ] take-while
- ] [
- drop f
- ] if ;
-
-: take-c-identifier ( sequence-parser -- string/f )
- [ (take-c-identifier) ] with-sequence-parser ;
-
<< "length" [ length ] define-sorting >>
: sort-tokens ( seq -- seq' )
swap
'[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
-
: take-longest ( sequence-parser seq -- seq )
sort-tokens take-first-matching ;
-: take-c-integer ( sequence-parser -- string/f )
- [
- dup take-integer [
- swap
- { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
- take-longest [ append ] when*
- ] [
- drop f
- ] if*
- ] with-sequence-parser ;
-
-CONSTANT: c-punctuators
- {
- "[" "]" "(" ")" "{" "}" "." "->"
- "++" "--" "&" "*" "+" "-" "~" "!"
- "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
- "?" ":" ";" "..."
- "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
- "," "#" "##"
- "<:" ":>" "<%" "%>" "%:" "%:%:"
- }
-
-: take-c-punctuator ( sequence-parser -- string/f )
- c-punctuators take-longest ;
-
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
--- /dev/null
+USING: arrays kernel locals math sequences ;
+IN: sequences.extras
+: reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
+
+:: reduce-r
+ ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+ list empty?
+ [ identity ]
+ [ list rest identity quot reduce-r list first quot call ] if ;
+ inline recursive
+
+! Quot must have static stack effect, unlike "reduce"
+:: reduce* ( seq id quot -- result ) seq
+ [ id ]
+ [ unclip id swap quot call( prev elt -- next ) quot reduce* ] if-empty ; inline recursive
+
+:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;
+: find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip
+ [ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline
+
+: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
\ No newline at end of file
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
:: (carry-n) ( ns lengths i -- )
- ns length i 1+ = [
+ ns length i 1 + = [
i ns nth i lengths nth = [
0 i ns set-nth
- i 1+ ns [ 1+ ] change-nth
- ns lengths i 1+ (carry-n)
+ i 1 + ns [ 1 + ] change-nth
+ ns lengths i 1 + (carry-n)
] when
] unless ;
0 (carry-n) ;
: product-iter ( ns lengths -- )
- [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
+ [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
: start-product-iter ( sequence-product -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
0 :> i!
sequences [ length ] [ * ] map-reduce sequences
[| result |
- sequences [ quot call i result set-nth i 1+ i! ] product-each
+ sequences [ quot call i result set-nth i 1 + i! ] product-each
result
] new-like ; inline
--- /dev/null
+USING: accessors assocs fry generalizations kernel math
+namespaces parser sequences words ;
+IN: set-n
+: get* ( var n -- val ) namestack dup length rot - head assoc-stack ;
+
+: set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ;
+
+! dynamic lambda
+SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
\ No newline at end of file
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
- dup third length 1- [
+ dup third length 1 - [
2 + (strip-tease)
] with map ;
[ lexenv self>> suffix ] dip <lambda> ;
: compile-method-body ( lexenv block -- quot )
- [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
+ [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
make-return ;
: compile-method ( lexenv ast-method -- )
: compile-smalltalk ( statement -- quot )
[ empty-lexenv ] dip [ compile-sequence nip 0 ]
- 2keep make-return ;
\ No newline at end of file
+ 2keep make-return ;
[ host>> = ] with partition ;
: add-spidered ( spider spider-result -- )
- [ [ 1+ ] change-count ] dip
+ [ [ 1 + ] change-count ] dip
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
[ filter-base-links ] 2keep
- depth>> 1+ swap
+ depth>> 1 + swap
[ add-nonmatching ]
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: combinators effects kernel math sequences splitting
-strings.parser ;
-IN: str-fry
-: str-fry ( str -- quot ) "_" split
- [ unclip [ [ rot glue ] reduce ] 2curry ]
- [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
-SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file
+++ /dev/null
-String Frying
\ No newline at end of file
DEFER: search
: assume ( n x y -- )
- [ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ;
+ [ >board ] 2keep [ [ 1 + ] dip search ] 2keep f>board ;
: attempt ( n x y -- )
{
[ assume ]
} cond ;
-: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
+: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ;
: board. ( board -- )
standard-table-style [
: search ( x y -- )
{
- { [ over 9 = ] [ [ drop 0 ] dip 1+ search ] }
+ { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
- { [ 2dup board> ] [ [ 1+ ] dip search ] }
+ { [ 2dup board> ] [ [ 1 + ] dip search ] }
[ solve ]
} cond ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays combinators.short-circuit grouping kernel lists
+lists.lazy locals math math.functions math.parser math.ranges
+models.product monads random sequences sets ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
+ui.gadgets.labels ;
+IN: sudokus
+
+: row ( index -- row ) 1 + 9 / ceiling ;
+: col ( index -- col ) 9 mod 1 + ;
+: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
+: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
+: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
+
+:: solutions ( puzzle random? -- solutions )
+ f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
+ [ :> pos
+ 1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff
+ [ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
+ ] [ puzzle list-monad return ] if* ;
+
+: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
+: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
+: create ( difficulty -- puzzle ) 81 [ f ] replicate
+ 40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
+
+: do-sudoku ( -- ) [ [
+ [
+ 81 [ "" ] replicate <basic> switch-models [ [ <basic> ] map 9 group [ 3 group ] map 3 group
+ [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
+ map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
+ [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
+ "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
+ "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
+ roll [ swap updates ] curry bi@
+ [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
+ ] bind
+ ] with-self , ] <vbox> { 280 220 } >>pref-dim
+ "Sudoku Sleuth" open-window ] with-ui ;
+
+MAIN: do-sudoku
\ No newline at end of file
--- /dev/null
+graphical sudoku solver
\ No newline at end of file
: svg-string>number ( string -- number )
{ { CHAR: E CHAR: e } } substitute "e" split1
- [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* *
+ [ string>number ] [ [ string>number 10^ ] [ 1 ] if* ] bi* *
>float ;
: degrees ( deg -- rad ) pi * 180.0 / ;
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1+
+ MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep <uint>
GetComputerName win32-error=0/f alien>native-string ;
destructors grid-meshes ;
IN: terrain
-CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: FOV $[ 2.0 sqrt 1 + ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
[ not ] change-paused? drop ;
: level>> ( tetris -- level )
- rows>> 1+ 10 / ceiling ;
+ rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval )
- level>> 1- 60 * 1000 swap - ;
+ level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
over board>> spin current-piece tetromino>> colour>> set-block ;
{ 2 [ 100 ] }
{ 3 [ 300 ] }
{ 4 [ 1200 ] }
- } case swap 1+ * ;
+ } case swap 1 + * ;
: add-score ( tetris n-rows -- tetris )
over level>> swap rows-score swap [ + ] change-score ;
tetrominoes get random ;
: blocks-max ( blocks quot -- max )
- map [ 1+ ] [ max ] map-reduce ; inline
+ map [ 1 + ] [ max ] map-reduce ; inline
: blocks-width ( blocks -- width )
[ first ] blocks-max ;
: go-left? ( -- ? ) current-side get left eq? ;
-: inc-count ( tree -- ) [ 1+ ] change-count drop ;
+: inc-count ( tree -- ) [ 1 + ] change-count drop ;
-: dec-count ( tree -- ) [ 1- ] change-count drop ;
+: dec-count ( tree -- ) [ 1 - ] change-count drop ;
: node-link@ ( node ? -- node )
go-left? xor [ left>> ] [ right>> ] if ;
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.markup help.syntax models monads sequences
-ui.gadgets.buttons ui.gadgets.tracks ;
-IN: ui.frp
-
-! Layout utilities
-
-HELP: ,
-{ $values { "uiitem" "a gadget or model" } }
-{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
-HELP: ->
-{ $values { "uiitem" "a gadget or model" } { "model" model } }
-{ $description "Like " { $link , } "but passes its model on for further use." } ;
-HELP: <hbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
-HELP: <vbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
-
-! Gadgets
-HELP: <frp-button>
-{ $values { "text" "the button's label" } { "button" button } }
-{ $description "Creates an button whose model updates on clicks" } ;
-
-HELP: <merge>
-{ $values { "models" "a list of models" } { "model" merge-model } }
-{ $description "Creates a model that merges the updates of others" } ;
-
-HELP: <filter>
-{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
-{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
-
-HELP: <fold>
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
-{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-
-HELP: <switch>
-{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
-{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
-
-ARTICLE: { "frp" "instances" } "FRP Instances"
-"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
-"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
-
+++ /dev/null
-USING: accessors arrays colors fonts kernel models
-models.product monads sequences ui.gadgets ui.gadgets.buttons
-ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
-ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
-QUALIFIED: make
-IN: ui.frp
-
-! Gadgets
-: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
-TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
-M: frp-table column-titles column-titles>> ;
-M: frp-table column-alignment column-alignment>> ;
-M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-
-: <frp-table> ( model -- table )
- frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
- f <model> >>selected-value sans-serif-font >>font
- focus-border-color >>focus-border-color
- transparent >>column-line-color [ ] >>val-quot ;
-: <frp-table*> ( -- table ) f <model> <frp-table> ;
-: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
-: <frp-list*> ( -- table ) f <model> <frp-list> ;
-
-: <frp-field> ( -- field ) f <model> <model-field> ;
-
-! Layout utilities
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: frp-table output-model selected-value>> ;
-M: model-field output-model field-model>> ;
-M: scroller output-model children>> first model>> ;
-
-GENERIC: , ( uiitem -- )
-M: gadget , make:, ;
-M: model , activate-model ;
-
-GENERIC: -> ( uiitem -- model )
-M: gadget -> dup make:, output-model ;
-M: model -> dup , ;
-M: table -> dup , selected-value>> ;
-
-: <box> ( gadgets type -- track )
- [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
-: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
-: <hbox> ( gadgets -- track ) horizontal <box> ; inline
-: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
-: <vbox> ( gadgets -- track ) vertical <box> ; inline
-: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
-
-! !!! Model utilities
-TUPLE: multi-model < model ;
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-
-! Events- discrete model utilities
-
-TUPLE: merge-model < multi-model ;
-M: merge-model model-changed [ value>> ] dip set-model ;
-: <merge> ( models -- model ) merge-model <multi-model> ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
- [ set-model ] [ 2drop ] if ;
-: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
-
-! Behaviors - continuous model utilities
-
-TUPLE: fold-model < multi-model oldval quot ;
-M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
- call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
- swap [ >>oldval ] [ >>value ] bi ;
-
-TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model model-changed 2dup switcher>> =
- [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
- [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
- [ >>original ] [ >>switcher ] bi* ;
-
-TUPLE: mapped < model model quot ;
-
-: <mapped> ( model quot -- arrow )
- f mapped new-model
- swap >>quot
- over >>model
- [ add-dependency ] keep ;
-
-M: mapped model-changed
- [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
- set-model ;
-
-! Instances
-M: model fmap <mapped> ;
-
-SINGLETON: gadget-monad
-INSTANCE: gadget-monad monad
-INSTANCE: gadget monad
-M: gadget monad-of drop gadget-monad ;
-M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
+++ /dev/null
-Utilities for functional reactive programming in user interfaces
-USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
+USING: accessors models monads macros generalizations kernel
+ui ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
+ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
+ui.gadgets.packs locals sequences fonts io.styles
+wrap.strings ;
+
IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
- "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
\ No newline at end of file
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
+ string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
+ "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
+
+: alert* ( str -- ) [ ] swap alert ;
+
+:: ask-user ( string -- model' )
+ [ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
+ fldm [ <model-field*> ->% 1 ]
+ btn [ "okay" <model-border-btn> ] |
+ btn -> [ fldm swap updates ]
+ [ [ drop lbl close-window ] $> , ] bi
+ ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
+
+MACRO: ask-buttons ( buttons -- quot ) dup length [
+ [ swap
+ [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
+ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+ "" open-window
+ ] dip firstn
+ ] 2curry ;
\ No newline at end of file
: |<< ( book -- ) 0 swap set-control-value ;
: next ( book -- ) model>> [ 1 + ] change-model ;
: prev ( book -- ) model>> [ 1 - ] change-model ;
-: (book-t) ( quot -- quot ) '[ : owner ( gadget -- book ) parent>> dup book? [ owner ] unless ; owner @ ] ;
+: owner ( gadget -- book ) parent>> dup book? [ owner ] unless ;
+: (book-t) ( quot -- quot ) '[ owner @ ] ;
: <book-btn> ( label quot -- button ) (book-t) <button> ;
-: <book-bevel-btn> ( label quot -- button ) (book-t) <border-button> ;
-: >>> ( label -- button ) [ next ] <book-btn> ;
-: <<< ( label -- button ) [ prev ] <book-btn> ;
\ No newline at end of file
+: <book-border-btn> ( label quot -- button ) (book-t) <border-button> ;
+: >>> ( gadget -- ) owner next ;
+: <<< ( gadget -- ) owner prev ;
+: go-to ( gadget number -- ) swap owner model>> set-model ;
+
+: <forward-btn> ( label -- button ) [ >>> ] <button> ;
+: <backward-btn> ( label -- button ) [ <<< ] <button> ;
-USING: accessors arrays kernel math.rectangles models sequences
-ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
-ui.gadgets.tables ui.gestures ;
+USING: accessors arrays kernel math.rectangles sequences
+ui.gadgets.controls models.combinators ui.gadgets ui.gadgets.glass
+ui.gadgets.labels ui.gestures ;
+QUALIFIED-WITH: ui.gadgets.tables tbl
IN: ui.gadgets.comboboxes
TUPLE: combo-table < table spawner ;
-M: combo-table handle-gesture [ call-next-method ] 2keep swap
+M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
T{ button-up } = [
[ spawner>> ]
- [ selected-value>> value>> [ swap set-control-value ] [ drop ] if* ]
- [ hide-glass ] tri drop t
- ] [ drop ] if ;
+ [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
+ [ hide-glass ] tri
+ ] [ drop ] if t ;
TUPLE: combobox < label-control table ;
combobox H{
{ T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
} set-gestures
-: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <model> >>model ] keep
- [ 1array ] map <model> trivial-renderer combo-table new-table
- >>table ;
\ No newline at end of file
+: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
+ <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.editors models ui.gadgets ;
+IN: ui.gadgets.controls
+
+HELP: <model-btn>
+{ $values { "gadget" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <model-border-btn>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <table>
+{ $values { "model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } } ;
+
+HELP: <table*>
+{ $values { "table" table } }
+{ $description "Creates an " { $link table } " with no initial values to display" } ;
+
+HELP: <list>
+{ $values { "column-model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ;
+
+HELP: <list*>
+{ $values { "table" table } }
+{ $description "Creates an model-list with no initial values to display" } ;
+
+HELP: indexed
+{ $values { "table" table } }
+{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ;
+
+HELP: <model-field>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates a field with an initial value" } ;
+
+HELP: <model-field*>
+{ $values { "field" model-field } }
+{ $description "Creates a field with an empty initial value" } ;
+
+HELP: <empty-field>
+{ $values { "model" model } { "field" model-field } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-editor>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates an editor with an initial value" } ;
+
+HELP: <model-editor*>
+{ $values { "editor" "an editor" } }
+{ $description "Creates a editor with an empty initial value" } ;
+
+HELP: <empty-editor>
+{ $values { "model" model } { "editor" "an editor" } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-action-field>
+{ $values { "field" action-field } }
+{ $description "Field that updates its model with its contents when the user hits the return key" } ;
+
+HELP: IMG-MODEL-BTN:
+{ $syntax "IMAGE-MODEL-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
+
+HELP: IMG-BTN:
+{ $syntax "[ do-something ] IMAGE-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
+
+HELP: output-model
+{ $values { "gadget" gadget } { "model" model } }
+{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays kernel models monads sequences
+models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.private ui.gadgets.editors words images.loader
+ui.gadgets.scrollers ui.images vocabs.parser lexer
+models.range ui.gadgets.sliders ;
+QUALIFIED-WITH: ui.gadgets.sliders slider
+QUALIFIED-WITH: ui.gadgets.tables tbl
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.controls
+
+TUPLE: model-btn < button hook value ;
+: <model-btn> ( gadget -- button ) [
+ [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
+ [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
+ [ model>> f swap (>>value) ] tri
+ ] model-btn new-button f <basic> >>model ;
+: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
+
+TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
+M: table tbl:column-titles column-titles>> ;
+M: table tbl:column-alignment column-alignment>> ;
+M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
+ f <basic> >>actions dup actions>> [ set-model ] curry >>action ;
+: <table> ( model -- table ) table new-table ;
+: <table*> ( -- table ) V{ } clone <model> <table> ;
+: <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
+: <list*> ( -- table ) V{ } clone <model> <list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+TUPLE: model-field < field model* ;
+: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ;
+: <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
+M: model-field graft*
+ [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
+ [ dup editor>> model>> add-connection ]
+ [ dup model*>> add-connection ] tri ;
+M: model-field ungraft*
+ [ dup editor>> model>> remove-connection ]
+ [ dup model*>> remove-connection ] bi ;
+M: model-field model-changed 2dup model*>> =
+ [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+ [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
+
+: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
+ field-theme { 1 0 } >>align ; inline
+: <model-field*> ( -- field ) "" <model> <model-field> ;
+: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
+: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
+: <model-editor*> ( -- editor ) "" <model> <model-editor> ;
+: <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
+
+: <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
+ f <model> >>model ;
+
+: <slider> ( init page min max step -- slider ) <range> horizontal slider:<slider> ;
+
+: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
+SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry over push-all ;
+
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
+M: model-field output-model model*>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+M: slider output-model model>> range-model ;
+
+IN: accessors
+M: model-btn text>> children>> first text>> ;
+
+IN: ui.gadgets.controls
+
+SINGLETON: gadget-monad
+INSTANCE: gadget-monad monad
+INSTANCE: gadget monad
+M: gadget monad-of drop gadget-monad ;
+M: gadget-monad return drop <gadget> swap >>model ;
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
--- /dev/null
+Gadgets with expanded model usage
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models ui.gadgets.tracks ;
+IN: ui.gadgets.layout
+
+HELP: ,
+{ $values { "item" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+
+HELP: ,%
+{ $syntax "gadget ,% width" }
+{ $description "Like ',' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like ',' but passes its model on for further use." } ;
+
+HELP: ->%
+{ $syntax "gadget ,% width" }
+{ $description "Like '->' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: <spacer>
+{ $description "Grows to fill any empty space in a box" } ;
+
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+HELP: $
+{ $syntax "$ PLACEHOLDER-NAME $" }
+{ $description "Defines an insertion point in a template named PLACEHOLDER-NAME which can be used by calling its name" } ;
+
+HELP: with-interface
+{ $values { "quot" "quotation that builds a template and inserts into it" } }
+{ $description "Create templates, used with " { $link POSTPONE: $ } } ;
+
+ARTICLE: "ui.gadgets.layout" "GUI Layout"
+"Laying out GUIs works the same way as building lists with " { $vocab-link "make" }
+". Gadgets are layed out using " { $vocab-link "ui.gadgets.tracks" } " through " { $link <hbox> } " and " { $link <vbox> } ", which allow both fixed and percentage widths. "
+{ $link , } " and " { $link -> } " add a model or gadget to the gadget you're building. "
+"Also, books can be made with " { $link <book> } ". "
+{ $link <spacer> } "s add flexable space between items. " $nl
+"Using " { $link with-interface } ", one can pre-build templates to add items to later: "
+"Like in the StringTemplate framework for java, placeholders are defined using $ PLACERHOLDER-NAME $ "
+"Using PLACEHOLDER-NAME again sets it as the current insertion point. "
+"For examples using normal layout, see the " { $vocab-link "sudokus" } " demo. "
+"For examples of templating, see the " { $vocab-link "recipes" } " demo. " ;
+
+ABOUT: "ui.gadgets.layout"
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays fry kernel lexer make math.parser
+models monads namespaces parser sequences
+sequences.extras models.combinators ui.gadgets
+ui.gadgets.tracks words ui.gadgets.controls ;
+QUALIFIED: make
+QUALIFIED-WITH: ui.gadgets.books book
+IN: ui.gadgets.layout
+
+SYMBOL: templates
+TUPLE: layout gadget size ; C: <layout> layout
+TUPLE: placeholder < gadget members ;
+: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
+
+: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
+ [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
+
+: remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep delete-all ] if-empty ;
+: add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
+
+: , ( item -- ) make:, ;
+: make* ( quot -- list ) { } make ; inline
+
+! Just take the previous mentioned placeholder and use it
+! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
+DEFER: with-interface
+: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
+ templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+
+SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup , output-model ;
+M: model -> dup , ;
+
+: <spacer> ( -- ) <gadget> 1 <layout> , ;
+
+: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ;
+: layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
+ [ [ dup layout? [ f <layout> ] unless ] map ]
+ [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
+: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
+ [ make* [ [ model? ] filter ] ] dip bi ; inline
+: <box> ( gadgets type -- track )
+ [ t make-layout ] dip <track>
+ swap [ add-layout ] each
+ swap [ <collection> >>model ] unless-empty ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+
+: make-book ( models gadgets model -- book ) book:<book> swap [ "No models in books" throw ] unless-empty ;
+: <book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
+: <book*> ( quot -- book ) f make-layout f make-book ; inline
+
+ERROR: not-in-template word ;
+SYNTAX: $ CREATE-WORD dup
+ [ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry (( -- )) define-declared "$" expect ]
+ [ [ <placeholder> [ swap templates get set-at ] keep , ] curry ] bi over push-all ;
+
+: insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
+: insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
+: insertion-point ( placeholder -- number parent ) dup parent>> [ children>> index ] keep ;
+
+GENERIC: >layout ( gadget -- layout )
+M: gadget >layout f <layout> ;
+M: layout >layout ;
+
+GENERIC# (add-gadget-at) 2 ( parent item n -- )
+M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
+M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
+
+GENERIC# add-gadget-at 1 ( item location -- )
+M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
+M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
+ [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
+: track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
+: (track-add-at) ( parent item n size -- ) swap [ <layout> ] dip (add-gadget-at) ;
+
+: insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
+ [ add-member ] 2keep add-gadget-at ;
+
+: insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
+
+: with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
+
+M: model >>= [ swap insertion-quot <action> ] curry ;
+M: model fmap insertion-quot <mapped> ;
+M: model $> insertion-quot side-effect-model new-mapped-model ;
+M: model <$ insertion-quot quot-model new-mapped-model ;
\ No newline at end of file
--- /dev/null
+Syntax for easily building GUIs and using templates
\ No newline at end of file
list-theme ;
: calc-bounded-index ( n list -- m )
- control-value length 1- min 0 max ;
+ control-value length 1 - min 0 max ;
: bound-index ( list -- )
dup index>> over calc-bounded-index >>index drop ;
] if ;
: select-previous ( list -- )
- [ index>> 1- ] keep select-index ;
+ [ index>> 1 - ] keep select-index ;
: select-next ( list -- )
- [ index>> 1+ ] keep select-index ;
+ [ index>> 1 + ] keep select-index ;
: invoke-value-action ( list -- )
dup list-empty? [
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors combinators kernel math
+models models.combinators namespaces sequences
+ui.gadgets ui.gadgets.controls ui.gadgets.layout
+ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.poppers
+
+TUPLE: popped < model-field { fatal? initial: t } ;
+TUPLE: popped-editor < multiline-editor ;
+: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
+
+: set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
+: new-popped ( popped -- ) insertion-point "" <popped>
+ [ rot 1 + f (track-add-at) ] keep [ relayout ] [ request-focus ] bi ;
+: focus-prev ( popped -- ) dup parent>> children>> length 1 =
+ [ drop ] [
+ insertion-point [ 1 - dup -1 = [ drop 1 ] when ] [ children>> ] bi* nth
+ [ request-focus ] [ editor>> end-of-document ] bi
+ ] if ;
+: initial-popped ( popper -- ) "" <popped> [ f track-add drop ] keep request-focus ;
+
+TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
+! list of strings is model (make shown objects implement sequence protocol)
+: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
+
+M: popped handle-gesture swap {
+ { gain-focus [ 1 set-expansion f ] }
+ { lose-focus [ dup parent>>
+ [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
+ [ drop ] if* f
+ ] }
+ { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
+ { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
+ [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
+ [ f >>fatal? drop ] if f
+ ] }
+ [ swap call-next-method ]
+} case ;
+
+M: popper handle-gesture swap T{ button-down f f 1 } =
+ [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
+
+M: popper model-changed
+ [ children>> [ unparent ] each ]
+ [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
+
+M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
+M: popper focusable-child* children>> [ t ] [ first ] if-empty ;
\ No newline at end of file
>>comments ;
: reverse-chronological-order ( seq -- sorted )
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: validate-author ( -- )
{ { "author" [ v-username ] } } validate-params ;
: pastes ( -- pastes )
f <paste> select-tuples
- [ [ date>> ] compare ] sort
+ [ date>> ] sort-with
reverse ;
TUPLE: annotation < entity parent ;
: blogroll ( -- seq )
f <blog> select-tuples
- [ [ name>> ] compare ] sort ;
+ [ name>> ] sort-with ;
: postings ( -- seq )
posting new select-tuples
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ '[ _ <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: update-cached-postings ( -- )
blogroll fetch-blogroll sort-entries 8 short head [
M: revision feed-entry-url id>> revision-url ;
: reverse-chronological-order ( seq -- sorted )
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: <revision> ( id -- revision )
revision new swap >>id ;
[
f <article> select-tuples
- [ [ title>> ] compare ] sort
+ [ title>> ] sort-with
"articles" set-value
] >>init
*wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
: update-times ( utime current-utime current-numinvokes -- utime' invokes' )
- rot [ + ] curry [ 1+ ] bi* ;
+ rot [ + ] curry [ 1 + ] bi* ;
: register-time ( utime word -- )
name>>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+x = ENV["TM_FILEPATH"][/\/([^\/]+\.factor)/,1]
+y = x.sub("-tests","").sub("docs", "tests")
+if x == y then
+ z = x.sub(".factor","")
+ factor_eval(%Q(USING: tools.scaffold #{z} ;\n"#{z}" scaffold-help))
+ y = x.sub(".factor", "-docs.factor")
+end
+exec "mate #{ENV["TM_FILEPATH"][/(.*\/)[^\/]+\.factor/,1] << y}"</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>keyEquivalent</key>
+ <string>^@`</string>
+ <key>name</key>
+ <string>Cycle Vocabs/Docs/Tests</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>D348BE40-6F51-4471-B300-DDDA70ED8C8C</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: editors\n "#{word}" edit-vocab))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@V</string>
+ <key>name</key>
+ <string>Edit Vocab</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>0034EC1C-DAD1-498F-82FD-BEF7015F84EE</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USING: help.topics editors ;\n \\ #{word} >link edit))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@D</string>
+ <key>name</key>
+ <string>Edit Word Docs</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>D95A617C-E1C6-44DA-9126-04171CB21299</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: editors\n \\ #{word} edit))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@E</string>
+ <key>name</key>
+ <string>Edit Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>C573487C-DD7D-497F-A728-52D7962D95E2</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: ui.tools.operations\n [ #{ENV["TM_SELECTED_TEXT"} ] com-expand-macros))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Expand Selection</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>8465B33D-7CA0-4337-945C-4078346D64BC</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_run(%Q(#{doc_using_statements(doc)} USE: editors\n \\ #{word} fix))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@F</string>
+ <key>name</key>
+ <string>Fix Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>D02D9D74-E073-48AE-A78E-B40FFFA519D5</string>
+</dict>
+</plist>
doc = STDIN.read
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
-factor_run(%Q(#{doc_using_statements(doc)} USE: ui.tools.workspace\n \\ #{word} help-window))</string>
+factor_run(%Q(#{doc_using_statements(doc)} USE: help\n \\ #{word} help))</string>
<key>fallbackInput</key>
<string>word</string>
<key>input</key>
+++ /dev/null
-<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
-<plist version="1.0">
-<dict>
- <key>beforeRunningCommand</key>
- <string>nop</string>
- <key>command</key>
- <string>#!/usr/bin/env ruby
-
-require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
-
-doc = STDIN.read
-puts factor_eval(%Q(#{doc_using_statements(doc)} USE: inference\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
- <key>fallbackInput</key>
- <string>word</string>
- <key>input</key>
- <string>document</string>
- <key>name</key>
- <string>Infer Effect of Selection</string>
- <key>output</key>
- <string>showAsTooltip</string>
- <key>scope</key>
- <string>source.factor</string>
- <key>uuid</key>
- <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
-</dict>
-</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: stack-checker\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^i</string>
+ <key>name</key>
+ <string>Infer Selection</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: stack-checker\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Insert Inferrence</string>
+ <key>output</key>
+ <string>afterSelectedText</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_run(%Q(#{doc_using_statements(doc)} USE: tools.profiler\n [ #{word} ] profile))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^p</string>
+ <key>name</key>
+ <string>Profile</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>7FF52332-CA5B-4D46-99EF-DAE0659DB478</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+doc = STDIN.read
+factor_run(%Q(USE: vocabs.loader\n "#{doc[/\bIN:\s(\S+)/, 1]}" reload))</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^r</string>
+ <key>name</key>
+ <string>Reload in Listener</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>8088D204-FFD7-4384-8FDD-A01536FFD0E7</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.annotations\n \\ #{word} reset))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^~r</string>
+ <key>name</key>
+ <string>Reset Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>71F08D9B-3D24-4E78-84C9-82CA736554D1</string>
+</dict>
+</plist>
doc = STDIN.read
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
-puts factor_eval(%Q(#{doc_using_statements(doc)} USE: prettyprint\n \\ #{word} see))</string>
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: see\n \\ #{word} see))</string>
<key>fallbackInput</key>
<string>word</string>
<key>input</key>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.annotations\n \\ #{word} breakpoint))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^b</string>
+ <key>name</key>
+ <string>Set Breakpoint</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>E4614756-DF2E-433A-8935-197159C67AB8</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+factor_run(%Q(USING: namespaces parser ;
+auto-use? t set "#{ENV["TM_FILEPATH"]}" run-file auto-use? f set))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>keyEquivalent</key>
+ <string>^u</string>
+ <key>name</key>
+ <string>Show Using</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>93AF1721-C14D-428A-B5A0-34CEFAA3B3C5</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.crossref\n \\ #{word} usage.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Usage</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>3043A033-A113-4283-BCBB-3DE2CCC8F63E</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(USE: tools.crossref\n "#{word}" vocab-usage.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>name</key>
+ <string>Vocab Usage</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B1F81321-B760-474F-875D-78FB52752E1B</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(USE: tools.crossref\n "#{word}" vocab-uses.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>name</key>
+ <string>Vocab Uses</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>BC3E2E39-3B79-460C-B05E-BD00BAACB90E</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_run(%Q(#{doc_using_statements(doc)} USE: tools.walker\n [ #{ENV["TM_SELECTED_TEXT"]} ] walk))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^w</string>
+ <key>name</key>
+ <string>Walk Selection</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>57C2BAAC-0474-404F-AA91-DFD02EC2A3ED</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.annotations\n \\ #{word} watch))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^~w</string>
+ <key>name</key>
+ <string>Watch Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>1C86869F-1030-4F74-B242-6357A080E127</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>commands</key>
+ <array>
+ <dict>
+ <key>command</key>
+ <string>cut:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>m</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>y</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>-</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>w</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>o</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>r</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>d</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <dict>
+ <key>action</key>
+ <string>findPrevious</string>
+ <key>findInProjectIgnoreCase</key>
+ <true/>
+ <key>findString</key>
+ <string>: </string>
+ <key>ignoreCase</key>
+ <true/>
+ <key>replaceAllScope</key>
+ <string>document</string>
+ <key>replaceString</key>
+ <string>table</string>
+ <key>wrapAround</key>
+ <true/>
+ </dict>
+ <key>command</key>
+ <string>findWithOptions:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToBeginningOfLine:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>paste:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToBeginningOfLineAndModifySelection:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: stack-checker\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Insert Inferrence</string>
+ <key>output</key>
+ <string>afterSelectedText</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+ </dict>
+ <key>command</key>
+ <string>executeCommandWithOptions:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>insertNewline:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <dict>
+ <key>action</key>
+ <string>findPrevious</string>
+ <key>findInProjectIgnoreCase</key>
+ <true/>
+ <key>findString</key>
+ <string>(</string>
+ <key>ignoreCase</key>
+ <true/>
+ <key>replaceAllScope</key>
+ <string>document</string>
+ <key>replaceString</key>
+ <string>table</string>
+ <key>wrapAround</key>
+ <true/>
+ </dict>
+ <key>command</key>
+ <string>findWithOptions:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToEndOfLineAndModifySelection:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>cut:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>;</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToBeginningOfLine:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>:</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>m</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>y</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>-</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>w</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>o</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>r</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>d</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>paste:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ </array>
+ <key>keyEquivalent</key>
+ <string>@W</string>
+ <key>name</key>
+ <string>Extract as New Word</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>82E740D1-8D20-48AF-8470-C85C251D4870</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>name</key>
+ <string>Miscellaneous</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>settings</key>
+ <dict>
+ <key>increaseIndentPattern</key>
+ <string>^:</string>
+ <key>shellVariables</key>
+ <array>
+ <dict>
+ <key>name</key>
+ <string>TM_COMMENT_START</string>
+ <key>value</key>
+ <string>! </string>
+ </dict>
+ </array>
+ </dict>
+ <key>uuid</key>
+ <string>D60675B0-9BF4-4CCF-9066-CA14FE836981</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>[
+ $TM_SELECTED_TEXT$0
+]</string>
+ <key>keyEquivalent</key>
+ <string>~[</string>
+ <key>name</key>
+ <string>[ expanded</string>
+ <key>scope</key>
+ <string>source.factor
+</string>
+ <key>tabTrigger</key>
+ <string>“</string>
+ <key>uuid</key>
+ <string>F771F82B-6B2B-4DAE-9A2A-E1042D3B08AD</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>[ $TM_SELECTED_TEXT$0 ]</string>
+ <key>keyEquivalent</key>
+ <string>[</string>
+ <key>name</key>
+ <string>[</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>[</string>
+ <key>uuid</key>
+ <string>3F17AF0F-4DE0-4A86-A649-CB65907F0DA5</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [ $1 ]
+ [ $2 ] bi</string>
+ <key>name</key>
+ <string>bi</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>bi</string>
+ <key>uuid</key>
+ <string>8D69F968-D322-4008-A540-209B32A97F5D</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ [ $1 ]
+ [ $2 ]
+ [ $3 ]
+ [ $4 ]
+} cleave</string>
+ <key>name</key>
+ <string>cleave</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>cleave</string>
+ <key>uuid</key>
+ <string>E51383D9-1C82-4ACE-AE45-633E6CE35245</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ { [ $1 ] [ $2 ] }
+ { [ $3 ] [ $4 ] }
+$5} cond </string>
+ <key>name</key>
+ <string>cond</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>cond</string>
+ <key>uuid</key>
+ <string>C8E068DE-A117-43AE-9916-99AF2C21BD24</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+FUNCTOR: $1 ( $2 -- $3 )
+$4
+WHERE
+$0
+;FUNCTOR
+</string>
+ <key>name</key>
+ <string>functor</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>functor</string>
+ <key>uuid</key>
+ <string>B9DA0999-D710-4693-8056-9E4B8BDAC7E9</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [ $1 ]
+ [ $2 ] if</string>
+ <key>name</key>
+ <string>if</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>if</string>
+ <key>uuid</key>
+ <string>AD9D0A71-2371-4756-86D7-A084B4A3FE2F</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>:: $1 ( $2 -- $3 ) $0 ;</string>
+ <key>name</key>
+ <string>::</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>::</string>
+ <key>uuid</key>
+ <string>9A96D386-F7B9-47DC-9CAE-E4BAD1F81748</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [let | $1 [ $2 ] $3|
+ $0
+ ]</string>
+ <key>name</key>
+ <string>let</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>let</string>
+ <key>uuid</key>
+ <string>1B3CF04D-B23D-4D9A-A648-7191315CDF96</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ [ $1 ]
+ [ $2 ]
+ [ $3 ]
+ [ $4 ]
+} spread</string>
+ <key>name</key>
+ <string>spread</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>spread</string>
+ <key>uuid</key>
+ <string>3DE1C097-6F69-4562-9C49-C897FF5AB909</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [ $1 ]
+ [ $2 ]
+ [ $3 ] tri</string>
+ <key>name</key>
+ <string>tri</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>tri</string>
+ <key>uuid</key>
+ <string>B8B7B5ED-C75C-4BD1-906A-220C9956F91F</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>: $1 ( $2 -- $3 ) $0 ;</string>
+ <key>name</key>
+ <string>:</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>:</string>
+ <key>uuid</key>
+ <string>7903894E-CB75-43ED-8635-C0E65F94DEBB</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ $TM_SELECTED_TEXT$0
+}</string>
+ <key>keyEquivalent</key>
+ <string>~{</string>
+ <key>name</key>
+ <string>{ expanded</string>
+ <key>scope</key>
+ <string>source.factor
+</string>
+ <key>uuid</key>
+ <string>275EA395-6026-481A-81C5-1F71D8026972</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{ $TM_SELECTED_TEXT$0 }</string>
+ <key>keyEquivalent</key>
+ <string>{</string>
+ <key>name</key>
+ <string>{</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>[</string>
+ <key>uuid</key>
+ <string>B4448FB0-B7F9-4FFD-AB4B-EAD31A5920CB</string>
+</dict>
+</plist>
document.scan(/\b(USING:\s[^;]*\s;|USE:\s+\S+|IN:\s\S+)/).join("\n") << "\n"
end
+def doc_vocab(document)
+ document.sub(/\bIN:\s(\S+)/, %Q("\\1"))
+end
+
def line_current_word(line, point)
left = line.rindex(/\s/, point - 1) || 0; right = line.index(/\s/, point) || line.length
line[left..right]
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+require ENV['TM_SUPPORT_PATH'] + '/lib/ui'
+
+a = TextMate::UI.request_string(:title => "Scaffold Setup", :prompt =>
+"Vocab Name:")
+b = ENV["TM_FILEPATH"]
+if b then c = b[/\/factor\/([^\/]+)\//,1]
+else c = "work"
+end
+factor_eval(%Q(USING: kernel editors tools.scaffold ; "#{a}" dup #{"scaffold-" << c} edit-vocab))</string>
+ <key>extension</key>
+ <string>factor</string>
+ <key>keyEquivalent</key>
+ <string>@N</string>
+ <key>name</key>
+ <string>Vocabulary</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B6D1D91E-3EF3-4112-97DF-BFCABEBAA1C9</string>
+</dict>
+</plist>
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
+ <key>deleted</key>
+ <array/>
+ <key>mainMenu</key>
+ <dict>
+ <key>excludedItems</key>
+ <array>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+ <string>1B3CF04D-B23D-4D9A-A648-7191315CDF96</string>
+ <string>3F17AF0F-4DE0-4A86-A649-CB65907F0DA5</string>
+ <string>B4448FB0-B7F9-4FFD-AB4B-EAD31A5920CB</string>
+ <string>C8E068DE-A117-43AE-9916-99AF2C21BD24</string>
+ <string>AD9D0A71-2371-4756-86D7-A084B4A3FE2F</string>
+ <string>8D69F968-D322-4008-A540-209B32A97F5D</string>
+ <string>B8B7B5ED-C75C-4BD1-906A-220C9956F91F</string>
+ <string>E51383D9-1C82-4ACE-AE45-633E6CE35245</string>
+ <string>3DE1C097-6F69-4562-9C49-C897FF5AB909</string>
+ <string>B9DA0999-D710-4693-8056-9E4B8BDAC7E9</string>
+ <string>7903894E-CB75-43ED-8635-C0E65F94DEBB</string>
+ <string>9A96D386-F7B9-47DC-9CAE-E4BAD1F81748</string>
+ <string>F771F82B-6B2B-4DAE-9A2A-E1042D3B08AD</string>
+ <string>275EA395-6026-481A-81C5-1F71D8026972</string>
+ </array>
+ <key>items</key>
+ <array>
+ <string>8088D204-FFD7-4384-8FDD-A01536FFD0E7</string>
+ <string>CAD3BB10-C480-4C0E-9518-94D61F7A0C0B</string>
+ <string>82E740D1-8D20-48AF-8470-C85C251D4870</string>
+ <string>D348BE40-6F51-4471-B300-DDDA70ED8C8C</string>
+ <string>9D99C141-EC9D-4C9E-9C08-0CA4EAEA2F3E</string>
+ <string>1C72489C-15A1-4B44-BCDF-438962D4F3EB</string>
+ <string>9E5EC5B6-AABD-4657-A663-D3C558051216</string>
+ <string>219C4AB2-742E-48FE-92E1-CB2EC19C8A24</string>
+ <string>D25BF2AE-0595-44AE-B97A-9F20D4E28173</string>
+ <string>93AF1721-C14D-428A-B5A0-34CEFAA3B3C5</string>
+ </array>
+ <key>submenus</key>
+ <dict>
+ <key>1C72489C-15A1-4B44-BCDF-438962D4F3EB</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>3043A033-A113-4283-BCBB-3DE2CCC8F63E</string>
+ <string>B1F81321-B760-474F-875D-78FB52752E1B</string>
+ <string>BC3E2E39-3B79-460C-B05E-BD00BAACB90E</string>
+ </array>
+ <key>name</key>
+ <string>Cross Ref</string>
+ </dict>
+ <key>219C4AB2-742E-48FE-92E1-CB2EC19C8A24</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>57C2BAAC-0474-404F-AA91-DFD02EC2A3ED</string>
+ <string>E4614756-DF2E-433A-8935-197159C67AB8</string>
+ <string>1C86869F-1030-4F74-B242-6357A080E127</string>
+ <string>71F08D9B-3D24-4E78-84C9-82CA736554D1</string>
+ </array>
+ <key>name</key>
+ <string>Debugging</string>
+ </dict>
+ <key>9D99C141-EC9D-4C9E-9C08-0CA4EAEA2F3E</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>D02D9D74-E073-48AE-A78E-B40FFFA519D5</string>
+ <string>C573487C-DD7D-497F-A728-52D7962D95E2</string>
+ <string>D95A617C-E1C6-44DA-9126-04171CB21299</string>
+ <string>0034EC1C-DAD1-498F-82FD-BEF7015F84EE</string>
+ </array>
+ <key>name</key>
+ <string>Edit</string>
+ </dict>
+ <key>9E5EC5B6-AABD-4657-A663-D3C558051216</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>7FF52332-CA5B-4D46-99EF-DAE0659DB478</string>
+ <string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
+ <string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
+ <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+ <string>8465B33D-7CA0-4337-945C-4078346D64BC</string>
+ </array>
+ <key>name</key>
+ <string>Tools</string>
+ </dict>
+ <key>D25BF2AE-0595-44AE-B97A-9F20D4E28173</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>35484754-DBF9-4381-BB25-00CAB64DF4A1</string>
+ <string>BC5BE120-734B-40DF-8B6B-5D3243614B27</string>
+ </array>
+ <key>name</key>
+ <string>Help</string>
+ </dict>
+ </dict>
+ </dict>
<key>name</key>
<string>Factor</string>
<key>ordering</key>
<array>
<string>3C9C9C2A-314A-475B-A4E4-A68BAAF3F36E</string>
+ <string>D60675B0-9BF4-4CCF-9066-CA14FE836981</string>
<string>141517D7-73E0-4475-A481-71102575A175</string>
+ <string>B6D1D91E-3EF3-4112-97DF-BFCABEBAA1C9</string>
<string>CAD3BB10-C480-4C0E-9518-94D61F7A0C0B</string>
+ <string>8088D204-FFD7-4384-8FDD-A01536FFD0E7</string>
<string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
<string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
<string>35484754-DBF9-4381-BB25-00CAB64DF4A1</string>
<string>BC5BE120-734B-40DF-8B6B-5D3243614B27</string>
<string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+ <string>93AF1721-C14D-428A-B5A0-34CEFAA3B3C5</string>
+ <string>3043A033-A113-4283-BCBB-3DE2CCC8F63E</string>
+ <string>B1F81321-B760-474F-875D-78FB52752E1B</string>
+ <string>BC3E2E39-3B79-460C-B05E-BD00BAACB90E</string>
+ <string>8465B33D-7CA0-4337-945C-4078346D64BC</string>
+ <string>57C2BAAC-0474-404F-AA91-DFD02EC2A3ED</string>
+ <string>1C86869F-1030-4F74-B242-6357A080E127</string>
+ <string>E4614756-DF2E-433A-8935-197159C67AB8</string>
+ <string>D02D9D74-E073-48AE-A78E-B40FFFA519D5</string>
+ <string>C573487C-DD7D-497F-A728-52D7962D95E2</string>
+ <string>0034EC1C-DAD1-498F-82FD-BEF7015F84EE</string>
+ <string>D95A617C-E1C6-44DA-9126-04171CB21299</string>
+ <string>71F08D9B-3D24-4E78-84C9-82CA736554D1</string>
+ <string>7FF52332-CA5B-4D46-99EF-DAE0659DB478</string>
+ <string>D348BE40-6F51-4471-B300-DDDA70ED8C8C</string>
+ <string>1B3CF04D-B23D-4D9A-A648-7191315CDF96</string>
+ <string>3F17AF0F-4DE0-4A86-A649-CB65907F0DA5</string>
+ <string>F771F82B-6B2B-4DAE-9A2A-E1042D3B08AD</string>
+ <string>B4448FB0-B7F9-4FFD-AB4B-EAD31A5920CB</string>
+ <string>275EA395-6026-481A-81C5-1F71D8026972</string>
+ <string>C8E068DE-A117-43AE-9916-99AF2C21BD24</string>
+ <string>AD9D0A71-2371-4756-86D7-A084B4A3FE2F</string>
+ <string>8D69F968-D322-4008-A540-209B32A97F5D</string>
+ <string>B8B7B5ED-C75C-4BD1-906A-220C9956F91F</string>
+ <string>E51383D9-1C82-4ACE-AE45-633E6CE35245</string>
+ <string>3DE1C097-6F69-4562-9C49-C897FF5AB909</string>
+ <string>B9DA0999-D710-4693-8056-9E4B8BDAC7E9</string>
+ <string>7903894E-CB75-43ED-8635-C0E65F94DEBB</string>
+ <string>9A96D386-F7B9-47DC-9CAE-E4BAD1F81748</string>
+ <string>82E740D1-8D20-48AF-8470-C85C251D4870</string>
</array>
<key>uuid</key>
<string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
syn match factorComment /\<#! .*/ contains=factorTodo
syn match factorComment /\<! .*/ contains=factorTodo
-syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
+syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
-syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(SYNTAX\|\(MACRO\|MEMO\)\?:\?\):\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorMethod matchgroup=factorMethodDelims start=/\<M::\?\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
-syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(SYNTAX\|\(MACRO\|MEMO\)\?:\?\):\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M::\?\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn keyword factorBoolean boolean f general-t t
-syn keyword factorCompileDirective inline foldable parsing
+syn keyword factorCompileDirective inline foldable recursive
<%
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
-syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+"syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+syn match factorStackEffect /\<( .*--.* )\>/ contained
+syn match factorLiteralStackEffect /\<(( .*--.* ))\>/
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
HiLink factorComment Comment
HiLink factorStackEffect Typedef
+ HiLink factorLiteralStackEffect Typedef
HiLink factorTodo Todo
HiLink factorInclude Include
HiLink factorRepeat Repeat
let b:current_syntax = "factor"
set sw=4
-set ts=4
+set sts=4
set expandtab
set autoindent " annoying?
;;; fuel-log.el -- logging utilities
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
(defvar fuel-log--inhibit-p nil
"Set this to t to inhibit all log messages")
+(defvar fuel-log--debug-p nil
+ "If t, all messages are logged no matter what")
+
(define-derived-mode factor-messages-mode fundamental-mode "FUEL Messages"
"Simple mode to log interactions with the factor listener"
(kill-all-local-variables)
(current-buffer))))
(defun fuel-log--msg (type &rest args)
- (unless fuel-log--inhibit-p
+ (when (or fuel-log--debug-p (not fuel-log--inhibit-p))
(with-current-buffer (fuel-log--buffer)
(let ((inhibit-read-only t))
(insert
names of all the vocabularies Factor knows about. To regenerate it manually,
run the following code in the listener:
- USE: editors.vim.generate-syntax
-
- generate-vim-syntax
+ "editors.vim.generate-syntax" run
...or run it from the command-line:
+
" Vim syntax file
" Language: factor
" Maintainer: Alex Chapman <chapman.alex@gmail.com>
syn match factorComment /\<#! .*/ contains=factorTodo
syn match factorComment /\<! .*/ contains=factorTodo
-syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
+syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
-syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(SYNTAX\|\(MACRO\|MEMO\)\?:\?\):\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorMethod matchgroup=factorMethodDelims start=/\<M::\?\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
-syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(SYNTAX\|\(MACRO\|MEMO\)\?:\?\):\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M::\?\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn keyword factorBoolean boolean f general-t t
-syn keyword factorCompileDirective inline foldable parsing
+syn keyword factorCompileDirective inline foldable recursive
syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
-syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
-syn keyword factorKeyword case execute-effect dispatch-case-quot <buckets> no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
+syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
+syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
-syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
+syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
-syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+"syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+syn match factorStackEffect /\<( .*--.* )\>/ contained
+syn match factorLiteralStackEffect /\<(( .*--.* ))\>/
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
HiLink factorComment Comment
HiLink factorStackEffect Typedef
+ HiLink factorLiteralStackEffect Typedef
HiLink factorTodo Todo
HiLink factorInclude Include
HiLink factorRepeat Repeat
let b:current_syntax = "factor"
set sw=4
-set ts=4
+set sts=4
set expandtab
set autoindent " annoying?
" vim: syntax=vim
+
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: modules.rpc-server vocabs ;
-IN: modules.remote-loading mem-service
-
-: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
+++ /dev/null
-required for listeners allowing remote loading of modules
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: accessors assocs continuations effects io
-io.encodings.binary io.servers.connection kernel
-memoize namespaces parser sets sequences serialize
-threads vocabs vocabs.parser words ;
-IN: modules.rpc-server
-
-SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
-
-: do-rpc ( args word -- bytes )
- [ execute ] curry with-datastack object>bytes ; inline
-
-MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
-
-: process ( vocabspec -- )
- vocab-words [ deserialize ] dip deserialize
- swap at "executer" get execute( args word -- bytes ) write flush ;
-
-: (serve) ( -- )
- deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- )
- [
- binary <threaded-server>
- 5000 >>insecure
- [ (serve) ] >>handler
- start-server
- ] in-thread ;
-
-: (service) ( -- )
- serving-vocabs get-global empty? [ start-serving-vocabs ] when
- current-vocab serving-vocabs get-global adjoin
- "get-words" create-in
- in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
- (( -- words )) define-inline ;
-
-SYNTAX: service \ do-rpc "executer" set (service) ;
-SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
-
-load-vocab-hook [
- [
- dup words>> values
- \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
- ] append
-] change-global
+++ /dev/null
-remote procedure call server
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: modules.rpc
-ARTICLE: { "modules" "protocol" } "RPC Protocol"
-{ $list
- "Send vocab as string"
- "Send arglist"
- "Send word as string"
- "Receive result list"
-} ;
\ No newline at end of file
+++ /dev/null
-USING: accessors compiler.units combinators fry generalizations io
-io.encodings.binary io.sockets kernel namespaces
-parser sequences serialize vocabs vocabs.parser words ;
-IN: modules.rpc
-
-DEFER: get-words
-
-: remote-quot ( addrspec vocabspec effect str -- quot )
- '[ _ 5000 <inet> binary
- [
- _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
- ] with-client
- ] ;
-
-: define-remote ( addrspec vocabspec effect str -- ) [
- [ remote-quot ] 2keep create-in -rot define-declared word make-inline
- ] with-compilation-unit ;
-
-: with-in ( vocab quot -- vocab ) over
- [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
-
-: remote-vocab ( addrspec vocabspec -- vocab )
- dup "-remote" append [
- [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
- [ rot first2 swap define-remote ] 2curry each
- ] with-in ;
\ No newline at end of file
+++ /dev/null
-remote procedure call client
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-module pushing in remote-loading listeners
\ No newline at end of file
+++ /dev/null
-USING: assocs modules.rpc-server vocabs
-modules.remote-loading words ;
-IN: modules.uploads service
-
-: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-improved module import syntax
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-USING: modules.rpc-server io.servers.connection ;
-IN: modules.test-server service
-: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
+++ /dev/null
-USING: modules.using ;
-IN: modules.using.tests
-USING: tools.test localhost::modules.test-server ;
-[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
+++ /dev/null
-USING: modules.using modules.rpc-server help.syntax help.markup strings ;
-IN: modules
-
-HELP: service
-{ $syntax "IN: module service" }
-{ $description "Starts a server for requests for remote procedure calls." } ;
-
-ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
-"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
-
-HELP: USING:
-{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
-{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
-{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
+++ /dev/null
-USING: assocs kernel modules.remote-loading modules.rpc
-namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
-strings ;
-IN: modules.using
-
-: >qualified ( vocab prefix -- assoc )
- [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
-
-: >partial-vocab ( words assoc -- assoc )
- [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
-
-: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
-
-: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
-
-EBNF: modulize
-tokenpart = (!(':').)+ => [[ >string ]]
-s = ':' => [[ drop ignore ]]
-rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
-remote = tokenpart s tokenpart => [[ first2 remote-load ]]
-plain = tokenpart => [[ load-vocab ]]
-module = rpc | remote | plain
-;EBNF
-
-ON-BNF: USING:
-tokenizer = <foreign factor>
-sym = !(";"|"}"|"=>").
-modspec = sym => [[ modulize ]]
-qualified = modspec sym => [[ first2 >qualified ]]
-unqualified = modspec => [[ vocab-words ]]
-words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
-long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
-short = modspec => [[ use+ ignore ]]
-wordSpec = long | short
-using = wordSpec+ ";" => [[ drop ignore ]]
-;ON-BNF
\ No newline at end of file
bool performing_compaction;
cell collecting_gen;
-/* if true, we collecting aging space for the second time, so if it is still
+/* if true, we are collecting aging space for the second time, so if it is still
full, we go on to collect tenured */
bool collecting_aging_again;
projects / factor.git / commitdiff