From c75fc48f23d9407538bc39299bc25f4716021d3a Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 24 Jul 2013 14:52:09 -0700 Subject: [PATCH] switch some vocabs to 4 spaces. --- basis/csv/csv-tests.factor | 10 +- basis/match/match-tests.factor | 88 ++- basis/math/functions/functions.factor | 20 +- basis/peg/peg-tests.factor | 134 ++--- basis/peg/peg.factor | 636 ++++++++++----------- basis/ui/ui.factor | 4 +- core/byte-arrays/byte-arrays-docs.factor | 3 +- extra/balloon-bomber/balloon-bomber.factor | 8 +- extra/ctags/ctags.factor | 36 +- extra/fjsc/fjsc.factor | 442 +++++++------- extra/libudev/libudev.factor | 210 +++---- extra/lunar-rescue/lunar-rescue.factor | 6 +- extra/s3/s3.factor | 20 +- extra/space-invaders/space-invaders.factor | 428 +++++++------- extra/update/update.factor | 46 +- extra/wordtimer/wordtimer.factor | 86 +-- 16 files changed, 1089 insertions(+), 1088 deletions(-) diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 3c12b14f84..2d55b1745e 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -5,7 +5,7 @@ IN: csv.tests ! I like to name my unit tests : named-unit-test ( name output input -- ) - unit-test drop ; inline + unit-test drop ; inline "Fields are separated by commas" [ { { "1997" "Ford" "E350" } } ] @@ -22,17 +22,17 @@ IN: csv.tests "double quotes mean escaped in quotes" [ { { "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." [ { { "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)" [ { { "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." [ { { "1997" "Ford" "E350" } } ] @@ -43,7 +43,7 @@ IN: csv.tests { "1997" "Ford" "E350" } { "2000" "Mercury" "Cougar" } } ] [ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" - string>csv ] named-unit-test + string>csv ] named-unit-test ! !!!!!!!! other tests diff --git a/basis/match/match-tests.factor b/basis/match/match-tests.factor index e31f01f1b3..69e82305d1 100644 --- a/basis/match/match-tests.factor +++ b/basis/match/match-tests.factor @@ -8,39 +8,39 @@ MATCH-VARS: ?a ?b ; [ f ] [ { ?a ?a } { 1 2 } match ] unit-test [ H{ { ?a 1 } { ?b 2 } } ] [ - { ?a ?b } { 1 2 } match + { ?a ?b } { 1 2 } match ] unit-test -[ { 1 2 } ] [ - { 1 2 } - { - { { ?a ?b } [ ?a ?b 2array ] } - } match-cond +[ { 1 2 } ] [ + { 1 2 } + { + { { ?a ?b } [ ?a ?b 2array ] } + } match-cond ] unit-test -[ t ] [ - { 1 2 } - { - { { 1 2 } [ t ] } - { f [ f ] } - } match-cond +[ t ] [ + { 1 2 } + { + { { 1 2 } [ t ] } + { f [ f ] } + } match-cond ] unit-test -[ t ] [ - { 1 3 } - { - { { 1 2 } [ t ] } - { { 1 3 } [ t ] } - } match-cond +[ t ] [ + { 1 3 } + { + { { 1 2 } [ t ] } + { { 1 3 } [ t ] } + } match-cond ] unit-test -[ f ] [ - { 1 5 } - { - { { 1 2 } [ t ] } - { { 1 3 } [ t ] } - { _ [ f ] } - } match-cond +[ f ] [ + { 1 5 } + { + { { 1 2 } [ t ] } + { { 1 3 } [ t ] } + { _ [ f ] } + } match-cond ] unit-test TUPLE: foo a b ; @@ -48,31 +48,29 @@ TUPLE: foo a b ; C: foo { 1 2 } [ - 1 2 T{ foo f ?a ?b } match [ - ?a ?b - ] with-variables + 1 2 T{ foo f ?a ?b } match [ + ?a ?b + ] with-variables ] unit-test { 1 2 } [ - 1 2 \ ?a \ ?b match [ - ?a ?b - ] with-variables + 1 2 \ ?a \ ?b match [ + ?a ?b + ] with-variables ] unit-test -{ H{ { ?a ?a } } } [ - \ ?a \ ?a match +{ H{ { ?a ?a } } } + \ ?a \ ?a match ] unit-test -[ "match" ] [ - "abcd" { - { ?a [ "match" ] } - } match-cond +[ "match" ] [ + "abcd" { + { ?a [ "match" ] } + } match-cond ] unit-test -[ - { 2 1 } -] [ - { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace +{ { 2 1 } } [ + { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace ] unit-test 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 1 2 } - T{ match-replace-test f ?a ?b } - T{ match-replace-test f ?b ?a } - match-replace + T{ match-replace-test f 1 2 } + T{ match-replace-test f ?a ?b } + T{ match-replace-test f ?b ?a } + match-replace ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 3ba6bfd324..7c667c078e 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -187,13 +187,22 @@ M: real absq sq ; inline : >=1? ( x -- ? ) dup complex? [ drop f ] [ 1 >= ] if ; inline + + GENERIC: frexp ( x -- y exp ) M: float frexp dup fp-special? [ dup zero? ] unless* [ 0 ] [ - double>bits - [ 0x800f,ffff,ffff,ffff bitand 0.5 double>bits bitor bits>double ] - [ -52 shift 0x7ff bitand 1022 - ] bi + fp-normalize [ + double>bits + [ 0x800f,ffff,ffff,ffff bitand 0.5 double>bits bitor bits>double ] + [ -52 shift 0x7ff bitand 1022 - ] bi + ] dip + ] if ; inline M: integer frexp @@ -210,8 +219,9 @@ GENERIC# ldexp 1 ( x exp -- y ) M: float ldexp 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 1023 > ] [ drop 0 < -1/0. 1/0. ? ] } [ diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 501b8ed856..ebfdebfcb1 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -8,191 +8,191 @@ IN: peg.tests [ ] [ reset-pegs ] unit-test [ - "endbegin" "begin" token parse + "endbegin" "begin" token parse ] must-fail { "begin" "end" } [ - "beginend" "begin" token (parse) - [ ast>> ] [ remaining>> ] bi - >string + "beginend" "begin" token (parse) + [ ast>> ] [ remaining>> ] bi + >string ] unit-test [ - "" CHAR: a CHAR: z range parse + "" CHAR: a CHAR: z range parse ] must-fail [ - "1bcd" CHAR: a CHAR: z range parse + "1bcd" CHAR: a CHAR: z range parse ] must-fail { CHAR: a } [ - "abcd" CHAR: a CHAR: z range parse + "abcd" CHAR: a CHAR: z range parse ] unit-test { CHAR: z } [ - "zbcd" CHAR: a CHAR: z range parse + "zbcd" CHAR: a CHAR: z range parse ] unit-test [ - "bad" "a" token "b" token 2array seq parse + "bad" "a" token "b" token 2array seq parse ] must-fail { V{ "g" "o" } } [ - "good" "g" token "o" token 2array seq parse + "good" "g" token "o" token 2array seq parse ] unit-test { "a" } [ - "abcd" "a" token "b" token 2array choice parse + "abcd" "a" token "b" token 2array choice parse ] unit-test { "b" } [ - "bbcd" "a" token "b" token 2array choice parse + "bbcd" "a" token "b" token 2array choice parse ] unit-test [ - "cbcd" "a" token "b" token 2array choice parse + "cbcd" "a" token "b" token 2array choice parse ] must-fail [ - "" "a" token "b" token 2array choice parse + "" "a" token "b" token 2array choice parse ] must-fail { 0 } [ - "" "a" token repeat0 parse length + "" "a" token repeat0 parse length ] unit-test { 0 } [ - "b" "a" token repeat0 parse length + "b" "a" token repeat0 parse length ] unit-test { V{ "a" "a" "a" } } [ - "aaab" "a" token repeat0 parse + "aaab" "a" token repeat0 parse ] unit-test [ - "" "a" token repeat1 parse + "" "a" token repeat1 parse ] must-fail [ - "b" "a" token repeat1 parse + "b" "a" token repeat1 parse ] must-fail { V{ "a" "a" "a" } } [ - "aaab" "a" token repeat1 parse + "aaab" "a" token repeat1 parse ] unit-test -{ V{ "a" "b" } } [ - "ab" "a" token optional "b" token 2array seq parse +{ V{ "a" "b" } } [ + "ab" "a" token optional "b" token 2array seq parse ] unit-test -{ V{ f "b" } } [ - "b" "a" token optional "b" token 2array seq parse +{ V{ f "b" } } [ + "b" "a" token optional "b" token 2array seq parse ] unit-test -[ - "cb" "a" token optional "b" token 2array seq parse +[ + "cb" "a" token optional "b" token 2array seq parse ] must-fail { 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 [ - "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 { t } [ - "a+b" - "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a+b" + "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] unit-test { t } [ - "a++b" - "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a++b" + "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] unit-test { t } [ - "a+b" - "a" token "+" token "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a+b" + "a" token "+" token "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] unit-test [ - "a++b" - "a" token "+" token "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a++b" + "a" token "+" token "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] must-fail { 1 } [ - "a" "a" token [ drop 1 ] action parse + "a" "a" token [ drop 1 ] action parse ] unit-test { 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 [ - "b" "a" token [ drop 1 ] action parse + "b" "a" token [ drop 1 ] action parse ] must-fail -[ - "b" [ CHAR: a = ] satisfy parse +[ + "b" [ CHAR: a = ] satisfy parse ] must-fail -{ CHAR: a } [ - "a" [ CHAR: a = ] satisfy parse +{ CHAR: a } [ + "a" [ CHAR: a = ] satisfy parse ] unit-test { "a" } [ - " a" "a" token sp parse + " a" "a" token sp parse ] unit-test { "a" } [ - "a" "a" token sp parse + "a" "a" token sp parse ] unit-test { V{ "a" } } [ - "[a]" "[" token hide "a" token "]" token hide 3array seq parse + "[a]" "[" token hide "a" token "]" token hide 3array seq parse ] unit-test [ - "a]" "[" token hide "a" token "]" token hide 3array seq parse + "a]" "[" token hide "a" token "]" token hide 3array seq parse ] must-fail { V{ "1" "-" "1" } V{ "1" "+" "1" } } [ - [ - [ "1" token , "-" token , "1" token , ] seq* , - [ "1" token , "+" token , "1" token , ] seq* , - ] choice* - "1-1" over parse swap - "1+1" swap parse + [ + [ "1" token , "-" token , "1" token , ] seq* , + [ "1" token , "+" token , "1" token , ] seq* , + ] choice* + "1-1" over parse swap + "1+1" swap parse ] unit-test : expr ( -- parser ) - #! Test direct left recursion. Currently left recursion should cause a - #! failure of that parser. - [ expr ] delay "+" token "1" token 3seq "1" token 2choice ; + #! Test direct left recursion. Currently left recursion should cause a + #! failure of that parser. + [ expr ] delay "+" token "1" token 3seq "1" token 2choice ; { V{ V{ "1" "+" "1" } "+" "1" } } [ - "1+1+1" expr parse + "1+1+1" expr parse ] unit-test { t } [ - #! Ensure a circular parser doesn't loop infinitely - [ f , "a" token , ] seq* - dup peg>> parsers>> - dupd 0 swap set-nth compile word? + #! Ensure a circular parser doesn't loop infinitely + [ f , "a" token , ] seq* + dup peg>> parsers>> + dupd 0 swap set-nth compile word? ] unit-test [ - "A" [ drop t ] satisfy [ 66 >= ] semantic parse + "A" [ drop t ] satisfy [ 66 >= ] semantic parse ] must-fail { CHAR: B } [ - "B" [ drop t ] satisfy [ 66 >= ] semantic parse + "B" [ drop t ] satisfy [ 66 >= ] semantic parse ] unit-test { f } [ \ + T{ parser f f f } equal? ] unit-test diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 23a929a9ee..6ccd93f3a7 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -12,7 +12,7 @@ TUPLE: parse-result remaining ast ; TUPLE: parse-error position messages ; 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* ; C: parse-result @@ -21,37 +21,38 @@ C: parse-error SYMBOL: error-stack : (merge-errors) ( a b -- c ) - { - { [ over position>> not ] [ nip ] } - { [ dup position>> not ] [ drop ] } - [ 2dup [ position>> ] compare { - { +lt+ [ nip ] } - { +gt+ [ drop ] } - { +eq+ [ messages>> over messages>> union [ position>> ] dip ] } - } case - ] - } cond ; + { + { [ over position>> not ] [ nip ] } + { [ dup position>> not ] [ drop ] } + [ + 2dup [ position>> ] compare { + { +lt+ [ nip ] } + { +gt+ [ drop ] } + { +eq+ [ messages>> over messages>> union [ position>> ] dip ] } + } case + ] + } cond ; : merge-errors ( -- ) - error-stack get dup length 1 > [ - dup pop over pop swap (merge-errors) swap push - ] [ - drop - ] if ; + error-stack get dup length 1 > [ + dup pop over pop swap (merge-errors) swap push + ] [ + drop + ] if ; : add-error ( remaining message -- ) - error-stack get push ; - -SYMBOL: ignore + error-stack get push ; + +SYMBOL: ignore : packrat ( id -- cache ) - #! The packrat cache is a mapping of parser-id->cache. - #! For each parser it maps to a cache holding a mapping - #! of position->result. The packrat cache therefore keeps - #! track of all parses that have occurred at each position - #! of the input string and the results obtained from that - #! parser. - \ packrat get [ drop H{ } clone ] cache ; + #! The packrat cache is a mapping of parser-id->cache. + #! For each parser it maps to a cache holding a mapping + #! of position->result. The packrat cache therefore keeps + #! track of all parses that have occurred at each position + #! of the input string and the results obtained from that + #! parser. + \ packrat get [ drop H{ } clone ] cache ; SYMBOL: pos SYMBOL: input @@ -59,26 +60,26 @@ SYMBOL: fail SYMBOL: lrstack : heads ( -- cache ) - #! A mapping from position->peg-head. It maps a - #! position in the input string being parsed to - #! the head of the left recursion which is currently - #! being grown. It is 'f' at any position where - #! left recursion growth is not underway. - \ heads get ; + #! A mapping from position->peg-head. It maps a + #! position in the input string being parsed to + #! the head of the left recursion which is currently + #! being grown. It is 'f' at any position where + #! left recursion growth is not underway. + \ heads get ; : failed? ( obj -- ? ) - fail = ; + fail = ; : peg-cache ( -- cache ) - #! Holds a hashtable mapping a peg tuple to - #! the parser tuple for that peg. The parser tuple - #! holds a unique id and the compiled form of that peg. - \ peg-cache get-global [ - H{ } clone dup \ peg-cache set-global - ] unless* ; + #! Holds a hashtable mapping a peg tuple to + #! the parser tuple for that peg. The parser tuple + #! holds a unique id and the compiled form of that peg. + \ peg-cache get-global [ + H{ } clone dup \ peg-cache set-global + ] unless* ; : reset-pegs ( -- ) - H{ } clone \ peg-cache set-global ; + H{ } clone \ peg-cache set-global ; reset-pegs @@ -93,116 +94,114 @@ TUPLE: left-recursion seed rule-id head next ; TUPLE: peg-head rule-id involved-set eval-set ; : rule-id ( word -- id ) - #! A rule is the parser compiled down to a word. It has - #! a "peg-id" property containing the id of the original parser. - "peg-id" word-prop ; + #! A rule is the parser compiled down to a word. It has + #! a "peg-id" property containing the id of the original parser. + "peg-id" word-prop ; : input-slice ( -- slice ) - #! Return a slice of the input from the current parse position - input get pos get tail-slice ; + #! Return a slice of the input from the current parse position + input get pos get tail-slice ; : input-from ( input -- n ) - #! Return the index from the original string that the - #! input slice is based on. - dup slice? [ from>> ] [ drop 0 ] if ; + #! Return the index from the original string that the + #! input slice is based on. + dup slice? [ from>> ] [ drop 0 ] if ; : process-rule-result ( p result -- result ) - [ - nip [ ast>> ] [ remaining>> ] bi input-from pos set - ] [ - pos set fail - ] if* ; + [ + nip [ ast>> ] [ remaining>> ] bi input-from pos set + ] [ + pos set fail + ] if* ; : eval-rule ( rule -- ast ) - #! Evaluate a rule, return an ast resulting from it. - #! Return fail if the rule failed. The rule has - #! stack effect ( -- parse-result ) - pos get swap execute( -- parse-result ) process-rule-result ; inline + #! Evaluate a rule, return an ast resulting from it. + #! Return fail if the rule failed. The rule has + #! stack effect ( -- parse-result ) + pos get swap execute( -- parse-result ) process-rule-result ; inline : memo ( pos id -- memo-entry ) - #! Return the result from the memo cache. - packrat at -! " memo result " write dup . - ; + #! Return the result from the memo cache. + packrat at ; : set-memo ( memo-entry pos id -- ) - #! Store an entry in the cache - packrat set-at ; + #! Store an entry in the cache + packrat set-at ; : update-m ( ast m -- ) - swap >>ans pos get >>pos drop ; + swap >>ans pos get >>pos drop ; : stop-growth? ( ast m -- ? ) - [ failed? pos get ] dip - pos>> <= or ; + [ failed? pos get ] dip + pos>> <= or ; : 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 -- ) - [ [ setup-growth ] 2keep ] 2dip - [ dup eval-rule ] dip swap - dup pick stop-growth? [ - 5 ndrop - ] [ - over update-m - (grow-lr) - ] if ; inline recursive - + [ [ setup-growth ] 2keep ] 2dip + [ dup eval-rule ] dip swap + dup pick stop-growth? [ + 5 ndrop + ] [ + over update-m + (grow-lr) + ] if ; inline recursive + : grow-lr ( h p r m -- ast ) - [ [ heads set-at ] 2keep ] 2dip - pick over [ (grow-lr) ] 2dip - swap heads delete-at - dup pos>> pos set ans>> - ; inline + [ [ heads set-at ] 2keep ] 2dip + pick over [ (grow-lr) ] 2dip + swap heads delete-at + dup pos>> pos set ans>> + ; inline :: (setup-lr) ( l s -- ) - s [ - s left-recursion? [ s throw ] unless - s head>> l head>> eq? [ - l head>> s head<< - l head>> [ s rule-id>> suffix ] change-involved-set drop - l s next>> (setup-lr) - ] unless - ] when ; + s [ + s left-recursion? [ s throw ] unless + s head>> l head>> eq? [ + l head>> s head<< + l head>> [ s rule-id>> suffix ] change-involved-set drop + l s next>> (setup-lr) + ] unless + ] when ; :: setup-lr ( r l -- ) - l head>> [ - r rule-id V{ } clone V{ } clone peg-head boa l head<< - ] unless - l lrstack get (setup-lr) ; + l head>> [ + r rule-id V{ } clone V{ } clone peg-head boa l head<< + ] unless + l lrstack get (setup-lr) ; :: lr-answer ( r p m -- ast ) m ans>> head>> :> h h rule-id>> r rule-id eq? [ - m ans>> seed>> m ans<< - m ans>> failed? [ - fail - ] [ - h p r m grow-lr - ] if + m ans>> seed>> m ans<< + m ans>> failed? [ + fail + ] [ + h p r m grow-lr + ] if ] [ - m ans>> seed>> + m ans>> seed>> ] if ; inline :: recall ( r p -- memo-entry ) p r rule-id memo :> m p heads at :> h h [ - m r rule-id h involved-set>> h rule-id>> suffix member? not and [ - fail p memo-entry boa - ] [ - r rule-id h eval-set>> member? [ - h [ r rule-id swap remove ] change-eval-set drop - r eval-rule - m update-m - m - ] [ - m + m r rule-id h involved-set>> h rule-id>> suffix member? not and [ + fail p memo-entry boa + ] [ + r rule-id h eval-set>> member? [ + h [ r rule-id swap remove ] change-eval-set drop + r eval-rule + m update-m + m + ] [ + m + ] if ] if - ] if ] [ - m + m ] if ; inline :: 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 pos get m pos<< lr head>> [ - m ans>> left-recursion? [ - ans lr seed<< - r p m lr-answer - ] [ ans ] if + m ans>> left-recursion? [ + ans lr seed<< + r p m lr-answer + ] [ ans ] if ] [ - ans m ans<< - ans + ans m ans<< + ans ] if ; inline : apply-memo-rule ( r m -- ast ) - [ ans>> ] [ pos>> ] bi pos set - dup left-recursion? [ - [ setup-lr ] keep seed>> - ] [ - nip - ] if ; + [ ans>> ] [ pos>> ] bi pos set + dup left-recursion? [ + [ setup-lr ] keep seed>> + ] [ + nip + ] if ; : apply-rule ( r p -- ast ) -! 2dup [ rule-id ] dip 2array "apply-rule: " write . - 2dup recall [ -! " memoed" print - nip apply-memo-rule - ] [ -! " not memoed" print - apply-non-memo-rule - ] if* ; inline + 2dup recall [ + nip apply-memo-rule + ] [ + apply-non-memo-rule + ] if* ; inline : with-packrat ( input quot -- result ) #! 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 ) : process-parser-result ( result -- result ) - dup failed? [ - drop f - ] [ - input-slice swap - ] if ; - + dup failed? [ + drop f + ] [ + input-slice swap + ] if ; + : execute-parser ( word -- result ) - pos get apply-rule process-parser-result ; + pos get apply-rule process-parser-result ; : preset-parser-word ( parser -- parser word ) - gensym [ >>compiled ] keep ; + gensym [ >>compiled ] keep ; : define-parser-word ( parser word -- ) - #! Return the body of the word that is the compiled version - #! of the parser. - 2dup swap peg>> (compile) ( -- result ) define-declared - swap id>> "peg-id" set-word-prop ; + #! Return the body of the word that is the compiled version + #! of the parser. + 2dup swap peg>> (compile) ( -- result ) define-declared + swap id>> "peg-id" set-word-prop ; : compile-parser ( parser -- word ) - #! Look to see if the given parser has been compiled. - #! If not, compile it to a temporary word, cache it, - #! and return it. Otherwise return the existing one. - #! Circular parsers are supported by getting the word - #! name and storing it in the cache, before compiling, - #! so it is picked up when re-entered. - dup compiled>> [ - nip - ] [ - preset-parser-word [ define-parser-word ] keep - ] if* ; + #! Look to see if the given parser has been compiled. + #! If not, compile it to a temporary word, cache it, + #! and return it. Otherwise return the existing one. + #! Circular parsers are supported by getting the word + #! name and storing it in the cache, before compiling, + #! so it is picked up when re-entered. + dup compiled>> [ + nip + ] [ + preset-parser-word [ define-parser-word ] keep + ] if* ; : compile-parser-quot ( parser -- quot ) - compile-parser [ execute-parser ] curry ; + compile-parser [ execute-parser ] curry ; SYMBOL: delayed : fixup-delayed ( -- ) - #! Work through all delayed parsers and recompile their - #! words to have the correct bodies. - delayed get [ - call( -- parser ) compile-parser-quot ( -- result ) define-declared - ] assoc-each ; + #! Work through all delayed parsers and recompile their + #! words to have the correct bodies. + delayed get [ + call( -- parser ) compile-parser-quot ( -- result ) define-declared + ] assoc-each ; : compile ( parser -- word ) - [ - H{ } clone delayed [ - compile-parser-quot ( -- result ) define-temp fixup-delayed - ] with-variable - ] with-compilation-unit ; + [ + H{ } clone delayed [ + compile-parser-quot ( -- result ) define-temp fixup-delayed + ] with-variable + ] with-compilation-unit ; : 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 ) - dup word? [ compile ] unless compiled-parse ; + dup word? [ compile ] unless compiled-parse ; : parse ( input parser -- ast ) - (parse) ast>> ; + (parse) ast>> ; f f add-error - ] [ - [ drop pos get "token '" ] dip append "'" append 1vector add-error f - ] if ; + #! Parse the string, returning a parse result + [ ?head-slice ] keep swap [ + f f add-error + ] [ + [ drop pos get "token '" ] dip append "'" append 1vector add-error f + ] if ; M: token-parser (compile) ( peg -- quot ) - symbol>> '[ input-slice _ parse-token ] ; - + symbol>> '[ input-slice _ parse-token ] ; + TUPLE: satisfy-parser quot ; : parse-satisfy ( input quot -- result ) - swap dup empty? [ - 2drop f - ] [ - unclip-slice rot dupd call [ - - ] [ - 2drop f - ] if - ] if ; inline + swap dup empty? [ + 2drop f + ] [ + unclip-slice rot dupd call [ + + ] [ + 2drop f + ] if + ] if ; inline M: satisfy-parser (compile) ( peg -- quot ) - quot>> '[ input-slice _ parse-satisfy ] ; + quot>> '[ input-slice _ parse-satisfy ] ; TUPLE: range-parser min max ; : parse-range ( input min max -- result ) - pick empty? [ - 3drop f - ] [ - [ dup first ] 2dip between? [ - unclip-slice - ] [ - drop f - ] if - ] if ; + pick empty? [ + 3drop f + ] [ + [ dup first ] 2dip between? [ + unclip-slice + ] [ + drop f + ] if + ] if ; M: range-parser (compile) ( peg -- quot ) - [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ; + [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ; TUPLE: seq-parser parsers ; : ignore? ( ast -- bool ) - ignore = ; + ignore = ; : calc-seq-result ( prev-result current-result -- next-result ) - [ - [ remaining>> swap remaining<< ] 2keep - ast>> dup ignore? [ - drop + [ + [ remaining>> swap remaining<< ] 2keep + ast>> dup ignore? [ + drop + ] [ + swap [ ast>> push ] keep + ] if ] [ - swap [ ast>> push ] keep - ] if - ] [ - drop f - ] if* ; + drop f + ] if* ; : parse-seq-element ( result quot -- result ) - over [ - call calc-seq-result - ] [ - 2drop f - ] if ; inline + over [ + call calc-seq-result + ] [ + 2drop f + ] if ; inline M: seq-parser (compile) ( peg -- quot ) - [ - [ input-slice V{ } clone ] % [ - parsers>> unclip compile-parser-quot [ parse-seq-element ] curry , - [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each - ] { } make , \ 1&& , - ] [ ] make ; + [ input-slice V{ } clone ] % + [ + parsers>> unclip compile-parser-quot [ parse-seq-element ] curry , + [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each + ] { } make , \ 1&& , + ] [ ] make ; TUPLE: choice-parser parsers ; M: choice-parser (compile) ( peg -- quot ) - [ [ - parsers>> [ compile-parser-quot ] map - unclip , [ [ merge-errors ] compose , ] each - ] { } make , \ 0|| , - ] [ ] make ; + [ + parsers>> [ compile-parser-quot ] map + unclip , [ [ merge-errors ] compose , ] each + ] { } make , \ 0|| , + ] [ ] make ; TUPLE: repeat0-parser p1 ; : (repeat) ( quot: ( -- result ) result -- result ) - over call [ - [ remaining>> swap remaining<< ] 2keep - ast>> swap [ ast>> push ] keep - (repeat) - ] [ - nip - ] if* ; inline recursive + over call [ + [ remaining>> swap remaining<< ] 2keep + ast>> swap [ ast>> push ] keep + (repeat) + ] [ + nip + ] if* ; inline recursive M: repeat0-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ - input-slice V{ } clone _ swap (repeat) - ] ; + p1>> compile-parser-quot '[ + input-slice V{ } clone _ swap (repeat) + ] ; TUPLE: repeat1-parser p1 ; : repeat1-empty-check ( result -- result ) - [ - dup ast>> empty? [ drop f ] when - ] [ - f - ] if* ; + [ + dup ast>> empty? [ drop f ] when + ] [ + f + ] if* ; M: repeat1-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ - input-slice V{ } clone _ swap (repeat) repeat1-empty-check - ] ; + p1>> compile-parser-quot '[ + input-slice V{ } clone _ swap (repeat) repeat1-empty-check + ] ; TUPLE: optional-parser p1 ; : check-optional ( result -- result ) - [ input-slice f ] unless* ; + [ input-slice f ] unless* ; M: optional-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ @ check-optional ] ; + p1>> compile-parser-quot '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; : check-semantic ( result quot -- result ) - over [ - over ast>> swap call [ drop f ] unless - ] [ - drop - ] if ; inline + over [ + over ast>> swap call [ drop f ] unless + ] [ + drop + ] if ; inline M: semantic-parser (compile) ( peg -- quot ) - [ p1>> compile-parser-quot ] [ quot>> ] bi - '[ @ _ check-semantic ] ; + [ p1>> compile-parser-quot ] [ quot>> ] bi + '[ @ _ check-semantic ] ; TUPLE: ensure-parser p1 ; : check-ensure ( old-input result -- result ) - [ ignore ] [ drop f ] if ; + [ ignore ] [ drop f ] if ; 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 ; : check-ensure-not ( old-input result -- result ) - [ drop f ] [ ignore ] if ; + [ drop f ] [ ignore ] if ; 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 ; : check-action ( result quot -- result ) - over [ - over ast>> swap call( ast -- ast ) >>ast - ] [ - drop - ] if ; + over [ + over ast>> swap call( ast -- ast ) >>ast + ] [ + drop + ] if ; 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 ; M: sp-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ - input-slice [ blank? ] trim-head-slice input-from pos set @ - ] ; + p1>> compile-parser-quot '[ + input-slice [ blank? ] trim-head-slice input-from pos set @ + ] ; TUPLE: delay-parser quot ; M: delay-parser (compile) ( peg -- quot ) - #! For efficiency we memoize the quotation. - #! This way it is run only once and the - #! parser constructed once at run time. - quot>> gensym [ delayed get set-at ] keep 1quotation ; + #! For efficiency we memoize the quotation. + #! This way it is run only once and the + #! parser constructed once at run time. + quot>> gensym [ delayed get set-at ] keep 1quotation ; TUPLE: box-parser quot ; M: box-parser (compile) ( peg -- quot ) - #! Calls the quotation at compile time - #! to produce the parser to be compiled. - #! This differs from 'delay' which calls - #! it at run time. - quot>> call( -- parser ) compile-parser-quot ; + #! Calls the quotation at compile time + #! to produce the parser to be compiled. + #! This differs from 'delay' which calls + #! it at run time. + quot>> call( -- parser ) compile-parser-quot ; PRIVATE> : token ( string -- parser ) - token-parser boa wrap-peg ; + token-parser boa wrap-peg ; : satisfy ( quot -- parser ) - satisfy-parser boa wrap-peg ; + satisfy-parser boa wrap-peg ; : range ( min max -- parser ) - range-parser boa wrap-peg ; + range-parser boa wrap-peg ; : seq ( seq -- parser ) - seq-parser boa wrap-peg ; + seq-parser boa wrap-peg ; : 2seq ( parser1 parser2 -- parser ) - 2array seq ; + 2array seq ; : 3seq ( parser1 parser2 parser3 -- parser ) - 3array seq ; + 3array seq ; : 4seq ( parser1 parser2 parser3 parser4 -- parser ) - 4array seq ; + 4array seq ; : seq* ( quot -- paser ) - { } make seq ; inline + { } make seq ; inline : choice ( seq -- parser ) - choice-parser boa wrap-peg ; + choice-parser boa wrap-peg ; : 2choice ( parser1 parser2 -- parser ) - 2array choice ; + 2array choice ; : 3choice ( parser1 parser2 parser3 -- parser ) - 3array choice ; + 3array choice ; : 4choice ( parser1 parser2 parser3 parser4 -- parser ) - 4array choice ; + 4array choice ; : choice* ( quot -- paser ) - { } make choice ; inline + { } make choice ; inline : repeat0 ( parser -- parser ) - repeat0-parser boa wrap-peg ; + repeat0-parser boa wrap-peg ; : repeat1 ( parser -- parser ) - repeat1-parser boa wrap-peg ; + repeat1-parser boa wrap-peg ; : optional ( parser -- parser ) - optional-parser boa wrap-peg ; + optional-parser boa wrap-peg ; : semantic ( parser quot -- parser ) - semantic-parser boa wrap-peg ; + semantic-parser boa wrap-peg ; : ensure ( parser -- parser ) - ensure-parser boa wrap-peg ; + ensure-parser boa wrap-peg ; : ensure-not ( parser -- parser ) - ensure-not-parser boa wrap-peg ; + ensure-not-parser boa wrap-peg ; : action ( parser quot -- parser ) - action-parser boa wrap-peg ; + action-parser boa wrap-peg ; : sp ( parser -- parser ) - sp-parser boa wrap-peg ; + sp-parser boa wrap-peg ; : hide ( parser -- parser ) - [ drop ignore ] action ; + [ drop ignore ] action ; : delay ( quot -- parser ) - delay-parser boa wrap-peg ; + delay-parser boa wrap-peg ; : box ( quot -- parser ) - #! because a box has its quotation run at compile time - #! it must always have a new parser wrapper created, - #! not a cached one. This is because the same box, - #! compiled twice can have a different compiled word - #! due to running at compile time. - #! Why the [ ] action at the end? Box parsers don't get - #! memoized during parsing due to all box parsers being - #! unique. This breaks left recursion detection during the - #! parse. The action adds an indirection with a parser type - #! that gets memoized and fixes this. Need to rethink how - #! to fix boxes so this isn't needed... - box-parser boa f next-id parser boa [ ] action ; + #! because a box has its quotation run at compile time + #! it must always have a new parser wrapper created, + #! not a cached one. This is because the same box, + #! compiled twice can have a different compiled word + #! due to running at compile time. + #! Why the [ ] action at the end? Box parsers don't get + #! memoized during parsing due to all box parsers being + #! unique. This breaks left recursion detection during the + #! parse. The action adds an indirection with a parser type + #! that gets memoized and fixes this. Need to rethink how + #! to fix boxes so this isn't needed... + box-parser boa f next-id parser boa [ ] action ; ERROR: parse-failed input word ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index f4c8b3af8b..5eafa48c87 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -218,8 +218,8 @@ HOOK: resize-window ui-backend ( world dim -- ) M: object resize-window 2drop ; : relayout-window ( gadget -- ) - [ relayout ] - [ find-world [ dup pref-dim resize-window ] when* ] bi ; + [ relayout ] + [ find-world [ dup pref-dim resize-window ] when* ] bi ; : with-ui ( quot: ( -- ) -- ) ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ; diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index 943d2822e5..1d8fa45b90 100644 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -40,8 +40,7 @@ HELP: (byte-array) HELP: >byte-array { $values { "seq" "a sequence" } { "byte-array" byte-array } } -{ $description - "Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." } +{ $description "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." } ; HELP: 1byte-array diff --git a/extra/balloon-bomber/balloon-bomber.factor b/extra/balloon-bomber/balloon-bomber.factor index 0e079e79f0..e5bd6ba4a1 100644 --- a/extra/balloon-bomber/balloon-bomber.factor +++ b/extra/balloon-bomber/balloon-bomber.factor @@ -14,7 +14,7 @@ IN: balloon-bomber TUPLE: balloon-bomber < space-invaders ; : ( -- cpu ) - balloon-bomber new cpu-init ; + balloon-bomber new cpu-init ; CONSTANT: rom-info { { 0x0000 "ballbomb/tn01" } @@ -22,9 +22,9 @@ CONSTANT: rom-info { { 0x1000 "ballbomb/tn03" } { 0x1800 "ballbomb/tn04" } { 0x4000 "ballbomb/tn05-1" } - } +} -: run-balloon ( -- ) - [ "Balloon Bomber" rom-info (run) ] with-ui ; +: run-balloon ( -- ) + [ "Balloon Bomber" rom-info (run) ] with-ui ; MAIN: run-balloon diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index e351fbf793..a6bfe7a315 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -10,35 +10,35 @@ namespaces make words sorting present ; IN: ctags : ctag-word ( ctag -- word ) - first ; + first ; : ctag-path ( ctag -- path ) - second first ; + second first ; : ctag-lineno ( ctag -- n ) - second second ; + second second ; : ctag ( seq -- str ) - [ - dup ctag-word present % - "\t" % - dup ctag-path normalize-path % - "\t" % - ctag-lineno number>string % - ] "" make ; + [ + dup ctag-word present % + "\t" % + dup ctag-path normalize-path % + "\t" % + ctag-lineno number>string % + ] "" make ; : ctag-strings ( alist -- seq ) - [ ctag ] map ; + [ ctag ] map ; : ctags-write ( seq path -- ) - [ ctag-strings ] dip ascii set-file-lines ; + [ ctag-strings ] dip ascii set-file-lines ; : (ctags) ( -- seq ) - all-words [ - dup where [ - 2array - ] when* - ] map [ sequence? ] filter ; + all-words [ + dup where [ + 2array + ] when* + ] map [ sequence? ] filter ; : ctags ( path -- ) - (ctags) sort-keys swap ctags-write ; \ No newline at end of file + (ctags) sort-keys swap ctags-write ; diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 83de1c5438..919823cca3 100644 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel peg strings sequences math math.parser 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 TUPLE: ast-number value ; @@ -21,348 +22,351 @@ TUPLE: ast-in name ; TUPLE: ast-hashtable elements ; : identifier-middle? ( ch -- bool ) - [ blank? not ] keep - [ "}];\"" member? not ] keep - digit? not - and and ; + { + [ blank? not ] + [ "}];\"" member? not ] + [ digit? not ] + } 1&& ; : 'identifier-ends' ( -- parser ) - [ - [ blank? not ] keep - [ CHAR: " = not ] keep - [ CHAR: ; = not ] keep - [ LETTER? not ] keep - [ letter? not ] keep - identifier-middle? not - and and and and and - ] satisfy repeat0 ; + [ + { + [ blank? not ] + [ CHAR: " = not ] + [ CHAR: ; = not ] + [ LETTER? not ] + [ letter? not ] + [ identifier-middle? not ] + } 1&& + ] satisfy repeat0 ; : 'identifier-middle' ( -- parser ) - [ identifier-middle? ] satisfy repeat1 ; + [ identifier-middle? ] satisfy repeat1 ; : 'identifier' ( -- parser ) - [ - 'identifier-ends' , - 'identifier-middle' , - 'identifier-ends' , - ] seq* [ - "" concat-as f ast-identifier boa - ] action ; + [ + 'identifier-ends' , + 'identifier-middle' , + 'identifier-ends' , + ] seq* [ + "" concat-as f ast-identifier boa + ] action ; DEFER: 'expression' : 'effect-name' ( -- parser ) - [ - [ blank? not ] keep - [ CHAR: ) = not ] keep - CHAR: - = not - and and - ] satisfy repeat1 [ >string ] action ; + [ + { + [ blank? not ] + [ CHAR: ) = not ] + [ CHAR: - = not ] + } 1&& + ] satisfy repeat1 [ >string ] action ; : 'stack-effect' ( -- parser ) - [ - "(" token hide , - 'effect-name' sp repeat0 , - "--" token sp hide , - 'effect-name' sp repeat0 , - ")" token sp hide , - ] seq* [ - first2 ast-stack-effect boa - ] action ; + [ + "(" token hide , + 'effect-name' sp repeat0 , + "--" token sp hide , + 'effect-name' sp repeat0 , + ")" token sp hide , + ] seq* [ + first2 ast-stack-effect boa + ] action ; : 'define' ( -- parser ) - [ - ":" token sp hide , - 'identifier' sp [ value>> ] action , - 'stack-effect' sp optional , - 'expression' , - ";" token sp hide , - ] seq* [ first3 ast-define boa ] action ; + [ + ":" token sp hide , + 'identifier' sp [ value>> ] action , + 'stack-effect' sp optional , + 'expression' , + ";" token sp hide , + ] seq* [ first3 ast-define boa ] action ; : 'quotation' ( -- parser ) - [ - "[" token sp hide , - 'expression' [ values>> ] action , - "]" token sp hide , - ] seq* [ first ast-quotation boa ] action ; + [ + "[" token sp hide , + 'expression' [ values>> ] action , + "]" token sp hide , + ] seq* [ first ast-quotation boa ] action ; : 'array' ( -- parser ) - [ - "{" token sp hide , - 'expression' [ values>> ] action , - "}" token sp hide , - ] seq* [ first ast-array boa ] action ; + [ + "{" token sp hide , + 'expression' [ values>> ] action , + "}" token sp hide , + ] seq* [ first ast-array boa ] action ; : 'word' ( -- parser ) - [ - "\\" token sp hide , - 'identifier' sp , - ] seq* [ first value>> f ast-word boa ] action ; + [ + "\\" token sp hide , + 'identifier' sp , + ] seq* [ first value>> f ast-word boa ] action ; : 'atom' ( -- parser ) - [ - 'identifier' , - 'integer' [ ast-number boa ] action , - 'string' [ ast-string boa ] action , - ] choice* ; + [ + 'identifier' , + 'integer' [ ast-number boa ] action , + 'string' [ ast-string boa ] action , + ] choice* ; : 'comment' ( -- parser ) - [ [ - "#!" token sp , - "!" token sp , - ] choice* hide , - [ - dup CHAR: \n = swap CHAR: \r = or not - ] satisfy repeat0 , - ] seq* [ drop ast-comment boa ] action ; + [ + "#!" token sp , + "!" token sp , + ] choice* hide , + [ + dup CHAR: \n = swap CHAR: \r = or not + ] satisfy repeat0 , + ] seq* [ drop ast-comment boa ] action ; : 'USE:' ( -- parser ) - [ - "USE:" token sp hide , - 'identifier' sp , - ] seq* [ first value>> ast-use boa ] action ; + [ + "USE:" token sp hide , + 'identifier' sp , + ] seq* [ first value>> ast-use boa ] action ; : 'IN:' ( -- parser ) - [ - "IN:" token sp hide , - 'identifier' sp , - ] seq* [ first value>> ast-in boa ] action ; + [ + "IN:" token sp hide , + 'identifier' sp , + ] seq* [ first value>> ast-in boa ] action ; : 'USING:' ( -- parser ) - [ - "USING:" token sp hide , - 'identifier' sp [ value>> ] action repeat1 , - ";" token sp hide , - ] seq* [ first ast-using boa ] action ; + [ + "USING:" token sp hide , + 'identifier' sp [ value>> ] action repeat1 , + ";" token sp hide , + ] seq* [ first ast-using boa ] action ; : 'hashtable' ( -- parser ) - [ - "H{" token sp hide , - 'expression' [ values>> ] action , - "}" token sp hide , - ] seq* [ first ast-hashtable boa ] action ; + [ + "H{" token sp hide , + 'expression' [ values>> ] action , + "}" token sp hide , + ] seq* [ first ast-hashtable boa ] action ; : 'parsing-word' ( -- parser ) - [ - 'USE:' , - 'USING:' , - 'IN:' , - ] choice* ; + [ + 'USE:' , + 'USING:' , + 'IN:' , + ] choice* ; : 'expression' ( -- parser ) - [ [ - 'comment' , - 'parsing-word' sp , - 'quotation' sp , - 'define' sp , - 'array' sp , - 'hashtable' sp , - 'word' sp , - 'atom' sp , - ] choice* repeat0 [ ast-expression boa ] action - ] delay ; + [ + 'comment' , + 'parsing-word' sp , + 'quotation' sp , + 'define' sp , + 'array' sp , + 'hashtable' sp , + 'word' sp , + 'atom' sp , + ] choice* repeat0 [ ast-expression boa ] action + ] delay ; : 'statement' ( -- parser ) - 'expression' ; + 'expression' ; GENERIC: (compile) ( ast -- ) GENERIC: (literal) ( ast -- ) M: ast-number (literal) - value>> number>string , ; + value>> number>string , ; M: ast-number (compile) - "factor.push_data(" , - (literal) - "," , ; + "factor.push_data(" , + (literal) + "," , ; M: ast-string (literal) - "\"" , - value>> , - "\"" , ; + "\"" , + value>> , + "\"" , ; M: ast-string (compile) - "factor.push_data(" , - (literal) - "," , ; + "factor.push_data(" , + (literal) + "," , ; M: ast-identifier (literal) - dup vocab>> [ - "factor.get_word(\"" , - dup vocab>> , - "\",\"" , - value>> , - "\")" , - ] [ - "factor.find_word(\"" , value>> , "\")" , - ] if ; + dup vocab>> [ + "factor.get_word(\"" , + dup vocab>> , + "\",\"" , + value>> , + "\")" , + ] [ + "factor.find_word(\"" , value>> , "\")" , + ] if ; M: ast-identifier (compile) - (literal) ".execute(" , ; + (literal) ".execute(" , ; M: ast-define (compile) - "factor.define_word(\"" , - dup name>> , - "\",\"source\"," , - expression>> (compile) - "," , ; + "factor.define_word(\"" , + dup name>> , + "\",\"source\"," , + expression>> (compile) + "," , ; : do-expressions ( seq -- ) - dup empty? not [ - unclip - dup ast-comment? not [ - "function() {" , - (compile) - do-expressions - ")}" , + dup empty? not [ + unclip + dup ast-comment? not [ + "function() {" , + (compile) + do-expressions + ")}" , + ] [ + drop do-expressions + ] if ] [ - drop do-expressions - ] if - ] [ - drop "factor.cont.next" , - ] if ; + drop "factor.cont.next" , + ] if ; M: ast-quotation (literal) - "factor.make_quotation(\"source\"," , - values>> do-expressions - ")" , ; + "factor.make_quotation(\"source\"," , + values>> do-expressions + ")" , ; M: ast-quotation (compile) - "factor.push_data(factor.make_quotation(\"source\"," , - values>> do-expressions - ")," , ; + "factor.push_data(factor.make_quotation(\"source\"," , + values>> do-expressions + ")," , ; M: ast-array (literal) - "[" , - elements>> [ "," , ] [ (literal) ] interleave - "]" , ; + "[" , + elements>> [ "," , ] [ (literal) ] interleave + "]" , ; M: ast-array (compile) - "factor.push_data(" , (literal) "," , ; + "factor.push_data(" , (literal) "," , ; M: ast-hashtable (literal) - "new Hashtable().fromAlist([" , - elements>> [ "," , ] [ (literal) ] interleave - "])" , ; + "new Hashtable().fromAlist([" , + elements>> [ "," , ] [ (literal) ] interleave + "])" , ; M: ast-hashtable (compile) - "factor.push_data(" , (literal) "," , ; + "factor.push_data(" , (literal) "," , ; M: ast-expression (literal) - values>> [ - (literal) - ] each ; + values>> [ + (literal) + ] each ; M: ast-expression (compile) - values>> do-expressions ; + values>> do-expressions ; M: ast-word (literal) - dup vocab>> [ - "factor.get_word(\"" , - dup vocab>> , - "\",\"" , - value>> , - "\")" , - ] [ - "factor.find_word(\"" , value>> , "\")" , - ] if ; + dup vocab>> [ + "factor.get_word(\"" , + dup vocab>> , + "\",\"" , + value>> , + "\")" , + ] [ + "factor.find_word(\"" , value>> , "\")" , + ] if ; M: ast-word (compile) - "factor.push_data(" , - (literal) - "," , ; + "factor.push_data(" , + (literal) + "," , ; M: ast-comment (compile) - drop ; + drop ; M: ast-stack-effect (compile) - drop ; + drop ; M: ast-use (compile) - "factor.use(\"" , - name>> , - "\"," , ; + "factor.use(\"" , + name>> , + "\"," , ; M: ast-in (compile) - "factor.set_in(\"" , - name>> , - "\"," , ; + "factor.set_in(\"" , + name>> , + "\"," , ; M: ast-using (compile) - "factor.using([" , - names>> [ - "," , - ] [ - "\"" , , "\"" , - ] interleave - "]," , ; + "factor.using([" , + names>> [ + "," , + ] [ + "\"" , , "\"" , + ] interleave + "]," , ; GENERIC: (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 ) - dup >string swap vocabulary>> ast-identifier boa ; + dup >string swap vocabulary>> ast-identifier boa ; 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 ) - ast-string boa ; + ast-string boa ; M: quotation (parse-factor-quotation) ( object -- ast ) - [ - [ (parse-factor-quotation) , ] each - ] { } make ast-quotation boa ; + [ + [ (parse-factor-quotation) , ] each + ] { } make ast-quotation boa ; M: array (parse-factor-quotation) ( object -- ast ) - [ - [ (parse-factor-quotation) , ] each - ] { } make ast-array boa ; + [ + [ (parse-factor-quotation) , ] each + ] { } make ast-array boa ; M: hashtable (parse-factor-quotation) ( object -- ast ) - >alist [ - [ (parse-factor-quotation) , ] each - ] { } make ast-hashtable boa ; + >alist [ + [ (parse-factor-quotation) , ] each + ] { } make ast-hashtable boa ; 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 ) M: string fjsc-parse ( object -- ast ) - 'expression' parse ; + 'expression' parse ; M: quotation fjsc-parse ( object -- ast ) - [ - [ (parse-factor-quotation) , ] each - ] { } make ast-expression boa ; + [ + [ (parse-factor-quotation) , ] each + ] { } make ast-expression boa ; : fjsc-compile ( ast -- string ) - [ [ - "(" , - (compile) - ")" , - ] { } make [ write ] each - ] with-string-writer ; + [ + "(" , + (compile) + ")" , + ] { } make [ write ] each + ] with-string-writer ; : fjsc-compile* ( string -- string ) - 'statement' parse fjsc-compile ; + 'statement' parse fjsc-compile ; : fc* ( string -- ) - [ - 'statement' parse values>> do-expressions - ] { } make [ write ] each ; + [ + 'statement' parse values>> do-expressions + ] { } make [ write ] each ; : fjsc-literal ( ast -- string ) - [ - [ (literal) ] { } make [ write ] each - ] with-string-writer ; + [ + [ (literal) ] { } make [ write ] each + ] with-string-writer ; diff --git a/extra/libudev/libudev.factor b/extra/libudev/libudev.factor index 17739d27ed..ded590daa9 100644 --- a/extra/libudev/libudev.factor +++ b/extra/libudev/libudev.factor @@ -11,12 +11,12 @@ LIBRARY: libudev C-TYPE: udev FUNCTION: udev* udev_ref ( - udev* udev ) ; + udev* udev ) ; FUNCTION: void udev_unref ( - udev* udev ) ; + udev* udev ) ; @@ -33,63 +33,63 @@ CALLBACK: void udev_set_log_fn_callback ( c-string format ) ; ! va_list args ) ; FUNCTION: void udev_set_log_fn ( - udev* udev, - udev_set_log_fn_callback log_fn ) ; + udev* udev, + udev_set_log_fn_callback log_fn ) ; FUNCTION: int udev_get_log_priority ( - udev* udev ) ; + udev* udev ) ; FUNCTION: void udev_set_log_priority ( - udev* udev, - int priority ) ; + udev* udev, + int priority ) ; FUNCTION: c-string udev_get_sys_path ( - udev* udev ) ; + udev* udev ) ; FUNCTION: c-string udev_get_dev_path ( - udev* udev ) ; + udev* udev ) ; FUNCTION: void* udev_get_userdata ( - udev* udev ) ; + udev* udev ) ; FUNCTION: void udev_set_userdata ( - udev* udev, - void* userdata ) ; + udev* udev, + void* userdata ) ; C-TYPE: udev_list_entry 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 ( - udev_list_entry* list_entry, - c-string name ) ; + udev_list_entry* list_entry, + c-string 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 ( - 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 FUNCTION: udev_device* udev_device_ref ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: void udev_device_unref ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: udev* udev_device_get_udev ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: udev_device* udev_device_new_from_syspath ( - udev* udev, - c-string syspath ) ; + udev* udev, + c-string syspath ) ; FUNCTION: udev_device* udev_device_new_from_devnum ( - udev* udev, - char type, - dev_t devnum ) ; + udev* udev, + char type, + dev_t devnum ) ; FUNCTION: udev_device* udev_device_new_from_subsystem_sysname ( - udev* udev, - c-string subsystem, - c-string sysname ) ; + udev* udev, + c-string subsystem, + c-string sysname ) ; 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 ( - udev_device* udev_device, - c-string subsystem, - c-string devtype ) ; + udev_device* udev_device, + c-string subsystem, + c-string devtype ) ; FUNCTION: c-string udev_device_get_devpath ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_subsystem ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_devtype ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_syspath ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_sysname ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_sysnum ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; 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 ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; 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 ( - udev_device* udev_device, - c-string key ) ; + udev_device* udev_device, + c-string key ) ; FUNCTION: c-string udev_device_get_driver ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: dev_t udev_device_get_devnum ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_action ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: ulonglong udev_device_get_seqnum ( - udev_device* udev_device ) ; + udev_device* udev_device ) ; FUNCTION: c-string udev_device_get_sysattr_value ( - udev_device* udev_device, - c-string sysattr ) ; + udev_device* udev_device, + c-string sysattr ) ; C-TYPE: udev_monitor FUNCTION: udev_monitor* udev_monitor_ref ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: void udev_monitor_unref ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: udev* udev_monitor_get_udev ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: udev_monitor* udev_monitor_new_from_netlink ( - udev* udev, - c-string name ) ; + udev* udev, + c-string name ) ; FUNCTION: udev_monitor* udev_monitor_new_from_socket ( - udev* udev, - c-string socket_path ) ; + udev* udev, + c-string socket_path ) ; FUNCTION: int udev_monitor_enable_receiving ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: int udev_monitor_set_receive_buffer_size ( - udev_monitor* udev_monitor, - int size ) ; + udev_monitor* udev_monitor, + int size ) ; FUNCTION: int udev_monitor_get_fd ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: udev_device* udev_monitor_receive_device ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype ( - udev_monitor* udev_monitor, - c-string subsystem, - c-string devtype ) ; + udev_monitor* udev_monitor, + c-string subsystem, + c-string devtype ) ; FUNCTION: int udev_monitor_filter_update ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; FUNCTION: int udev_monitor_filter_remove ( - udev_monitor* udev_monitor ) ; + udev_monitor* udev_monitor ) ; C-TYPE: udev_enumerate FUNCTION: udev_enumerate* udev_enumerate_ref ( - udev_enumerate* udev_enumerate ) ; + udev_enumerate* udev_enumerate ) ; FUNCTION: void udev_enumerate_unref ( - udev_enumerate* udev_enumerate ) ; + udev_enumerate* udev_enumerate ) ; FUNCTION: udev* udev_enumerate_get_udev ( - udev_enumerate* udev_enumerate ) ; + udev_enumerate* udev_enumerate ) ; FUNCTION: udev_enumerate* udev_enumerate_new ( - udev* udev ) ; + udev* udev ) ; FUNCTION: int udev_enumerate_add_match_subsystem ( - udev_enumerate* udev_enumerate, - c-string subsystem ) ; + udev_enumerate* udev_enumerate, + c-string subsystem ) ; FUNCTION: int udev_enumerate_add_nomatch_subsystem ( - udev_enumerate* udev_enumerate, - c-string subsystem ) ; + udev_enumerate* udev_enumerate, + c-string subsystem ) ; FUNCTION: int udev_enumerate_add_match_sysattr ( - udev_enumerate* udev_enumerate, - c-string sysattr, - c-string value ) ; + udev_enumerate* udev_enumerate, + c-string sysattr, + c-string value ) ; FUNCTION: int udev_enumerate_add_nomatch_sysattr ( - udev_enumerate* udev_enumerate, - c-string sysattr, - c-string value ) ; + udev_enumerate* udev_enumerate, + c-string sysattr, + c-string value ) ; FUNCTION: int udev_enumerate_add_match_property ( - udev_enumerate* udev_enumerate, - c-string property, - c-string value ) ; + udev_enumerate* udev_enumerate, + c-string property, + c-string value ) ; FUNCTION: int udev_enumerate_add_match_sysname ( - udev_enumerate* udev_enumerate, - c-string sysname ) ; + udev_enumerate* udev_enumerate, + c-string sysname ) ; FUNCTION: int udev_enumerate_add_syspath ( - udev_enumerate* udev_enumerate, - c-string syspath ) ; + udev_enumerate* udev_enumerate, + c-string syspath ) ; FUNCTION: int udev_enumerate_scan_devices ( - udev_enumerate* udev_enumerate ) ; + udev_enumerate* udev_enumerate ) ; FUNCTION: int udev_enumerate_scan_subsystems ( - udev_enumerate* udev_enumerate ) ; + udev_enumerate* udev_enumerate ) ; FUNCTION: udev_list_entry* udev_enumerate_get_list_entry ( - udev_enumerate* udev_enumerate ) ; + udev_enumerate* udev_enumerate ) ; C-TYPE: udev_queue FUNCTION: udev_queue* udev_queue_ref ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: void udev_queue_unref ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: udev* udev_queue_get_udev ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: udev_queue* udev_queue_new ( - udev* udev ) ; + udev* udev ) ; FUNCTION: ulonglong udev_queue_get_kernel_seqnum ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: ulonglong udev_queue_get_udev_seqnum ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: int udev_queue_get_udev_is_active ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: int udev_queue_get_queue_is_empty ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; FUNCTION: int udev_queue_get_seqnum_is_finished ( - udev_queue* udev_queue, - ulonglong seqnum ) ; + udev_queue* udev_queue, + ulonglong seqnum ) ; FUNCTION: int udev_queue_get_seqnum_sequence_is_finished ( - udev_queue* udev_queue, - ulonglong start, - ulonglong end ) ; + udev_queue* udev_queue, + ulonglong start, + ulonglong end ) ; 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 ( - udev_queue* udev_queue ) ; + udev_queue* udev_queue ) ; diff --git a/extra/lunar-rescue/lunar-rescue.factor b/extra/lunar-rescue/lunar-rescue.factor index 9d267a78ce..6cd0cf3499 100644 --- a/extra/lunar-rescue/lunar-rescue.factor +++ b/extra/lunar-rescue/lunar-rescue.factor @@ -14,7 +14,7 @@ IN: lunar-rescue TUPLE: lunar-rescue < space-invaders ; : ( -- cpu ) - lunar-rescue new cpu-init ; + lunar-rescue new cpu-init ; CONSTANT: rom-info { { 0x0000 "lrescue/lrescue.1" } @@ -23,9 +23,9 @@ CONSTANT: rom-info { { 0x1800 "lrescue/lrescue.4" } { 0x4000 "lrescue/lrescue.5" } { 0x4800 "lrescue/lrescue.6" } - } +} : run-lunar ( -- ) - [ "Lunar Rescue" rom-info (run) ] with-ui ; + [ "Lunar Rescue" rom-info (run) ] with-ui ; MAIN: run-lunar diff --git a/extra/s3/s3.factor b/extra/s3/s3.factor index e4677e1167..e04117024b 100644 --- a/extra/s3/s3.factor +++ b/extra/s3/s3.factor @@ -54,12 +54,12 @@ TUPLE: s3-request path mime-type date method headers bucket data ; ":" % signature secret-key get sha1 hmac-bytes >base64 % ] "" make ; - + : s3-url ( s3-request -- string ) - [ + [ "http://" % dup bucket>> [ % "." % ] when* - "s3.amazonaws.com" % + "s3.amazonaws.com" % path>> % ] "" make ; @@ -110,13 +110,13 @@ TUPLE: key name last-modified size ; string ] - [ "LastModified" tag-named children>string ] - [ "Size" tag-named children>string ] - tri key boa - ] map ; + [ "Key" tag-named children>string ] + [ "LastModified" tag-named children>string ] + [ "Size" tag-named children>string ] + tri key boa + ] map ; PRIVATE> - + : keys ( bucket -- seq ) "/" H{ } clone s3-get nip >string string>xml (keys) ; @@ -138,7 +138,7 @@ PRIVATE> : delete-bucket ( bucket -- ) "/" H{ } clone "DELETE" dup s3-url sign-http-request http-request 2drop ; - + : put-object ( data mime-type bucket key headers -- ) [ "/" prepend ] dip "PUT" over >>mime-type diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 599964b9fd..05743aafa7 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -37,11 +37,11 @@ CONSTANT: game-width 224 CONSTANT: game-height 256 : make-opengl-bitmap ( -- array ) - game-height game-width 3 * * uchar ; + game-height game-width 3 * * uchar ; : bitmap-index ( point -- index ) - #! Point is a {x y}. - first2 game-width 3 * * swap 3 * + ; + #! Point is a {x y}. + first2 game-width 3 * * swap 3 * + ; :: set-bitmap-pixel ( bitmap point color -- ) point bitmap-index :> index @@ -50,12 +50,12 @@ CONSTANT: game-height 256 color third index 2 + bitmap set-nth ; : get-bitmap-pixel ( point array -- color ) - #! Point is a {x y}. color is a {r g b} - [ bitmap-index ] dip - [ nth ] 2keep - [ [ 1 + ] dip nth ] 2keep - [ 2 + ] dip nth 3array ; - + #! Point is a {x y}. color is a {r g b} + [ bitmap-index ] dip + [ nth ] 2keep + [ [ 1 + ] dip nth ] 2keep + [ 2 + ] dip nth 3array ; + CONSTANT: SOUND-SHOT 0 CONSTANT: SOUND-UFO 1 CONSTANT: SOUND-BASE-HIT 2 @@ -67,212 +67,212 @@ CONSTANT: SOUND-WALK4 7 CONSTANT: SOUND-UFO-HIT 8 : init-sound ( index cpu filename -- ) - absolute-path swapd [ sounds>> nth AL_BUFFER ] dip - create-buffer-from-wav set-source-param ; + absolute-path swapd [ sounds>> nth AL_BUFFER ] dip + create-buffer-from-wav set-source-param ; : init-sounds ( cpu -- ) - init-openal - [ 9 gen-sources swap sounds<< ] keep - [ SOUND-SHOT "vocab:space-invaders/resources/Shot.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 - [ 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-WALK1 "vocab:space-invaders/resources/Walk1.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-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep - [ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep - f swap looping?<< ; + init-openal + [ 9 gen-sources swap sounds<< ] keep + [ SOUND-SHOT "vocab:space-invaders/resources/Shot.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 + [ 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-WALK1 "vocab:space-invaders/resources/Walk1.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-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep + [ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep + f swap looping?<< ; : cpu-init ( cpu -- cpu ) - make-opengl-bitmap over bitmap<< - [ init-sounds ] keep - [ reset ] keep ; + make-opengl-bitmap over bitmap<< + [ init-sounds ] keep + [ reset ] keep ; : ( -- cpu ) - space-invaders new cpu-init ; + space-invaders new cpu-init ; : play-invaders-sound ( cpu sound -- ) - swap sounds>> nth source-play ; + swap sounds>> nth source-play ; : stop-invaders-sound ( cpu sound -- ) - swap sounds>> nth source-stop ; + swap sounds>> nth source-stop ; : read-port1 ( cpu -- byte ) - #! Port 1 maps the keys for space invaders - #! Bit 0 = coin slot - #! Bit 1 = two players button - #! Bit 2 = one player button - #! Bit 4 = player one fire - #! Bit 5 = player one left - #! Bit 6 = player one right - [ port1>> dup 0xFE bitand ] keep - port1<< ; + #! Port 1 maps the keys for space invaders + #! Bit 0 = coin slot + #! Bit 1 = two players button + #! Bit 2 = one player button + #! Bit 4 = player one fire + #! Bit 5 = player one left + #! Bit 6 = player one right + [ port1>> dup 0xFE bitand ] keep + port1<< ; : read-port2 ( cpu -- byte ) - #! Port 2 maps player 2 controls and dip switches - #! Bit 0,1 = number of ships - #! Bit 2 = mode (1=easy, 0=hard) - #! Bit 4 = player two fire - #! Bit 5 = player two left - #! Bit 6 = player two right - #! Bit 7 = show or hide coin info - [ port2i>> 0x8F bitand ] keep - port1>> 0x70 bitand bitor ; + #! Port 2 maps player 2 controls and dip switches + #! Bit 0,1 = number of ships + #! Bit 2 = mode (1=easy, 0=hard) + #! Bit 4 = player two fire + #! Bit 5 = player two left + #! Bit 6 = player two right + #! Bit 7 = show or hide coin info + [ port2i>> 0x8F bitand ] keep + port1>> 0x70 bitand bitor ; : read-port3 ( cpu -- byte ) - #! Used to compute a special formula - [ port4hi>> 8 shift ] keep - [ port4lo>> bitor ] keep - port2o>> shift -8 shift 0xFF bitand ; + #! Used to compute a special formula + [ port4hi>> 8 shift ] keep + [ port4lo>> bitor ] keep + port2o>> shift -8 shift 0xFF bitand ; M: space-invaders read-port ( port cpu -- byte ) - #! Read a byte from the hardware port. 'port' should - #! be an 8-bit value. - swap { - { 1 [ read-port1 ] } - { 2 [ read-port2 ] } - { 3 [ read-port3 ] } - [ 2drop 0 ] - } case ; + #! Read a byte from the hardware port. 'port' should + #! be an 8-bit value. + swap { + { 1 [ read-port1 ] } + { 2 [ read-port2 ] } + { 3 [ read-port3 ] } + [ 2drop 0 ] + } case ; : write-port2 ( value cpu -- ) - #! Setting this value affects the value read from port 3 - port2o<< ; + #! Setting this value affects the value read from port 3 + port2o<< ; :: 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 ) - [ port3o>> swap ] dip bit-newly-set? ; + [ port3o>> swap ] dip bit-newly-set? ; : port5-newly-set? ( new-value cpu bit -- bool ) - [ port5o>> swap ] dip bit-newly-set? ; + [ port5o>> swap ] dip bit-newly-set? ; : write-port3 ( value cpu -- ) - #! Connected to the sound hardware - #! Bit 0 = spaceship sound (looped) - #! Bit 1 = Shot - #! Bit 2 = Your ship hit - #! Bit 3 = Invader hit - #! Bit 4 = Extended play sound - over 0 bit? over looping?>> not and [ - dup SOUND-UFO play-invaders-sound - t over looping?<< - ] when - over 0 bit? not over looping?>> and [ - dup SOUND-UFO stop-invaders-sound - f over looping?<< - ] 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 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 - port3o<< ; + #! Connected to the sound hardware + #! Bit 0 = spaceship sound (looped) + #! Bit 1 = Shot + #! Bit 2 = Your ship hit + #! Bit 3 = Invader hit + #! Bit 4 = Extended play sound + over 0 bit? over looping?>> not and [ + dup SOUND-UFO play-invaders-sound + t over looping?<< + ] when + over 0 bit? not over looping?>> and [ + dup SOUND-UFO stop-invaders-sound + f over looping?<< + ] 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 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 + port3o<< ; : write-port4 ( value cpu -- ) - #! Affects the value returned by reading port 3 - [ port4hi>> ] keep - [ port4lo<< ] keep - port4hi<< ; + #! Affects the value returned by reading port 3 + [ port4hi>> ] keep + [ port4lo<< ] keep + port4hi<< ; : write-port5 ( value cpu -- ) - #! Plays sounds - #! Bit 0 = invaders sound 1 - #! Bit 1 = invaders sound 2 - #! Bit 2 = invaders sound 3 - #! Bit 3 = invaders sound 4 - #! Bit 4 = spaceship hit - #! Bit 5 = amplifier enabled/disabled - 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 2 port5-newly-set? [ dup SOUND-WALK3 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 - port5o<< ; + #! Plays sounds + #! Bit 0 = invaders sound 1 + #! Bit 1 = invaders sound 2 + #! Bit 2 = invaders sound 3 + #! Bit 3 = invaders sound 4 + #! Bit 4 = spaceship hit + #! Bit 5 = amplifier enabled/disabled + 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 2 port5-newly-set? [ dup SOUND-WALK3 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 + port5o<< ; M: space-invaders write-port ( value port cpu -- ) - #! Write a byte to the hardware port, where 'port' is - #! an 8-bit value. - swap { - { 2 [ write-port2 ] } - { 3 [ write-port3 ] } - { 4 [ write-port4 ] } - { 5 [ write-port5 ] } - [ 3drop ] - } case ; + #! Write a byte to the hardware port, where 'port' is + #! an 8-bit value. + swap { + { 2 [ write-port2 ] } + { 3 [ write-port3 ] } + { 4 [ write-port4 ] } + { 5 [ write-port5 ] } + [ 3drop ] + } case ; M: space-invaders reset ( cpu -- ) - dup call-next-method - 0 >>port1 - 0 >>port2i - 0 >>port2o - 0 >>port3o - 0 >>port4lo - 0 >>port4hi - 0 >>port5o - drop ; + dup call-next-method + 0 >>port1 + 0 >>port2i + 0 >>port2o + 0 >>port3o + 0 >>port4lo + 0 >>port4hi + 0 >>port5o + drop ; : gui-step ( cpu -- ) - [ read-instruction ] keep ! n cpu - over get-cycles over inc-cycles - [ swap instructions nth call( cpu -- ) ] keep - [ pc>> 0xFFFF bitand ] keep - pc<< ; + [ read-instruction ] keep ! n cpu + over get-cycles over inc-cycles + [ swap instructions nth call( cpu -- ) ] keep + [ pc>> 0xFFFF bitand ] keep + pc<< ; : gui-frame/2 ( cpu -- ) - [ gui-step ] keep - [ cycles>> ] keep - over 16667 < [ ! cycles cpu - nip gui-frame/2 - ] [ - [ [ 16667 - ] dip cycles<< ] keep - dup last-interrupt>> 0x10 = [ - 0x08 over last-interrupt<< 0x08 swap interrupt + [ gui-step ] keep + [ cycles>> ] keep + over 16667 < [ ! cycles cpu + nip gui-frame/2 ] [ - 0x10 over last-interrupt<< 0x10 swap interrupt - ] if - ] if ; + [ [ 16667 - ] dip cycles<< ] keep + dup last-interrupt>> 0x10 = [ + 0x08 over last-interrupt<< 0x08 swap interrupt + ] [ + 0x10 over last-interrupt<< 0x10 swap interrupt + ] if + ] if ; : gui-frame ( cpu -- ) - dup gui-frame/2 gui-frame/2 ; + dup gui-frame/2 gui-frame/2 ; : coin-down ( cpu -- ) - [ port1>> 1 bitor ] keep port1<< ; + [ port1>> 1 bitor ] keep port1<< ; : coin-up ( cpu -- ) - [ port1>> 255 1 - bitand ] keep port1<< ; + [ port1>> 255 1 - bitand ] keep port1<< ; : player1-down ( cpu -- ) - [ port1>> 4 bitor ] keep port1<< ; + [ port1>> 4 bitor ] keep port1<< ; : player1-up ( cpu -- ) - [ port1>> 255 4 - bitand ] keep port1<< ; + [ port1>> 255 4 - bitand ] keep port1<< ; : player2-down ( cpu -- ) - [ port1>> 2 bitor ] keep port1<< ; + [ port1>> 2 bitor ] keep port1<< ; : player2-up ( cpu -- ) - [ port1>> 255 2 - bitand ] keep port1<< ; + [ port1>> 255 2 - bitand ] keep port1<< ; : fire-down ( cpu -- ) - [ port1>> 0x10 bitor ] keep port1<< ; + [ port1>> 0x10 bitor ] keep port1<< ; : fire-up ( cpu -- ) - [ port1>> 255 0x10 - bitand ] keep port1<< ; + [ port1>> 255 0x10 - bitand ] keep port1<< ; : left-down ( cpu -- ) - [ port1>> 0x20 bitor ] keep port1<< ; + [ port1>> 0x20 bitor ] keep port1<< ; : left-up ( cpu -- ) - [ port1>> 255 0x20 - bitand ] keep port1<< ; + [ port1>> 255 0x20 - bitand ] keep port1<< ; : right-down ( cpu -- ) - [ port1>> 0x40 bitor ] keep port1<< ; + [ port1>> 0x40 bitor ] keep port1<< ; : right-up ( cpu -- ) - [ port1>> 255 0x40 - bitand ] keep port1<< ; + [ port1>> 255 0x40 - bitand ] keep port1<< ; 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-down f f "RIGHT" } [ cpu>> right-down ] } { T{ key-up f f "RIGHT" } [ cpu>> right-up ] } - } set-gestures +} set-gestures : ( cpu -- gadget ) - invaders-gadget new - swap >>cpu - f >>quit? ; + invaders-gadget new + swap >>cpu + f >>quit? ; M: invaders-gadget pref-dim* drop { 224 256 } ; M: invaders-gadget draw-gadget* ( gadget -- ) - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip - cpu>> bitmap>> glDrawPixels ; + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip + cpu>> bitmap>> glDrawPixels ; CONSTANT: black { 0 0 0 } CONSTANT: white { 255 255 255 } @@ -312,91 +312,91 @@ CONSTANT: green { 0 255 0 } CONSTANT: red { 255 0 0 } : addr>xy ( addr -- point ) - #! Convert video RAM address to base X Y value. point is a {x y}. - 0x2400 - ! n - dup 0x1f bitand 8 * 255 swap - ! n y - swap -5 shift swap 2array ; + #! Convert video RAM address to base X Y value. point is a {x y}. + 0x2400 - ! n + dup 0x1f bitand 8 * 255 swap - ! n y + swap -5 shift swap 2array ; : plot-bitmap-pixel ( bitmap point color -- ) - #! point is a {x y}. color is a {r g b}. - set-bitmap-pixel ; + #! point is a {x y}. color is a {r g b}. + set-bitmap-pixel ; : get-point-color ( point -- color ) - #! Return the color to use for the given x/y position. - first2 - { - { [ dup 184 238 between? pick 0 223 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 ] } - [ 2drop white ] - } cond ; + #! Return the color to use for the given x/y position. + first2 + { + { [ dup 184 238 between? pick 0 223 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 ] } + [ 2drop white ] + } cond ; : plot-bitmap-bits ( bitmap point byte bit -- ) - #! point is a {x y}. - [ first2 ] 2dip - dup swapd -1 * shift 1 bitand 0 = - [ - 2array ] dip - [ black ] [ dup get-point-color ] if - plot-bitmap-pixel ; + #! point is a {x y}. + [ first2 ] 2dip + dup swapd -1 * shift 1 bitand 0 = + [ - 2array ] dip + [ black ] [ dup get-point-color ] if + plot-bitmap-pixel ; : do-bitmap-update ( bitmap value addr -- ) - addr>xy swap - [ 0 plot-bitmap-bits ] 3keep - [ 1 plot-bitmap-bits ] 3keep - [ 2 plot-bitmap-bits ] 3keep - [ 3 plot-bitmap-bits ] 3keep - [ 4 plot-bitmap-bits ] 3keep - [ 5 plot-bitmap-bits ] 3keep - [ 6 plot-bitmap-bits ] 3keep - 7 plot-bitmap-bits ; + addr>xy swap + [ 0 plot-bitmap-bits ] 3keep + [ 1 plot-bitmap-bits ] 3keep + [ 2 plot-bitmap-bits ] 3keep + [ 3 plot-bitmap-bits ] 3keep + [ 4 plot-bitmap-bits ] 3keep + [ 5 plot-bitmap-bits ] 3keep + [ 6 plot-bitmap-bits ] 3keep + 7 plot-bitmap-bits ; M: space-invaders update-video ( value addr cpu -- ) - over 0x2400 >= [ - bitmap>> -rot do-bitmap-update - ] [ - 3drop - ] if ; + over 0x2400 >= [ + bitmap>> -rot do-bitmap-update + ] [ + 3drop + ] if ; : sync-frame ( micros -- micros ) - #! Sleep until the time for the next frame arrives. - 1000 60 / >fixnum + gmt timestamp>micros - dup 0 > - [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ; + #! Sleep until the time for the next frame arrives. + 1000 60 / >fixnum + gmt timestamp>micros - dup 0 > + [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ; : invaders-process ( micros gadget -- ) - #! Run a space invaders gadget inside a - #! concurrent process. Messages can be sent to - #! signal key presses, etc. - dup quit?>> [ - 2drop - ] [ - [ sync-frame ] dip - [ cpu>> gui-frame ] keep - [ relayout-1 ] keep - invaders-process - ] if ; + #! Run a space invaders gadget inside a + #! concurrent process. Messages can be sent to + #! signal key presses, etc. + dup quit?>> [ + 2drop + ] [ + [ sync-frame ] dip + [ cpu>> gui-frame ] keep + [ relayout-1 ] keep + invaders-process + ] if ; M: invaders-gadget graft* ( gadget -- ) - dup cpu>> init-sounds - f over quit?<< - [ gmt timestamp>micros swap invaders-process ] curry - "Space invaders" threads:spawn drop ; + dup cpu>> init-sounds + f over quit?<< + [ gmt timestamp>micros swap invaders-process ] curry + "Space invaders" threads:spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) - t swap quit?<< ; + t swap quit?<< ; : (run) ( title cpu rom-info -- ) - over load-rom* t >>windowed? swap open-window ; + over load-rom* t >>windowed? swap open-window ; CONSTANT: rom-info { { 0x0000 "invaders/invaders.h" } { 0x0800 "invaders/invaders.g" } { 0x1000 "invaders/invaders.f" } { 0x1800 "invaders/invaders.e" } - } +} : run-invaders ( -- ) - [ - "Space Invaders" rom-info (run) - ] with-ui ; + [ + "Space Invaders" rom-info (run) + ] with-ui ; MAIN: run-invaders diff --git a/extra/update/update.factor b/extra/update/update.factor index ba09cc3f3d..6a31f20e13 100644 --- a/extra/update/update.factor +++ b/extra/update/update.factor @@ -9,18 +9,16 @@ IN: update ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-pull-clean ( -- ) - image parent-directory - [ - { "git" "pull" "git://factorcode.org/git/factor.git" branch-name } - run-command - ] - with-directory ; + image parent-directory [ + { "git" "pull" "git://factorcode.org/git/factor.git" branch-name } + run-command + ] with-directory ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : remote-clean-image ( -- url ) - { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name } - to-string ; + { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name } + to-string ; : download-clean-image ( -- ) remote-clean-image download ; @@ -33,29 +31,25 @@ IN: update ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : rebuild ( -- ) - image parent-directory - [ - download-clean-image - make-clean - make - boot - ] - with-directory ; + image parent-directory [ + download-clean-image + make-clean + make + boot + ] with-directory ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : update ( -- ) - image parent-directory - [ - git-id - git-pull-clean - git-id - = not + image parent-directory [ + git-id + git-pull-clean + git-id + = not [ rebuild ] - when - ] - with-directory ; + when + ] with-directory ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MAIN: update \ No newline at end of file +MAIN: update diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index 6de6a88d61..0c0d36a829 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -8,82 +8,82 @@ SYMBOL: *wordtimes* SYMBOL: *calling* : reset-word-timer ( -- ) - H{ } clone *wordtimes* set-global - H{ } clone *calling* set-global ; - + H{ } clone *wordtimes* set-global + H{ } clone *calling* set-global ; + : 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' ) - rot [ + ] curry [ 1 + ] bi* ; + rot [ + ] curry [ 1 + ] bi* ; : register-time ( utime word -- ) - name>> - [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; + name>> + [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; : calling ( word -- ) - dup *calling* get-global set-at ; inline + dup *calling* get-global set-at ; inline : finished ( word -- ) - *calling* get-global delete-at ; inline + *calling* get-global delete-at ; inline : called-recursively? ( word -- t/f ) - *calling* get-global at ; inline - + *calling* get-global at ; inline + : 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 -- ) - dup called-recursively? not - [ timed-call ] [ drop call ] if ; inline - + dup called-recursively? not + [ timed-call ] [ drop call ] if ; inline + : (add-timer) ( word quot -- quot' ) - [ swap time-unless-recursing ] 2curry ; + [ swap time-unless-recursing ] 2curry ; : add-timer ( word -- ) - dup '[ [ _ ] dip (add-timer) ] annotate ; + dup '[ [ _ ] dip (add-timer) ] annotate ; : add-timers ( vocab -- ) - words [ add-timer ] each ; + words [ add-timer ] each ; : reset-vocab ( vocab -- ) - words [ reset ] each ; + words [ reset ] each ; : dummy-word ( -- ) ; : 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} ) - [ first2 ] dip - swap [ * - ] keep 2array ; + [ first2 ] dip + swap [ * - ] keep 2array ; : (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 ( -- ) - *wordtimes* [ (correct-for-timing-overhead) ] change-global ; - + *wordtimes* [ (correct-for-timing-overhead) ] change-global ; + : 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 -- ) - reset-word-timer - benchmark [ - correct-for-timing-overhead - "total time:" write - ] dip pprint nl - print-word-timings nl ; inline + reset-word-timer + benchmark [ + correct-for-timing-overhead + "total time:" write + ] dip pprint nl + print-word-timings nl ; inline : profile-vocab ( vocab quot -- ) - "annotating vocab..." print flush - over [ reset-vocab ] [ add-timers ] bi - reset-word-timer - "executing quotation..." print flush - benchmark [ - "resetting annotations..." print flush - reset-vocab - correct-for-timing-overhead - "total time:" write - ] dip pprint - print-word-timings ; inline + "annotating vocab..." print flush + over [ reset-vocab ] [ add-timers ] bi + reset-word-timer + "executing quotation..." print flush + benchmark [ + "resetting annotations..." print flush + reset-vocab + correct-for-timing-overhead + "total time:" write + ] dip pprint + print-word-timings ; inline