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

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

db4
Slava Pestov 2008-08-31 01:34:12 -05:00
parent f5fbd94a4c 278d2457a7
commit b93baaa315
31 changed files with 138 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/concurrency/locks/locks-tests.factor
View File

@ -174,7 +174,7 @@ threads sequences calendar accessors ;
] ; ] ;
[ lock-timeout-test ] [ [ lock-timeout-test ] [
linked-error-thread name>> "Lock timeout-er" = thread>> name>> "Lock timeout-er" =
] must-fail-with ] must-fail-with
:: read/write-test ( -- ) :: read/write-test ( -- )

45
basis/concurrency/locks/locks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math USING: deques dlists kernel threads continuations math
concurrency.conditions ; concurrency.conditions combinators.short-circuit accessors ;
IN: concurrency.locks IN: concurrency.locks
! Simple critical sections ! Simple critical sections
@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ;
<PRIVATE <PRIVATE
: acquire-lock ( lock timeout -- ) : acquire-lock ( lock timeout -- )
over lock-owner over owner>>
[ 2dup >r lock-threads r> "lock" wait ] when drop [ 2dup >r threads>> r> "lock" wait ] when drop
self swap set-lock-owner ; self >>owner drop ;
: release-lock ( lock -- ) : release-lock ( lock -- )
f over set-lock-owner f >>owner
lock-threads notify-1 ; threads>> notify-1 ;
: do-lock ( lock timeout quot acquire release -- ) : do-lock ( lock timeout quot acquire release -- )
>r >r pick rot r> call ! use up timeout acquire >r >r pick rot r> call ! use up timeout acquire
@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ;
PRIVATE> PRIVATE>
: with-lock-timeout ( lock timeout quot -- ) : with-lock-timeout ( lock timeout quot -- )
pick lock-reentrant? [ pick reentrant?>> [
pick lock-owner self eq? [ pick owner>> self eq? [
2nip call 2nip call
] [ ] [
(with-lock) (with-lock)
@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ;
<PRIVATE <PRIVATE
: add-reader ( lock -- ) : add-reader ( lock -- )
dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; [ 1+ ] change-reader# drop ;
: acquire-read-lock ( lock timeout -- ) : acquire-read-lock ( lock timeout -- )
over rw-lock-writer over writer>>
[ 2dup >r rw-lock-readers r> "read lock" wait ] when drop [ 2dup >r readers>> r> "read lock" wait ] when drop
add-reader ; add-reader ;
: notify-writer ( lock -- ) : notify-writer ( lock -- )
rw-lock-writers notify-1 ; writers>> notify-1 ;
: remove-reader ( lock -- ) : remove-reader ( lock -- )
dup rw-lock-reader# 1- swap set-rw-lock-reader# ; [ 1- ] change-reader# drop ;
: release-read-lock ( lock -- ) : release-read-lock ( lock -- )
dup remove-reader dup remove-reader
dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; dup reader#>> zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- ) : acquire-write-lock ( lock timeout -- )
over rw-lock-writer pick rw-lock-reader# 0 > or over writer>> pick reader#>> 0 > or
[ 2dup >r rw-lock-writers r> "write lock" wait ] when drop [ 2dup >r writers>> r> "write lock" wait ] when drop
self swap set-rw-lock-writer ; self >>writer drop ;
: release-write-lock ( lock -- ) : release-write-lock ( lock -- )
f over set-rw-lock-writer f >>writer
dup rw-lock-readers deque-empty? dup readers>> deque-empty?
[ notify-writer ] [ rw-lock-readers notify-all ] if ; [ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? ) : reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read #! If we already have a write lock, then we can grab a read
#! lock too. #! lock too.
rw-lock-writer self eq? ; writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? ) : reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is #! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit #! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy. #! a further write -> read -> write re-entrancy.
dup rw-lock-writer self eq? { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
swap rw-lock-reader# zero? and ;
PRIVATE> PRIVATE>

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

@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ; concurrency.count-downs accessors ;
IN: concurrency.messaging.tests IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data clear-deque ] unit-test [ ] [ my-mailbox data>> clear-deque ] unit-test
[ "received" ] [ [ "received" ] [
[ [

11
basis/multiline/multiline.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007 Daniel Ehrenberg ! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces parser lexer kernel sequences words quotations math ; USING: namespaces parser lexer kernel sequences words quotations math
accessors ;
IN: multiline IN: multiline
: next-line-text ( -- str ) : next-line-text ( -- str )
lexer get dup next-line lexer-line-text ; lexer get dup next-line text>> ;
: (parse-here) ( -- ) : (parse-here) ( -- )
next-line-text [ next-line-text [
@ -22,7 +23,7 @@ IN: multiline
parse-here 1quotation define-inline ; parsing parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index ) : (parse-multiline-string) ( start-index end-text -- end-index )
lexer get lexer-line-text [ lexer get text>> [
2dup start 2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [ [ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0 rot tail % "\n" % 0
@ -32,8 +33,8 @@ IN: multiline
: parse-multiline-string ( end-text -- str ) : parse-multiline-string ( end-text -- str )
[ [
lexer get lexer-column swap (parse-multiline-string) lexer get column>> swap (parse-multiline-string)
lexer get set-lexer-column lexer get (>>column)
] "" make rest but-last ; ] "" make rest but-last ;
: <" : <"

6
basis/prettyprint/prettyprint-tests.factor
View File

@ -195,11 +195,11 @@ DEFER: parse-error-file
: string-layout : string-layout
{ {
"USING: debugger io kernel lexer ;" "USING: accessors debugger io kernel ;"
"IN: prettyprint.tests" "IN: prettyprint.tests"
": string-layout-test ( error -- )" ": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write" " \"Expected \" write dup want>> expected>string write"
" \" but got \" write unexpected-got expected>string print ;" " \" but got \" write got>> expected>string print ;"
} ; } ;

4
basis/prettyprint/sections/sections.factor
View File

@ -115,10 +115,10 @@ M: object short-section? section-fits? ;
: pprint-section ( section -- ) : pprint-section ( section -- )
dup short-section? [ dup short-section? [
dup section-style [ short-section ] with-style dup style>> [ short-section ] with-style
] [ ] [
[ <long-section ] [ <long-section ]
[ dup section-style [ long-section ] with-style ] [ dup style>> [ long-section ] with-style ]
[ long-section> ] [ long-section> ]
tri tri
] if ; ] if ;

2
basis/ui/gadgets/grid-lines/grid-lines-docs.factor
View File

@ -3,4 +3,4 @@ ui.render ;
IN: ui.gadgets.grid-lines IN: ui.gadgets.grid-lines
HELP: grid-lines HELP: grid-lines
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ; { $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;

6
basis/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces opengl opengl.gl sequences USING: kernel accessors math namespaces opengl opengl.gl sequences
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ; math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
IN: ui.gadgets.grid-lines IN: ui.gadgets.grid-lines
@ -10,7 +10,7 @@ C: <grid-lines> grid-lines
SYMBOL: grid-dim SYMBOL: grid-dim
: half-gap grid get grid-gap [ 2/ ] map ; inline : half-gap grid get gap>> [ 2/ ] map ; inline
: grid-line-from/to ( orientation point -- from to ) : grid-line-from/to ( orientation point -- from to )
half-gap v- half-gap v-
@ -25,7 +25,7 @@ SYMBOL: grid-dim
M: grid-lines draw-boundary M: grid-lines draw-boundary
origin get [ origin get [
-0.5 -0.5 0.0 glTranslated -0.5 -0.5 0.0 glTranslated
grid-lines-color set-color [ color>> set-color [
dup grid set dup grid set
dup rect-dim half-gap v- grid-dim set dup rect-dim half-gap v- grid-dim set
compute-grid compute-grid

4
basis/ui/gadgets/grids/grids-docs.factor
View File

@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
HELP: grid HELP: grid
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height." { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
$nl $nl
"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively." "The " { $snippet "gap" } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
$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 } "." "The " { $snippet "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 $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 $nl

6
basis/ui/gadgets/grids/grids.factor
View File

@ -48,7 +48,7 @@ grid
dupd add-gaps dim-sum v+ ; dupd add-gaps dim-sum v+ ;
M: grid pref-dim* M: grid pref-dim*
dup grid-gap swap compute-grid >r over r> dup gap>> swap compute-grid >r over r>
gap-sum >r gap-sum r> (pair-up) ; gap-sum >r gap-sum r> (pair-up) ;
: do-grid ( dims grid quot -- ) : do-grid ( dims grid quot -- )
@ -57,7 +57,7 @@ M: grid pref-dim*
drop ; inline drop ; inline
: grid-positions ( grid dims -- locs ) : grid-positions ( grid dims -- locs )
>r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ; >r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
: position-grid ( grid horiz vert -- ) : position-grid ( grid horiz vert -- )
pick >r pick >r
@ -65,7 +65,7 @@ M: grid pref-dim*
pair-up r> [ set-rect-loc ] do-grid ; pair-up r> [ set-rect-loc ] do-grid ;
: resize-grid ( grid horiz vert -- ) : resize-grid ( grid horiz vert -- )
pick grid-fill? [ pick fill?>> [
pair-up swap [ (>>dim) ] do-grid pair-up swap [ (>>dim) ] do-grid
] [ ] [
2drop grid>> [ [ prefer ] each ] each 2drop grid>> [ [ prefer ] each ] each

12
basis/ui/gadgets/incremental/incremental.factor
View File

@ -24,20 +24,20 @@ TUPLE: incremental < pack cursor ;
M: incremental pref-dim* M: incremental pref-dim*
dup layout-state>> [ dup layout-state>> [
dup call-next-method over set-incremental-cursor dup call-next-method over (>>cursor)
] when incremental-cursor ; ] when cursor>> ;
: next-cursor ( gadget incremental -- cursor ) : next-cursor ( gadget incremental -- cursor )
[ [
swap rect-dim swap incremental-cursor swap rect-dim swap cursor>>
2dup v+ >r vmax r> 2dup v+ >r vmax r>
] keep orientation>> set-axis ; ] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- ) : update-cursor ( gadget incremental -- )
[ next-cursor ] keep set-incremental-cursor ; [ next-cursor ] keep (>>cursor) ;
: incremental-loc ( gadget incremental -- ) : incremental-loc ( gadget incremental -- )
dup incremental-cursor swap orientation>> v* dup cursor>> swap orientation>> v*
swap set-rect-loc ; swap set-rect-loc ;
: prefer-incremental ( gadget -- ) : prefer-incremental ( gadget -- )
@ -57,5 +57,5 @@ M: incremental pref-dim*
not-in-layout not-in-layout
dup (clear-gadget) dup (clear-gadget)
dup forget-pref-dim dup forget-pref-dim
{ 0 0 } over set-incremental-cursor { 0 0 } over (>>cursor)
parent>> [ relayout ] when* ; parent>> [ relayout ] when* ;

4
basis/ui/gadgets/labelled/labelled.factor
View File

@ -16,7 +16,7 @@ TUPLE: labelled-gadget < track content ;
swap >>content swap >>content
dup content>> 1 track-add ; dup content>> 1 track-add ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* content>> ;
: <labelled-scroller> ( gadget title -- gadget ) : <labelled-scroller> ( gadget title -- gadget )
>r <scroller> r> <labelled-gadget> ; >r <scroller> r> <labelled-gadget> ;
@ -53,4 +53,4 @@ TUPLE: closable-gadget < frame content ;
swap >>content swap >>content
dup content>> @center grid-add ; dup content>> @center grid-add ;
M: closable-gadget focusable-child* closable-gadget-content ; M: closable-gadget focusable-child* content>> ;

4
basis/ui/gadgets/labels/labels.factor
View File

@ -14,9 +14,9 @@ TUPLE: label < gadget text font color ;
: set-label-string ( string label -- ) : set-label-string ( string label -- )
CHAR: \n pick memq? [ CHAR: \n pick memq? [
>r string-lines r> set-label-text >r string-lines r> (>>text)
] [ ] [
set-label-text (>>text)
] if ; inline ] if ; inline
: label-theme ( gadget -- gadget ) : label-theme ( gadget -- gadget )

20
basis/ui/gadgets/lists/lists.factor
View File

@ -27,8 +27,8 @@ TUPLE: list < pack index presenter color hook ;
control-value length 1- min 0 max ; control-value length 1- min 0 max ;
: bound-index ( list -- ) : bound-index ( list -- )
dup list-index over calc-bounded-index dup index>> over calc-bounded-index
swap set-list-index ; swap (>>index) ;
: list-presentation-hook ( list -- quot ) : list-presentation-hook ( list -- quot )
hook>> [ [ list? ] find-parent ] prepend ; hook>> [ [ list? ] find-parent ] prepend ;
@ -53,18 +53,18 @@ M: list model-changed
bound-index ; bound-index ;
: selected-rect ( list -- rect ) : selected-rect ( list -- rect )
dup list-index swap children>> ?nth ; dup index>> swap children>> ?nth ;
M: list draw-gadget* M: list draw-gadget*
origin get [ origin get [
dup list-color set-color dup color>> set-color
selected-rect [ rect-extent gl-fill-rect ] when* selected-rect [ rect-extent gl-fill-rect ] when*
] with-translation ; ] with-translation ;
M: list focusable-child* drop t ; M: list focusable-child* drop t ;
: list-value ( list -- object ) : list-value ( list -- object )
dup list-index swap control-value ?nth ; dup index>> swap control-value ?nth ;
: scroll>selected ( list -- ) : scroll>selected ( list -- )
#! We change the rectangle's width to zero to avoid #! We change the rectangle's width to zero to avoid
@ -79,22 +79,22 @@ M: list focusable-child* drop t ;
2drop 2drop
] [ ] [
[ control-value length rem ] keep [ control-value length rem ] keep
[ set-list-index ] keep [ (>>index) ] keep
[ relayout-1 ] keep [ relayout-1 ] keep
scroll>selected scroll>selected
] if ; ] if ;
: select-previous ( list -- ) : select-previous ( list -- )
dup list-index 1- swap select-index ; dup index>> 1- swap select-index ;
: select-next ( list -- ) : select-next ( list -- )
dup list-index 1+ swap select-index ; dup index>> 1+ swap select-index ;
: invoke-value-action ( list -- ) : invoke-value-action ( list -- )
dup list-empty? [ dup list-empty? [
dup list-hook call dup hook>> call
] [ ] [
dup list-index swap nth-gadget invoke-secondary dup index>> swap nth-gadget invoke-secondary
] if ; ] if ;
: select-gadget ( gadget list -- ) : select-gadget ( gadget list -- )

8
basis/ui/gadgets/panes/panes.factor
View File

@ -173,7 +173,7 @@ M: pane-stream make-span-stream
>r pick at r> when* ; inline >r pick at r> when* ; inline
: apply-foreground-style ( style gadget -- style gadget ) : apply-foreground-style ( style gadget -- style gadget )
foreground [ over set-label-color ] apply-style ; foreground [ over (>>color) ] apply-style ;
: apply-background-style ( style gadget -- style gadget ) : apply-background-style ( style gadget -- style gadget )
background [ solid-interior ] apply-style ; background [ solid-interior ] apply-style ;
@ -184,7 +184,7 @@ M: pane-stream make-span-stream
font-size swap at 12 or 3array ; font-size swap at 12 or 3array ;
: apply-font-style ( style gadget -- style gadget ) : apply-font-style ( style gadget -- style gadget )
over specified-font over set-label-font ; over specified-font over (>>font) ;
: apply-presentation-style ( style gadget -- style gadget ) : apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ; presented [ <presentation> ] apply-style ;
@ -255,7 +255,7 @@ M: pane-stream make-block-stream
! Tables ! Tables
: apply-table-gap-style ( style grid -- style grid ) : apply-table-gap-style ( style grid -- style grid )
table-gap [ over set-grid-gap ] apply-style ; table-gap [ over (>>gap) ] apply-style ;
: apply-table-border-style ( style grid -- style grid ) : apply-table-border-style ( style grid -- style grid )
table-border [ <grid-lines> over (>>boundary) ] table-border [ <grid-lines> over (>>boundary) ]
@ -263,7 +263,7 @@ M: pane-stream make-block-stream
: styled-grid ( style grid -- grid ) : styled-grid ( style grid -- grid )
<grid> <grid>
f over set-grid-fill? f over (>>fill?)
apply-table-gap-style apply-table-gap-style
apply-table-border-style apply-table-border-style
nip ; nip ;

6
basis/units/units.factor
View File

@ -39,7 +39,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
[ dimensions 2array ] bi@ = [ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ; [ dimensions-not-equal ] unless ;
: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ; : 2values ( dim dim -- val val ) [ value>> ] bi@ ;
: <dimension-op ( dim dim -- top bot val val ) : <dimension-op ( dim dim -- top bot val val )
2dup check-dimensions dup dimensions 2swap 2values ; 2dup check-dimensions dup dimensions 2swap 2values ;
@ -56,8 +56,8 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d* ( d d -- d ) : d* ( d d -- d )
[ dup number? [ scalar ] when ] bi@ [ dup number? [ scalar ] when ] bi@
[ [ dimensioned-top ] bi@ append ] 2keep [ [ top>> ] bi@ append ] 2keep
[ [ dimensioned-bot ] bi@ append ] 2keep [ [ bot>> ] bi@ append ] 2keep
2values * dimension-op> ; 2values * dimension-op> ;
: d-neg ( d -- d ) -1 d* ; : d-neg ( d -- d ) -1 d* ;

4
extra/classes/tuple/lib/lib.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros sequences slots words classes.tuple USING: kernel macros sequences slots words classes.tuple
quotations combinators ; quotations combinators accessors ;
IN: classes.tuple.lib IN: classes.tuple.lib
: reader-slots ( seq -- quot ) : reader-slots ( seq -- quot )
[ slot-spec-reader 1quotation ] map [ cleave ] curry ; [ reader>> 1quotation ] map [ cleave ] curry ;
MACRO: >tuple< ( class -- ) MACRO: >tuple< ( class -- )
all-slots rest-slice reader-slots ; all-slots rest-slice reader-slots ;

4
extra/fjsc/fjsc.factor
View File

@ -353,11 +353,11 @@ M: quotation fjsc-parse ( object -- ast )
] with-string-writer ; ] with-string-writer ;
: fjsc-compile* ( string -- string ) : fjsc-compile* ( string -- string )
'statement' parse parse-result-ast fjsc-compile ; 'statement' parse ast>> fjsc-compile ;
: fc* ( string -- string ) : fc* ( string -- string )
[ [
'statement' parse parse-result-ast values>> do-expressions 'statement' parse ast>> values>> do-expressions
] { } make [ write ] each ; ] { } make [ write ] each ;

2
extra/inverse/inverse.factor
View File

@ -208,7 +208,7 @@ DEFER: _
: slot-readers ( class -- quot ) : slot-readers ( class -- quot )
all-slots rest ! tail gets rid of delegate all-slots rest ! tail gets rid of delegate
[ slot-spec-reader 1quotation [ keep ] curry ] map concat [ reader>> 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ; [ ] like [ drop ] compose ;
: ?wrapped ( object -- wrapped ) : ?wrapped ( object -- wrapped )

7
extra/json/reader/reader.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order assocs math math.parser math.vectors math.functions math.order
lists hashtables ascii ; lists hashtables ascii accessors ;
IN: json.reader IN: json.reader
! Grammar for JSON from RFC 4627 ! Grammar for JSON from RFC 4627
@ -169,11 +169,12 @@ LAZY: 'value' ( -- parser )
'array' , 'array' ,
'number' , 'number' ,
] [<|>] spaced ; ] [<|>] spaced ;
ERROR: could-not-parse-json ;
: json> ( string -- object ) : json> ( string -- object )
#! Parse a json formatted string to a factor object #! Parse a json formatted string to a factor object
'value' parse dup nil? [ 'value' parse dup nil? [
"Could not parse json" throw could-not-parse-json
] [ ] [
car parse-result-parsed car parsed>>
] if ; ] if ;

2
extra/lists/lazy/lazy.factor
View File

@ -24,7 +24,7 @@ TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise ) : lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa [ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone T{ promise f f t f } clone
[ set-promise-value ] keep ; swap >>value ;
M: lazy-cons car ( lazy-cons -- car ) M: lazy-cons car ( lazy-cons -- car )
car>> force ; car>> force ;

2
extra/morse/morse.factor
View File

@ -116,7 +116,7 @@ LAZY: 'morse-words' ( -- parser )
PRIVATE> PRIVATE>
: morse> ( str -- str ) : morse> ( str -- str )
'morse-words' parse car parse-result-parsed [ 'morse-words' parse car parsed>> [
[ [
>string morse>ch >string morse>ch
] map >string ] map >string

16
extra/nehe/4/4.factor
View File

@ -1,5 +1,5 @@
USING: arrays kernel math opengl opengl.gl opengl.glu ui USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render threads ; ui.gadgets ui.render threads accessors ;
IN: nehe.4 IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
@ -10,8 +10,8 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
: <nehe4-gadget> ( -- gadget ) : <nehe4-gadget> ( -- gadget )
nehe4-gadget new-gadget nehe4-gadget new-gadget
0.0 over set-nehe4-gadget-rtri 0.0 >>rtri
0.0 over set-nehe4-gadget-rquad ; 0.0 >>rquad ;
M: nehe4-gadget pref-dim* ( gadget -- dim ) M: nehe4-gadget pref-dim* ( gadget -- dim )
drop width height 2array ; drop width height 2array ;
@ -53,22 +53,22 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
1.0 -1.0 0.0 glVertex3f 1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f -1.0 -1.0 0.0 glVertex3f
] do-state ] do-state
dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri [ 0.2 + ] change-rtri
dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ; [ 0.15 - ] change-rquad drop ;
: nehe4-update-thread ( gadget -- ) : nehe4-update-thread ( gadget -- )
dup nehe4-gadget-quit? [ drop ] [ dup quit?>> [ drop ] [
redraw-interval sleep redraw-interval sleep
dup relayout-1 dup relayout-1
nehe4-update-thread nehe4-update-thread
] if ; ] if ;
M: nehe4-gadget graft* ( gadget -- ) M: nehe4-gadget graft* ( gadget -- )
[ f swap set-nehe4-gadget-quit? ] keep f >>quit?
[ nehe4-update-thread ] in-thread drop ; [ nehe4-update-thread ] in-thread drop ;
M: nehe4-gadget ungraft* ( gadget -- ) M: nehe4-gadget ungraft* ( gadget -- )
t swap set-nehe4-gadget-quit? ; t >>quit? drop ;
: run4 ( -- ) : run4 ( -- )
<nehe4-gadget> "NeHe Tutorial 4" open-window ; <nehe4-gadget> "NeHe Tutorial 4" open-window ;

18
extra/nehe/5/5.factor
View File

@ -1,5 +1,5 @@
USING: arrays kernel math opengl opengl.gl opengl.glu ui USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render threads ; ui.gadgets ui.render threads accessors ;
IN: nehe.5 IN: nehe.5
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
@ -9,8 +9,8 @@ TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
: <nehe5-gadget> ( -- gadget ) : <nehe5-gadget> ( -- gadget )
nehe5-gadget new-gadget nehe5-gadget new-gadget
0.0 over set-nehe5-gadget-rtri 0.0 >>rtri
0.0 over set-nehe5-gadget-rquad ; 0.0 >>rquad ;
M: nehe5-gadget pref-dim* ( gadget -- dim ) M: nehe5-gadget pref-dim* ( gadget -- dim )
drop width height 2array ; drop width height 2array ;
@ -103,11 +103,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
1.0 -1.0 1.0 glVertex3f 1.0 -1.0 1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f 1.0 -1.0 -1.0 glVertex3f
] do-state ] do-state
dup nehe5-gadget-rtri 0.2 + over set-nehe5-gadget-rtri [ 0.2 + ] change-rtri
dup nehe5-gadget-rquad 0.15 - swap set-nehe5-gadget-rquad ; [ 0.15 - ] change-rquad drop ;
: nehe5-update-thread ( gadget -- ) : nehe5-update-thread ( gadget -- )
dup nehe5-gadget-quit? [ dup quit?>> [
drop drop
] [ ] [
redraw-interval sleep redraw-interval sleep
@ -116,11 +116,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
] if ; ] if ;
M: nehe5-gadget graft* ( gadget -- ) M: nehe5-gadget graft* ( gadget -- )
[ f swap set-nehe5-gadget-quit? ] keep f >>quit?
[ nehe5-update-thread ] in-thread drop ; [ nehe5-update-thread ] in-thread drop ;
M: nehe5-gadget ungraft* ( gadget -- ) M: nehe5-gadget ungraft* ( gadget -- )
t swap set-nehe5-gadget-quit? ; t >>quit? drop ;
: run5 ( -- ) : run5 ( -- )

6
extra/ori/ori.factor
View File

@ -1,5 +1,5 @@
USING: kernel namespaces USING: kernel namespaces accessors
math math.constants math.functions math.matrices math.vectors math math.constants math.functions math.matrices math.vectors
sequences splitting grouping self math.trig ; sequences splitting grouping self math.trig ;
@ -11,9 +11,9 @@ C: <ori> ori
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ori> ( -- val ) self> ori-val ; : ori> ( -- val ) self> val>> ;
: >ori ( val -- ) self> set-ori-val ; : >ori ( val -- ) self> (>>val) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

28
extra/parser-combinators/parser-combinators.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lists lists.lazy promises kernel sequences strings math USING: lists lists.lazy promises kernel sequences strings math
arrays splitting quotations combinators namespaces arrays splitting quotations combinators namespaces
unicode.case unicode.categories sequences.deep ; unicode.case unicode.categories sequences.deep accessors ;
IN: parser-combinators IN: parser-combinators
! Parser combinator protocol ! Parser combinator protocol
@ -13,11 +13,13 @@ M: promise parse ( input parser -- list )
TUPLE: parse-result parsed unparsed ; TUPLE: parse-result parsed unparsed ;
ERROR: cannot-parse input ;
: parse-1 ( input parser -- result ) : parse-1 ( input parser -- result )
dupd parse dup nil? [ dupd parse dup nil? [
"Cannot parse " rot append throw rot cannot-parse
] [ ] [
nip car parse-result-parsed nip car parsed>>
] if ; ] if ;
C: <parse-result> parse-result C: <parse-result> parse-result
@ -26,12 +28,12 @@ C: <parse-result> parse-result
<parse-result> 1list ; <parse-result> 1list ;
: parse-result-parsed-slice ( parse-result -- slice ) : parse-result-parsed-slice ( parse-result -- slice )
dup parse-result-parsed empty? [ dup parsed>> empty? [
parse-result-unparsed 0 0 rot <slice> unparsed>> 0 0 rot <slice>
] [ ] [
dup parse-result-unparsed dup unparsed>>
dup slice-from [ rot parse-result-parsed length - ] keep dup from>> [ rot parsed>> length - ] keep
rot slice-seq <slice> rot seq>> <slice>
] if ; ] if ;
: string= ( str1 str2 ignore-case -- ? ) : string= ( str1 str2 ignore-case -- ? )
@ -132,7 +134,7 @@ TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser ) : <&> ( parser1 parser2 -- parser )
over and-parser? [ over and-parser? [
>r and-parser-parsers r> suffix >r parsers>> r> suffix
] [ ] [
2array 2array
] if and-parser boa ; ] if and-parser boa ;
@ -142,11 +144,11 @@ TUPLE: and-parser parsers ;
: and-parser-parse ( list p1 -- list ) : and-parser-parse ( list p1 -- list )
swap [ swap [
dup parse-result-unparsed rot parse dup unparsed>> rot parse
[ [
>r parse-result-parsed r> >r parsed>> r>
[ parse-result-parsed 2array ] keep [ parsed>> 2array ] keep
parse-result-unparsed <parse-result> unparsed>> <parse-result>
] lazy-map-with ] lazy-map-with
] lazy-map-with lconcat ; ] lazy-map-with lconcat ;

4
extra/peg/ebnf/ebnf.factor
View File

@ -508,10 +508,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: check-parse-result ( result -- result ) : check-parse-result ( result -- result )
dup [ dup [
dup parse-result-remaining [ blank? ] trim empty? [ dup remaining>> [ blank? ] trim empty? [
[ [
"Unable to fully parse EBNF. Left to parse was: " % "Unable to fully parse EBNF. Left to parse was: " %
parse-result-remaining % remaining>> %
] "" make throw ] "" make throw
] unless ] unless
] [ ] [

9
extra/pos/pos.factor
View File

@ -1,5 +1,6 @@
USING: kernel math math.functions math.vectors sequences self ; USING: kernel math math.functions math.vectors sequences self
accessors ;
IN: pos IN: pos
@ -9,13 +10,13 @@ TUPLE: pos val ;
C: <pos> pos C: <pos> pos
: pos> ( -- val ) self> pos-val ; : pos> ( -- val ) self> val>> ;
: >pos ( val -- ) self> set-pos-val ; : >pos ( val -- ) self> (>>val) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: distance ( pos pos -- n ) pos-val swap pos-val v- [ sq ] map sum sqrt ; : distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
: move-by ( point -- ) pos> v+ >pos ; : move-by ( point -- ) pos> v+ >pos ;

8
extra/regexp/regexp.factor
View File

@ -270,14 +270,14 @@ TUPLE: regexp source parser ignore-case? ;
] keep regexp boa ; ] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp ) : do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ; dup ignore-case?>> [ >r >upper r> ] when ;
: matches? ( string regexp -- ? ) : matches? ( string regexp -- ? )
do-ignore-case regexp-parser just parse nil? not ; do-ignore-case parser>> just parse nil? not ;
: match-head ( string regexp -- end ) : match-head ( string regexp -- end )
do-ignore-case regexp-parser parse dup nil? do-ignore-case parser>> parse dup nil?
[ drop f ] [ car parse-result-unparsed from>> ] if ; [ drop f ] [ car unparsed>> from>> ] if ;
! Literal syntax for regexps ! Literal syntax for regexps
: parse-options ( string -- ? ) : parse-options ( string -- ? )

9
extra/state-machine/state-machine.factor
View File

@ -1,5 +1,6 @@
USING: kernel parser lexer strings math namespaces sequences words io USING: kernel parser lexer strings math namespaces
arrays quotations debugger kernel.private sequences.private ; sequences words io arrays quotations debugger accessors
sequences.private ;
IN: state-machine IN: state-machine
: STATES: : STATES:
@ -20,9 +21,9 @@ M: missing-state error.
! quot is ( state string -- output-string ) ! quot is ( state string -- output-string )
[ missing-state ] <array> dup [ missing-state ] <array> dup
[ [
[ >r dup dup state-data swap state-place r> ] % [ >r dup [ data>> ] [ place>> ] bi r> ] %
[ swapd bounds-check dispatch ] curry , [ swapd bounds-check dispatch ] curry ,
[ each pick set-state-place swap set-state-data ] % [ each pick (>>place) swap (>>date) ] %
] [ ] make [ over make ] curry ; ] [ ] make [ over make ] curry ;
: define-machine ( word state-class -- ) : define-machine ( word state-class -- )

10
extra/turing/turing.factor
View File

@ -1,6 +1,6 @@
IN: turing
USING: arrays assocs io kernel math namespaces USING: arrays assocs io kernel math namespaces
prettyprint sequences strings vectors words ; prettyprint sequences strings vectors words accessors ;
IN: turing
! A turing machine simulator. ! A turing machine simulator.
@ -55,9 +55,9 @@ SYMBOL: tape
: turing-step ( -- ) : turing-step ( -- )
#! Do one step of the turing machine. #! Do one step of the turing machine.
next-state next-state
dup state-sym set-sym dup sym>> set-sym
dup state-dir position [ + ] change dup dir>> position [ + ] change
state-next state set ; next>> state set ;
: c ( -- ) : c ( -- )
#! Print current turing machine state. #! Print current turing machine state.