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

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

db4
U-VICTORIA\Administrator 2008-07-26 10:44:57 -07:00
parent 79bf201a81 5a0c3e3d73
commit 9a0e149791
37 changed files with 479 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
core/bootstrap/stage1.factor
View File

@ -19,8 +19,13 @@ load-help? off
[
[
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
! using the host image's hashing algorithms. We don't
! use each-object here since the catch stack isn't yet
! set up.
begin-scan
[ hashtable? ] pusher [ (each-object) ] dip
end-scan
[ rehash ] each
boot
] %

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

@ -20,6 +20,10 @@ ERROR: not-a-tuple object ;
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
#! Delegation
all-slots rest-slice [ read-only>> ] all? ;
<PRIVATE
: tuple-layout ( class -- layout )

8
core/cpu/ppc/bootstrap.factor
View File

@ -14,13 +14,13 @@ big-endian on
: ds-reg 14 ;
: rs-reg 15 ;
: factor-area-size 4 bootstrap-cells ;
: factor-area-size ( -- n ) 4 bootstrap-cells ;
: stack-frame
: stack-frame ( -- n )
factor-area-size c-area-size + 4 bootstrap-cells align ;
: next-save stack-frame bootstrap-cell - ;
: xt-save stack-frame 2 bootstrap-cells - ;
: next-save ( -- n ) stack-frame bootstrap-cell - ;
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[
0 6 LOAD32

4
core/cpu/ppc/linux/bootstrap.factor
View File

@ -3,8 +3,8 @@
USING: parser layouts system kernel ;
IN: bootstrap.ppc
: c-area-size 10 bootstrap-cells ;
: lr-save bootstrap-cell ;
: c-area-size ( -- n ) 10 bootstrap-cells ;
: lr-save ( -- n ) bootstrap-cell ;
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
call

4
core/cpu/ppc/macosx/bootstrap.factor
View File

@ -3,8 +3,8 @@
USING: parser layouts system kernel ;
IN: bootstrap.ppc
: c-area-size 14 bootstrap-cells ;
: lr-save 2 bootstrap-cells ;
: c-area-size ( -- n ) 14 bootstrap-cells ;
: lr-save ( -- n ) 2 bootstrap-cells ;
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
call

8
core/kernel/kernel.factor
View File

@ -165,13 +165,9 @@ GENERIC: boa ( ... class -- tuple )
compose compose ; inline
! Booleans
: not ( obj -- ? )
#! Not inline because its special-cased by compiler.
f eq? ;
: not ( obj -- ? ) f t ? ; inline
: and ( obj1 obj2 -- ? )
#! Not inline because its special-cased by compiler.
over ? ;
: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) t f ? ; inline

3
core/math/intervals/intervals.factor
View File

@ -135,6 +135,9 @@ TUPLE: interval { from read-only } { to read-only } ;
]
} cond ;
: intervals-intersect? ( i1 i2 -- ? )
interval-intersect empty-interval eq? not ;
: interval-union ( i1 i2 -- i3 )
{
{ [ dup empty-interval eq? ] [ drop ] }

3
core/memory/memory-tests.factor
View File

@ -23,3 +23,6 @@ TUPLE: testing x y z ;
] when*
] each
] unit-test
! Erg's bug
2 [ [ [ 3 throw ] instances ] must-fail ] times

10
core/memory/memory.factor
View File

@ -1,17 +1,15 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences arrays system ;
IN: memory
USING: arrays kernel sequences vectors system hashtables
kernel.private sbufs growable assocs namespaces quotations
math strings combinators ;
: (each-object) ( quot: ( obj -- ) -- )
[ next-object dup ] swap [ drop ] while ; inline
: each-object ( quot -- )
begin-scan (each-object) end-scan ; inline
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
: instances ( quot -- seq )
pusher >r each-object r> >array ; inline
pusher [ each-object ] dip >array ; inline
: save ( -- ) image save-image ;

26
core/slots/slots.factor
View File

@ -8,13 +8,17 @@ IN: slots
TUPLE: slot-spec name offset class initial read-only reader writer ;
PREDICATE: reader < word "reader" word-prop ;
PREDICATE: writer < word "writer" word-prop ;
: <slot-spec> ( -- slot-spec )
slot-spec new
object bootstrap-word >>class ;
: define-typecheck ( class generic quot props -- )
[ dup define-simple-generic create-method ] 2dip
[ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ]
[ [ props>> ] [ drop ] [ ] tri* update ]
[ drop define ]
3bi ;
@ -31,17 +35,23 @@ TUPLE: slot-spec name offset class initial read-only reader writer ;
] [ ] make ;
: reader-word ( name -- word )
">>" append (( object -- value )) create-accessor ;
">>" append (( object -- value )) create-accessor
dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- seq )
read-only>> { "foldable" "flushable" } { "flushable" } ? ;
: reader-props ( slot-spec -- assoc )
[
[ "reading" set ]
[ read-only>> [ t "foldable" set ] when ] bi
t "flushable" set
] H{ } make-assoc ;
: define-reader ( class slot-spec -- )
[ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
define-typecheck ;
: writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
"(>>" swap ")" 3append (( value object -- )) create-accessor
dup t "writer" set-word-prop ;
ERROR: bad-slot-value value class ;
@ -77,8 +87,12 @@ ERROR: bad-slot-value value class ;
} cond
] [ ] make ;
: writer-props ( slot-spec -- assoc )
[ "writing" set ] H{ } make-assoc ;
: define-writer ( class slot-spec -- )
[ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ;
[ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
define-typecheck ;
: setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ;

1
core/words/words.factor
View File

@ -187,6 +187,7 @@ M: word reset-word
"parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"reader" "writer"
"constructing"
"declared-effect" "constructor-quot" "delimiter"
} reset-props ;

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

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

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

@ -100,72 +100,68 @@ VARS: population-label cohesion-label alignment-label separation-label ;
: boids-window* ( -- )
init-variables init-world-size init-boids loop on
C[ display ] <slate> >slate
t slate> set-gadget-clipped?
{ 600 400 } slate> set-slate-pdim
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
"" <label> reverse-video-theme >population-label update-population-label
"" <label> reverse-video-theme >cohesion-label update-cohesion-label
"" <label> reverse-video-theme >alignment-label update-alignment-label
"" <label> reverse-video-theme >separation-label update-separation-label
<frame>
<shelf>
<shelf>
{
[ "ESC - Pause" [ drop toggle-loop ] button* ]
1 >>fill
[ "1 - Randomize" [ drop randomize ] button* ]
"ESC - Pause" [ drop toggle-loop ] button* add-gadget
"1 - Randomize" [ drop randomize ] button* add-gadget
<pile> 1 over set-pack-fill
population-label> add-gadget
"3 - Add 10" [ drop add-10-boids ] button* add-gadget
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
add-gadget
<pile> 1 over set-pack-fill
cohesion-label> add-gadget
"q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
add-gadget
[ <pile> 1 over set-pack-fill
population-label> add-gadget
"3 - Add 10" [ drop add-10-boids ] button* add-gadget
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
<pile> 1 over set-pack-fill
alignment-label> add-gadget
"w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
"s - -0.1" [ drop dec-alignment-weight ] button* add-gadget
add-gadget
[ <pile> 1 over set-pack-fill
cohesion-label> add-gadget
"q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
<pile> 1 over set-pack-fill
separation-label> add-gadget
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget
add-gadget
[ <pile> 1 over set-pack-fill
alignment-label> add-gadget
"w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
"s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
@top grid-add
[ <pile> 1 over set-pack-fill
separation-label> add-gadget
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
} [ call ] map [ add-gadget ] each
1 over set-pack-fill
@top grid-add*
slate> @center grid-add*
C[ display ] <slate>
dup >slate
t >>clipped?
{ 600 400 } >>pdim
C[ [ run ] in-thread ] >>graft
C[ loop off ] >>ungraft
@center grid-add
<handler>
H{ } clone
T{ key-down f f "1" } C[ drop randomize ] is
T{ key-down f f "2" } C[ drop sub-10-boids ] is
T{ key-down f f "3" } C[ drop add-10-boids ] is
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
T{ key-down f f "e" } C[ drop inc-separation-weight ] is
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
>>table
H{ } clone
T{ key-down f f "1" } C[ drop randomize ] is
T{ key-down f f "2" } C[ drop sub-10-boids ] is
T{ key-down f f "3" } C[ drop add-10-boids ] is
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
T{ key-down f f "e" } C[ drop inc-separation-weight ] is
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
>>table
"Boids" open-window ;

6
extra/color-picker/color-picker.factor
View File

@ -37,11 +37,11 @@ M: color-preview model-changed
<frame>
<color-sliders>
swap dup
[ @top grid-add* ]
[ <color-model> <color-preview> @center grid-add* ]
[ @top grid-add ]
[ <color-model> <color-preview> @center grid-add ]
[
[ [ truncate number>string ] map " " join ] <filter> <label-control>
@bottom grid-add*
@bottom grid-add
]
tri* ;

11
extra/csv/csv-docs.factor
View File

@ -2,20 +2,27 @@ USING: help.syntax help.markup kernel prettyprint sequences ;
IN: csv
HELP: csv
{ $values { "stream" "a stream" }
{ $values { "stream" "an input stream" }
{ "rows" "an array of arrays of fields" } }
{ $description "parses a csv stream into an array of row arrays"
} ;
HELP: csv-row
{ $values { "stream" "a stream" }
{ $values { "stream" "an input stream" }
{ "row" "an array of fields" } }
{ $description "parses a row from a csv stream"
} ;
HELP: write-csv
{ $values { "rows" "an sequence of sequences of strings" }
{ "stream" "an output stream" } }
{ $description "writes csv to the output stream, escaping where necessary"
} ;
HELP: with-delimiter
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
{ "quot" "a quotation" } }
{ $description "Sets the field delimiter for csv or csv-row words "
} ;

10
extra/csv/csv-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.streams.string csv tools.test shuffle ;
IN: csv.tests
USING: io.streams.string csv tools.test shuffle kernel strings ;
! I like to name my unit tests
: named-unit-test ( name output input -- )
@ -68,3 +68,11 @@ IN: csv.tests
[ { { "foo" "bar" }
{ "1" "2" } } ]
[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test
"can write csv too!"
[ "foo1,bar1\nfoo2,bar2\n" ]
[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> tuck write-csv >string ] named-unit-test
"escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "

25
extra/csv/csv.factor
View File

@ -10,7 +10,7 @@ IN: csv
DEFER: quoted-field
VAR: delimiter
! trims whitespace from either end of string
: trim-whitespace ( str -- str )
[ blank? ] trim ; inline
@ -57,7 +57,7 @@ VAR: delimiter
[ (csv) ] when ;
: init-vars ( -- )
delimiter> [ CHAR: , >delimiter ] unless ; inline
delimiter> [ CHAR: , >delimiter ] unless ; inline
: csv-row ( stream -- row )
init-vars
@ -69,3 +69,24 @@ VAR: delimiter
: with-delimiter ( char quot -- )
delimiter swap with-variable ; inline
: needs-escaping? ( cell -- ? )
[ "\n\"" delimiter> suffix member? ] contains? ; inline ! "
: escape-quotes ( cell -- cell' )
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
: enclose-in-quotes ( cell -- cell' )
CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
: escape-if-required ( cell -- cell' )
dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
: write-row ( row -- )
[ delimiter> write1 ] [ escape-if-required write ] interleave nl ; inline
: write-csv ( rows outstream -- )
init-vars
[ [ write-row ] each ] with-output-stream ;

4
extra/io/launcher/launcher.factor
View File

@ -183,7 +183,7 @@ M: object run-pipeline-element
[ |dispose drop ]
[
swap >process
[ swap in>> or ] change-stdout
[ swap in>> or ] change-stdin
run-detached
]
[ in>> dispose ]
@ -200,8 +200,8 @@ M: object run-pipeline-element
[ [ |dispose drop ] bi@ ]
[
rot >process
[ swap out>> or ] change-stdout
[ swap in>> or ] change-stdin
[ swap out>> or ] change-stdout
run-detached
]
[ [ out>> dispose ] [ in>> dispose ] bi* ]

13
extra/io/unix/launcher/launcher-tests.factor
View File

@ -1,7 +1,8 @@
IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
continuations math io.encodings.binary io.encodings.ascii
accessors kernel sequences io.encodings.utf8 destructors ;
accessors kernel sequences io.encodings.utf8 destructors
io.streams.duplex ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors
@ -111,4 +112,12 @@ accessors kernel sequences io.encodings.utf8 destructors ;
"append-test" temp-file utf8 file-contents
] unit-test
[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test
[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
[ "Hello world.\n" ] [
"cat" utf8 <process-stream> [
"Hello world.\n" write
output-stream get dispose
input-stream get contents
] with-stream
] unit-test

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

@ -155,12 +155,12 @@ irc-editor "general" f {
: <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* ;
<irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @bottom grid-add ;
: <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab>
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
<irc-list> [ <scroller> @right grid-add ] dip >>listmodel
[ update-participants ] keep ;
: <irc-server-tab> ( listener client -- irc-tab )

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

@ -7,7 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
{ $subsection frame }
"Creating empty frames:"
{ $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* } ":"
"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 }
@ -20,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* } "." } 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 ;
@ -35,7 +35,7 @@ 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 } }

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" } ;

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

@ -20,12 +20,12 @@ grid
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add* ( grid child i j -- grid )
: 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-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
: pref-dim-grid ( grid -- dims )
grid>> [ [ pref-dim ] map ] map ;

8
extra/ui/gadgets/labelled/labelled.factor
View File

@ -39,8 +39,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
: <title-bar> ( title quot -- gadget )
<frame>
swap dup [ <close-box> @left grid-add* ] [ drop ] if
swap <title-label> @center grid-add* ;
swap dup [ <close-box> @left grid-add ] [ drop ] if
swap <title-label> @center grid-add ;
TUPLE: closable-gadget < frame content ;
@ -49,8 +49,8 @@ TUPLE: closable-gadget < frame content ;
: <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new-frame
-rot <title-bar> @top grid-add*
-rot <title-bar> @top grid-add
swap >>content
dup content>> @center grid-add* ;
dup content>> @center grid-add ;
M: closable-gadget focusable-child* closable-gadget-content ;

6
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -38,11 +38,11 @@ scroller H{
<scroller-model> >>model
faint-boundary
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add*
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
swap over model>> <viewport> >>viewport
dup viewport>> @center grid-add* ;
dup viewport>> @center grid-add ;
: <scroller> ( gadget -- scroller ) scroller new-scroller ;

10
extra/ui/gadgets/sliders/sliders.factor
View File

@ -130,7 +130,7 @@ M: elevator layout*
tuck <elevator> >>elevator
swap <thumb> >>thumb
dup elevator>> over thumb>> add-gadget
@center grid-add* ;
@center grid-add ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
@ -145,15 +145,15 @@ M: elevator layout*
: <x-slider> ( range -- slider )
{ 1 0 } <slider>
<left-button> @left grid-add*
<left-button> @left grid-add
{ 0 1 } elevator,
<right-button> @right grid-add* ;
<right-button> @right grid-add ;
: <y-slider> ( range -- slider )
{ 0 1 } <slider>
<up-button> @top grid-add*
<up-button> @top grid-add
{ 1 0 } elevator,
<down-button> @bottom grid-add* ;
<down-button> @bottom grid-add ;
M: slider pref-dim*
dup call-next-method

8
extra/ui/gadgets/tabs/tabs.factor
View File

@ -15,8 +15,8 @@ DEFER: (del-page)
:: add-toggle ( model n name toggler -- )
<frame>
n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
@right grid-add*
n model name <toggle-button> @center grid-add*
@right grid-add
n model name <toggle-button> @center grid-add
toggler swap add-gadget drop ;
: redo-toggler ( tabbed -- )
@ -52,10 +52,10 @@ DEFER: (del-page)
tabbed new-frame
0 <model> >>model
<pile> 1 >>fill >>toggler
dup toggler>> @left grid-add*
dup toggler>> @left grid-add
swap
[ keys >vector >>names ]
[ values over model>> <book> >>content dup content>> @center grid-add* ]
[ values over model>> <book> >>content dup content>> @center grid-add ]
bi
dup redo-toggler ;

39
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra kernel accessors math
math.intervals namespaces sequences words combinators arrays
compiler.tree.copy-equiv ;
USING: assocs classes classes.algebra kernel
accessors math math.intervals namespaces sequences words
combinators arrays compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.info
SYMBOL: +interval+
@ -17,13 +17,15 @@ M: complex eql? over complex? [ = ] [ 2drop f ] if ;
! Value info represents a set of objects. Don't mutate value infos
! you receive, always construct new ones. We don't declare the
! slots read-only to allow cloning followed by writing.
! slots read-only to allow cloning followed by writing, and to
! simplify constructors.
TUPLE: value-info
{ class initial: null }
{ interval initial: empty-interval }
class
interval
literal
literal?
length ;
length
slots ;
: class-interval ( class -- interval )
dup real class<=
@ -57,6 +59,7 @@ length ;
null >>class
empty-interval >>interval
] [
[ [-inf,inf] or ] change-interval
dup class>> integer class<= [ [ integral-closure ] change-interval ] when
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
@ -88,10 +91,15 @@ length ;
: <sequence-info> ( value -- info )
<value-info>
object >>class
[-inf,inf] >>interval
swap value-info >>length
init-value-info ; foldable
: <tuple-info> ( slots class -- info )
<value-info>
swap >>class
swap >>slots
init-value-info ;
: >literal< ( info -- literal literal? )
[ literal>> ] [ literal?>> ] bi ;
@ -112,6 +120,11 @@ DEFER: value-info-intersect
[ value-info-intersect ]
} cond ;
: intersect-slots ( info1 info2 -- slots )
[ slots>> ] bi@
2dup [ length ] bi@ =
[ [ value-info-intersect ] 2map ] [ 2drop f ] if ;
: (value-info-intersect) ( info1 info2 -- info )
[ <value-info> ] 2dip
{
@ -119,6 +132,7 @@ DEFER: value-info-intersect
[ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
[ intersect-slots >>slots ]
} 2cleave
init-value-info ;
@ -143,6 +157,11 @@ DEFER: value-info-union
[ value-info-union ]
} cond ;
: union-slots ( info1 info2 -- slots )
[ slots>> ] bi@
2dup [ length ] bi@ =
[ [ value-info-union ] 2map ] [ 2drop f ] if ;
: (value-info-union) ( info1 info2 -- info )
[ <value-info> ] 2dip
{
@ -150,6 +169,7 @@ DEFER: value-info-union
[ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
[ union-slots >>slots ]
} 2cleave
init-value-info ;
@ -167,7 +187,8 @@ DEFER: value-info-union
SYMBOL: value-infos
: value-info ( value -- info )
resolve-copy value-infos get at T{ value-info } or ;
resolve-copy value-infos get at
T{ value-info f null empty-interval } or ;
: set-value-info ( info value -- )
resolve-copy value-infos get set-at ;

21
unfinished/compiler/tree/propagation/known-words/known-words.factor
View File

@ -185,6 +185,27 @@ generic-comparison-ops [
'[ , fold-comparison ] +outputs+ set-word-prop
] each
: maybe-or-never ( ? -- info )
[ object <class-info> ] [ \ f <class-info> ] if ;
: info-intervals-intersect? ( info1 info2 -- ? )
[ interval>> ] bi@ intervals-intersect? ;
{ number= bignum= float= } [
[
info-intervals-intersect? maybe-or-never
] +outputs+ set-word-prop
] each
: info-classes-intersect? ( info1 info2 -- ? )
[ class>> ] bi@ classes-intersect? ;
\ eq? [
[ info-intervals-intersect? ]
[ info-classes-intersect? ]
bi or maybe-or-never
] +outputs+ set-word-prop
{
{ >fixnum fixnum }
{ >bignum bignum }

95
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -3,7 +3,8 @@ compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
byte-arrays ;
byte-arrays classes.algebra math.functions math.private
strings ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@ -234,8 +235,100 @@ IN: compiler.tree.propagation.tests
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
[ V{ string string } ] [
[
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
] final-classes
] unit-test
! Array length propagation
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
! Slot propagation
TUPLE: prop-test-tuple { x integer } ;
[ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ;
UNION: prop-test-union prop-test-tuple another-prop-test-tuple ;
[ t ] [
[ { prop-test-union } declare x>> ] final-classes first
rational class=
] unit-test
TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
[ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
unit-test
TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
[ "hey" immutable-prop-test-tuple boa ] final-literals
] unit-test
[ V{ { 1 2 } } ] [
[ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
] unit-test
[ V{ array } ] [
[ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
] unit-test
[ V{ complex } ] [
[ <complex> ] final-classes
] unit-test
[ V{ complex } ] [
[ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
] unit-test
[ V{ float float } ] [
[
{ float float } declare
dup 0.0 <= [ "Oops" throw ] when rect>
[ real>> ] [ imaginary>> ] bi
] final-classes
] unit-test
[ V{ complex } ] [
[
{ float float object } declare
[ "Oops" throw ] [ <complex> ] if
] final-classes
] unit-test
[ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
[ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
[ V{ POSTPONE: f } ] [
[ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
] unit-test
! Don't fold this
TUPLE: mutable-tuple-test { x sequence } ;
[ V{ sequence } ] [
[ "hey" mutable-tuple-test boa x>> ] final-classes
] unit-test
[ V{ sequence } ] [
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test
! Mixed mutable and immutable slots
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
[ V{ integer array } ] [
[
3 { 2 1 } mixed-mutable-immutable boa
[ x>> ] [ y>> ] bi
] final-classes
] unit-test

49
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -2,11 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators classes
continuations arrays byte-arrays strings
classes.tuple classes.tuple.private continuations arrays
byte-arrays strings math math.private slots
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.slots
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.simple
@ -53,6 +55,17 @@ M: #declare propagate-before
[ word>> +outputs+ word-prop ]
bi with-datastack ;
: foldable-word? ( #call -- ? )
dup word>> "foldable" word-prop [
drop t
] [
dup word>> \ <tuple-boa> eq? [
in-d>> peek value-info literal>> immutable-tuple-class?
] [
drop f
] if
] if ;
: foldable-call? ( #call -- ? )
dup word>> "foldable" word-prop [
in-d>> [ value-info literal?>> ] all?
@ -73,27 +86,11 @@ M: #declare propagate-before
out-d>> length object <class-info> <repetition>
] ?if ;
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( node -- ? )
word>> { <array> <byte-array> <string> } memq? ;
: propagate-sequence-constructor ( node -- infos )
[ default-output-value-infos first ]
[ in-d>> first <sequence-info> ]
bi value-info-intersect 1array ;
: length-accessor? ( node -- ? )
dup in-d>> first fixed-length-sequence value-is?
[ word>> \ length eq? ] [ drop f ] if ;
: propagate-length ( node -- infos )
in-d>> first value-info length>>
[ array-capacity <class-info> ] unless* 1array ;
: output-value-infos ( node -- infos )
{
{ [ dup foldable-call? ] [ fold-call ] }
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
{ [ dup word>> reader? ] [ reader-word-outputs ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup length-accessor? ] [ propagate-length ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
@ -107,12 +104,16 @@ M: #call propagate-before
M: node propagate-before drop ;
: propagate-input-classes ( node -- )
[ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi
refine-value-infos ;
M: #call propagate-after
dup word>> "input-classes" word-prop dup [
class-infos swap in-d>> refine-value-infos
] [
2drop
] if ;
{
{ [ dup reader? ] [ reader-word-inputs ] }
{ [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
[ drop ]
} cond ;
M: node propagate-after drop ;

111
unfinished/compiler/tree/propagation/slots/slots.factor Normal file
View File

@ -0,0 +1,111 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry assocs arrays byte-arrays strings accessors sequences
kernel slots classes.algebra classes.tuple classes.tuple.private
words math math.private combinators sequences.private namespaces
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.slots
! Propagation of immutable slots and array lengths
! Revisit this code when delegation is removed and when complex
! numbers become tuples.
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( node -- ? )
word>> { <array> <byte-array> <string> } memq? ;
: constructor-output-class ( word -- class )
{
{ <array> array }
{ <byte-array> byte-array }
{ <string> string }
} at ;
: propagate-sequence-constructor ( node -- infos )
[ word>> constructor-output-class <class-info> ]
[ in-d>> first <sequence-info> ]
bi value-info-intersect 1array ;
: length-accessor? ( node -- ? )
dup in-d>> first fixed-length-sequence value-is?
[ word>> \ length eq? ] [ drop f ] if ;
: propagate-length ( node -- infos )
in-d>> first value-info length>>
[ array-capacity <class-info> ] unless* 1array ;
: tuple-constructor? ( node -- ? )
word>> { <tuple-boa> <complex> } memq? ;
: propagate-<tuple-boa> ( node -- info )
#! Delegation
in-d>> [ value-info ] map unclip-last
literal>> class>> dup immutable-tuple-class? [
over [ literal?>> ] all?
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
[ <tuple-info> ]
if
] [ nip <class-info> ] if ;
: propagate-<complex> ( node -- info )
in-d>> [ value-info ] map complex <tuple-info> ;
: propagate-tuple-constructor ( node -- infos )
dup word>> {
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
{ \ <complex> [ propagate-<complex> ] }
} case 1array ;
: relevant-methods ( node -- methods )
[ word>> "methods" word-prop ]
[ in-d>> first value-info class>> ] bi
'[ drop , classes-intersect? ] assoc-filter ;
: relevant-slots ( node -- slots )
relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
: no-reader-methods ( input slots -- info )
2drop null <class-info> ;
: same-offset ( slots -- slot/f )
dup [ dup [ read-only>> ] when ] all? [
[ offset>> ] map dup all-equal? [ first ] [ drop f ] if
] [ drop f ] if ;
: (reader-word-outputs) ( reader -- info )
null
[ [ class>> ] [ object ] if* class-or ] reduce
<class-info> ;
: value-info-slot ( slot info -- info' )
#! Delegation.
[ class>> complex class<= 1 3 ? - ] keep
dup literal?>> [
literal>> {
{ [ dup tuple? ] [
tuple-slots 1 tail-slice nth <literal-info>
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond
] [ slots>> ?nth ] if ;
: reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi
over empty? [ no-reader-methods ] [
over same-offset dup
[ swap value-info value-info-slot ] [ 2drop f ] if
[ ] [ (reader-word-outputs) ] ?if
] if 1array ;
: reader-word-inputs ( node -- )
[ in-d>> first ] [
relevant-slots keys
object [ class>> [ class-and ] when* ] reduce
<class-info>
] bi
refine-value-info ;

6
unfinished/stack-checker/branches/branches.factor
View File

@ -7,7 +7,7 @@ stack-checker.backend stack-checker.errors stack-checker.visitor
IN: stack-checker.branches
: balanced? ( seq -- ? )
[ first2 length - ] map all-equal? ;
[ second ] filter [ first2 length - ] map all-equal? ;
: phi-inputs ( seq -- newseq )
dup empty? [
@ -16,7 +16,7 @@ IN: stack-checker.branches
] unless ;
: unify-values ( values -- phi-out )
dup [ known ] map dup all-eq?
dup sift [ known ] map dup all-eq?
[ nip first make-known ] [ 2drop <value> ] if ;
: phi-outputs ( phi-in -- stack )
@ -25,7 +25,7 @@ IN: stack-checker.branches
SYMBOL: quotations
: unify-branches ( ins stacks -- in phi-in phi-out )
zip [ second ] filter dup empty? [ drop 0 { } { } ] [
zip dup empty? [ drop 0 { } { } ] [
dup balanced?
[ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ]
[ quotations get unbalanced-branches-error ]

7
vm/errors.c
View File

@ -1,5 +1,12 @@
#include "master.h"
void out_of_memory(void)
{
fprintf(stderr,"Out of memory\n\n");
dump_generations();
exit(1);
}
void fatal_error(char* msg, CELL tagged)
{
fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged);

1
vm/errors.h
View File

@ -19,6 +19,7 @@ typedef enum
ERROR_MEMORY,
} F_ERRORTYPE;
void out_of_memory(void);
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
DECLARE_PRIMITIVE(die);

2
vm/os-unix.c
View File

@ -174,7 +174,7 @@ F_SEGMENT *alloc_segment(CELL size)
MAP_ANON | MAP_PRIVATE,-1,0);
if(array == (char*)-1)
fatal_error("Out of memory in alloc_segment",0);
out_of_memory();
if(mprotect(array,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect low guard page",(CELL)array);

2
vm/os-windows.c
View File

@ -171,7 +171,7 @@ F_SEGMENT *alloc_segment(CELL size)
if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
fatal_error("Out of memory in alloc_segment",0);
out_of_memory();
if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (CELL)mem);