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

switch some vocabs to 4 spaces.

db4
John Benediktsson 2013-07-24 14:52:09 -07:00
parent 1f5e8f3970
commit c75fc48f23
16 changed files with 1089 additions and 1088 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,7 @@ IN: csv.tests
! I like to name my unit tests ! I like to name my unit tests
: named-unit-test ( name output input -- ) : named-unit-test ( name output input -- )
unit-test drop ; inline unit-test drop ; inline
"Fields are separated by commas" "Fields are separated by commas"
[ { { "1997" "Ford" "E350" } } ] [ { { "1997" "Ford" "E350" } } ]
@ -22,17 +22,17 @@ IN: csv.tests
"double quotes mean escaped in quotes" "double quotes mean escaped in quotes"
[ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ] [ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ]
[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\"" [ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\""
string>csv ] named-unit-test string>csv ] named-unit-test
"Fields with embedded line breaks must be delimited by double-quote characters." "Fields with embedded line breaks must be delimited by double-quote characters."
[ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ] [ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ]
[ "1997,Ford,E350,\"Go get one now\nthey are going fast\"" [ "1997,Ford,E350,\"Go get one now\nthey are going fast\""
string>csv ] named-unit-test string>csv ] named-unit-test
"Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)" "Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)"
[ { { "1997" "Ford" "E350" " Super luxurious truck " } } ] [ { { "1997" "Ford" "E350" " Super luxurious truck " } } ]
[ "1997,Ford,E350,\" Super luxurious truck \"" [ "1997,Ford,E350,\" Super luxurious truck \""
string>csv ] named-unit-test string>csv ] named-unit-test
"Fields may always be delimited by double-quote characters, whether necessary or not." "Fields may always be delimited by double-quote characters, whether necessary or not."
[ { { "1997" "Ford" "E350" } } ] [ { { "1997" "Ford" "E350" } } ]
@ -43,7 +43,7 @@ IN: csv.tests
{ "1997" "Ford" "E350" } { "1997" "Ford" "E350" }
{ "2000" "Mercury" "Cougar" } } ] { "2000" "Mercury" "Cougar" } } ]
[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" [ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar"
string>csv ] named-unit-test string>csv ] named-unit-test
! !!!!!!!! other tests ! !!!!!!!! other tests

88
basis/match/match-tests.factor
View File

@ -8,39 +8,39 @@ MATCH-VARS: ?a ?b ;
[ f ] [ { ?a ?a } { 1 2 } match ] unit-test [ f ] [ { ?a ?a } { 1 2 } match ] unit-test
[ H{ { ?a 1 } { ?b 2 } } ] [ [ H{ { ?a 1 } { ?b 2 } } ] [
{ ?a ?b } { 1 2 } match { ?a ?b } { 1 2 } match
] unit-test ] unit-test
[ { 1 2 } ] [ [ { 1 2 } ] [
{ 1 2 } { 1 2 }
{ {
{ { ?a ?b } [ ?a ?b 2array ] } { { ?a ?b } [ ?a ?b 2array ] }
} match-cond } match-cond
] unit-test ] unit-test
[ t ] [ [ t ] [
{ 1 2 } { 1 2 }
{ {
{ { 1 2 } [ t ] } { { 1 2 } [ t ] }
{ f [ f ] } { f [ f ] }
} match-cond } match-cond
] unit-test ] unit-test
[ t ] [ [ t ] [
{ 1 3 } { 1 3 }
{ {
{ { 1 2 } [ t ] } { { 1 2 } [ t ] }
{ { 1 3 } [ t ] } { { 1 3 } [ t ] }
} match-cond } match-cond
] unit-test ] unit-test
[ f ] [ [ f ] [
{ 1 5 } { 1 5 }
{ {
{ { 1 2 } [ t ] } { { 1 2 } [ t ] }
{ { 1 3 } [ t ] } { { 1 3 } [ t ] }
{ _ [ f ] } { _ [ f ] }
} match-cond } match-cond
] unit-test ] unit-test
TUPLE: foo a b ; TUPLE: foo a b ;
@ -48,31 +48,29 @@ TUPLE: foo a b ;
C: <foo> foo C: <foo> foo
{ 1 2 } [ { 1 2 } [
1 2 <foo> T{ foo f ?a ?b } match [ 1 2 <foo> T{ foo f ?a ?b } match [
?a ?b ?a ?b
] with-variables ] with-variables
] unit-test ] unit-test
{ 1 2 } [ { 1 2 } [
1 2 <foo> \ ?a \ ?b <foo> match [ 1 2 <foo> \ ?a \ ?b <foo> match [
?a ?b ?a ?b
] with-variables ] with-variables
] unit-test ] unit-test
{ H{ { ?a ?a } } } [ { H{ { ?a ?a } } }
\ ?a \ ?a match \ ?a \ ?a match
] unit-test ] unit-test
[ "match" ] [ [ "match" ] [
"abcd" { "abcd" {
{ ?a [ "match" ] } { ?a [ "match" ] }
} match-cond } match-cond
] unit-test ] unit-test
[ { { 2 1 } } [
{ 2 1 } { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
] [
{ "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
] unit-test ] unit-test
TUPLE: match-replace-test a b ; TUPLE: match-replace-test a b ;
@ -80,8 +78,8 @@ TUPLE: match-replace-test a b ;
[ [
T{ match-replace-test f 2 1 } T{ match-replace-test f 2 1 }
] [ ] [
T{ match-replace-test f 1 2 } T{ match-replace-test f 1 2 }
T{ match-replace-test f ?a ?b } T{ match-replace-test f ?a ?b }
T{ match-replace-test f ?b ?a } T{ match-replace-test f ?b ?a }
match-replace match-replace
] unit-test ] unit-test

20
basis/math/functions/functions.factor
View File

@ -187,13 +187,22 @@ M: real absq sq ; inline
: >=1? ( x -- ? ) : >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline dup complex? [ drop f ] [ 1 >= ] if ; inline
<PRIVATE
: fp-normalize ( x -- y exp )
dup abs 0x1.0p-1022 < [ 52 2^ * -52 ] [ 0 ] if ; inline
PRIVATE>
GENERIC: frexp ( x -- y exp ) GENERIC: frexp ( x -- y exp )
M: float frexp M: float frexp
dup fp-special? [ dup zero? ] unless* [ 0 ] [ dup fp-special? [ dup zero? ] unless* [ 0 ] [
double>bits fp-normalize [
[ 0x800f,ffff,ffff,ffff bitand 0.5 double>bits bitor bits>double ] double>bits
[ -52 shift 0x7ff bitand 1022 - ] bi [ 0x800f,ffff,ffff,ffff bitand 0.5 double>bits bitor bits>double ]
[ -52 shift 0x7ff bitand 1022 - ] bi
] dip +
] if ; inline ] if ; inline
M: integer frexp M: integer frexp
@ -210,8 +219,9 @@ GENERIC# ldexp 1 ( x exp -- y )
M: float ldexp M: float ldexp
over fp-special? [ over zero? ] unless* [ drop ] [ over fp-special? [ over zero? ] unless* [ drop ] [
[ double>bits dup -52 shift 0x7ff bitand 1023 - ] dip + [ fp-normalize ] dip
{ [ double>bits dup -52 shift 0x7ff bitand 1023 - ]
[ + ] [ + ] tri* {
{ [ dup -1074 < ] [ drop 0 copysign ] } { [ dup -1074 < ] [ drop 0 copysign ] }
{ [ dup 1023 > ] [ drop 0 < -1/0. 1/0. ? ] } { [ dup 1023 > ] [ drop 0 < -1/0. 1/0. ? ] }
[ [

134
basis/peg/peg-tests.factor
View File

@ -8,191 +8,191 @@ IN: peg.tests
[ ] [ reset-pegs ] unit-test [ ] [ reset-pegs ] unit-test
[ [
"endbegin" "begin" token parse "endbegin" "begin" token parse
] must-fail ] must-fail
{ "begin" "end" } [ { "begin" "end" } [
"beginend" "begin" token (parse) "beginend" "begin" token (parse)
[ ast>> ] [ remaining>> ] bi [ ast>> ] [ remaining>> ] bi
>string >string
] unit-test ] unit-test
[ [
"" CHAR: a CHAR: z range parse "" CHAR: a CHAR: z range parse
] must-fail ] must-fail
[ [
"1bcd" CHAR: a CHAR: z range parse "1bcd" CHAR: a CHAR: z range parse
] must-fail ] must-fail
{ CHAR: a } [ { CHAR: a } [
"abcd" CHAR: a CHAR: z range parse "abcd" CHAR: a CHAR: z range parse
] unit-test ] unit-test
{ CHAR: z } [ { CHAR: z } [
"zbcd" CHAR: a CHAR: z range parse "zbcd" CHAR: a CHAR: z range parse
] unit-test ] unit-test
[ [
"bad" "a" token "b" token 2array seq parse "bad" "a" token "b" token 2array seq parse
] must-fail ] must-fail
{ V{ "g" "o" } } [ { V{ "g" "o" } } [
"good" "g" token "o" token 2array seq parse "good" "g" token "o" token 2array seq parse
] unit-test ] unit-test
{ "a" } [ { "a" } [
"abcd" "a" token "b" token 2array choice parse "abcd" "a" token "b" token 2array choice parse
] unit-test ] unit-test
{ "b" } [ { "b" } [
"bbcd" "a" token "b" token 2array choice parse "bbcd" "a" token "b" token 2array choice parse
] unit-test ] unit-test
[ [
"cbcd" "a" token "b" token 2array choice parse "cbcd" "a" token "b" token 2array choice parse
] must-fail ] must-fail
[ [
"" "a" token "b" token 2array choice parse "" "a" token "b" token 2array choice parse
] must-fail ] must-fail
{ 0 } [ { 0 } [
"" "a" token repeat0 parse length "" "a" token repeat0 parse length
] unit-test ] unit-test
{ 0 } [ { 0 } [
"b" "a" token repeat0 parse length "b" "a" token repeat0 parse length
] unit-test ] unit-test
{ V{ "a" "a" "a" } } [ { V{ "a" "a" "a" } } [
"aaab" "a" token repeat0 parse "aaab" "a" token repeat0 parse
] unit-test ] unit-test
[ [
"" "a" token repeat1 parse "" "a" token repeat1 parse
] must-fail ] must-fail
[ [
"b" "a" token repeat1 parse "b" "a" token repeat1 parse
] must-fail ] must-fail
{ V{ "a" "a" "a" } } [ { V{ "a" "a" "a" } } [
"aaab" "a" token repeat1 parse "aaab" "a" token repeat1 parse
] unit-test ] unit-test
{ V{ "a" "b" } } [ { V{ "a" "b" } } [
"ab" "a" token optional "b" token 2array seq parse "ab" "a" token optional "b" token 2array seq parse
] unit-test ] unit-test
{ V{ f "b" } } [ { V{ f "b" } } [
"b" "a" token optional "b" token 2array seq parse "b" "a" token optional "b" token 2array seq parse
] unit-test ] unit-test
[ [
"cb" "a" token optional "b" token 2array seq parse "cb" "a" token optional "b" token 2array seq parse
] must-fail ] must-fail
{ V{ CHAR: a CHAR: b } } [ { V{ CHAR: a CHAR: b } } [
"ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse
] unit-test ] unit-test
[ [
"bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse "bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse
] must-fail ] must-fail
{ t } [ { t } [
"a+b" "a+b"
"a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if parse [ t ] [ f ] if
] unit-test ] unit-test
{ t } [ { t } [
"a++b" "a++b"
"a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if parse [ t ] [ f ] if
] unit-test ] unit-test
{ t } [ { t } [
"a+b" "a+b"
"a" token "+" token "++" token 2array choice "b" token 3array seq "a" token "+" token "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if parse [ t ] [ f ] if
] unit-test ] unit-test
[ [
"a++b" "a++b"
"a" token "+" token "++" token 2array choice "b" token 3array seq "a" token "+" token "++" token 2array choice "b" token 3array seq
parse [ t ] [ f ] if parse [ t ] [ f ] if
] must-fail ] must-fail
{ 1 } [ { 1 } [
"a" "a" token [ drop 1 ] action parse "a" "a" token [ drop 1 ] action parse
] unit-test ] unit-test
{ V{ 1 1 } } [ { V{ 1 1 } } [
"aa" "a" token [ drop 1 ] action dup 2array seq parse "aa" "a" token [ drop 1 ] action dup 2array seq parse
] unit-test ] unit-test
[ [
"b" "a" token [ drop 1 ] action parse "b" "a" token [ drop 1 ] action parse
] must-fail ] must-fail
[ [
"b" [ CHAR: a = ] satisfy parse "b" [ CHAR: a = ] satisfy parse
] must-fail ] must-fail
{ CHAR: a } [ { CHAR: a } [
"a" [ CHAR: a = ] satisfy parse "a" [ CHAR: a = ] satisfy parse
] unit-test ] unit-test
{ "a" } [ { "a" } [
" a" "a" token sp parse " a" "a" token sp parse
] unit-test ] unit-test
{ "a" } [ { "a" } [
"a" "a" token sp parse "a" "a" token sp parse
] unit-test ] unit-test
{ V{ "a" } } [ { V{ "a" } } [
"[a]" "[" token hide "a" token "]" token hide 3array seq parse "[a]" "[" token hide "a" token "]" token hide 3array seq parse
] unit-test ] unit-test
[ [
"a]" "[" token hide "a" token "]" token hide 3array seq parse "a]" "[" token hide "a" token "]" token hide 3array seq parse
] must-fail ] must-fail
{ V{ "1" "-" "1" } V{ "1" "+" "1" } } [ { V{ "1" "-" "1" } V{ "1" "+" "1" } } [
[ [
[ "1" token , "-" token , "1" token , ] seq* , [ "1" token , "-" token , "1" token , ] seq* ,
[ "1" token , "+" token , "1" token , ] seq* , [ "1" token , "+" token , "1" token , ] seq* ,
] choice* ] choice*
"1-1" over parse swap "1-1" over parse swap
"1+1" swap parse "1+1" swap parse
] unit-test ] unit-test
: expr ( -- parser ) : expr ( -- parser )
#! Test direct left recursion. Currently left recursion should cause a #! Test direct left recursion. Currently left recursion should cause a
#! failure of that parser. #! failure of that parser.
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ; [ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
{ V{ V{ "1" "+" "1" } "+" "1" } } [ { V{ V{ "1" "+" "1" } "+" "1" } } [
"1+1+1" expr parse "1+1+1" expr parse
] unit-test ] unit-test
{ t } [ { t } [
#! Ensure a circular parser doesn't loop infinitely #! Ensure a circular parser doesn't loop infinitely
[ f , "a" token , ] seq* [ f , "a" token , ] seq*
dup peg>> parsers>> dup peg>> parsers>>
dupd 0 swap set-nth compile word? dupd 0 swap set-nth compile word?
] unit-test ] unit-test
[ [
"A" [ drop t ] satisfy [ 66 >= ] semantic parse "A" [ drop t ] satisfy [ 66 >= ] semantic parse
] must-fail ] must-fail
{ CHAR: B } [ { CHAR: B } [
"B" [ drop t ] satisfy [ 66 >= ] semantic parse "B" [ drop t ] satisfy [ 66 >= ] semantic parse
] unit-test ] unit-test
{ f } [ \ + T{ parser f f f } equal? ] unit-test { f } [ \ + T{ parser f f f } equal? ] unit-test

636
basis/peg/peg.factor
View File

@ -12,7 +12,7 @@ TUPLE: parse-result remaining ast ;
TUPLE: parse-error position messages ; TUPLE: parse-error position messages ;
TUPLE: parser peg compiled id ; TUPLE: parser peg compiled id ;
M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ; M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
M: parser hashcode* id>> hashcode* ; M: parser hashcode* id>> hashcode* ;
C: <parse-result> parse-result C: <parse-result> parse-result
@ -21,37 +21,38 @@ C: <parse-error> parse-error
SYMBOL: error-stack SYMBOL: error-stack
: (merge-errors) ( a b -- c ) : (merge-errors) ( a b -- c )
{ {
{ [ over position>> not ] [ nip ] } { [ over position>> not ] [ nip ] }
{ [ dup position>> not ] [ drop ] } { [ dup position>> not ] [ drop ] }
[ 2dup [ position>> ] compare { [
{ +lt+ [ nip ] } 2dup [ position>> ] compare {
{ +gt+ [ drop ] } { +lt+ [ nip ] }
{ +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] } { +gt+ [ drop ] }
} case { +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
] } case
} cond ; ]
} cond ;
: merge-errors ( -- ) : merge-errors ( -- )
error-stack get dup length 1 > [ error-stack get dup length 1 > [
dup pop over pop swap (merge-errors) swap push dup pop over pop swap (merge-errors) swap push
] [ ] [
drop drop
] if ; ] if ;
: add-error ( remaining message -- ) : add-error ( remaining message -- )
<parse-error> error-stack get push ; <parse-error> error-stack get push ;
SYMBOL: ignore SYMBOL: ignore
: packrat ( id -- cache ) : packrat ( id -- cache )
#! The packrat cache is a mapping of parser-id->cache. #! The packrat cache is a mapping of parser-id->cache.
#! For each parser it maps to a cache holding a mapping #! For each parser it maps to a cache holding a mapping
#! of position->result. The packrat cache therefore keeps #! of position->result. The packrat cache therefore keeps
#! track of all parses that have occurred at each position #! track of all parses that have occurred at each position
#! of the input string and the results obtained from that #! of the input string and the results obtained from that
#! parser. #! parser.
\ packrat get [ drop H{ } clone ] cache ; \ packrat get [ drop H{ } clone ] cache ;
SYMBOL: pos SYMBOL: pos
SYMBOL: input SYMBOL: input
@ -59,26 +60,26 @@ SYMBOL: fail
SYMBOL: lrstack SYMBOL: lrstack
: heads ( -- cache ) : heads ( -- cache )
#! A mapping from position->peg-head. It maps a #! A mapping from position->peg-head. It maps a
#! position in the input string being parsed to #! position in the input string being parsed to
#! the head of the left recursion which is currently #! the head of the left recursion which is currently
#! being grown. It is 'f' at any position where #! being grown. It is 'f' at any position where
#! left recursion growth is not underway. #! left recursion growth is not underway.
\ heads get ; \ heads get ;
: failed? ( obj -- ? ) : failed? ( obj -- ? )
fail = ; fail = ;
: peg-cache ( -- cache ) : peg-cache ( -- cache )
#! Holds a hashtable mapping a peg tuple to #! Holds a hashtable mapping a peg tuple to
#! the parser tuple for that peg. The parser tuple #! the parser tuple for that peg. The parser tuple
#! holds a unique id and the compiled form of that peg. #! holds a unique id and the compiled form of that peg.
\ peg-cache get-global [ \ peg-cache get-global [
H{ } clone dup \ peg-cache set-global H{ } clone dup \ peg-cache set-global
] unless* ; ] unless* ;
: reset-pegs ( -- ) : reset-pegs ( -- )
H{ } clone \ peg-cache set-global ; H{ } clone \ peg-cache set-global ;
reset-pegs reset-pegs
@ -93,116 +94,114 @@ TUPLE: left-recursion seed rule-id head next ;
TUPLE: peg-head rule-id involved-set eval-set ; TUPLE: peg-head rule-id involved-set eval-set ;
: rule-id ( word -- id ) : rule-id ( word -- id )
#! A rule is the parser compiled down to a word. It has #! A rule is the parser compiled down to a word. It has
#! a "peg-id" property containing the id of the original parser. #! a "peg-id" property containing the id of the original parser.
"peg-id" word-prop ; "peg-id" word-prop ;
: input-slice ( -- slice ) : input-slice ( -- slice )
#! Return a slice of the input from the current parse position #! Return a slice of the input from the current parse position
input get pos get tail-slice ; input get pos get tail-slice ;
: input-from ( input -- n ) : input-from ( input -- n )
#! Return the index from the original string that the #! Return the index from the original string that the
#! input slice is based on. #! input slice is based on.
dup slice? [ from>> ] [ drop 0 ] if ; dup slice? [ from>> ] [ drop 0 ] if ;
: process-rule-result ( p result -- result ) : process-rule-result ( p result -- result )
[ [
nip [ ast>> ] [ remaining>> ] bi input-from pos set nip [ ast>> ] [ remaining>> ] bi input-from pos set
] [ ] [
pos set fail pos set fail
] if* ; ] if* ;
: eval-rule ( rule -- ast ) : eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it. #! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has #! Return fail if the rule failed. The rule has
#! stack effect ( -- parse-result ) #! stack effect ( -- parse-result )
pos get swap execute( -- parse-result ) process-rule-result ; inline pos get swap execute( -- parse-result ) process-rule-result ; inline
: memo ( pos id -- memo-entry ) : memo ( pos id -- memo-entry )
#! Return the result from the memo cache. #! Return the result from the memo cache.
packrat at packrat at ;
! " memo result " write dup .
;
: set-memo ( memo-entry pos id -- ) : set-memo ( memo-entry pos id -- )
#! Store an entry in the cache #! Store an entry in the cache
packrat set-at ; packrat set-at ;
: update-m ( ast m -- ) : update-m ( ast m -- )
swap >>ans pos get >>pos drop ; swap >>ans pos get >>pos drop ;
: stop-growth? ( ast m -- ? ) : stop-growth? ( ast m -- ? )
[ failed? pos get ] dip [ failed? pos get ] dip
pos>> <= or ; pos>> <= or ;
: setup-growth ( h p -- ) : setup-growth ( h p -- )
pos set dup involved-set>> clone >>eval-set drop ; pos set dup involved-set>> clone >>eval-set drop ;
: (grow-lr) ( h p r: ( -- result ) m -- ) : (grow-lr) ( h p r: ( -- result ) m -- )
[ [ setup-growth ] 2keep ] 2dip [ [ setup-growth ] 2keep ] 2dip
[ dup eval-rule ] dip swap [ dup eval-rule ] dip swap
dup pick stop-growth? [ dup pick stop-growth? [
5 ndrop 5 ndrop
] [ ] [
over update-m over update-m
(grow-lr) (grow-lr)
] if ; inline recursive ] if ; inline recursive
: grow-lr ( h p r m -- ast ) : grow-lr ( h p r m -- ast )
[ [ heads set-at ] 2keep ] 2dip [ [ heads set-at ] 2keep ] 2dip
pick over [ (grow-lr) ] 2dip pick over [ (grow-lr) ] 2dip
swap heads delete-at swap heads delete-at
dup pos>> pos set ans>> dup pos>> pos set ans>>
; inline ; inline
:: (setup-lr) ( l s -- ) :: (setup-lr) ( l s -- )
s [ s [
s left-recursion? [ s throw ] unless s left-recursion? [ s throw ] unless
s head>> l head>> eq? [ s head>> l head>> eq? [
l head>> s head<< l head>> s head<<
l head>> [ s rule-id>> suffix ] change-involved-set drop l head>> [ s rule-id>> suffix ] change-involved-set drop
l s next>> (setup-lr) l s next>> (setup-lr)
] unless ] unless
] when ; ] when ;
:: setup-lr ( r l -- ) :: setup-lr ( r l -- )
l head>> [ l head>> [
r rule-id V{ } clone V{ } clone peg-head boa l head<< r rule-id V{ } clone V{ } clone peg-head boa l head<<
] unless ] unless
l lrstack get (setup-lr) ; l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast ) :: lr-answer ( r p m -- ast )
m ans>> head>> :> h m ans>> head>> :> h
h rule-id>> r rule-id eq? [ h rule-id>> r rule-id eq? [
m ans>> seed>> m ans<< m ans>> seed>> m ans<<
m ans>> failed? [ m ans>> failed? [
fail fail
] [ ] [
h p r m grow-lr h p r m grow-lr
] if ] if
] [ ] [
m ans>> seed>> m ans>> seed>>
] if ; inline ] if ; inline
:: recall ( r p -- memo-entry ) :: recall ( r p -- memo-entry )
p r rule-id memo :> m p r rule-id memo :> m
p heads at :> h p heads at :> h
h [ h [
m r rule-id h involved-set>> h rule-id>> suffix member? not and [ m r rule-id h involved-set>> h rule-id>> suffix member? not and [
fail p memo-entry boa fail p memo-entry boa
] [ ] [
r rule-id h eval-set>> member? [ r rule-id h eval-set>> member? [
h [ r rule-id swap remove ] change-eval-set drop h [ r rule-id swap remove ] change-eval-set drop
r eval-rule r eval-rule
m update-m m update-m
m m
] [ ] [
m m
] if
] if ] if
] if
] [ ] [
m m
] if ; inline ] if ; inline
:: apply-non-memo-rule ( r p -- ast ) :: apply-non-memo-rule ( r p -- ast )
@ -212,32 +211,29 @@ TUPLE: peg-head rule-id involved-set eval-set ;
lrstack get next>> lrstack set lrstack get next>> lrstack set
pos get m pos<< pos get m pos<<
lr head>> [ lr head>> [
m ans>> left-recursion? [ m ans>> left-recursion? [
ans lr seed<< ans lr seed<<
r p m lr-answer r p m lr-answer
] [ ans ] if ] [ ans ] if
] [ ] [
ans m ans<< ans m ans<<
ans ans
] if ; inline ] if ; inline
: apply-memo-rule ( r m -- ast ) : apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi pos set [ ans>> ] [ pos>> ] bi pos set
dup left-recursion? [ dup left-recursion? [
[ setup-lr ] keep seed>> [ setup-lr ] keep seed>>
] [ ] [
nip nip
] if ; ] if ;
: apply-rule ( r p -- ast ) : apply-rule ( r p -- ast )
! 2dup [ rule-id ] dip 2array "apply-rule: " write . 2dup recall [
2dup recall [ nip apply-memo-rule
! " memoed" print ] [
nip apply-memo-rule apply-non-memo-rule
] [ ] if* ; inline
! " not memoed" print
apply-non-memo-rule
] if* ; inline
: with-packrat ( input quot -- result ) : with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active. #! Run the quotation with a packrat cache active.
@ -253,361 +249,361 @@ TUPLE: peg-head rule-id involved-set eval-set ;
GENERIC: (compile) ( peg -- quot ) GENERIC: (compile) ( peg -- quot )
: process-parser-result ( result -- result ) : process-parser-result ( result -- result )
dup failed? [ dup failed? [
drop f drop f
] [ ] [
input-slice swap <parse-result> input-slice swap <parse-result>
] if ; ] if ;
: execute-parser ( word -- result ) : execute-parser ( word -- result )
pos get apply-rule process-parser-result ; pos get apply-rule process-parser-result ;
: preset-parser-word ( parser -- parser word ) : preset-parser-word ( parser -- parser word )
gensym [ >>compiled ] keep ; gensym [ >>compiled ] keep ;
: define-parser-word ( parser word -- ) : define-parser-word ( parser word -- )
#! Return the body of the word that is the compiled version #! Return the body of the word that is the compiled version
#! of the parser. #! of the parser.
2dup swap peg>> (compile) ( -- result ) define-declared 2dup swap peg>> (compile) ( -- result ) define-declared
swap id>> "peg-id" set-word-prop ; swap id>> "peg-id" set-word-prop ;
: compile-parser ( parser -- word ) : compile-parser ( parser -- word )
#! Look to see if the given parser has been compiled. #! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it, #! If not, compile it to a temporary word, cache it,
#! and return it. Otherwise return the existing one. #! and return it. Otherwise return the existing one.
#! Circular parsers are supported by getting the word #! Circular parsers are supported by getting the word
#! name and storing it in the cache, before compiling, #! name and storing it in the cache, before compiling,
#! so it is picked up when re-entered. #! so it is picked up when re-entered.
dup compiled>> [ dup compiled>> [
nip nip
] [ ] [
preset-parser-word [ define-parser-word ] keep preset-parser-word [ define-parser-word ] keep
] if* ; ] if* ;
: compile-parser-quot ( parser -- quot ) : compile-parser-quot ( parser -- quot )
compile-parser [ execute-parser ] curry ; compile-parser [ execute-parser ] curry ;
SYMBOL: delayed SYMBOL: delayed
: fixup-delayed ( -- ) : fixup-delayed ( -- )
#! Work through all delayed parsers and recompile their #! Work through all delayed parsers and recompile their
#! words to have the correct bodies. #! words to have the correct bodies.
delayed get [ delayed get [
call( -- parser ) compile-parser-quot ( -- result ) define-declared call( -- parser ) compile-parser-quot ( -- result ) define-declared
] assoc-each ; ] assoc-each ;
: compile ( parser -- word ) : compile ( parser -- word )
[ [
H{ } clone delayed [ H{ } clone delayed [
compile-parser-quot ( -- result ) define-temp fixup-delayed compile-parser-quot ( -- result ) define-temp fixup-delayed
] with-variable ] with-variable
] with-compilation-unit ; ] with-compilation-unit ;
: compiled-parse ( state word -- result ) : compiled-parse ( state word -- result )
swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ; swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
: (parse) ( input parser -- result ) : (parse) ( input parser -- result )
dup word? [ compile ] unless compiled-parse ; dup word? [ compile ] unless compiled-parse ;
: parse ( input parser -- ast ) : parse ( input parser -- ast )
(parse) ast>> ; (parse) ast>> ;
<PRIVATE <PRIVATE
SYMBOL: id SYMBOL: id
: next-id ( -- n ) : next-id ( -- n )
#! Return the next unique id for a parser #! Return the next unique id for a parser
id get-global [ id get-global [
dup 1 + id set-global dup 1 + id set-global
] [ ] [
1 id set-global 0 1 id set-global 0
] if* ; ] if* ;
: wrap-peg ( peg -- parser ) : wrap-peg ( peg -- parser )
#! Wrap a parser tuple around the peg object. #! Wrap a parser tuple around the peg object.
#! Look for an existing parser tuple for that #! Look for an existing parser tuple for that
#! peg object. #! peg object.
peg-cache [ peg-cache [
f next-id parser boa f next-id parser boa
] cache ; ] cache ;
TUPLE: token-parser symbol ; TUPLE: token-parser symbol ;
: parse-token ( input string -- result ) : parse-token ( input string -- result )
#! Parse the string, returning a parse result #! Parse the string, returning a parse result
[ ?head-slice ] keep swap [ [ ?head-slice ] keep swap [
<parse-result> f f add-error <parse-result> f f add-error
] [ ] [
[ drop pos get "token '" ] dip append "'" append 1vector add-error f [ drop pos get "token '" ] dip append "'" append 1vector add-error f
] if ; ] if ;
M: token-parser (compile) ( peg -- quot ) M: token-parser (compile) ( peg -- quot )
symbol>> '[ input-slice _ parse-token ] ; symbol>> '[ input-slice _ parse-token ] ;
TUPLE: satisfy-parser quot ; TUPLE: satisfy-parser quot ;
: parse-satisfy ( input quot -- result ) : parse-satisfy ( input quot -- result )
swap dup empty? [ swap dup empty? [
2drop f 2drop f
] [ ] [
unclip-slice rot dupd call [ unclip-slice rot dupd call [
<parse-result> <parse-result>
] [ ] [
2drop f 2drop f
] if ] if
] if ; inline ] if ; inline
M: satisfy-parser (compile) ( peg -- quot ) M: satisfy-parser (compile) ( peg -- quot )
quot>> '[ input-slice _ parse-satisfy ] ; quot>> '[ input-slice _ parse-satisfy ] ;
TUPLE: range-parser min max ; TUPLE: range-parser min max ;
: parse-range ( input min max -- result ) : parse-range ( input min max -- result )
pick empty? [ pick empty? [
3drop f 3drop f
] [ ] [
[ dup first ] 2dip between? [ [ dup first ] 2dip between? [
unclip-slice <parse-result> unclip-slice <parse-result>
] [ ] [
drop f drop f
] if ] if
] if ; ] if ;
M: range-parser (compile) ( peg -- quot ) M: range-parser (compile) ( peg -- quot )
[ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ; [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
TUPLE: seq-parser parsers ; TUPLE: seq-parser parsers ;
: ignore? ( ast -- bool ) : ignore? ( ast -- bool )
ignore = ; ignore = ;
: calc-seq-result ( prev-result current-result -- next-result ) : calc-seq-result ( prev-result current-result -- next-result )
[ [
[ remaining>> swap remaining<< ] 2keep [ remaining>> swap remaining<< ] 2keep
ast>> dup ignore? [ ast>> dup ignore? [
drop drop
] [
swap [ ast>> push ] keep
] if
] [ ] [
swap [ ast>> push ] keep drop f
] if ] if* ;
] [
drop f
] if* ;
: parse-seq-element ( result quot -- result ) : parse-seq-element ( result quot -- result )
over [ over [
call calc-seq-result call calc-seq-result
] [ ] [
2drop f 2drop f
] if ; inline ] if ; inline
M: seq-parser (compile) ( peg -- quot ) M: seq-parser (compile) ( peg -- quot )
[
[ input-slice V{ } clone <parse-result> ] %
[ [
parsers>> unclip compile-parser-quot [ parse-seq-element ] curry , [ input-slice V{ } clone <parse-result> ] %
[ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each [
] { } make , \ 1&& , parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
] [ ] make ; [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
] { } make , \ 1&& ,
] [ ] make ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( peg -- quot ) M: choice-parser (compile) ( peg -- quot )
[
[ [
parsers>> [ compile-parser-quot ] map [
unclip , [ [ merge-errors ] compose , ] each parsers>> [ compile-parser-quot ] map
] { } make , \ 0|| , unclip , [ [ merge-errors ] compose , ] each
] [ ] make ; ] { } make , \ 0|| ,
] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;
: (repeat) ( quot: ( -- result ) result -- result ) : (repeat) ( quot: ( -- result ) result -- result )
over call [ over call [
[ remaining>> swap remaining<< ] 2keep [ remaining>> swap remaining<< ] 2keep
ast>> swap [ ast>> push ] keep ast>> swap [ ast>> push ] keep
(repeat) (repeat)
] [ ] [
nip nip
] if* ; inline recursive ] if* ; inline recursive
M: repeat0-parser (compile) ( peg -- quot ) M: repeat0-parser (compile) ( peg -- quot )
p1>> compile-parser-quot '[ p1>> compile-parser-quot '[
input-slice V{ } clone <parse-result> _ swap (repeat) input-slice V{ } clone <parse-result> _ swap (repeat)
] ; ] ;
TUPLE: repeat1-parser p1 ; TUPLE: repeat1-parser p1 ;
: repeat1-empty-check ( result -- result ) : repeat1-empty-check ( result -- result )
[ [
dup ast>> empty? [ drop f ] when dup ast>> empty? [ drop f ] when
] [ ] [
f f
] if* ; ] if* ;
M: repeat1-parser (compile) ( peg -- quot ) M: repeat1-parser (compile) ( peg -- quot )
p1>> compile-parser-quot '[ p1>> compile-parser-quot '[
input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
] ; ] ;
TUPLE: optional-parser p1 ; TUPLE: optional-parser p1 ;
: check-optional ( result -- result ) : check-optional ( result -- result )
[ input-slice f <parse-result> ] unless* ; [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( peg -- quot ) M: optional-parser (compile) ( peg -- quot )
p1>> compile-parser-quot '[ @ check-optional ] ; p1>> compile-parser-quot '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ; TUPLE: semantic-parser p1 quot ;
: check-semantic ( result quot -- result ) : check-semantic ( result quot -- result )
over [ over [
over ast>> swap call [ drop f ] unless over ast>> swap call [ drop f ] unless
] [ ] [
drop drop
] if ; inline ] if ; inline
M: semantic-parser (compile) ( peg -- quot ) M: semantic-parser (compile) ( peg -- quot )
[ p1>> compile-parser-quot ] [ quot>> ] bi [ p1>> compile-parser-quot ] [ quot>> ] bi
'[ @ _ check-semantic ] ; '[ @ _ check-semantic ] ;
TUPLE: ensure-parser p1 ; TUPLE: ensure-parser p1 ;
: check-ensure ( old-input result -- result ) : check-ensure ( old-input result -- result )
[ ignore <parse-result> ] [ drop f ] if ; [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( peg -- quot ) M: ensure-parser (compile) ( peg -- quot )
p1>> compile-parser-quot '[ input-slice @ check-ensure ] ; p1>> compile-parser-quot '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
: check-ensure-not ( old-input result -- result ) : check-ensure-not ( old-input result -- result )
[ drop f ] [ ignore <parse-result> ] if ; [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( peg -- quot ) M: ensure-not-parser (compile) ( peg -- quot )
p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ; p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
: check-action ( result quot -- result ) : check-action ( result quot -- result )
over [ over [
over ast>> swap call( ast -- ast ) >>ast over ast>> swap call( ast -- ast ) >>ast
] [ ] [
drop drop
] if ; ] if ;
M: action-parser (compile) ( peg -- quot ) M: action-parser (compile) ( peg -- quot )
[ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ; [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot ) M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser-quot '[ p1>> compile-parser-quot '[
input-slice [ blank? ] trim-head-slice input-from pos set @ input-slice [ blank? ] trim-head-slice input-from pos set @
] ; ] ;
TUPLE: delay-parser quot ; TUPLE: delay-parser quot ;
M: delay-parser (compile) ( peg -- quot ) M: delay-parser (compile) ( peg -- quot )
#! For efficiency we memoize the quotation. #! For efficiency we memoize the quotation.
#! This way it is run only once and the #! This way it is run only once and the
#! parser constructed once at run time. #! parser constructed once at run time.
quot>> gensym [ delayed get set-at ] keep 1quotation ; quot>> gensym [ delayed get set-at ] keep 1quotation ;
TUPLE: box-parser quot ; TUPLE: box-parser quot ;
M: box-parser (compile) ( peg -- quot ) M: box-parser (compile) ( peg -- quot )
#! Calls the quotation at compile time #! Calls the quotation at compile time
#! to produce the parser to be compiled. #! to produce the parser to be compiled.
#! This differs from 'delay' which calls #! This differs from 'delay' which calls
#! it at run time. #! it at run time.
quot>> call( -- parser ) compile-parser-quot ; quot>> call( -- parser ) compile-parser-quot ;
PRIVATE> PRIVATE>
: token ( string -- parser ) : token ( string -- parser )
token-parser boa wrap-peg ; token-parser boa wrap-peg ;
: satisfy ( quot -- parser ) : satisfy ( quot -- parser )
satisfy-parser boa wrap-peg ; satisfy-parser boa wrap-peg ;
: range ( min max -- parser ) : range ( min max -- parser )
range-parser boa wrap-peg ; range-parser boa wrap-peg ;
: seq ( seq -- parser ) : seq ( seq -- parser )
seq-parser boa wrap-peg ; seq-parser boa wrap-peg ;
: 2seq ( parser1 parser2 -- parser ) : 2seq ( parser1 parser2 -- parser )
2array seq ; 2array seq ;
: 3seq ( parser1 parser2 parser3 -- parser ) : 3seq ( parser1 parser2 parser3 -- parser )
3array seq ; 3array seq ;
: 4seq ( parser1 parser2 parser3 parser4 -- parser ) : 4seq ( parser1 parser2 parser3 parser4 -- parser )
4array seq ; 4array seq ;
: seq* ( quot -- paser ) : seq* ( quot -- paser )
{ } make seq ; inline { } make seq ; inline
: choice ( seq -- parser ) : choice ( seq -- parser )
choice-parser boa wrap-peg ; choice-parser boa wrap-peg ;
: 2choice ( parser1 parser2 -- parser ) : 2choice ( parser1 parser2 -- parser )
2array choice ; 2array choice ;
: 3choice ( parser1 parser2 parser3 -- parser ) : 3choice ( parser1 parser2 parser3 -- parser )
3array choice ; 3array choice ;
: 4choice ( parser1 parser2 parser3 parser4 -- parser ) : 4choice ( parser1 parser2 parser3 parser4 -- parser )
4array choice ; 4array choice ;
: choice* ( quot -- paser ) : choice* ( quot -- paser )
{ } make choice ; inline { } make choice ; inline
: repeat0 ( parser -- parser ) : repeat0 ( parser -- parser )
repeat0-parser boa wrap-peg ; repeat0-parser boa wrap-peg ;
: repeat1 ( parser -- parser ) : repeat1 ( parser -- parser )
repeat1-parser boa wrap-peg ; repeat1-parser boa wrap-peg ;
: optional ( parser -- parser ) : optional ( parser -- parser )
optional-parser boa wrap-peg ; optional-parser boa wrap-peg ;
: semantic ( parser quot -- parser ) : semantic ( parser quot -- parser )
semantic-parser boa wrap-peg ; semantic-parser boa wrap-peg ;
: ensure ( parser -- parser ) : ensure ( parser -- parser )
ensure-parser boa wrap-peg ; ensure-parser boa wrap-peg ;
: ensure-not ( parser -- parser ) : ensure-not ( parser -- parser )
ensure-not-parser boa wrap-peg ; ensure-not-parser boa wrap-peg ;
: action ( parser quot -- parser ) : action ( parser quot -- parser )
action-parser boa wrap-peg ; action-parser boa wrap-peg ;
: sp ( parser -- parser ) : sp ( parser -- parser )
sp-parser boa wrap-peg ; sp-parser boa wrap-peg ;
: hide ( parser -- parser ) : hide ( parser -- parser )
[ drop ignore ] action ; [ drop ignore ] action ;
: delay ( quot -- parser ) : delay ( quot -- parser )
delay-parser boa wrap-peg ; delay-parser boa wrap-peg ;
: box ( quot -- parser ) : box ( quot -- parser )
#! because a box has its quotation run at compile time #! because a box has its quotation run at compile time
#! it must always have a new parser wrapper created, #! it must always have a new parser wrapper created,
#! not a cached one. This is because the same box, #! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word #! compiled twice can have a different compiled word
#! due to running at compile time. #! due to running at compile time.
#! Why the [ ] action at the end? Box parsers don't get #! Why the [ ] action at the end? Box parsers don't get
#! memoized during parsing due to all box parsers being #! memoized during parsing due to all box parsers being
#! unique. This breaks left recursion detection during the #! unique. This breaks left recursion detection during the
#! parse. The action adds an indirection with a parser type #! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how #! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed... #! to fix boxes so this isn't needed...
box-parser boa f next-id parser boa [ ] action ; box-parser boa f next-id parser boa [ ] action ;
ERROR: parse-failed input word ; ERROR: parse-failed input word ;

4
basis/ui/ui.factor
View File

@ -218,8 +218,8 @@ HOOK: resize-window ui-backend ( world dim -- )
M: object resize-window 2drop ; M: object resize-window 2drop ;
: relayout-window ( gadget -- ) : relayout-window ( gadget -- )
[ relayout ] [ relayout ]
[ find-world [ dup pref-dim resize-window ] when* ] bi ; [ find-world [ dup pref-dim resize-window ] when* ] bi ;
: with-ui ( quot: ( -- ) -- ) : with-ui ( quot: ( -- ) -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ; ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;

3
core/byte-arrays/byte-arrays-docs.factor
View File

@ -40,8 +40,7 @@ HELP: (byte-array)
HELP: >byte-array HELP: >byte-array
{ $values { "seq" "a sequence" } { "byte-array" byte-array } } { $values { "seq" "a sequence" } { "byte-array" byte-array } }
{ $description { $description "Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
"Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ; { $errors "Throws an error if the sequence contains elements other than integers." } ;
HELP: 1byte-array HELP: 1byte-array

8
extra/balloon-bomber/balloon-bomber.factor
View File

@ -14,7 +14,7 @@ IN: balloon-bomber
TUPLE: balloon-bomber < space-invaders ; TUPLE: balloon-bomber < space-invaders ;
: <balloon-bomber> ( -- cpu ) : <balloon-bomber> ( -- cpu )
balloon-bomber new cpu-init ; balloon-bomber new cpu-init ;
CONSTANT: rom-info { CONSTANT: rom-info {
{ 0x0000 "ballbomb/tn01" } { 0x0000 "ballbomb/tn01" }
@ -22,9 +22,9 @@ CONSTANT: rom-info {
{ 0x1000 "ballbomb/tn03" } { 0x1000 "ballbomb/tn03" }
{ 0x1800 "ballbomb/tn04" } { 0x1800 "ballbomb/tn04" }
{ 0x4000 "ballbomb/tn05-1" } { 0x4000 "ballbomb/tn05-1" }
} }
: run-balloon ( -- ) : run-balloon ( -- )
[ "Balloon Bomber" <balloon-bomber> rom-info (run) ] with-ui ; [ "Balloon Bomber" <balloon-bomber> rom-info (run) ] with-ui ;
MAIN: run-balloon MAIN: run-balloon

36
extra/ctags/ctags.factor
View File

@ -10,35 +10,35 @@ namespaces make words sorting present ;
IN: ctags IN: ctags
: ctag-word ( ctag -- word ) : ctag-word ( ctag -- word )
first ; first ;
: ctag-path ( ctag -- path ) : ctag-path ( ctag -- path )
second first ; second first ;
: ctag-lineno ( ctag -- n ) : ctag-lineno ( ctag -- n )
second second ; second second ;
: ctag ( seq -- str ) : ctag ( seq -- str )
[ [
dup ctag-word present % dup ctag-word present %
"\t" % "\t" %
dup ctag-path normalize-path % dup ctag-path normalize-path %
"\t" % "\t" %
ctag-lineno number>string % ctag-lineno number>string %
] "" make ; ] "" make ;
: ctag-strings ( alist -- seq ) : ctag-strings ( alist -- seq )
[ ctag ] map ; [ ctag ] map ;
: ctags-write ( seq path -- ) : ctags-write ( seq path -- )
[ ctag-strings ] dip ascii set-file-lines ; [ ctag-strings ] dip ascii set-file-lines ;
: (ctags) ( -- seq ) : (ctags) ( -- seq )
all-words [ all-words [
dup where [ dup where [
2array 2array
] when* ] when*
] map [ sequence? ] filter ; ] map [ sequence? ] filter ;
: ctags ( path -- ) : ctags ( path -- )
(ctags) sort-keys swap ctags-write ; (ctags) sort-keys swap ctags-write ;

442
extra/fjsc/fjsc.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel peg strings sequences math math.parser USING: accessors kernel peg strings sequences math math.parser
namespaces make words quotations arrays hashtables io namespaces make words quotations arrays hashtables io
io.streams.string assocs ascii peg.parsers words.symbol ; io.streams.string assocs ascii peg.parsers words.symbol
combinators.short-circuit ;
IN: fjsc IN: fjsc
TUPLE: ast-number value ; TUPLE: ast-number value ;
@ -21,348 +22,351 @@ TUPLE: ast-in name ;
TUPLE: ast-hashtable elements ; TUPLE: ast-hashtable elements ;
: identifier-middle? ( ch -- bool ) : identifier-middle? ( ch -- bool )
[ blank? not ] keep {
[ "}];\"" member? not ] keep [ blank? not ]
digit? not [ "}];\"" member? not ]
and and ; [ digit? not ]
} 1&& ;
: 'identifier-ends' ( -- parser ) : 'identifier-ends' ( -- parser )
[ [
[ blank? not ] keep {
[ CHAR: " = not ] keep [ blank? not ]
[ CHAR: ; = not ] keep [ CHAR: " = not ]
[ LETTER? not ] keep [ CHAR: ; = not ]
[ letter? not ] keep [ LETTER? not ]
identifier-middle? not [ letter? not ]
and and and and and [ identifier-middle? not ]
] satisfy repeat0 ; } 1&&
] satisfy repeat0 ;
: 'identifier-middle' ( -- parser ) : 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy repeat1 ; [ identifier-middle? ] satisfy repeat1 ;
: 'identifier' ( -- parser ) : 'identifier' ( -- parser )
[ [
'identifier-ends' , 'identifier-ends' ,
'identifier-middle' , 'identifier-middle' ,
'identifier-ends' , 'identifier-ends' ,
] seq* [ ] seq* [
"" concat-as f ast-identifier boa "" concat-as f ast-identifier boa
] action ; ] action ;
DEFER: 'expression' DEFER: 'expression'
: 'effect-name' ( -- parser ) : 'effect-name' ( -- parser )
[ [
[ blank? not ] keep {
[ CHAR: ) = not ] keep [ blank? not ]
CHAR: - = not [ CHAR: ) = not ]
and and [ CHAR: - = not ]
] satisfy repeat1 [ >string ] action ; } 1&&
] satisfy repeat1 [ >string ] action ;
: 'stack-effect' ( -- parser ) : 'stack-effect' ( -- parser )
[ [
"(" token hide , "(" token hide ,
'effect-name' sp repeat0 , 'effect-name' sp repeat0 ,
"--" token sp hide , "--" token sp hide ,
'effect-name' sp repeat0 , 'effect-name' sp repeat0 ,
")" token sp hide , ")" token sp hide ,
] seq* [ ] seq* [
first2 ast-stack-effect boa first2 ast-stack-effect boa
] action ; ] action ;
: 'define' ( -- parser ) : 'define' ( -- parser )
[ [
":" token sp hide , ":" token sp hide ,
'identifier' sp [ value>> ] action , 'identifier' sp [ value>> ] action ,
'stack-effect' sp optional , 'stack-effect' sp optional ,
'expression' , 'expression' ,
";" token sp hide , ";" token sp hide ,
] seq* [ first3 ast-define boa ] action ; ] seq* [ first3 ast-define boa ] action ;
: 'quotation' ( -- parser ) : 'quotation' ( -- parser )
[ [
"[" token sp hide , "[" token sp hide ,
'expression' [ values>> ] action , 'expression' [ values>> ] action ,
"]" token sp hide , "]" token sp hide ,
] seq* [ first ast-quotation boa ] action ; ] seq* [ first ast-quotation boa ] action ;
: 'array' ( -- parser ) : 'array' ( -- parser )
[ [
"{" token sp hide , "{" token sp hide ,
'expression' [ values>> ] action , 'expression' [ values>> ] action ,
"}" token sp hide , "}" token sp hide ,
] seq* [ first ast-array boa ] action ; ] seq* [ first ast-array boa ] action ;
: 'word' ( -- parser ) : 'word' ( -- parser )
[ [
"\\" token sp hide , "\\" token sp hide ,
'identifier' sp , 'identifier' sp ,
] seq* [ first value>> f ast-word boa ] action ; ] seq* [ first value>> f ast-word boa ] action ;
: 'atom' ( -- parser ) : 'atom' ( -- parser )
[ [
'identifier' , 'identifier' ,
'integer' [ ast-number boa ] action , 'integer' [ ast-number boa ] action ,
'string' [ ast-string boa ] action , 'string' [ ast-string boa ] action ,
] choice* ; ] choice* ;
: 'comment' ( -- parser ) : 'comment' ( -- parser )
[
[ [
"#!" token sp , [
"!" token sp , "#!" token sp ,
] choice* hide , "!" token sp ,
[ ] choice* hide ,
dup CHAR: \n = swap CHAR: \r = or not [
] satisfy repeat0 , dup CHAR: \n = swap CHAR: \r = or not
] seq* [ drop ast-comment boa ] action ; ] satisfy repeat0 ,
] seq* [ drop ast-comment boa ] action ;
: 'USE:' ( -- parser ) : 'USE:' ( -- parser )
[ [
"USE:" token sp hide , "USE:" token sp hide ,
'identifier' sp , 'identifier' sp ,
] seq* [ first value>> ast-use boa ] action ; ] seq* [ first value>> ast-use boa ] action ;
: 'IN:' ( -- parser ) : 'IN:' ( -- parser )
[ [
"IN:" token sp hide , "IN:" token sp hide ,
'identifier' sp , 'identifier' sp ,
] seq* [ first value>> ast-in boa ] action ; ] seq* [ first value>> ast-in boa ] action ;
: 'USING:' ( -- parser ) : 'USING:' ( -- parser )
[ [
"USING:" token sp hide , "USING:" token sp hide ,
'identifier' sp [ value>> ] action repeat1 , 'identifier' sp [ value>> ] action repeat1 ,
";" token sp hide , ";" token sp hide ,
] seq* [ first ast-using boa ] action ; ] seq* [ first ast-using boa ] action ;
: 'hashtable' ( -- parser ) : 'hashtable' ( -- parser )
[ [
"H{" token sp hide , "H{" token sp hide ,
'expression' [ values>> ] action , 'expression' [ values>> ] action ,
"}" token sp hide , "}" token sp hide ,
] seq* [ first ast-hashtable boa ] action ; ] seq* [ first ast-hashtable boa ] action ;
: 'parsing-word' ( -- parser ) : 'parsing-word' ( -- parser )
[ [
'USE:' , 'USE:' ,
'USING:' , 'USING:' ,
'IN:' , 'IN:' ,
] choice* ; ] choice* ;
: 'expression' ( -- parser ) : 'expression' ( -- parser )
[
[ [
'comment' , [
'parsing-word' sp , 'comment' ,
'quotation' sp , 'parsing-word' sp ,
'define' sp , 'quotation' sp ,
'array' sp , 'define' sp ,
'hashtable' sp , 'array' sp ,
'word' sp , 'hashtable' sp ,
'atom' sp , 'word' sp ,
] choice* repeat0 [ ast-expression boa ] action 'atom' sp ,
] delay ; ] choice* repeat0 [ ast-expression boa ] action
] delay ;
: 'statement' ( -- parser ) : 'statement' ( -- parser )
'expression' ; 'expression' ;
GENERIC: (compile) ( ast -- ) GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- ) GENERIC: (literal) ( ast -- )
M: ast-number (literal) M: ast-number (literal)
value>> number>string , ; value>> number>string , ;
M: ast-number (compile) M: ast-number (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (literal)
"," , ; "," , ;
M: ast-string (literal) M: ast-string (literal)
"\"" , "\"" ,
value>> , value>> ,
"\"" , ; "\"" , ;
M: ast-string (compile) M: ast-string (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (literal)
"," , ; "," , ;
M: ast-identifier (literal) M: ast-identifier (literal)
dup vocab>> [ dup vocab>> [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup vocab>> , dup vocab>> ,
"\",\"" , "\",\"" ,
value>> , value>> ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , value>> , "\")" , "factor.find_word(\"" , value>> , "\")" ,
] if ; ] if ;
M: ast-identifier (compile) M: ast-identifier (compile)
(literal) ".execute(" , ; (literal) ".execute(" , ;
M: ast-define (compile) M: ast-define (compile)
"factor.define_word(\"" , "factor.define_word(\"" ,
dup name>> , dup name>> ,
"\",\"source\"," , "\",\"source\"," ,
expression>> (compile) expression>> (compile)
"," , ; "," , ;
: do-expressions ( seq -- ) : do-expressions ( seq -- )
dup empty? not [ dup empty? not [
unclip unclip
dup ast-comment? not [ dup ast-comment? not [
"function() {" , "function() {" ,
(compile) (compile)
do-expressions do-expressions
")}" , ")}" ,
] [
drop do-expressions
] if
] [ ] [
drop do-expressions drop "factor.cont.next" ,
] if ] if ;
] [
drop "factor.cont.next" ,
] if ;
M: ast-quotation (literal) M: ast-quotation (literal)
"factor.make_quotation(\"source\"," , "factor.make_quotation(\"source\"," ,
values>> do-expressions values>> do-expressions
")" , ; ")" , ;
M: ast-quotation (compile) M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," , "factor.push_data(factor.make_quotation(\"source\"," ,
values>> do-expressions values>> do-expressions
")," , ; ")," , ;
M: ast-array (literal) M: ast-array (literal)
"[" , "[" ,
elements>> [ "," , ] [ (literal) ] interleave elements>> [ "," , ] [ (literal) ] interleave
"]" , ; "]" , ;
M: ast-array (compile) M: ast-array (compile)
"factor.push_data(" , (literal) "," , ; "factor.push_data(" , (literal) "," , ;
M: ast-hashtable (literal) M: ast-hashtable (literal)
"new Hashtable().fromAlist([" , "new Hashtable().fromAlist([" ,
elements>> [ "," , ] [ (literal) ] interleave elements>> [ "," , ] [ (literal) ] interleave
"])" , ; "])" , ;
M: ast-hashtable (compile) M: ast-hashtable (compile)
"factor.push_data(" , (literal) "," , ; "factor.push_data(" , (literal) "," , ;
M: ast-expression (literal) M: ast-expression (literal)
values>> [ values>> [
(literal) (literal)
] each ; ] each ;
M: ast-expression (compile) M: ast-expression (compile)
values>> do-expressions ; values>> do-expressions ;
M: ast-word (literal) M: ast-word (literal)
dup vocab>> [ dup vocab>> [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup vocab>> , dup vocab>> ,
"\",\"" , "\",\"" ,
value>> , value>> ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , value>> , "\")" , "factor.find_word(\"" , value>> , "\")" ,
] if ; ] if ;
M: ast-word (compile) M: ast-word (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (literal)
"," , ; "," , ;
M: ast-comment (compile) M: ast-comment (compile)
drop ; drop ;
M: ast-stack-effect (compile) M: ast-stack-effect (compile)
drop ; drop ;
M: ast-use (compile) M: ast-use (compile)
"factor.use(\"" , "factor.use(\"" ,
name>> , name>> ,
"\"," , ; "\"," , ;
M: ast-in (compile) M: ast-in (compile)
"factor.set_in(\"" , "factor.set_in(\"" ,
name>> , name>> ,
"\"," , ; "\"," , ;
M: ast-using (compile) M: ast-using (compile)
"factor.using([" , "factor.using([" ,
names>> [ names>> [
"," , "," ,
] [ ] [
"\"" , , "\"" , "\"" , , "\"" ,
] interleave ] interleave
"]," , ; "]," , ;
GENERIC: (parse-factor-quotation) ( object -- ast ) GENERIC: (parse-factor-quotation) ( object -- ast )
M: number (parse-factor-quotation) ( object -- ast ) M: number (parse-factor-quotation) ( object -- ast )
ast-number boa ; ast-number boa ;
M: symbol (parse-factor-quotation) ( object -- ast ) M: symbol (parse-factor-quotation) ( object -- ast )
dup >string swap vocabulary>> ast-identifier boa ; dup >string swap vocabulary>> ast-identifier boa ;
M: word (parse-factor-quotation) ( object -- ast ) M: word (parse-factor-quotation) ( object -- ast )
dup name>> swap vocabulary>> ast-identifier boa ; dup name>> swap vocabulary>> ast-identifier boa ;
M: string (parse-factor-quotation) ( object -- ast ) M: string (parse-factor-quotation) ( object -- ast )
ast-string boa ; ast-string boa ;
M: quotation (parse-factor-quotation) ( object -- ast ) M: quotation (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make ast-quotation boa ; ] { } make ast-quotation boa ;
M: array (parse-factor-quotation) ( object -- ast ) M: array (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make ast-array boa ; ] { } make ast-array boa ;
M: hashtable (parse-factor-quotation) ( object -- ast ) M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [ >alist [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make ast-hashtable boa ; ] { } make ast-hashtable boa ;
M: wrapper (parse-factor-quotation) ( object -- ast ) M: wrapper (parse-factor-quotation) ( object -- ast )
wrapped>> dup name>> swap vocabulary>> ast-word boa ; wrapped>> dup name>> swap vocabulary>> ast-word boa ;
GENERIC: fjsc-parse ( object -- ast ) GENERIC: fjsc-parse ( object -- ast )
M: string fjsc-parse ( object -- ast ) M: string fjsc-parse ( object -- ast )
'expression' parse ; 'expression' parse ;
M: quotation fjsc-parse ( object -- ast ) M: quotation fjsc-parse ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make ast-expression boa ; ] { } make ast-expression boa ;
: fjsc-compile ( ast -- string ) : fjsc-compile ( ast -- string )
[
[ [
"(" , [
(compile) "(" ,
")" , (compile)
] { } make [ write ] each ")" ,
] with-string-writer ; ] { } make [ write ] each
] with-string-writer ;
: fjsc-compile* ( string -- string ) : fjsc-compile* ( string -- string )
'statement' parse fjsc-compile ; 'statement' parse fjsc-compile ;
: fc* ( string -- ) : fc* ( string -- )
[ [
'statement' parse values>> do-expressions 'statement' parse values>> do-expressions
] { } make [ write ] each ; ] { } make [ write ] each ;
: fjsc-literal ( ast -- string ) : fjsc-literal ( ast -- string )
[ [
[ (literal) ] { } make [ write ] each [ (literal) ] { } make [ write ] each
] with-string-writer ; ] with-string-writer ;

210
extra/libudev/libudev.factor
View File

@ -11,12 +11,12 @@ LIBRARY: libudev
C-TYPE: udev C-TYPE: udev
FUNCTION: udev* udev_ref ( FUNCTION: udev* udev_ref (
udev* udev ) ; udev* udev ) ;
FUNCTION: void udev_unref ( FUNCTION: void udev_unref (
udev* udev ) ; udev* udev ) ;
@ -33,63 +33,63 @@ CALLBACK: void udev_set_log_fn_callback (
c-string format ) ; c-string format ) ;
! va_list args ) ; ! va_list args ) ;
FUNCTION: void udev_set_log_fn ( FUNCTION: void udev_set_log_fn (
udev* udev, udev* udev,
udev_set_log_fn_callback log_fn ) ; udev_set_log_fn_callback log_fn ) ;
FUNCTION: int udev_get_log_priority ( FUNCTION: int udev_get_log_priority (
udev* udev ) ; udev* udev ) ;
FUNCTION: void udev_set_log_priority ( FUNCTION: void udev_set_log_priority (
udev* udev, udev* udev,
int priority ) ; int priority ) ;
FUNCTION: c-string udev_get_sys_path ( FUNCTION: c-string udev_get_sys_path (
udev* udev ) ; udev* udev ) ;
FUNCTION: c-string udev_get_dev_path ( FUNCTION: c-string udev_get_dev_path (
udev* udev ) ; udev* udev ) ;
FUNCTION: void* udev_get_userdata ( FUNCTION: void* udev_get_userdata (
udev* udev ) ; udev* udev ) ;
FUNCTION: void udev_set_userdata ( FUNCTION: void udev_set_userdata (
udev* udev, udev* udev,
void* userdata ) ; void* userdata ) ;
C-TYPE: udev_list_entry C-TYPE: udev_list_entry
FUNCTION: udev_list_entry* udev_list_entry_get_next ( FUNCTION: udev_list_entry* udev_list_entry_get_next (
udev_list_entry* list_entry ) ; udev_list_entry* list_entry ) ;
FUNCTION: udev_list_entry* udev_list_entry_get_by_name ( FUNCTION: udev_list_entry* udev_list_entry_get_by_name (
udev_list_entry* list_entry, udev_list_entry* list_entry,
c-string name ) ; c-string name ) ;
FUNCTION: c-string udev_list_entry_get_name ( FUNCTION: c-string udev_list_entry_get_name (
udev_list_entry* list_entry ) ; udev_list_entry* list_entry ) ;
FUNCTION: c-string udev_list_entry_get_value ( FUNCTION: c-string udev_list_entry_get_value (
udev_list_entry* list_entry ) ; udev_list_entry* list_entry ) ;
@ -107,340 +107,340 @@ FUNCTION: c-string udev_list_entry_get_value (
C-TYPE: udev_device C-TYPE: udev_device
FUNCTION: udev_device* udev_device_ref ( FUNCTION: udev_device* udev_device_ref (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: void udev_device_unref ( FUNCTION: void udev_device_unref (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: udev* udev_device_get_udev ( FUNCTION: udev* udev_device_get_udev (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: udev_device* udev_device_new_from_syspath ( FUNCTION: udev_device* udev_device_new_from_syspath (
udev* udev, udev* udev,
c-string syspath ) ; c-string syspath ) ;
FUNCTION: udev_device* udev_device_new_from_devnum ( FUNCTION: udev_device* udev_device_new_from_devnum (
udev* udev, udev* udev,
char type, char type,
dev_t devnum ) ; dev_t devnum ) ;
FUNCTION: udev_device* udev_device_new_from_subsystem_sysname ( FUNCTION: udev_device* udev_device_new_from_subsystem_sysname (
udev* udev, udev* udev,
c-string subsystem, c-string subsystem,
c-string sysname ) ; c-string sysname ) ;
FUNCTION: udev_device* udev_device_get_parent ( FUNCTION: udev_device* udev_device_get_parent (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype ( FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype (
udev_device* udev_device, udev_device* udev_device,
c-string subsystem, c-string subsystem,
c-string devtype ) ; c-string devtype ) ;
FUNCTION: c-string udev_device_get_devpath ( FUNCTION: c-string udev_device_get_devpath (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_subsystem ( FUNCTION: c-string udev_device_get_subsystem (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_devtype ( FUNCTION: c-string udev_device_get_devtype (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_syspath ( FUNCTION: c-string udev_device_get_syspath (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_sysname ( FUNCTION: c-string udev_device_get_sysname (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_sysnum ( FUNCTION: c-string udev_device_get_sysnum (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_devnode ( FUNCTION: c-string udev_device_get_devnode (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: udev_list_entry* udev_device_get_devlinks_list_entry ( FUNCTION: udev_list_entry* udev_device_get_devlinks_list_entry (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: udev_list_entry* udev_device_get_properties_list_entry ( FUNCTION: udev_list_entry* udev_device_get_properties_list_entry (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_property_value ( FUNCTION: c-string udev_device_get_property_value (
udev_device* udev_device, udev_device* udev_device,
c-string key ) ; c-string key ) ;
FUNCTION: c-string udev_device_get_driver ( FUNCTION: c-string udev_device_get_driver (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: dev_t udev_device_get_devnum ( FUNCTION: dev_t udev_device_get_devnum (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_action ( FUNCTION: c-string udev_device_get_action (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: ulonglong udev_device_get_seqnum ( FUNCTION: ulonglong udev_device_get_seqnum (
udev_device* udev_device ) ; udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_sysattr_value ( FUNCTION: c-string udev_device_get_sysattr_value (
udev_device* udev_device, udev_device* udev_device,
c-string sysattr ) ; c-string sysattr ) ;
C-TYPE: udev_monitor C-TYPE: udev_monitor
FUNCTION: udev_monitor* udev_monitor_ref ( FUNCTION: udev_monitor* udev_monitor_ref (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: void udev_monitor_unref ( FUNCTION: void udev_monitor_unref (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: udev* udev_monitor_get_udev ( FUNCTION: udev* udev_monitor_get_udev (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: udev_monitor* udev_monitor_new_from_netlink ( FUNCTION: udev_monitor* udev_monitor_new_from_netlink (
udev* udev, udev* udev,
c-string name ) ; c-string name ) ;
FUNCTION: udev_monitor* udev_monitor_new_from_socket ( FUNCTION: udev_monitor* udev_monitor_new_from_socket (
udev* udev, udev* udev,
c-string socket_path ) ; c-string socket_path ) ;
FUNCTION: int udev_monitor_enable_receiving ( FUNCTION: int udev_monitor_enable_receiving (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: int udev_monitor_set_receive_buffer_size ( FUNCTION: int udev_monitor_set_receive_buffer_size (
udev_monitor* udev_monitor, udev_monitor* udev_monitor,
int size ) ; int size ) ;
FUNCTION: int udev_monitor_get_fd ( FUNCTION: int udev_monitor_get_fd (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: udev_device* udev_monitor_receive_device ( FUNCTION: udev_device* udev_monitor_receive_device (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype ( FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype (
udev_monitor* udev_monitor, udev_monitor* udev_monitor,
c-string subsystem, c-string subsystem,
c-string devtype ) ; c-string devtype ) ;
FUNCTION: int udev_monitor_filter_update ( FUNCTION: int udev_monitor_filter_update (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
FUNCTION: int udev_monitor_filter_remove ( FUNCTION: int udev_monitor_filter_remove (
udev_monitor* udev_monitor ) ; udev_monitor* udev_monitor ) ;
C-TYPE: udev_enumerate C-TYPE: udev_enumerate
FUNCTION: udev_enumerate* udev_enumerate_ref ( FUNCTION: udev_enumerate* udev_enumerate_ref (
udev_enumerate* udev_enumerate ) ; udev_enumerate* udev_enumerate ) ;
FUNCTION: void udev_enumerate_unref ( FUNCTION: void udev_enumerate_unref (
udev_enumerate* udev_enumerate ) ; udev_enumerate* udev_enumerate ) ;
FUNCTION: udev* udev_enumerate_get_udev ( FUNCTION: udev* udev_enumerate_get_udev (
udev_enumerate* udev_enumerate ) ; udev_enumerate* udev_enumerate ) ;
FUNCTION: udev_enumerate* udev_enumerate_new ( FUNCTION: udev_enumerate* udev_enumerate_new (
udev* udev ) ; udev* udev ) ;
FUNCTION: int udev_enumerate_add_match_subsystem ( FUNCTION: int udev_enumerate_add_match_subsystem (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string subsystem ) ; c-string subsystem ) ;
FUNCTION: int udev_enumerate_add_nomatch_subsystem ( FUNCTION: int udev_enumerate_add_nomatch_subsystem (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string subsystem ) ; c-string subsystem ) ;
FUNCTION: int udev_enumerate_add_match_sysattr ( FUNCTION: int udev_enumerate_add_match_sysattr (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string sysattr, c-string sysattr,
c-string value ) ; c-string value ) ;
FUNCTION: int udev_enumerate_add_nomatch_sysattr ( FUNCTION: int udev_enumerate_add_nomatch_sysattr (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string sysattr, c-string sysattr,
c-string value ) ; c-string value ) ;
FUNCTION: int udev_enumerate_add_match_property ( FUNCTION: int udev_enumerate_add_match_property (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string property, c-string property,
c-string value ) ; c-string value ) ;
FUNCTION: int udev_enumerate_add_match_sysname ( FUNCTION: int udev_enumerate_add_match_sysname (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string sysname ) ; c-string sysname ) ;
FUNCTION: int udev_enumerate_add_syspath ( FUNCTION: int udev_enumerate_add_syspath (
udev_enumerate* udev_enumerate, udev_enumerate* udev_enumerate,
c-string syspath ) ; c-string syspath ) ;
FUNCTION: int udev_enumerate_scan_devices ( FUNCTION: int udev_enumerate_scan_devices (
udev_enumerate* udev_enumerate ) ; udev_enumerate* udev_enumerate ) ;
FUNCTION: int udev_enumerate_scan_subsystems ( FUNCTION: int udev_enumerate_scan_subsystems (
udev_enumerate* udev_enumerate ) ; udev_enumerate* udev_enumerate ) ;
FUNCTION: udev_list_entry* udev_enumerate_get_list_entry ( FUNCTION: udev_list_entry* udev_enumerate_get_list_entry (
udev_enumerate* udev_enumerate ) ; udev_enumerate* udev_enumerate ) ;
C-TYPE: udev_queue C-TYPE: udev_queue
FUNCTION: udev_queue* udev_queue_ref ( FUNCTION: udev_queue* udev_queue_ref (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: void udev_queue_unref ( FUNCTION: void udev_queue_unref (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: udev* udev_queue_get_udev ( FUNCTION: udev* udev_queue_get_udev (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: udev_queue* udev_queue_new ( FUNCTION: udev_queue* udev_queue_new (
udev* udev ) ; udev* udev ) ;
FUNCTION: ulonglong udev_queue_get_kernel_seqnum ( FUNCTION: ulonglong udev_queue_get_kernel_seqnum (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: ulonglong udev_queue_get_udev_seqnum ( FUNCTION: ulonglong udev_queue_get_udev_seqnum (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: int udev_queue_get_udev_is_active ( FUNCTION: int udev_queue_get_udev_is_active (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: int udev_queue_get_queue_is_empty ( FUNCTION: int udev_queue_get_queue_is_empty (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: int udev_queue_get_seqnum_is_finished ( FUNCTION: int udev_queue_get_seqnum_is_finished (
udev_queue* udev_queue, udev_queue* udev_queue,
ulonglong seqnum ) ; ulonglong seqnum ) ;
FUNCTION: int udev_queue_get_seqnum_sequence_is_finished ( FUNCTION: int udev_queue_get_seqnum_sequence_is_finished (
udev_queue* udev_queue, udev_queue* udev_queue,
ulonglong start, ulonglong start,
ulonglong end ) ; ulonglong end ) ;
FUNCTION: udev_list_entry* udev_queue_get_queued_list_entry ( FUNCTION: udev_list_entry* udev_queue_get_queued_list_entry (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;
FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry ( FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry (
udev_queue* udev_queue ) ; udev_queue* udev_queue ) ;

6
extra/lunar-rescue/lunar-rescue.factor
View File

@ -14,7 +14,7 @@ IN: lunar-rescue
TUPLE: lunar-rescue < space-invaders ; TUPLE: lunar-rescue < space-invaders ;
: <lunar-rescue> ( -- cpu ) : <lunar-rescue> ( -- cpu )
lunar-rescue new cpu-init ; lunar-rescue new cpu-init ;
CONSTANT: rom-info { CONSTANT: rom-info {
{ 0x0000 "lrescue/lrescue.1" } { 0x0000 "lrescue/lrescue.1" }
@ -23,9 +23,9 @@ CONSTANT: rom-info {
{ 0x1800 "lrescue/lrescue.4" } { 0x1800 "lrescue/lrescue.4" }
{ 0x4000 "lrescue/lrescue.5" } { 0x4000 "lrescue/lrescue.5" }
{ 0x4800 "lrescue/lrescue.6" } { 0x4800 "lrescue/lrescue.6" }
} }
: run-lunar ( -- ) : run-lunar ( -- )
[ "Lunar Rescue" <lunar-rescue> rom-info (run) ] with-ui ; [ "Lunar Rescue" <lunar-rescue> rom-info (run) ] with-ui ;
MAIN: run-lunar MAIN: run-lunar

20
extra/s3/s3.factor
View File

@ -54,12 +54,12 @@ TUPLE: s3-request path mime-type date method headers bucket data ;
":" % ":" %
signature secret-key get sha1 hmac-bytes >base64 % signature secret-key get sha1 hmac-bytes >base64 %
] "" make ; ] "" make ;
: s3-url ( s3-request -- string ) : s3-url ( s3-request -- string )
[ [
"http://" % "http://" %
dup bucket>> [ % "." % ] when* dup bucket>> [ % "." % ] when*
"s3.amazonaws.com" % "s3.amazonaws.com" %
path>> % path>> %
] "" make ; ] "" make ;
@ -110,13 +110,13 @@ TUPLE: key name last-modified size ;
<PRIVATE <PRIVATE
: (keys) ( xml -- seq ) : (keys) ( xml -- seq )
"Contents" tags-named [ "Contents" tags-named [
[ "Key" tag-named children>string ] [ "Key" tag-named children>string ]
[ "LastModified" tag-named children>string ] [ "LastModified" tag-named children>string ]
[ "Size" tag-named children>string ] [ "Size" tag-named children>string ]
tri key boa tri key boa
] map ; ] map ;
PRIVATE> PRIVATE>
: keys ( bucket -- seq ) : keys ( bucket -- seq )
"/" H{ } clone s3-get "/" H{ } clone s3-get
nip >string string>xml (keys) ; nip >string string>xml (keys) ;
@ -138,7 +138,7 @@ PRIVATE>
: delete-bucket ( bucket -- ) : delete-bucket ( bucket -- )
"/" H{ } clone "DELETE" <s3-request> "/" H{ } clone "DELETE" <s3-request>
dup s3-url <delete-request> sign-http-request http-request 2drop ; dup s3-url <delete-request> sign-http-request http-request 2drop ;
: put-object ( data mime-type bucket key headers -- ) : put-object ( data mime-type bucket key headers -- )
[ "/" prepend ] dip "PUT" <s3-request> [ "/" prepend ] dip "PUT" <s3-request>
over >>mime-type over >>mime-type

428
extra/space-invaders/space-invaders.factor
View File

@ -37,11 +37,11 @@ CONSTANT: game-width 224
CONSTANT: game-height 256 CONSTANT: game-height 256
: make-opengl-bitmap ( -- array ) : make-opengl-bitmap ( -- array )
game-height game-width 3 * * uchar <c-array> ; game-height game-width 3 * * uchar <c-array> ;
: bitmap-index ( point -- index ) : bitmap-index ( point -- index )
#! Point is a {x y}. #! Point is a {x y}.
first2 game-width 3 * * swap 3 * + ; first2 game-width 3 * * swap 3 * + ;
:: set-bitmap-pixel ( bitmap point color -- ) :: set-bitmap-pixel ( bitmap point color -- )
point bitmap-index :> index point bitmap-index :> index
@ -50,12 +50,12 @@ CONSTANT: game-height 256
color third index 2 + bitmap set-nth ; color third index 2 + bitmap set-nth ;
: get-bitmap-pixel ( point array -- color ) : get-bitmap-pixel ( point array -- color )
#! Point is a {x y}. color is a {r g b} #! Point is a {x y}. color is a {r g b}
[ bitmap-index ] dip [ bitmap-index ] dip
[ nth ] 2keep [ nth ] 2keep
[ [ 1 + ] dip nth ] 2keep [ [ 1 + ] dip nth ] 2keep
[ 2 + ] dip nth 3array ; [ 2 + ] dip nth 3array ;
CONSTANT: SOUND-SHOT 0 CONSTANT: SOUND-SHOT 0
CONSTANT: SOUND-UFO 1 CONSTANT: SOUND-UFO 1
CONSTANT: SOUND-BASE-HIT 2 CONSTANT: SOUND-BASE-HIT 2
@ -67,212 +67,212 @@ CONSTANT: SOUND-WALK4 7
CONSTANT: SOUND-UFO-HIT 8 CONSTANT: SOUND-UFO-HIT 8
: init-sound ( index cpu filename -- ) : init-sound ( index cpu filename -- )
absolute-path swapd [ sounds>> nth AL_BUFFER ] dip absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
create-buffer-from-wav set-source-param ; create-buffer-from-wav set-source-param ;
: init-sounds ( cpu -- ) : init-sounds ( cpu -- )
init-openal init-openal
[ 9 gen-sources swap sounds<< ] keep [ 9 gen-sources swap sounds<< ] keep
[ SOUND-SHOT "vocab:space-invaders/resources/Shot.wav" init-sound ] keep [ SOUND-SHOT "vocab:space-invaders/resources/Shot.wav" init-sound ] keep
[ SOUND-UFO "vocab:space-invaders/resources/Ufo.wav" init-sound ] keep [ SOUND-UFO "vocab:space-invaders/resources/Ufo.wav" init-sound ] keep
[ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep [ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
[ SOUND-BASE-HIT "vocab:space-invaders/resources/BaseHit.wav" init-sound ] keep [ SOUND-BASE-HIT "vocab:space-invaders/resources/BaseHit.wav" init-sound ] keep
[ SOUND-INVADER-HIT "vocab:space-invaders/resources/InvHit.Wav" init-sound ] keep [ SOUND-INVADER-HIT "vocab:space-invaders/resources/InvHit.Wav" init-sound ] keep
[ SOUND-WALK1 "vocab:space-invaders/resources/Walk1.wav" init-sound ] keep [ SOUND-WALK1 "vocab:space-invaders/resources/Walk1.wav" init-sound ] keep
[ SOUND-WALK2 "vocab:space-invaders/resources/Walk2.wav" init-sound ] keep [ SOUND-WALK2 "vocab:space-invaders/resources/Walk2.wav" init-sound ] keep
[ SOUND-WALK3 "vocab:space-invaders/resources/Walk3.wav" init-sound ] keep [ SOUND-WALK3 "vocab:space-invaders/resources/Walk3.wav" init-sound ] keep
[ SOUND-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep [ SOUND-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep
[ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep [ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep
f swap looping?<< ; f swap looping?<< ;
: cpu-init ( cpu -- cpu ) : cpu-init ( cpu -- cpu )
make-opengl-bitmap over bitmap<< make-opengl-bitmap over bitmap<<
[ init-sounds ] keep [ init-sounds ] keep
[ reset ] keep ; [ reset ] keep ;
: <space-invaders> ( -- cpu ) : <space-invaders> ( -- cpu )
space-invaders new cpu-init ; space-invaders new cpu-init ;
: play-invaders-sound ( cpu sound -- ) : play-invaders-sound ( cpu sound -- )
swap sounds>> nth source-play ; swap sounds>> nth source-play ;
: stop-invaders-sound ( cpu sound -- ) : stop-invaders-sound ( cpu sound -- )
swap sounds>> nth source-stop ; swap sounds>> nth source-stop ;
: read-port1 ( cpu -- byte ) : read-port1 ( cpu -- byte )
#! Port 1 maps the keys for space invaders #! Port 1 maps the keys for space invaders
#! Bit 0 = coin slot #! Bit 0 = coin slot
#! Bit 1 = two players button #! Bit 1 = two players button
#! Bit 2 = one player button #! Bit 2 = one player button
#! Bit 4 = player one fire #! Bit 4 = player one fire
#! Bit 5 = player one left #! Bit 5 = player one left
#! Bit 6 = player one right #! Bit 6 = player one right
[ port1>> dup 0xFE bitand ] keep [ port1>> dup 0xFE bitand ] keep
port1<< ; port1<< ;
: read-port2 ( cpu -- byte ) : read-port2 ( cpu -- byte )
#! Port 2 maps player 2 controls and dip switches #! Port 2 maps player 2 controls and dip switches
#! Bit 0,1 = number of ships #! Bit 0,1 = number of ships
#! Bit 2 = mode (1=easy, 0=hard) #! Bit 2 = mode (1=easy, 0=hard)
#! Bit 4 = player two fire #! Bit 4 = player two fire
#! Bit 5 = player two left #! Bit 5 = player two left
#! Bit 6 = player two right #! Bit 6 = player two right
#! Bit 7 = show or hide coin info #! Bit 7 = show or hide coin info
[ port2i>> 0x8F bitand ] keep [ port2i>> 0x8F bitand ] keep
port1>> 0x70 bitand bitor ; port1>> 0x70 bitand bitor ;
: read-port3 ( cpu -- byte ) : read-port3 ( cpu -- byte )
#! Used to compute a special formula #! Used to compute a special formula
[ port4hi>> 8 shift ] keep [ port4hi>> 8 shift ] keep
[ port4lo>> bitor ] keep [ port4lo>> bitor ] keep
port2o>> shift -8 shift 0xFF bitand ; port2o>> shift -8 shift 0xFF bitand ;
M: space-invaders read-port ( port cpu -- byte ) M: space-invaders read-port ( port cpu -- byte )
#! Read a byte from the hardware port. 'port' should #! Read a byte from the hardware port. 'port' should
#! be an 8-bit value. #! be an 8-bit value.
swap { swap {
{ 1 [ read-port1 ] } { 1 [ read-port1 ] }
{ 2 [ read-port2 ] } { 2 [ read-port2 ] }
{ 3 [ read-port3 ] } { 3 [ read-port3 ] }
[ 2drop 0 ] [ 2drop 0 ]
} case ; } case ;
: write-port2 ( value cpu -- ) : write-port2 ( value cpu -- )
#! Setting this value affects the value read from port 3 #! Setting this value affects the value read from port 3
port2o<< ; port2o<< ;
:: bit-newly-set? ( old-value new-value bit -- bool ) :: bit-newly-set? ( old-value new-value bit -- bool )
new-value bit bit? [ old-value bit bit? not ] dip and ; new-value bit bit? [ old-value bit bit? not ] dip and ;
: port3-newly-set? ( new-value cpu bit -- bool ) : port3-newly-set? ( new-value cpu bit -- bool )
[ port3o>> swap ] dip bit-newly-set? ; [ port3o>> swap ] dip bit-newly-set? ;
: port5-newly-set? ( new-value cpu bit -- bool ) : port5-newly-set? ( new-value cpu bit -- bool )
[ port5o>> swap ] dip bit-newly-set? ; [ port5o>> swap ] dip bit-newly-set? ;
: write-port3 ( value cpu -- ) : write-port3 ( value cpu -- )
#! Connected to the sound hardware #! Connected to the sound hardware
#! Bit 0 = spaceship sound (looped) #! Bit 0 = spaceship sound (looped)
#! Bit 1 = Shot #! Bit 1 = Shot
#! Bit 2 = Your ship hit #! Bit 2 = Your ship hit
#! Bit 3 = Invader hit #! Bit 3 = Invader hit
#! Bit 4 = Extended play sound #! Bit 4 = Extended play sound
over 0 bit? over looping?>> not and [ over 0 bit? over looping?>> not and [
dup SOUND-UFO play-invaders-sound dup SOUND-UFO play-invaders-sound
t over looping?<< t over looping?<<
] when ] when
over 0 bit? not over looping?>> and [ over 0 bit? not over looping?>> and [
dup SOUND-UFO stop-invaders-sound dup SOUND-UFO stop-invaders-sound
f over looping?<< f over looping?<<
] when ] when
2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when 2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when
2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when 2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when 2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when 2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
port3o<< ; port3o<< ;
: write-port4 ( value cpu -- ) : write-port4 ( value cpu -- )
#! Affects the value returned by reading port 3 #! Affects the value returned by reading port 3
[ port4hi>> ] keep [ port4hi>> ] keep
[ port4lo<< ] keep [ port4lo<< ] keep
port4hi<< ; port4hi<< ;
: write-port5 ( value cpu -- ) : write-port5 ( value cpu -- )
#! Plays sounds #! Plays sounds
#! Bit 0 = invaders sound 1 #! Bit 0 = invaders sound 1
#! Bit 1 = invaders sound 2 #! Bit 1 = invaders sound 2
#! Bit 2 = invaders sound 3 #! Bit 2 = invaders sound 3
#! Bit 3 = invaders sound 4 #! Bit 3 = invaders sound 4
#! Bit 4 = spaceship hit #! Bit 4 = spaceship hit
#! Bit 5 = amplifier enabled/disabled #! Bit 5 = amplifier enabled/disabled
2dup 0 port5-newly-set? [ dup SOUND-WALK1 play-invaders-sound ] when 2dup 0 port5-newly-set? [ dup SOUND-WALK1 play-invaders-sound ] when
2dup 1 port5-newly-set? [ dup SOUND-WALK2 play-invaders-sound ] when 2dup 1 port5-newly-set? [ dup SOUND-WALK2 play-invaders-sound ] when
2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when 2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when 2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when 2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
port5o<< ; port5o<< ;
M: space-invaders write-port ( value port cpu -- ) M: space-invaders write-port ( value port cpu -- )
#! Write a byte to the hardware port, where 'port' is #! Write a byte to the hardware port, where 'port' is
#! an 8-bit value. #! an 8-bit value.
swap { swap {
{ 2 [ write-port2 ] } { 2 [ write-port2 ] }
{ 3 [ write-port3 ] } { 3 [ write-port3 ] }
{ 4 [ write-port4 ] } { 4 [ write-port4 ] }
{ 5 [ write-port5 ] } { 5 [ write-port5 ] }
[ 3drop ] [ 3drop ]
} case ; } case ;
M: space-invaders reset ( cpu -- ) M: space-invaders reset ( cpu -- )
dup call-next-method dup call-next-method
0 >>port1 0 >>port1
0 >>port2i 0 >>port2i
0 >>port2o 0 >>port2o
0 >>port3o 0 >>port3o
0 >>port4lo 0 >>port4lo
0 >>port4hi 0 >>port4hi
0 >>port5o 0 >>port5o
drop ; drop ;
: gui-step ( cpu -- ) : gui-step ( cpu -- )
[ read-instruction ] keep ! n cpu [ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles over get-cycles over inc-cycles
[ swap instructions nth call( cpu -- ) ] keep [ swap instructions nth call( cpu -- ) ] keep
[ pc>> 0xFFFF bitand ] keep [ pc>> 0xFFFF bitand ] keep
pc<< ; pc<< ;
: gui-frame/2 ( cpu -- ) : gui-frame/2 ( cpu -- )
[ gui-step ] keep [ gui-step ] keep
[ cycles>> ] keep [ cycles>> ] keep
over 16667 < [ ! cycles cpu over 16667 < [ ! cycles cpu
nip gui-frame/2 nip gui-frame/2
] [
[ [ 16667 - ] dip cycles<< ] keep
dup last-interrupt>> 0x10 = [
0x08 over last-interrupt<< 0x08 swap interrupt
] [ ] [
0x10 over last-interrupt<< 0x10 swap interrupt [ [ 16667 - ] dip cycles<< ] keep
] if dup last-interrupt>> 0x10 = [
] if ; 0x08 over last-interrupt<< 0x08 swap interrupt
] [
0x10 over last-interrupt<< 0x10 swap interrupt
] if
] if ;
: gui-frame ( cpu -- ) : gui-frame ( cpu -- )
dup gui-frame/2 gui-frame/2 ; dup gui-frame/2 gui-frame/2 ;
: coin-down ( cpu -- ) : coin-down ( cpu -- )
[ port1>> 1 bitor ] keep port1<< ; [ port1>> 1 bitor ] keep port1<< ;
: coin-up ( cpu -- ) : coin-up ( cpu -- )
[ port1>> 255 1 - bitand ] keep port1<< ; [ port1>> 255 1 - bitand ] keep port1<< ;
: player1-down ( cpu -- ) : player1-down ( cpu -- )
[ port1>> 4 bitor ] keep port1<< ; [ port1>> 4 bitor ] keep port1<< ;
: player1-up ( cpu -- ) : player1-up ( cpu -- )
[ port1>> 255 4 - bitand ] keep port1<< ; [ port1>> 255 4 - bitand ] keep port1<< ;
: player2-down ( cpu -- ) : player2-down ( cpu -- )
[ port1>> 2 bitor ] keep port1<< ; [ port1>> 2 bitor ] keep port1<< ;
: player2-up ( cpu -- ) : player2-up ( cpu -- )
[ port1>> 255 2 - bitand ] keep port1<< ; [ port1>> 255 2 - bitand ] keep port1<< ;
: fire-down ( cpu -- ) : fire-down ( cpu -- )
[ port1>> 0x10 bitor ] keep port1<< ; [ port1>> 0x10 bitor ] keep port1<< ;
: fire-up ( cpu -- ) : fire-up ( cpu -- )
[ port1>> 255 0x10 - bitand ] keep port1<< ; [ port1>> 255 0x10 - bitand ] keep port1<< ;
: left-down ( cpu -- ) : left-down ( cpu -- )
[ port1>> 0x20 bitor ] keep port1<< ; [ port1>> 0x20 bitor ] keep port1<< ;
: left-up ( cpu -- ) : left-up ( cpu -- )
[ port1>> 255 0x20 - bitand ] keep port1<< ; [ port1>> 255 0x20 - bitand ] keep port1<< ;
: right-down ( cpu -- ) : right-down ( cpu -- )
[ port1>> 0x40 bitor ] keep port1<< ; [ port1>> 0x40 bitor ] keep port1<< ;
: right-up ( cpu -- ) : right-up ( cpu -- )
[ port1>> 255 0x40 - bitand ] keep port1<< ; [ port1>> 255 0x40 - bitand ] keep port1<< ;
TUPLE: invaders-gadget < gadget cpu quit? windowed? ; TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
@ -291,20 +291,20 @@ invaders-gadget H{
{ T{ key-up f f "LEFT" } [ cpu>> left-up ] } { T{ key-up f f "LEFT" } [ cpu>> left-up ] }
{ T{ key-down f f "RIGHT" } [ cpu>> right-down ] } { T{ key-down f f "RIGHT" } [ cpu>> right-down ] }
{ T{ key-up f f "RIGHT" } [ cpu>> right-up ] } { T{ key-up f f "RIGHT" } [ cpu>> right-up ] }
} set-gestures } set-gestures
: <invaders-gadget> ( cpu -- gadget ) : <invaders-gadget> ( cpu -- gadget )
invaders-gadget new invaders-gadget new
swap >>cpu swap >>cpu
f >>quit? ; f >>quit? ;
M: invaders-gadget pref-dim* drop { 224 256 } ; M: invaders-gadget pref-dim* drop { 224 256 } ;
M: invaders-gadget draw-gadget* ( gadget -- ) M: invaders-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i 0 0 glRasterPos2i
1.0 -1.0 glPixelZoom 1.0 -1.0 glPixelZoom
[ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip
cpu>> bitmap>> glDrawPixels ; cpu>> bitmap>> glDrawPixels ;
CONSTANT: black { 0 0 0 } CONSTANT: black { 0 0 0 }
CONSTANT: white { 255 255 255 } CONSTANT: white { 255 255 255 }
@ -312,91 +312,91 @@ CONSTANT: green { 0 255 0 }
CONSTANT: red { 255 0 0 } CONSTANT: red { 255 0 0 }
: addr>xy ( addr -- point ) : addr>xy ( addr -- point )
#! Convert video RAM address to base X Y value. point is a {x y}. #! Convert video RAM address to base X Y value. point is a {x y}.
0x2400 - ! n 0x2400 - ! n
dup 0x1f bitand 8 * 255 swap - ! n y dup 0x1f bitand 8 * 255 swap - ! n y
swap -5 shift swap 2array ; swap -5 shift swap 2array ;
: plot-bitmap-pixel ( bitmap point color -- ) : plot-bitmap-pixel ( bitmap point color -- )
#! point is a {x y}. color is a {r g b}. #! point is a {x y}. color is a {r g b}.
set-bitmap-pixel ; set-bitmap-pixel ;
: get-point-color ( point -- color ) : get-point-color ( point -- color )
#! Return the color to use for the given x/y position. #! Return the color to use for the given x/y position.
first2 first2
{ {
{ [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] } { [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
{ [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] } { [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] }
{ [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] } { [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] }
[ 2drop white ] [ 2drop white ]
} cond ; } cond ;
: plot-bitmap-bits ( bitmap point byte bit -- ) : plot-bitmap-bits ( bitmap point byte bit -- )
#! point is a {x y}. #! point is a {x y}.
[ first2 ] 2dip [ first2 ] 2dip
dup swapd -1 * shift 1 bitand 0 = dup swapd -1 * shift 1 bitand 0 =
[ - 2array ] dip [ - 2array ] dip
[ black ] [ dup get-point-color ] if [ black ] [ dup get-point-color ] if
plot-bitmap-pixel ; plot-bitmap-pixel ;
: do-bitmap-update ( bitmap value addr -- ) : do-bitmap-update ( bitmap value addr -- )
addr>xy swap addr>xy swap
[ 0 plot-bitmap-bits ] 3keep [ 0 plot-bitmap-bits ] 3keep
[ 1 plot-bitmap-bits ] 3keep [ 1 plot-bitmap-bits ] 3keep
[ 2 plot-bitmap-bits ] 3keep [ 2 plot-bitmap-bits ] 3keep
[ 3 plot-bitmap-bits ] 3keep [ 3 plot-bitmap-bits ] 3keep
[ 4 plot-bitmap-bits ] 3keep [ 4 plot-bitmap-bits ] 3keep
[ 5 plot-bitmap-bits ] 3keep [ 5 plot-bitmap-bits ] 3keep
[ 6 plot-bitmap-bits ] 3keep [ 6 plot-bitmap-bits ] 3keep
7 plot-bitmap-bits ; 7 plot-bitmap-bits ;
M: space-invaders update-video ( value addr cpu -- ) M: space-invaders update-video ( value addr cpu -- )
over 0x2400 >= [ over 0x2400 >= [
bitmap>> -rot do-bitmap-update bitmap>> -rot do-bitmap-update
] [ ] [
3drop 3drop
] if ; ] if ;
: sync-frame ( micros -- micros ) : sync-frame ( micros -- micros )
#! Sleep until the time for the next frame arrives. #! Sleep until the time for the next frame arrives.
1000 60 / >fixnum + gmt timestamp>micros - dup 0 > 1000 60 / >fixnum + gmt timestamp>micros - dup 0 >
[ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ; [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ;
: invaders-process ( micros gadget -- ) : invaders-process ( micros gadget -- )
#! Run a space invaders gadget inside a #! Run a space invaders gadget inside a
#! concurrent process. Messages can be sent to #! concurrent process. Messages can be sent to
#! signal key presses, etc. #! signal key presses, etc.
dup quit?>> [ dup quit?>> [
2drop 2drop
] [ ] [
[ sync-frame ] dip [ sync-frame ] dip
[ cpu>> gui-frame ] keep [ cpu>> gui-frame ] keep
[ relayout-1 ] keep [ relayout-1 ] keep
invaders-process invaders-process
] if ; ] if ;
M: invaders-gadget graft* ( gadget -- ) M: invaders-gadget graft* ( gadget -- )
dup cpu>> init-sounds dup cpu>> init-sounds
f over quit?<< f over quit?<<
[ gmt timestamp>micros swap invaders-process ] curry [ gmt timestamp>micros swap invaders-process ] curry
"Space invaders" threads:spawn drop ; "Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- ) M: invaders-gadget ungraft* ( gadget -- )
t swap quit?<< ; t swap quit?<< ;
: (run) ( title cpu rom-info -- ) : (run) ( title cpu rom-info -- )
over load-rom* <invaders-gadget> t >>windowed? swap open-window ; over load-rom* <invaders-gadget> t >>windowed? swap open-window ;
CONSTANT: rom-info { CONSTANT: rom-info {
{ 0x0000 "invaders/invaders.h" } { 0x0000 "invaders/invaders.h" }
{ 0x0800 "invaders/invaders.g" } { 0x0800 "invaders/invaders.g" }
{ 0x1000 "invaders/invaders.f" } { 0x1000 "invaders/invaders.f" }
{ 0x1800 "invaders/invaders.e" } { 0x1800 "invaders/invaders.e" }
} }
: run-invaders ( -- ) : run-invaders ( -- )
[ [
"Space Invaders" <space-invaders> rom-info (run) "Space Invaders" <space-invaders> rom-info (run)
] with-ui ; ] with-ui ;
MAIN: run-invaders MAIN: run-invaders

46
extra/update/update.factor
View File

@ -9,18 +9,16 @@ IN: update
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-pull-clean ( -- ) : git-pull-clean ( -- )
image parent-directory image parent-directory [
[ { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
{ "git" "pull" "git://factorcode.org/git/factor.git" branch-name } run-command
run-command ] with-directory ;
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-clean-image ( -- url ) : remote-clean-image ( -- url )
{ "http://factorcode.org/images/clean/" platform "/" my-boot-image-name } { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
to-string ; to-string ;
: download-clean-image ( -- ) remote-clean-image download ; : download-clean-image ( -- ) remote-clean-image download ;
@ -33,29 +31,25 @@ IN: update
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rebuild ( -- ) : rebuild ( -- )
image parent-directory image parent-directory [
[ download-clean-image
download-clean-image make-clean
make-clean make
make boot
boot ] with-directory ;
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: update ( -- ) : update ( -- )
image parent-directory image parent-directory [
[ git-id
git-id git-pull-clean
git-pull-clean git-id
git-id = not
= not
[ rebuild ] [ rebuild ]
when when
] ] with-directory ;
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: update MAIN: update

86
extra/wordtimer/wordtimer.factor
View File

@ -8,82 +8,82 @@ SYMBOL: *wordtimes*
SYMBOL: *calling* SYMBOL: *calling*
: reset-word-timer ( -- ) : reset-word-timer ( -- )
H{ } clone *wordtimes* set-global H{ } clone *wordtimes* set-global
H{ } clone *calling* set-global ; H{ } clone *calling* set-global ;
: lookup-word-time ( wordname -- utime n ) : lookup-word-time ( wordname -- utime n )
*wordtimes* get-global [ drop { 0 0 } ] cache first2 ; *wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
: update-times ( utime current-utime current-numinvokes -- utime' invokes' ) : update-times ( utime current-utime current-numinvokes -- utime' invokes' )
rot [ + ] curry [ 1 + ] bi* ; rot [ + ] curry [ 1 + ] bi* ;
: register-time ( utime word -- ) : register-time ( utime word -- )
name>> name>>
[ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ;
: calling ( word -- ) : calling ( word -- )
dup *calling* get-global set-at ; inline dup *calling* get-global set-at ; inline
: finished ( word -- ) : finished ( word -- )
*calling* get-global delete-at ; inline *calling* get-global delete-at ; inline
: called-recursively? ( word -- t/f ) : called-recursively? ( word -- t/f )
*calling* get-global at ; inline *calling* get-global at ; inline
: timed-call ( quot word -- ) : timed-call ( quot word -- )
[ calling ] [ [ benchmark ] dip register-time ] [ finished ] tri ; inline [ calling ] [ [ benchmark ] dip register-time ] [ finished ] tri ; inline
: time-unless-recursing ( quot word -- ) : time-unless-recursing ( quot word -- )
dup called-recursively? not dup called-recursively? not
[ timed-call ] [ drop call ] if ; inline [ timed-call ] [ drop call ] if ; inline
: (add-timer) ( word quot -- quot' ) : (add-timer) ( word quot -- quot' )
[ swap time-unless-recursing ] 2curry ; [ swap time-unless-recursing ] 2curry ;
: add-timer ( word -- ) : add-timer ( word -- )
dup '[ [ _ ] dip (add-timer) ] annotate ; dup '[ [ _ ] dip (add-timer) ] annotate ;
: add-timers ( vocab -- ) : add-timers ( vocab -- )
words [ add-timer ] each ; words [ add-timer ] each ;
: reset-vocab ( vocab -- ) : reset-vocab ( vocab -- )
words [ reset ] each ; words [ reset ] each ;
: dummy-word ( -- ) ; : dummy-word ( -- ) ;
: time-dummy-word ( -- n ) : time-dummy-word ( -- n )
[ 100000 [ [ dummy-word ] benchmark , ] times ] { } make median ; [ 100000 [ [ dummy-word ] benchmark , ] times ] { } make median ;
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} ) : subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
[ first2 ] dip [ first2 ] dip
swap [ * - ] keep 2array ; swap [ * - ] keep 2array ;
: (correct-for-timing-overhead) ( timingshash -- timingshash ) : (correct-for-timing-overhead) ( timingshash -- timingshash )
time-dummy-word [ subtract-overhead ] curry assoc-map ; time-dummy-word [ subtract-overhead ] curry assoc-map ;
: correct-for-timing-overhead ( -- ) : correct-for-timing-overhead ( -- )
*wordtimes* [ (correct-for-timing-overhead) ] change-global ; *wordtimes* [ (correct-for-timing-overhead) ] change-global ;
: print-word-timings ( -- ) : print-word-timings ( -- )
*wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ; *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
: wordtimer-call ( quot -- ) : wordtimer-call ( quot -- )
reset-word-timer reset-word-timer
benchmark [ benchmark [
correct-for-timing-overhead correct-for-timing-overhead
"total time:" write "total time:" write
] dip pprint nl ] dip pprint nl
print-word-timings nl ; inline print-word-timings nl ; inline
: profile-vocab ( vocab quot -- ) : profile-vocab ( vocab quot -- )
"annotating vocab..." print flush "annotating vocab..." print flush
over [ reset-vocab ] [ add-timers ] bi over [ reset-vocab ] [ add-timers ] bi
reset-word-timer reset-word-timer
"executing quotation..." print flush "executing quotation..." print flush
benchmark [ benchmark [
"resetting annotations..." print flush "resetting annotations..." print flush
reset-vocab reset-vocab
correct-for-timing-overhead correct-for-timing-overhead
"total time:" write "total time:" write
] dip pprint ] dip pprint
print-word-timings ; inline print-word-timings ; inline