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-25 23:08:13 -03:00
parent 86f831d33d 1f39689e76
commit 939cac65b3
20 changed files with 142 additions and 104 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
] %

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

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 ;

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>

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

@ -100,14 +100,7 @@ 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
@ -116,55 +109,58 @@ VARS: population-label cohesion-label alignment-label separation-label ;
<shelf>
{
[ "ESC - Pause" [ drop toggle-loop ] button* ]
1 >>fill
[ "1 - Randomize" [ drop randomize ] button* ]
"ESC - Pause" [ drop toggle-loop ] button* add-gadget
[ <pile> 1 over set-pack-fill
"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 ]
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
add-gadget
[ <pile> 1 over set-pack-fill
<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 ]
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
add-gadget
[ <pile> 1 over set-pack-fill
<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 ]
"s - -0.1" [ drop dec-alignment-weight ] button* add-gadget
add-gadget
[ <pile> 1 over set-pack-fill
<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 ]
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget
add-gadget
} [ call ] map [ add-gadget ] each
1 over set-pack-fill
@top grid-add*
@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
"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 ! "

21
extra/csv/csv.factor
View File

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

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 ;