steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Bruno Deferrari 2008-07-21 11:16:38 -03:00
parent 55d7cb3168 547c0e87b1
commit acb67fe09c
168 changed files with 5857 additions and 448 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/arrays/arrays.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private math math.private sequences
sequences.private ;
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
IN: arrays
M: array clone (clone) ;
M: array length array-capacity ;
M: array length length>> ;
M: array nth-unsafe >r >fixnum r> array-nth ;
M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
M: array resize resize-array ;

5
core/assocs/assocs.factor
View File

@ -84,7 +84,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
] [
3dup nth-unsafe at*
[ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
] if ; inline
] if ; inline recursive
: assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ;
@ -158,6 +158,9 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
: zip ( keys values -- alist )
2array flip ; inline
: unzip ( assoc -- keys values )
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline

4
core/binary-search/binary-search.factor
View File

@ -16,7 +16,7 @@ IN: binary-search
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
: (search) ( quot seq -- i elt )
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
@ -25,7 +25,7 @@ IN: binary-search
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
} case
] if ; inline
] if ; inline recursive
PRIVATE>

2
core/bootstrap/compiler/compiler.factor
View File

@ -37,7 +37,7 @@ nl
array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth
array-nth set-array-nth
wrap probe

29
core/bootstrap/primitives.factor
View File

@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts
classes classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union classes.intersection classes.predicate
compiler.units bootstrap.image.private io.files accessors combinators ;
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -225,7 +226,9 @@ bi
{ "imaginary" { "real" "math" } read-only }
} define-builtin
"array" "arrays" create { } define-builtin
"array" "arrays" create {
{ "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin
"wrapper" "kernel" create {
{ "wrapped" read-only }
@ -261,7 +264,9 @@ bi
{ "sub-primitive" read-only }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"byte-array" "byte-arrays" create {
{ "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin
"callstack" "kernel" create { } define-builtin
@ -306,9 +311,12 @@ tuple
} prepare-slots define-tuple-class
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri
{
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ]
} cleave
(( obj quot -- curry )) define-declared
"compose" "kernel" create
@ -319,9 +327,12 @@ tuple
} prepare-slots define-tuple-class
"compose" "kernel" lookup
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri
{
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ]
} cleave
(( quot1 quot2 -- compose )) define-declared
! Sub-primitive words

1
core/bootstrap/stage1.factor
View File

@ -32,7 +32,6 @@ load-help? off
"libc" require
"io.streams.c" require
"io.thread" require
"vocabs.loader" require
"syntax" require

2
core/bootstrap/stage2.factor
View File

@ -56,6 +56,8 @@ parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
"io.thread" require
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when

1
core/bootstrap/syntax.factor
View File

@ -59,6 +59,7 @@ IN: bootstrap.syntax
"flushable"
"foldable"
"inline"
"recursive"
"parsing"
"t"
"{"

4
core/byte-arrays/byte-arrays.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien.accessors sequences
USING: accessors kernel kernel.private alien.accessors sequences
sequences.private math ;
IN: byte-arrays
M: byte-array clone (clone) ;
M: byte-array length array-capacity ;
M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline

2
core/classes/tuple/tuple.factor
View File

@ -91,7 +91,7 @@ ERROR: bad-superclass class ;
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of 4 slot
2dup array-capacity fixnum<
2dup 1 slot fixnum<
[ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline

8
core/combinators/combinators.factor
View File

@ -90,10 +90,10 @@ ERROR: no-case ;
: <buckets> ( initial length -- array )
next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( assoc initial quot -- buckets )
spin [ length <buckets> ] keep
[ >r 2dup r> dup first roll call (distribute-buckets) ] each
nip ; inline
: distribute-buckets ( alist initial quot -- buckets )
swapd [ >r dup first r> call 2array ] curry map
[ length <buckets> dup ] keep
[ first2 (distribute-buckets) ] with each ; inline
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets

5
core/dequeues/dequeues.factor
View File

@ -37,8 +37,7 @@ GENERIC: node-value ( node -- value )
[ peek-back ] [ pop-back* ] bi ;
: slurp-dequeue ( dequeue quot -- )
over dequeue-empty? [ 2drop ] [
[ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
] if ; inline
[ drop [ dequeue-empty? not ] curry ]
[ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
MIXIN: dequeue

4
core/dlists/dlists.factor
View File

@ -48,11 +48,11 @@ M: dlist-node node-value obj>> ;
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ;
: (dlist-find-node) ( dlist-node quot -- node/f ? )
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
] [ 2drop f f ] if ; inline
] [ 2drop f f ] if ; inline recursive
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline

18
core/effects/effects.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
combinators accessors ;
combinators accessors arrays ;
IN: effects
TUPLE: effect in out terminated? ;
@ -22,15 +22,16 @@ TUPLE: effect in out terminated? ;
[ t ]
} cond 2nip ;
GENERIC: (stack-picture) ( obj -- str )
M: string (stack-picture) ;
M: word (stack-picture) name>> ;
M: integer (stack-picture) drop "object" ;
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
M: word effect>string name>> ;
M: integer effect>string drop "object" ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string )
[ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
[ [ effect>string % CHAR: \s , ] each ] "" make ;
: effect>string ( effect -- string )
M: effect effect>string ( effect -- string )
[
"( " %
[ in>> stack-picture % "-- " % ]
@ -51,6 +52,9 @@ M: word stack-effect
M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ;
: stack-height ( word -- n )
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;

34
core/effects/parser/parser.factor
View File

@ -1,15 +1,31 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects ;
USING: lexer sets sequences kernel splitting effects summary
combinators debugger arrays parser ;
IN: effects.parser
: parse-effect ( end -- effect )
parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
DEFER: parse-effect
ERROR: bad-effect ;
M: bad-effect summary
drop "Bad stack effect declaration" ;
: parse-effect-token ( end -- token/f )
scan tuck = [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan-word {
{ \ ( [ ")" parse-effect ] }
[ ]
} case 2array
] when
] if
] [
"Stack effect declaration must not contain ( or ((" throw
] if ;
: parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] [ drop ] produce ;
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;

3
core/generic/generic.factor
View File

@ -77,6 +77,9 @@ TUPLE: check-method class generic ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
M: method-body inline?
"method-generic" word-prop inline? ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;

3
core/generic/standard/engines/tuple/tuple.factor
View File

@ -64,6 +64,9 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;

4
core/graphs/graphs.factor
View File

@ -37,14 +37,14 @@ SYMBOL: graph
SYMBOL: previous
: (closure) ( obj quot -- )
: (closure) ( obj quot: ( elt -- assoc ) -- )
over previous get key? [
2drop
] [
over previous get conjoin
dup slip
[ nip (closure) ] curry assoc-each
] if ; inline
] if ; inline recursive
: closure ( obj quot -- assoc )
H{ } clone [

10
core/hashtables/hashtables.factor
View File

@ -12,7 +12,7 @@ TUPLE: hashtable
<PRIVATE
: wrap ( i array -- n )
array-capacity 1 fixnum-fast fixnum-bitand ; inline
length>> 1 fixnum-fast fixnum-bitand ; inline
: hash@ ( key array -- i )
>r hashcode >fixnum dup fixnum+fast r> wrap ; inline
@ -27,10 +27,10 @@ TUPLE: hashtable
dup ((empty)) eq?
[ 3drop no-key ] [
= [ rot drop t ] [ probe (key@) ] if
] if ; inline
] if ; inline recursive
: key@ ( key hash -- array n ? )
array>> dup array-capacity 0 eq?
array>> dup length>> 0 eq?
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
@ -51,7 +51,7 @@ TUPLE: hashtable
] [
probe (new-key@)
] if
] if ; inline
] if ; inline recursive
: new-key@ ( key hash -- array n empty? )
array>> 2dup hash@ (new-key@) ; inline
@ -71,7 +71,7 @@ TUPLE: hashtable
: hash-large? ( hash -- ? )
[ count>> 3 fixnum*fast 1 fixnum+fast ]
[ array>> array-capacity ] bi fixnum> ; inline
[ array>> length>> ] bi fixnum> ; inline
: hash-stale? ( hash -- ? )
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline

3
core/inference/backend/backend.factor
View File

@ -365,7 +365,8 @@ TUPLE: unbalanced-branches-error quots in out ;
[ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- )
#! last is a quotation which provides a #return or a #values
#! last -> #return or #values
#! node -> #if or #dispatch
1 reify-curries
call dup node,
pop-d drop

2
core/inference/class/class-tests.factor
View File

@ -620,6 +620,8 @@ TUPLE: declared-fixnum { x fixnum } ;
[ { ascii } declare decode-char ] \ decode-char inlined?
] unit-test
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
! Later
! [ t ] [

19
core/inference/dataflow/dataflow.factor
View File

@ -144,7 +144,8 @@ TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
TUPLE: #merge < node ;
! Phi node: merging is a sequence of sequences of values
TUPLE: #merge < node merging ;
: #merge ( -- node ) \ #merge all-out-node ;
@ -191,7 +192,7 @@ TUPLE: #declare < node ;
: #drop ( n -- #shuffle )
d-tail flatten-curries \ #shuffle in-node ;
: node-exists? ( node quot -- ? )
: node-exists? ( node quot: ( node -- ? ) -- ? )
over [
2dup 2slip rot [
2drop t
@ -201,7 +202,7 @@ TUPLE: #declare < node ;
] if
] [
2drop f
] if ; inline
] if ; inline recursive
GENERIC: calls-label* ( label node -- ? )
@ -223,21 +224,21 @@ SYMBOL: node-stack
: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
: iterate-nodes ( node quot: ( -- ) -- )
over [
[ swap >node call node> drop ] keep iterate-nodes
] [
2drop
] if ; inline
] if ; inline recursive
: (each-node) ( quot -- next )
: (each-node) ( quot: ( node -- ) -- next )
node@ [ swap call ] 2keep
node-children [
[
[ (each-node) ] keep swap
] iterate-nodes
] each drop
iterate-next ; inline
iterate-next ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
@ -260,14 +261,14 @@ SYMBOL: node-stack
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
: (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
dup >r call dup [
>>successor
successor>> dup successor>>
r> (transform-nodes)
] [
r> 2drop f >>successor drop
] if ; inline
] if ; inline recursive
: transform-nodes ( node quot -- new-node )
over [

10
core/inference/transforms/transforms-tests.factor
View File

@ -10,16 +10,6 @@ classes classes.tuple ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
[ 0 ] [ { } bitfield-quot call ] unit-test
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
TUPLE: color r g b ;
C: <color> color

21
core/inference/transforms/transforms.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel words sequences generic math
namespaces quotations assocs combinators math.bitfields
namespaces quotations assocs combinators
inference.backend inference.dataflow inference.state
classes.tuple classes.tuple.private effects summary hashtables
classes generic sets definitions generic.standard slots.private ;
@ -48,25 +48,6 @@ IN: inference.transforms
\ spread [ spread>quot ] 1 define-transform
! Bitfields
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform
! Tuple operations
: [get-slots] ( slots -- quot )
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;

5
core/io/encodings/encodings.factor
View File

@ -93,11 +93,10 @@ M: decoder stream-read-partial stream-read ;
{ CHAR: \n [ line-ends\n ] }
} case ; inline
: ((read-until)) ( buf quot -- string/f sep/f )
! quot: -- char stop?
: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
dup call
[ >r drop "" like r> ]
[ pick push ((read-until)) ] if ; inline
[ pick push ((read-until)) ] if ; inline recursive
: (read-until) ( quot -- string/f sep/f )
100 <sbuf> swap ((read-until)) ; inline

7
core/kernel/kernel.factor
View File

@ -109,10 +109,13 @@ DEFER: if
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
: while ( pred body tail -- )
: loop ( pred: ( -- ? ) -- )
dup slip swap [ loop ] [ drop ] if ; inline recursive
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
>r >r dup slip r> r> roll
[ >r tuck 2slip r> while ]
[ 2nip call ] if ; inline
[ 2nip call ] if ; inline recursive
! Object protocol
GENERIC: hashcode* ( depth obj -- code )

4
core/listener/listener.factor
View File

@ -59,9 +59,7 @@ SYMBOL: error-hook
] recover ;
: until-quit ( -- )
quit-flag get
[ quit-flag off ]
[ listen until-quit ] if ; inline
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;

10
core/math/bitfields/bitfields-tests.factor
View File

@ -15,3 +15,13 @@ IN: math.bitfields.tests
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
[ 0 ] [ { } bitfield-quot call ] unit-test
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test

21
core/math/bitfields/bitfields.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences words ;
USING: arrays kernel math sequences words
namespaces inference.transforms ;
IN: math.bitfields
GENERIC: (bitfield) ( value accum shift -- newaccum )
@ -16,3 +17,21 @@ M: pair (bitfield) ( value accum pair -- newaccum )
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform

2
core/math/integers/integers.factor
View File

@ -40,7 +40,7 @@ M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum )
dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
inline
inline recursive
M: fixnum (log2) 0 swap (fixnum-log2) ;

16
core/math/math.factor
View File

@ -124,21 +124,21 @@ M: float fp-nan?
PRIVATE>
: (each-integer) ( i n quot -- )
: (each-integer) ( i n quot: ( i -- ) -- )
[ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline
[ 3drop ] if-iterate? ; inline recursive
: (find-integer) ( i n quot -- i )
: (find-integer) ( i n quot: ( i -- ? ) -- i )
[
iterate-step roll
[ 2drop ] [ iterate-next (find-integer) ] if
] [ 3drop f ] if-iterate? ; inline
] [ 3drop f ] if-iterate? ; inline recursive
: (all-integers?) ( i n quot -- ? )
: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
[
iterate-step roll
[ iterate-next (all-integers?) ] [ 3drop f ] if
] [ 3drop t ] if-iterate? ; inline
] [ 3drop t ] if-iterate? ; inline recursive
: each-integer ( n quot -- )
iterate-prep (each-integer) ; inline
@ -152,7 +152,7 @@ PRIVATE>
: all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline
: find-last-integer ( n quot -- i )
: find-last-integer ( n quot: ( i -- ? ) -- i )
over 0 < [
2drop f
] [
@ -161,4 +161,4 @@ PRIVATE>
] [
>r 1- r> find-last-integer
] if
] if ; inline
] if ; inline recursive

12
core/math/parser/parser-tests.factor
View File

@ -77,10 +77,6 @@ unit-test
[ "-101.0e-2" string>number number>string ]
unit-test
[ 5.0 ]
[ "10.0/2" string>number ]
unit-test
[ f ]
[ "1e1/2" string>number ]
unit-test
@ -104,3 +100,11 @@ unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test

22
core/math/parser/parser.factor
View File

@ -55,8 +55,9 @@ SYMBOL: negative?
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"-" ?head dup negative? set swap
"/" split1 (base>) >r whole-part r>
3dup and and [ / + ] [ 3drop f ] if ;
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: valid-digits? ( seq -- ? )
{
@ -66,20 +67,23 @@ SYMBOL: negative?
} cond ;
: string>integer ( str -- n/f )
"-" ?head swap
string>digits dup valid-digits?
[ radix get digits>integer ] [ drop f ] if ;
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
PRIVATE>
: base> ( str radix -- n/f )
[
"-" ?head dup negative? set >r
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
[ string>integer ]
} cond
r> [ dup [ neg ] when ] when
CHAR: / over member? [
string>ratio
] [
CHAR: . over member? [
string>float
] [
string>integer
] if
] if
] with-radix ;
: string>number ( str -- n/f ) 10 base> ;

5
core/memory/memory.factor
View File

@ -5,9 +5,8 @@ USING: arrays kernel sequences vectors system hashtables
kernel.private sbufs growable assocs namespaces quotations
math strings combinators ;
: (each-object) ( quot -- )
next-object dup
[ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline
: (each-object) ( quot: ( obj -- ) -- )
[ next-object dup ] swap [ drop ] while ; inline
: each-object ( quot -- )
begin-scan (each-object) end-scan ; inline

2
core/optimizer/control/control.factor
View File

@ -70,8 +70,6 @@ M: #label collect-label-info*
[ V{ } clone node-stack get length 3array ] keep
node-param label-info get set-at ;
USE: prettyprint
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail

12
core/quotations/quotations.factor
View File

@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private
slots.private ;
IN: quotations
<PRIVATE
: uncurry dup 3 slot swap 4 slot ; inline
: uncompose dup 3 slot swap 4 slot ; inline
PRIVATE>
M: quotation call (call) ;
M: curry call dup 3 slot swap 4 slot call ;
M: curry call uncurry call ;
M: compose call dup 3 slot swap 4 slot slip call ;
M: compose call uncompose slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;

10
core/sequences/sequences.factor
View File

@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence
<PRIVATE
: array-capacity ( array -- n )
1 slot { array-capacity } declare ; inline
: array-nth ( n array -- elt )
swap 2 fixnum+fast slot ; inline
@ -241,7 +238,8 @@ INSTANCE: repetition immutable-sequence
] 3keep ; inline
: (copy) ( dst i src j n -- dst )
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
inline recursive
: prepare-subseq ( from to seq -- dst i src j n )
[ >r swap - r> new-sequence dup 0 ] 3keep
@ -653,7 +651,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: halves ( seq -- first second )
dup midpoint@ cut-slice ;
: binary-reduce ( seq start quot -- value )
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
#! We can't use case here since combinators depends on
#! sequences
pick length dup 0 3 between? [
@ -668,7 +666,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
>r >r halves r> r>
[ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline
] if ; inline recursive
: cut ( seq n -- before after )
[ head ] [ tail ] 2bi ;

11
core/sorting/sorting.factor
View File

@ -52,14 +52,14 @@ TUPLE: merge
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
: (merge) ( merge quot -- )
: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
over r-done? [ drop dump-l ] [
over l-done? [ drop dump-r ] [
2dup decide
[ over r-next ] [ over l-next ] if
(merge)
] if
] if ; inline
] if ; inline recursive
: flip-accum ( merge -- )
dup [ accum>> ] [ accum1>> ] bi eq? [
@ -111,10 +111,9 @@ TUPLE: merge
[ merge ] 2curry each-chunk ; inline
: sort-loop ( merge quot -- )
2 swap
[ pick seq>> length pick > ]
[ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
[ ] while 3drop ; inline
[ 2 [ over seq>> length over > ] ] dip
[ [ 1 shift 2dup ] dip sort-pass ] curry
[ ] while 2drop ; inline
: each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip

2
core/splitting/splitting.factor
View File

@ -30,7 +30,7 @@ IN: splitting
: (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
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;

1
core/syntax/syntax.factor
View File

@ -89,6 +89,7 @@ IN: bootstrap.syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
"\\" [ scan-word literalize parsed ] define-syntax
"inline" [ word make-inline ] define-syntax
"recursive" [ word make-recursive ] define-syntax
"foldable" [ word make-foldable ] define-syntax
"flushable" [ word make-flushable ] define-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax

2
core/threads/threads.factor
View File

@ -195,7 +195,7 @@ M: real sleep
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
>r [ loop ] curry r> spawn ;
: in-thread ( quot -- )
>r datastack r>

9
core/words/words.factor
View File

@ -164,6 +164,9 @@ M: object redefined drop ;
: make-inline ( word -- )
t "inline" set-word-prop ;
: make-recursive ( word -- )
t "recursive" set-word-prop ;
: make-flushable ( word -- )
t "flushable" set-word-prop ;
@ -181,7 +184,7 @@ GENERIC: reset-word ( word -- )
M: word reset-word
{
"unannotated-def"
"parsing" "inline" "foldable" "flushable"
"parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"constructing"
@ -222,6 +225,10 @@ ERROR: bad-create name vocab ;
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
GENERIC: inline? ( word -- ? )
M: word inline? "inline" word-prop ;
PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )

12
extra/automata/ui/ui.factor
View File

@ -15,7 +15,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui.gadgets.theme
ui.gadgets.handler
accessors
qualified
namespaces.lib assocs.lib vars
rewrite-closures automata math.geometry.rect newfx ;
@ -23,13 +22,6 @@ IN: automata.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
QUALIFIED: ui.gadgets.grids
: grid-add ( grid child i j -- grid )
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
@ -80,13 +72,13 @@ DEFER: automata-window
"5 - Random Rule" [ random-rule ] view-button add-gadget
"n - New" [ automata-window ] view-button add-gadget
@top grid-add
@top grid-add*
C[ display ] <slate>
{ 400 400 } >>pdim
dup >slate
@center grid-add
@center grid-add*
<handler>

60
extra/backtrack/backtrack.factor
View File

@ -1,20 +1,68 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences namespaces fry ;
USING: kernel continuations combinators sequences quotations arrays namespaces
fry summary assocs math math.order macros ;
IN: backtrack
SYMBOL: failure
: amb ( seq -- elt )
failure get
'[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each
, continue ] callcc1 ;
ERROR: amb-failure ;
M: amb-failure summary drop "Backtracking failure" ;
: fail ( -- )
f amb drop ;
failure get [ continue ]
[ amb-failure ] if* ;
: require ( ? -- )
[ fail ] unless ;
MACRO: checkpoint ( quot -- quot' )
'[ failure get ,
'[ '[ failure set , continue ] callcc0
, failure set @ ] callcc0 ] ;
: number-from ( from -- from+n )
[ 1 + number-from ] checkpoint ;
<PRIVATE
: unsafe-number-from-to ( to from -- to from+n )
2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;
: number-from-to ( to from -- to from+n )
2dup < [ fail ] when unsafe-number-from-to ;
: amb-integer ( seq -- int )
length 1 - 0 number-from-to nip ;
MACRO: unsafe-amb ( seq -- quot )
dup length 1 =
[ first 1quotation ]
[ [ first ] [ rest ] bi
'[ , [ drop , unsafe-amb ] checkpoint ] ] if ;
PRIVATE>
: amb-lazy ( seq -- elt )
[ amb-integer ] [ nth ] bi ;
: amb ( seq -- elt )
dup empty?
[ drop fail f ]
[ unsafe-amb ] if ; inline
MACRO: amb-execute ( seq -- quot )
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi
'[ , 0 unsafe-number-from-to nip , case ] ;
: if-amb ( true false -- )
[
[ { t f } amb ]
[ '[ @ require t ] ]
[ '[ @ f ] ]
tri* if
] with-scope ; inline

12
extra/benchmark/backtrack/backtrack.factor Normal file → Executable file
View File

@ -12,18 +12,6 @@ IN: benchmark.backtrack
: nop ;
MACRO: amb-execute ( seq -- quot )
[ length ] [ <enum> [ 1quotation ] assoc-map ] bi
'[ , amb , case ] ;
: if-amb ( true false -- )
[
[ { t f } amb ]
[ '[ @ require t ] ]
[ '[ @ f ] ]
tri* if
] with-scope ; inline
: do-something ( a b -- c )
{ + - * } amb-execute ;

4
extra/boids/ui/ui.factor
View File

@ -143,9 +143,9 @@ VARS: population-label cohesion-label alignment-label separation-label ;
} [ call ] map [ add-gadget ] each
1 over set-pack-fill
over @top grid-add
@top grid-add*
slate> over @center grid-add
slate> @center grid-add*
<handler>

4
extra/cocoa/enumeration/enumeration.factor
View File

@ -11,13 +11,13 @@ IN: cocoa.enumeration
] with-malloc
] with-malloc ; inline
:: (NSFastEnumeration-each) ( object quot state stackbuf count -- )
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
'[ , void*-nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline
] if ; inline recursive
: NSFastEnumeration-each ( object quot -- )
[ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline

10
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -23,13 +23,13 @@ M: mailbox dispose* threads>> notify-all ;
: wait-for-mailbox ( mailbox timeout -- )
>r threads>> r> "mailbox" wait ;
: block-unless-pred ( mailbox timeout pred -- )
: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
pick check-disposed
pick data>> over dlist-contains? [
3drop
] [
>r 2dup wait-for-mailbox r> block-unless-pred
] if ; inline
] if ; inline recursive
: block-if-empty ( mailbox timeout -- mailbox )
over check-disposed
@ -58,11 +58,7 @@ M: mailbox dispose* threads>> notify-all ;
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
dup >r dip r> while-mailbox-empty
] [
2drop
] if ; inline
[ [ mailbox-empty? ] curry ] dip [ ] while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
3dup block-unless-pred

2
extra/concurrency/messaging/messaging-tests.factor
View File

@ -47,7 +47,7 @@ SYMBOL: exit
} match-cond ;
[ -5 ] [
[ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set
[ 0 [ counter ] loop ] "Counter" spawn "counter" set
{ increment 10 } "counter" get send
{ decrement 15 } "counter" get send
[ value , self , ] { } make "counter" get send

72
extra/disjoint-set/disjoint-set.factor
View File

@ -1,72 +0,0 @@
USING: accessors arrays hints kernel locals math sequences ;
IN: disjoint-set
<PRIVATE
TUPLE: disjoint-set parents ranks counts ;
: count ( a disjoint-set -- n )
counts>> nth ; inline
: add-count ( p a disjoint-set -- )
[ count [ + ] curry ] keep counts>> swap change-nth ; inline
: parent ( a disjoint-set -- p )
parents>> nth ; inline
: set-parent ( p a disjoint-set -- )
parents>> set-nth ; inline
: link-sets ( p a disjoint-set -- )
[ set-parent ]
[ add-count ] 3bi ; inline
: rank ( a disjoint-set -- r )
ranks>> nth ; inline
: inc-rank ( a disjoint-set -- )
ranks>> [ 1+ ] change-nth ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
: representative ( a disjoint-set -- p )
2dup representative? [ drop ] [
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
: ranks ( a b disjoint-set -- r r )
[ rank ] curry bi@ ; inline
:: branch ( a b neg zero pos -- )
a b = zero [ a b < neg pos if ] if ; inline
PRIVATE>
: <disjoint-set> ( n -- disjoint-set )
[ >array ]
[ 0 <array> ]
[ 1 <array> ] tri
disjoint-set boa ;
: equiv-set-size ( a disjoint-set -- n )
[ representative ] keep count ;
: equiv? ( a b disjoint-set -- ? )
representatives = ; inline
:: equate ( a b disjoint-set -- )
a b disjoint-set representatives
2dup = [ 2drop ] [
2dup disjoint-set ranks
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
disjoint-set link-sets
] if ;
HINTS: equate disjoint-set ;
HINTS: representative disjoint-set ;
HINTS: equiv-set-size disjoint-set ;

0
extra/disjoint-set/authors.txt → extra/disjoint-sets/authors.txt
View File

88
extra/disjoint-sets/disjoint-sets.factor Normal file
View File

@ -0,0 +1,88 @@
! Copyright (C) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hints kernel locals math hashtables
assocs ;
IN: disjoint-sets
TUPLE: disjoint-set
{ parents hashtable read-only }
{ ranks hashtable read-only }
{ counts hashtable read-only } ;
<PRIVATE
: count ( a disjoint-set -- n )
counts>> at ; inline
: add-count ( p a disjoint-set -- )
[ count [ + ] curry ] keep counts>> swap change-at ; inline
: parent ( a disjoint-set -- p )
parents>> at ; inline
: set-parent ( p a disjoint-set -- )
parents>> set-at ; inline
: link-sets ( p a disjoint-set -- )
[ set-parent ] [ add-count ] 3bi ; inline
: rank ( a disjoint-set -- r )
ranks>> at ; inline
: inc-rank ( a disjoint-set -- )
ranks>> [ 1+ ] change-at ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
PRIVATE>
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
2dup representative? [ drop ] [
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
<PRIVATE
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
: ranks ( a b disjoint-set -- r r )
[ rank ] curry bi@ ; inline
:: branch ( a b neg zero pos -- )
a b = zero [ a b < neg pos if ] if ; inline
PRIVATE>
: <disjoint-set> ( -- disjoint-set )
H{ } clone H{ } clone H{ } clone disjoint-set boa ;
GENERIC: add-atom ( a disjoint-set -- )
M: disjoint-set add-atom
[ dupd parents>> set-at ]
[ 0 -rot ranks>> set-at ]
[ 1 -rot counts>> set-at ]
2tri ;
GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ;
GENERIC: equiv? ( a b disjoint-set -- ? )
M: disjoint-set equiv? representatives = ;
GENERIC: equate ( a b disjoint-set -- )
M:: disjoint-set equate ( a b disjoint-set -- )
a b disjoint-set representatives
2dup = [ 2drop ] [
2dup disjoint-set ranks
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
disjoint-set link-sets
] if ;

0
extra/disjoint-set/summary.txt → extra/disjoint-sets/summary.txt
View File

0
extra/disjoint-set/tags.txt → extra/disjoint-sets/tags.txt
View File

24
extra/fry/fry-docs.factor
View File

@ -19,10 +19,11 @@ HELP: fry
HELP: '[
{ $syntax "code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."
"The easiest way to understand fried quotations is to look at some examples."
$nl
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
{ $code "{ 10 20 30 } '[ . ] each" }
@ -38,9 +39,10 @@ $nl
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
"{ 10 20 30 } [ 3 5 / ] map"
}
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } [ sq ] '[ @ . ] each"
"{ 10 20 30 } [ sq ] [ call . ] curry each"
"{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each"
}
@ -50,16 +52,17 @@ $nl
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } 1 '[ , _ / ] map"
"{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"
"{ 10 20 30 } 1 [ swap / ] curry map"
"{ 10 20 30 } [ 1 swap / ] map"
}
"For any quotation body " { $snippet "X" } ", the following two are equivalent:"
{ $code
"[ >r X r> ]"
"[ X _ ]"
"[ [ X ] dip ]"
"'[ X _ ]"
}
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
@ -73,8 +76,11 @@ $nl
} ;
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."
$nl
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
{ $code
"'[ [ , key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 , + 4 , / ]"
@ -87,7 +93,7 @@ $nl
} ;
ARTICLE: "fry.limitations" "Fried quotation limitations"
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
ARTICLE: "fry" "Fried quotations"
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."

68
extra/golden-section/golden-section.factor
View File

@ -1,64 +1,64 @@
USING: kernel namespaces math math.constants math.functions arrays sequences
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors ;
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors accessors combinators.cleave ;
IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! To run:
! "golden-section" run
: disk ( radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
glPopMatrix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: disk ( quadric radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
0 1 10 10 gluDisk
glPopMatrix ;
! omega(i) = 2*pi*i*(phi-1)
! x(i) = 0.5*i*cos(omega(i))
! y(i) = 0.5*i*sin(omega(i))
! radius(i) = 10*sin((pi*i)/720)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: omega ( i -- omega ) phi 1- * 2 * pi * ;
: x ( i -- x ) dup omega cos * 0.5 * ;
: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
: y ( i -- y ) dup omega sin * 0.5 * ;
: center ( i -- point ) dup x swap y 2array ;
: center ( i -- point ) { x y } 1arr ;
: radius ( i -- radius ) pi * 720 / sin 10 * ;
: color ( i -- color ) 360.0 / dup 0.25 1 4array ;
: rim ( quadric i -- )
black gl-color dup radius 1.5 * swap center disk ;
: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
: inner ( quadric i -- )
dup color gl-color dup radius swap center disk ;
: dot ( i -- ) [ rim ] [ inner ] bi ;
: dot ( quadric i -- ) 2dup rim inner ;
: golden-section ( quadric -- ) 720 [ dot ] with each ;
: golden-section ( -- ) 720 [ dot ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: with-quadric ( quot -- )
gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
: display ( -- )
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ golden-section ] with-quadric ;
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
golden-section ;
: golden-section-window ( -- )
[
[ display ] <slate>
{ 600 600 } over set-slate-pdim
"Golden Section" open-window
] with-ui ;
[ display ] <slate>
{ 600 600 } >>pdim
"Golden Section" open-window
]
with-ui ;
MAIN: golden-section-window

2
extra/help/handbook/handbook.factor
View File

@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections"
{ $subsection "heaps" }
{ $subsection "graphs" }
{ $subsection "buffers" }
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;

2
extra/help/lint/lint.factor
View File

@ -29,7 +29,7 @@ IN: help.lint
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
[ (stack-picture) ] map
[ dup pair? [ first ] when effect>string ] map
prune natural-sort ;
: contains-funky-elements? ( element -- ? )

4
extra/io/monitors/monitors-tests.factor
View File

@ -55,7 +55,7 @@ os { winnt linux macosx } member? [
dup print flush
dup parent-directory
[ right-trim-separators "xyz" tail? ] either? not
] [ ] [ ] while
] loop
"c1" get count-down
@ -64,7 +64,7 @@ os { winnt linux macosx } member? [
dup print flush
dup parent-directory
[ right-trim-separators "yxy" tail? ] either? not
] [ ] [ ] while
] loop
"c2" get count-down
] "Monitor test thread" spawn drop

2
extra/irc/ui/load/load.factor
View File

@ -5,7 +5,7 @@ USING: kernel io.files parser editors sequences ;
IN: irc.ui.load
: file-or ( path path -- path ) over exists? ? ;
: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;

85
extra/irc/ui/ui.factor
View File

@ -5,8 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids
io io.styles namespaces calendar calendar.format
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels
io io.styles namespaces calendar calendar.format models
irc.client irc.client.private irc.messages irc.messages.private
irc.ui.commandparser irc.ui.load ;
@ -18,11 +18,18 @@ SYMBOL: client
TUPLE: ui-window client tabs ;
TUPLE: irc-tab < frame listener client listmodel ;
: write-color ( str color -- )
foreground associate format ;
: red { 0.5 0 0 1 } ;
: green { 0 0.5 0 1 } ;
: blue { 0 0 1 1 } ;
: black { 0 0 0 1 } ;
: colors H{ { +operator+ { 0 0.5 0 1 } }
{ +voice+ { 0 0 1 1 } }
{ +normal+ { 0 0 0 1 } } } ;
: dot-or-parens ( string -- string )
dup empty? [ drop "." ]
@ -64,6 +71,14 @@ M: quit write-irc
" has left IRC" red write-color
trailing>> dot-or-parens red write-color ;
M: mode write-irc
"* " blue write-color
[ name>> write ] keep
" has applied mode " blue write-color
[ mode>> write ] keep
" to " blue write-color
channel>> write ;
M: irc-end write-irc
drop "* You have left IRC" red write-color ;
@ -84,20 +99,39 @@ M: irc-message write-irc
[ print-irc ]
[ listener get write-message ] bi ;
: display ( stream listener -- )
GENERIC: handle-inbox ( tab message -- )
: filter-participants ( assoc val -- alist )
[ >alist ] dip
'[ second , = ] filter ;
: update-participants ( tab -- )
[ listmodel>> ] [ listener>> participants>> ] bi
[ +operator+ filter-participants ]
[ +voice+ filter-participants ]
[ +normal+ filter-participants ] tri
append append swap set-model ;
M: participant-changed handle-inbox
drop update-participants ;
M: object handle-inbox
nip print-irc ;
: display ( stream tab -- )
'[ , [ [ t ]
[ , read-message print-irc ]
[ , dup listener>> read-message handle-inbox ]
[ ] while ] with-output-stream ] "ircv" spawn drop ;
: <irc-pane> ( listener -- pane )
: <irc-pane> ( tab -- tab pane )
<scrolling-pane>
[ <pane-stream> swap display ] keep ;
[ <pane-stream> swap display ] 2keep ;
TUPLE: irc-editor < editor outstream listener client ;
: <irc-editor> ( page pane listener -- client editor )
irc-editor new-editor
swap >>listener swap <pane-stream> >>outstream
: <irc-editor> ( tab pane -- tab editor )
over irc-editor new-editor
swap listener>> >>listener swap <pane-stream> >>outstream
over client>> >>client ;
: editor-send ( irc-editor -- )
@ -113,25 +147,36 @@ irc-editor "general" f {
{ T{ key-down f f "ENTER" } editor-send }
} define-command-map
TUPLE: irc-page < frame listener client ;
: <irc-list> ( -- gadget model )
[ drop ]
[ first2 [ <label> ] dip >>color ]
{ } <model> [ <list> ] keep ;
: <irc-page> ( listener client -- irc-page )
irc-page new-frame
swap client>> >>client swap [ >>listener ] keep
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
[ <irc-editor> <scroller> @bottom grid-add* ] bi ;
: <irc-tab> ( listener client -- irc-tab )
irc-tab new-frame
swap client>> >>client swap >>listener
<irc-pane> [ <scroller> @center grid-add* ] keep
<irc-editor> <scroller> @bottom grid-add* ;
M: irc-page graft*
: <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab>
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
[ update-participants ] keep ;
: <irc-server-tab> ( listener client -- irc-tab )
<irc-tab> ;
M: irc-tab graft*
[ listener>> ] [ client>> ] bi
add-listener ;
M: irc-page ungraft*
M: irc-tab ungraft*
[ listener>> ] [ client>> ] bi
remove-listener ;
: join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip
[ <irc-page> swap ] keep
[ <irc-channel-tab> swap ] keep
tabs>> add-page ;
: irc-window ( ui-window -- )
@ -142,12 +187,12 @@ M: irc-page ungraft*
: ui-connect ( profile -- ui-window )
<irc-client> ui-window new over >>client swap
[ connect-irc ]
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
[ listeners>> +server-listener+ swap at over <irc-tab>
"Server" associate <tabbed> >>tabs ] bi ;
: server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
[ over join-channel ] each ;
[ over join-channel ] each drop ;
: main-run ( -- ) run-ircui ;

2
extra/koszul/koszul.factor
View File

@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )

6
extra/locals/locals.factor
View File

@ -64,8 +64,8 @@ C: <quote> quote
local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
>r "local-reader" word-prop r>
read-local-quot [ set-local-value ] append ;
>r "local-reader" word-prop r>
read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
@ -275,7 +275,7 @@ M: wlet local-rewrite*
: parse-locals ( -- vars assoc )
")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals dup push-locals ;
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>

4
extra/math/functions/functions.factor
View File

@ -23,12 +23,12 @@ GENERIC: sqrt ( x -- y ) foldable
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot -- )
: each-bit ( n quot: ( ? -- ) -- )
over 0 number= pick -1 number= or [
2drop
] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline
] if ; inline recursive
GENERIC: (^) ( x y -- z ) foldable

8
extra/math/geometry/geometry.factor Normal file
View File

@ -0,0 +1,8 @@
IN: math.geometry
GENERIC: width ( object -- width )
GENERIC: height ( object -- width )
GENERIC# set-x! 1 ( object x -- object )
GENERIC# set-y! 1 ( object y -- object )

15
extra/math/geometry/rect/rect.factor
View File

@ -1,13 +1,15 @@
USING: kernel arrays math.vectors ;
USING: kernel arrays sequences math.vectors math.geometry accessors ;
IN: math.geometry.rect
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
TUPLE: rect loc dim ;
: <zero-rect> ( -- rect ) rect new ;
: init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ;
C: <rect> rect
: <rect> ( loc dim -- rect ) rect boa ;
: <zero-rect> ( -- rect ) rect new init-rect ;
M: array rect-loc ;
@ -40,3 +42,8 @@ M: array rect-dim drop { 0 0 } ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
M: rect width ( rect -- width ) dim>> first ;
M: rect height ( rect -- height ) dim>> second ;
M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
M: rect set-y! ( rect y -- rect ) over loc>> set-second ;

2
extra/math/matrices/elimination/elimination.factor
View File

@ -11,7 +11,7 @@ SYMBOL: matrix
: nth-row ( row# -- seq ) matrix get nth ;
: change-row ( row# quot -- | quot: seq -- seq )
: change-row ( row# quot: ( seq -- seq ) -- )
matrix get swap change-nth ; inline
: exchange-rows ( row# row# -- ) matrix get exchange ;

25
extra/optimizer/debugger/debugger.factor
View File

@ -3,8 +3,8 @@
USING: classes io kernel kernel.private math.parser namespaces
optimizer prettyprint prettyprint.backend sequences words arrays
match macros assocs sequences.private generic combinators
sorting math quotations accessors inference inference.dataflow
optimizer.specializers ;
sorting math quotations accessors inference inference.backend
inference.dataflow optimizer.specializers generator ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
@ -135,14 +135,21 @@ M: object node>quot
: optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
SYMBOL: pass-count
SYMBOL: words-called
SYMBOL: generics-called
SYMBOL: methods-called
SYMBOL: intrinsics-called
SYMBOL: node-count
: dataflow>report ( node -- alist )
: count-optimization-passes ( node n -- node n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ r> ] if ;
: make-report ( word -- assoc )
[
word-dataflow nip 1 count-optimization-passes pass-count set
H{ } clone words-called set
H{ } clone generics-called set
H{ } clone methods-called set
@ -164,14 +171,12 @@ SYMBOL: node-count
node-count set
] H{ } make-assoc ;
: quot-optimize-report ( quot -- report )
dataflow optimize dataflow>report ;
: word-optimize-report ( word -- report )
def>> quot-optimize-report ;
: report. ( report -- )
[
"==== Optimization passes:" print
pass-count get .
nl
"==== Total number of dataflow nodes:" print
node-count get .
@ -186,4 +191,4 @@ SYMBOL: node-count
] bind ;
: optimizer-report. ( word -- )
word-optimize-report report. ;
make-report report. ;

17
extra/processing/gadget/gadget.factor
View File

@ -1,25 +1,14 @@
USING: kernel namespaces combinators
ui.gestures qualified accessors ui.gadgets.frame-buffer ;
ui.gestures accessors ui.gadgets.frame-buffer ;
IN: processing.gadget
QUALIFIED: ui.gadgets
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: processing-gadget button-down button-up key-down key-up ;
TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set-gadget-delegate ( tuple gadget -- tuple )
over ui.gadgets:set-gadget-delegate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <processing-gadget> ( -- gadget )
processing-gadget new
<frame-buffer> set-gadget-delegate ;
: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/processing/processing.factor Executable file → Normal file
View File

@ -374,7 +374,7 @@ SYMBOL: setup-called
500 sleep
<processing-gadget>
size-val get >>dim
size-val get >>pdim
dup "Processing" open-window
500 sleep

2
extra/project-euler/079/079.factor
View File

@ -35,7 +35,7 @@ IN: project-euler.079
] { } make ;
: find-source ( seq -- elt )
[ keys ] [ values ] bi diff prune
unzip diff prune
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )

7
extra/project-euler/186/186.factor
View File

@ -1,4 +1,4 @@
USING: circular disjoint-set kernel math math.ranges
USING: circular disjoint-sets kernel math math.ranges
sequences sequences.lib ;
IN: project-euler.186
@ -29,7 +29,10 @@ IN: project-euler.186
drop nip
] if ;
: <relation> ( n -- unionfind )
<disjoint-set> [ [ add-atom ] curry each ] keep ;
: euler186 ( -- n )
<generator> 0 1000000 <disjoint-set> (p186) ;
<generator> 0 1000000 <relation> (p186) ;
MAIN: euler186

16
extra/reports/optimizer/optimizer.factor
View File

@ -2,13 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs words sequences arrays compiler
tools.time io.styles io prettyprint vocabs kernel sorting
generator optimizer math math.order math.statistics combinators ;
generator optimizer math math.order math.statistics combinators
optimizer.debugger ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: table. ( alist -- )
20 short tail*
standard-table-style
@ -28,13 +25,12 @@ IN: report.optimizer
tri
] 2bi ; inline
: optimization-passes ( word -- n )
word-dataflow nip 1 count-optimization-passes nip ;
: optimizer-measurements ( -- alist )
all-words [ compiled>> ] filter
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark 2array
] { } map>assoc ;
[ dup [ optimization-passes ] benchmark 2array ] { } map>assoc ;
: optimizer-measurements. ( alist -- )
{

20
extra/sequences/deep/deep.factor
View File

@ -10,25 +10,25 @@ IN: sequences.deep
dup string? swap number? or not
] [ drop f ] if ;
: deep-each ( obj quot -- )
: deep-each ( obj quot: ( elt -- ) -- )
[ call ] 2keep over branch?
[ [ deep-each ] curry each ] [ 2drop ] if ; inline
[ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
: deep-map ( obj quot -- newobj )
: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
[ call ] keep over branch?
[ [ deep-map ] curry map ] [ drop ] if ; inline
[ [ deep-map ] curry map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot -- seq )
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
over >r
pusher >r deep-each r>
r> dup branch? [ like ] [ drop ] if ; inline
r> dup branch? [ like ] [ drop ] if ; inline recursive
: deep-find-from ( obj quot -- elt ? )
: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
] [ 2drop f f ] if
] if ; inline
] if ; inline recursive
: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
@ -37,10 +37,10 @@ IN: sequences.deep
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
: deep-change-each ( obj quot -- )
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [ [
[ call ] keep over >r deep-change-each r>
] curry change-each ] [ 2drop ] if ; inline
] curry change-each ] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;

4
extra/sorting/insertion/insertion.factor
View File

@ -2,13 +2,13 @@ USING: locals sequences kernel math ;
IN: sorting.insertion
<PRIVATE
:: insert ( seq quot n -- )
:: 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
] unless
] unless ; inline
] unless ; inline recursive
PRIVATE>
: insertion-sort ( seq quot -- )

5
extra/ui/cocoa/cocoa.factor
View File

@ -16,10 +16,7 @@ SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[
[
NSApp [ dup do-event ] [ ] [ ] while drop
ui-wait
] ui-try
[ NSApp [ do-event ] curry loop ui-wait ] ui-try
] with-autorelease-pool ;
TUPLE: pasteboard handle ;

2
extra/ui/freetype/freetype.factor
View File

@ -142,7 +142,7 @@ M: freetype-renderer string-height ( open-font string -- h )
i end < [
i j bitmap texture copy-pixel
bitmap texture end (copy-row)
] when ; inline
] when ; inline recursive
:: copy-row ( i j bitmap texture width width2 -- i j )
i j bitmap texture i width + (copy-row)

12
extra/ui/gadgets/frame-buffer/frame-buffer.factor
View File

@ -7,7 +7,7 @@ IN: ui.gadgets.frame-buffer
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -18,13 +18,15 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <frame-buffer> ( -- frame-buffer )
frame-buffer construct-gadget
: new-frame-buffer ( class -- gadget )
new-gadget
[ ] >>action
{ 100 100 } >>dim
{ 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-pixels ( fb -- fb )
@ -44,7 +46,7 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: frame-buffer pref-dim* dim>> ;
M: frame-buffer pref-dim* pdim>> ;
M: frame-buffer graft* graft>> call ;
M: frame-buffer ungraft* ungraft>> call ;

12
extra/ui/gadgets/frames/frames-docs.factor
View File

@ -7,9 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection frame, }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add* } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
@ -22,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
: $ui-frame-constant ( element -- )
drop
{ $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
{ $description "Symbolic constant for a common input to " { $link grid-add* } "." } print-element ;
HELP: @center $ui-frame-constant ;
HELP: @left $ui-frame-constant ;
@ -37,16 +35,12 @@ HELP: @bottom-right $ui-frame-constant ;
HELP: frame
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
$nl
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;
HELP: <frame>
{ $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
HELP: frame,
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
{ grid frame } related-words
ABOUT: "ui-frame-layout"

3
extra/ui/gadgets/frames/frames.factor
View File

@ -38,6 +38,3 @@ M: frame layout*
dup compute-grid
[ rot rect-dim fill-center ] 3keep
grid-layout ;
: frame, ( gadget i j -- )
gadget get -rot grid-add ;

16
extra/ui/gadgets/gadgets.factor
View File

@ -27,11 +27,13 @@ M: gadget model-changed 2drop ;
: nth-gadget ( n gadget -- child ) children>> nth ;
: new-gadget ( class -- gadget )
new
{ 0 1 } >>orientation
t >>visible?
{ f f } >>graft-state ; inline
: init-gadget ( gadget -- gadget )
init-rect
{ 0 1 } >>orientation
t >>visible?
{ f f } >>graft-state ; inline
: new-gadget ( class -- gadget ) new init-gadget ; inline
: <gadget> ( -- gadget )
gadget new-gadget ;
@ -361,10 +363,6 @@ M: f request-focus-on 2drop ;
[ focus>> ] follow ;
! Deprecated
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ (>>parent) ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

6
extra/ui/gadgets/grids/grids-docs.factor
View File

@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-add* }
{ $subsection grid-remove }
{ $subsection grid-child } ;
@ -18,7 +18,7 @@ $nl
$nl
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
$nl
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
$nl
"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
@ -31,7 +31,7 @@ HELP: grid-child
{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
{ $errors "Throws an error if the indices are out of bounds." } ;
HELP: grid-add
HELP: grid-add*
{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location." }
{ $side-effects "grid" } ;

12
extra/ui/gadgets/grids/grids.factor
View File

@ -20,14 +20,12 @@ grid
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- )
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid )
>r >r dupd swap r> r>
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
: grid-remove ( grid i j -- )
>r >r >r <gadget> r> r> r> grid-add ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
: pref-dim-grid ( grid -- dims )
grid>> [ [ pref-dim ] map ] map ;

2
extra/ui/gadgets/slots/slots.factor
View File

@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
[ clear-track ]
[
dup ref>> <slot-editor>
[ swap 1 track-add ]
[ 1 track-add* drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;

2
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
: open-status-window ( gadget title -- )
f <model> [ <world> ] keep
<status-bar> over f track-add
<status-bar> f track-add*
open-world-window ;
: show-summary ( object gadget -- )

4
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add } ;
{ $subsection track-add* } ;
HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -17,7 +17,7 @@ HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
HELP: track-add
HELP: track-add*
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;

5
extra/ui/gadgets/tracks/tracks.factor
View File

@ -41,14 +41,11 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]
[ [ alloted-dim ] [ track-pref-dims-1 ] bi v+ ]
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
[ orientation>> ]
tri
set-axis ;
: track-add ( gadget track constraint -- )
over track-sizes push swap add-gadget drop ;
: track-add* ( track gadget constraint -- track )
pick sizes>> push add-gadget ;

2
extra/ui/gadgets/worlds/worlds.factor
View File

@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
{ 0 0 } >>window-loc
swap >>status
swap >>title
[ 1 track-add ] keep
swap 1 track-add*
dup request-focus ;
M: world layout*

22
extra/ui/render/render-docs.factor
View File

@ -5,17 +5,17 @@ IN: ui.render
HELP: gadget
{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
{ $list
{ { $link "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
{ { $link "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
{ { $link "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
{ { $link "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
{ { $link "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
{ { $link "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
{ { $link "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
{ { $link "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $link "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $link "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $link "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
{ { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
{ { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
{ { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
{ { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
{ { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
{ { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
{ { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
{ { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
}
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
{ $notes

293
unfinished/compiler/cfg/alias/alias.factor Normal file
View File

@ -0,0 +1,293 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences
accessors vectors combinators sets compiler.vops compiler.cfg ;
IN: compiler.cfg.alias
! Alias analysis -- must be run after compiler.cfg.stack.
!
! We try to eliminate redundant slot and stack
! traffic using some simple heuristics.
!
! All heap-allocated objects which are loaded from the stack, or
! other object slots are pessimistically assumed to belong to
! the same alias class.
!
! Freshly-allocated objects get their own alias class.
!
! The data and retain stack pointer registers are treated
! uniformly, and each one gets its own alias class.
!
! Simple pseudo-C example showing load elimination:
!
! int *x, *y, z: inputs
! int a, b, c, d, e: locals
!
! Before alias analysis:
!
! a = x[2]
! b = x[2]
! c = x[3]
! y[2] = z
! d = x[2]
! e = y[2]
! f = x[3]
!
! After alias analysis:
!
! a = x[2]
! b = a /* ELIMINATED */
! c = x[3]
! y[2] = z
! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
! e = z /* ELIMINATED */
! f = c /* ELIMINATED */
!
! Simple pseudo-C example showing store elimination:
!
! Before alias analysis:
!
! x[0] = a
! b = x[n]
! x[0] = c
! x[1] = d
! e = x[0]
! x[1] = c
!
! After alias analysis:
!
! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
! b = x[n]
! x[0] = c
! /* x[1] = d */ /* ELIMINATED */
! e = c
! x[1] = c
! Map vregs -> alias classes
SYMBOL: vregs>acs
: check [ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac )
#! Only vregs produced by %%allot, %peek and %%slot can
#! ever be used as valid inputs to %%slot and %%set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
vregs>acs get at check ;
! Map alias classes -> sequence of vregs
SYMBOL: acs>vregs
: ac>vregs ( ac -- vregs ) acs>vregs get at ;
: aliases ( vreg -- vregs )
#! All vregs which may contain the same value as vreg.
vreg>ac ac>vregs ;
: each-alias ( vreg quot -- )
[ aliases ] dip each ; inline
! Map vregs -> slot# -> vreg
SYMBOL: live-slots
! Current instruction number
SYMBOL: insn#
! Load/store history, for dead store elimination
TUPLE: load insn# ;
TUPLE: store insn# ;
: new-action ( class -- action )
insn# get swap boa ; inline
! Maps vreg -> slot# -> sequence of loads/stores
SYMBOL: histories
: history ( vreg -- history ) histories get at ;
: set-ac ( vreg ac -- )
#! Set alias class of newly-seen vreg.
{
[ drop H{ } clone swap histories get set-at ]
[ drop H{ } clone swap live-slots get set-at ]
[ swap vregs>acs get set-at ]
[ acs>vregs get push-at ]
} 2cleave ;
: live-slot ( slot#/f vreg -- vreg' )
#! If the slot number is unknown, we never reuse a previous
#! value.
over [ live-slots get at at ] [ 2drop f ] if ;
: load-constant-slot ( value slot# vreg -- )
live-slots get at check set-at ;
: load-slot ( value slot#/f vreg -- )
over [ load-constant-slot ] [ 3drop ] if ;
: record-constant-slot ( slot# vreg -- )
#! A load can potentially read every store of this slot#
#! in that alias class.
[
history [ load new-action swap ?push ] change-at
] with each-alias ;
: record-computed-slot ( vreg -- )
#! Computed load is like a load of every slot touched so far
[
history values [ load new-action swap push ] each
] each-alias ;
: remember-slot ( value slot#/f vreg -- )
over
[ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
[ 2nip record-computed-slot ] if ;
SYMBOL: ac-counter
: next-ac ( -- n )
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
! can all alias each other.
SYMBOL: heap-ac
: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
: set-new-ac ( vreg -- ) next-ac set-ac ;
: kill-constant-set-slot ( slot# vreg -- )
[ live-slots get at delete-at ] with each-alias ;
: record-constant-set-slot ( slot# vreg -- )
history [
dup empty? [ dup peek store? [ dup pop* ] when ] unless
store new-action swap ?push
] change-at ;
: kill-computed-set-slot ( ac -- )
[ live-slots get at clear-assoc ] each-alias ;
: remember-set-slot ( slot#/f vreg -- )
over [
[ record-constant-set-slot ]
[ kill-constant-set-slot ] 2bi
] [ nip kill-computed-set-slot ] if ;
SYMBOL: copies
: resolve ( vreg -- vreg )
dup copies get at swap or ;
SYMBOL: constants
: constant ( vreg -- n/f )
#! Return an %iconst value, or f if the vreg was not
#! assigned by an %iconst.
resolve constants get at ;
! We treat slot accessors and stack traffic alike
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
M: %peek insn-slot# n>> ;
M: %replace insn-slot# n>> ;
M: %%slot insn-slot# slot>> constant ;
M: %%set-slot insn-slot# slot>> constant ;
M: %peek insn-object stack>> ;
M: %replace insn-object stack>> ;
M: %%slot insn-object obj>> resolve ;
M: %%set-slot insn-object obj>> resolve ;
: init-alias-analysis ( -- )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone constants set
H{ } clone copies set
0 ac-counter set
next-ac heap-ac set
%data next-ac set-ac
%retain next-ac set-ac ;
GENERIC: analyze-aliases ( insn -- insn' )
M: %iconst analyze-aliases
dup [ value>> ] [ out>> ] bi constants get set-at ;
M: %%allot analyze-aliases
#! A freshly allocated object is distinct from any other
#! object.
dup out>> set-new-ac ;
M: read-op analyze-aliases
dup out>> set-heap-ac
dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip %copy boa analyze-aliases nip
] [
drop remember-slot
] if ;
: idempotent? ( value slot#/f vreg -- ? )
#! Are we storing a value back to the same slot it was read
#! from?
live-slot = ;
M: write-op analyze-aliases
dup
[ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
3dup idempotent? [
2drop 2drop nop
] [
[ remember-set-slot drop ] [ load-slot ] 3bi
] if ;
M: %copy analyze-aliases
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
M: vop analyze-aliases ;
SYMBOL: live-stores
: compute-live-stores ( -- )
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
] map concat unique
live-stores set ;
GENERIC: eliminate-dead-store ( insn -- insn' )
: (eliminate-dead-store) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
drop nop
] unless
] when ;
M: %replace eliminate-dead-store
#! Writes to above the top of the stack can be pruned also.
#! This is sound since any such writes are not observable
#! after the basic block, and any reads of those locations
#! will have been converted to copies by analyze-slot,
#! and the final stack height of the basic block is set at
#! the beginning by compiler.cfg.stack.
dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
M: vop eliminate-dead-store ;
: alias-analysis ( insns -- insns' )
init-alias-analysis
[ insn# set analyze-aliases ] map-index
compute-live-stores
[ insn# set eliminate-dead-store ] map-index ;

1
unfinished/compiler/cfg/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

270
unfinished/compiler/cfg/builder/builder.factor Normal file
View File

@ -0,0 +1,270 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel assocs sequences sequences.lib fry accessors
compiler.cfg compiler.vops compiler.vops.builder
namespaces math inference.dataflow optimizer.allot combinators
math.order ;
IN: compiler.cfg.builder
! Convert dataflow IR to procedure CFG.
! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the
! logic.
SYMBOL: procedures
SYMBOL: values>vregs
SYMBOL: loop-nesting
GENERIC: convert* ( node -- )
GENERIC: convert ( node -- )
: init-builder ( -- )
H{ } clone values>vregs set
V{ } clone loop-nesting set ;
: end-basic-block ( -- )
basic-block get [ %b emit ] when ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get
[
end-basic-block
dupd successors>> push
] when*
set-basic-block ;
: convert-nodes ( node -- )
dup basic-block get and [
[ convert ] [ successor>> convert-nodes ] bi
] [ drop ] if ;
: (build-cfg) ( node word -- )
init-builder
begin-basic-block
basic-block get swap procedures get set-at
%prolog emit
convert-nodes ;
: build-cfg ( node word -- procedures )
H{ } clone [
procedures [ (build-cfg) ] with-variable
] keep ;
: value>vreg ( value -- vreg )
values>vregs get at ;
: output-vreg ( value vreg -- )
swap values>vregs get set-at ;
: produce-vreg ( value -- vreg )
next-vreg [ output-vreg ] keep ;
: (load-inputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ '[ produce-vreg _ , %peek emit ] each-index ]
[ [ length neg ] dip %height emit ]
2bi
] if ;
: load-inputs ( node -- )
[ in-d>> %data (load-inputs) ]
[ in-r>> %retain (load-inputs) ]
bi ;
: (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [
[ <reversed> ] dip
[ [ length ] dip %height emit ]
[ '[ value>vreg _ , %replace emit ] each-index ]
2bi
] if ;
: store-outputs ( node -- )
[ out-d>> %data (store-outputs) ]
[ out-r>> %retain (store-outputs) ]
bi ;
M: #push convert*
out-d>> [
[ produce-vreg ] [ value-literal ] bi
emit-literal
] each ;
M: #shuffle convert* drop ;
M: #>r convert* drop ;
M: #r> convert* drop ;
M: node convert
[ load-inputs ]
[ convert* ]
[ store-outputs ]
tri ;
: (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- )
[ load-inputs ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ;
: intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
[ store-outputs ]
bi ;
: intrinsic ( node quot -- )
[
init-intrinsic
[ intrinsic-inputs ]
swap
[ intrinsic-outputs ]
tri
] with-scope ; inline
USING: kernel.private math.private slots.private
optimizer.allot ;
: maybe-emit-fixnum-shift-fast ( node -- node )
dup dup in-d>> second node-literal? [
dup dup in-d>> second node-literal
'[ , emit-fixnum-shift-fast ] intrinsic
] [
dup param>> (emit-call)
] if ;
: emit-call ( node -- )
dup param>> {
{ \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] }
{ \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
{ \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
{ \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
{ \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
{ \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
{ \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
{ \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
{ \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
{ \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
{ \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
{ \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
{ \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
{ \ eq? [ [ emit-eq? ] intrinsic ] }
{ \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
{ \ float+ [ [ emit-float+ ] intrinsic ] }
{ \ float- [ [ emit-float- ] intrinsic ] }
{ \ float* [ [ emit-float* ] intrinsic ] }
{ \ float/f [ [ emit-float/f ] intrinsic ] }
{ \ float<= [ [ emit-float<= ] intrinsic ] }
{ \ float>= [ [ emit-float>= ] intrinsic ] }
{ \ float< [ [ emit-float< ] intrinsic ] }
{ \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] }
{ \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
{ \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
{ \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ]
} case drop ;
M: #call convert emit-call ;
M: #call-label convert
dup param>> loop-nesting get at [
basic-block get successors>> push
end-basic-block
basic-block off
drop
] [
(emit-call)
] if* ;
: integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
: float-conditional ( in1 in2 branch -- )
[ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
: emit-if ( #if -- )
in-d>> first value>vreg
next-vreg dup f emit-literal
cc/= integer-conditional ;
: convert-nested ( node -- last-bb )
[
<basic-block>
[ set-basic-block ] keep
[ convert-nodes end-basic-block ] dip
basic-block get
] with-scope
[ basic-block get successors>> push ] dip ;
: convert-if-children ( #if -- )
children>> [ convert-nested ] map sift
<basic-block>
[ '[ , _ successors>> push ] each ]
[ set-basic-block ]
bi ;
: phi-inputs ( #if -- vregs-seq )
children>>
[ last-node ] map
[ #values? ] filter
[ in-d>> [ value>vreg ] map ] map ;
: phi-outputs ( #if -- vregs )
successor>> out-d>> [ produce-vreg ] map ;
: emit-phi ( #if -- )
[ phi-outputs ] [ phi-inputs ] bi %phi emit ;
M: #if convert
{
[ load-inputs ]
[ emit-if ]
[ convert-if-children ]
[ emit-phi ]
} cleave ;
M: #values convert drop ;
M: #merge convert drop ;
M: #entry convert drop ;
M: #declare convert drop ;
M: #terminate convert drop ;
M: #label convert
#! Labels create a new procedure.
[ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
M: #loop convert
#! Loops become part of the current CFG.
begin-basic-block
[ param>> basic-block get 2array loop-nesting get push ]
[ node-child convert-nodes ]
bi
loop-nesting get pop* ;
M: #return convert
param>> loop-nesting get key? [
%epilog emit
%return emit
] unless ;

47
unfinished/compiler/cfg/cfg.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sequences sets fry ;
IN: compiler.cfg
! The id is a globally unique id used for fast hashcode* and
! equal? on basic blocks. The number is assigned by
! linearization.
TUPLE: basic-block < identity-tuple
id
number
instructions
successors
predecessors
stack-frame ;
SYMBOL: next-block-id
: <basic-block> ( -- basic-block )
basic-block new
next-block-id counter >>id
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors ;
M: basic-block hashcode* id>> nip ;
! Utilities
SYMBOL: visited-blocks
: visit-block ( basic-block quot -- )
over visited-blocks get 2dup key?
[ 2drop 2drop ] [ conjoin call ] if ; inline
: (each-block) ( basic-block quot -- )
'[
,
[ call ]
[ [ successors>> ] dip '[ , (each-block) ] each ]
2bi
] visit-block ; inline
: each-block ( basic-block quot -- )
H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
: copy-at ( from to assoc -- )
3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline

49
unfinished/compiler/cfg/elaboration/elaboration.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces math layouts sequences locals
combinators compiler.vops compiler.vops.builder
compiler.cfg.builder ;
IN: compiler.cfg.elaboration
! This pass must run before conversion to machine IR to ensure
! correctness.
GENERIC: elaborate* ( insn -- )
: slot-shift ( -- n )
tag-bits get cell log2 - ;
:: compute-slot-known-tag ( insn -- addr )
{ $1 $2 $3 $4 $5 } temps
init-intrinsic
$1 slot-shift %iconst emit ! load shift offset
$2 insn slot>> $1 %shr emit ! shift slot by shift offset
$3 insn tag>> %iconst emit ! load tag number
$4 $2 $3 %isub emit
$5 insn obj>> $4 %iadd emit ! compute slot offset
$5
;
:: compute-slot-any-tag ( insn -- addr )
{ $1 $2 $3 $4 } temps
init-intrinsic
$1 insn obj>> emit-untag ! untag object
$2 slot-shift %iconst emit ! load shift offset
$3 insn slot>> $2 %shr emit ! shift slot by shift offset
$4 $1 $3 %iadd emit ! compute slot offset
$4
;
: compute-slot ( insn -- addr )
dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
M: %%slot elaborate*
[ out>> ] [ compute-slot ] bi %load emit ;
M: %%set-slot elaborate*
[ in>> ] [ compute-slot ] bi %store emit ;
M: object elaborate* , ;
: elaboration ( insns -- insns )
[ [ elaborate* ] each ] { } make ;

9
unfinished/compiler/cfg/kill-nops/kill-nops.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel compiler.vops ;
IN: compiler.cfg.kill-nops
! Smallest compiler pass ever.
: kill-nops ( instructions -- instructions' )
[ nop? not ] filter ;

40
unfinished/compiler/cfg/live-ranges/live-ranges.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors math.order sequences
compiler.vops ;
IN: compiler.cfg.live-ranges
TUPLE: live-range from to ;
! Maps vregs to live ranges
SYMBOL: live-ranges
: def ( n vreg -- )
[ dup live-range boa ] dip live-ranges get set-at ;
: use ( n vreg -- )
live-ranges get at [ max ] change-to drop ;
GENERIC: compute-live-ranges* ( n insn -- )
M: nullary-op compute-live-ranges*
2drop ;
M: flushable-op compute-live-ranges*
out>> def ;
M: effect-op compute-live-ranges*
in>> use ;
M: unary-op compute-live-ranges*
[ out>> def ] [ in>> use ] 2bi ;
M: binary-op compute-live-ranges*
[ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
M: %store compute-live-ranges*
[ call-next-method ] [ addr>> use ] 2bi ;
: compute-live-ranges ( insns -- )
H{ } clone live-ranges set
[ swap compute-live-ranges* ] each-index ;

12
unfinished/compiler/cfg/predecessors/predecessors.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg kernel accessors sequences ;
IN: compiler.cfg.predecessors
! Pass to compute precedecessors.
: compute-predecessors ( procedure -- )
[
dup successors>>
[ predecessors>> push ] with each
] each-block ;

25
unfinished/compiler/cfg/simplifier/simplifier.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel
compiler.cfg
compiler.cfg.predecessors
compiler.cfg.stack
compiler.cfg.alias
compiler.cfg.write-barrier
compiler.cfg.elaboration
compiler.cfg.vn
compiler.cfg.vn.conditions
compiler.cfg.kill-nops ;
IN: compiler.cfg.simplifier
: simplify ( insns -- insns' )
normalize-height
alias-analysis
elaboration
value-numbering
eliminate-write-barrier
kill-nops ;
: simplify-cfg ( procedure -- procedure )
dup compute-predecessors
dup [ [ simplify ] change-instructions drop ] each-block ;

42
unfinished/compiler/cfg/stack/stack.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.vops ;
IN: compiler.cfg.stack
! Combine multiple stack height changes into one, done at the
! start of the basic block.
!
! Alias analysis and value numbering assume this optimization
! has been performed.
! Current data and retain stack height is stored in
! %data, %retain variables.
GENERIC: compute-heights ( insn -- )
M: %height compute-heights
[ n>> ] [ stack>> ] bi [ + ] change ;
M: object compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn )
M: %height normalize-height*
[ n>> ] [ stack>> ] bi [ swap - ] change nop ;
: (normalize-height) ( insn -- insn )
dup stack>> get '[ , + ] change-n ; inline
M: %peek normalize-height* (normalize-height) ;
M: %replace normalize-height* (normalize-height) ;
M: object normalize-height* ;
: normalize-height ( insns -- insns' )
0 %data set
0 %retain set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map ] with-scope ] bi
%data get dup zero? [ drop ] [ %data %height boa prefix ] if
%retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;

1
unfinished/compiler/cfg/summary.txt Normal file
View File

@ -0,0 +1 @@
Low-level optimizer operating on control flow graph SSA IR

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