! 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" } } ]
"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" } } ]
{ "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
[ 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 ;
C: <foo> foo
{ 1 2 } [
- 1 2 <foo> T{ foo f ?a ?b } match [
- ?a ?b
- ] with-variables
+ 1 2 <foo> T{ foo f ?a ?b } match [
+ ?a ?b
+ ] with-variables
] unit-test
{ 1 2 } [
- 1 2 <foo> \ ?a \ ?b <foo> match [
- ?a ?b
- ] with-variables
+ 1 2 <foo> \ ?a \ ?b <foo> 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 ;
[
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
: >=1? ( x -- ? )
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 )
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
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. ? ] }
[
[ ] [ 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
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> parse-result
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 <parse-error> ] }
- } case
- ]
- } cond ;
+ {
+ { [ over position>> not ] [ nip ] }
+ { [ dup position>> not ] [ drop ] }
+ [
+ 2dup [ position>> ] compare {
+ { +lt+ [ nip ] }
+ { +gt+ [ drop ] }
+ { +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
+ } 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 -- )
- <parse-error> error-stack get push ;
-
-SYMBOL: ignore
+
<parse-error> 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
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
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 )
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.
GENERIC: (compile) ( peg -- quot )
: process-parser-result ( result -- result )
- dup failed? [
- drop f
- ] [
- input-slice swap <parse-result>
- ] if ;
-
+ dup failed? [
+ drop f
+ ] [
+
input-slice swap <parse-result>
+ ] 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>> ;
<PRIVATE
-SYMBOL: id
+SYMBOL: id
: next-id ( -- n )
- #! Return the next unique id for a parser
- id get-global [
- dup 1 + id set-global
- ] [
- 1 id set-global 0
- ] if* ;
+ #! Return the next unique id for a parser
+ id get-global [
+ dup 1 + id set-global
+ ] [
+ 1 id set-global 0
+ ] if* ;
: wrap-peg ( peg -- parser )
- #! Wrap a parser tuple around the peg object.
- #! Look for an existing parser tuple for that
- #! peg object.
- peg-cache [
- f next-id parser boa
- ] cache ;
+ #! Wrap a parser tuple around the peg object.
+ #! Look for an existing parser tuple for that
+ #! peg object.
+ peg-cache [
+ f next-id parser boa
+ ] cache ;
TUPLE: token-parser symbol ;
: parse-token ( input string -- result )
- #! Parse the string, returning a parse result
- [ ?head-slice ] keep swap [
- <parse-result> 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 [
+
<parse-result> 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 [
- <parse-result>
- ] [
- 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 <parse-result>
- ] [
- drop f
- ] if
- ] if ;
+ pick empty? [
+ 3drop f
+ ] [
+ [ dup first ] 2dip between? [
+
unclip-slice <parse-result>
+ ] [
+ 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 <parse-result> ] %
[
- 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 <parse-result> ] %
+ [
+ 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 <parse-result> _ swap (repeat)
- ] ;
+ p1>> compile-parser-quot '[
+
input-slice V{ } clone <parse-result> _ 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 <parse-result> _ swap (repeat) repeat1-empty-check
- ] ;
+ p1>> compile-parser-quot '[
+
input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
+ ] ;
TUPLE: optional-parser p1 ;
: check-optional ( result -- result )
- [ input-slice f <parse-result> ] unless* ;
+
[ input-slice f <parse-result> ] 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 <parse-result> ] [ drop f ] if ;
+
[ ignore <parse-result> ] [ 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 <parse-result> ] if ;
+
[ drop f ] [ ignore <parse-result> ] 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 ;
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 ;
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
TUPLE: balloon-bomber < space-invaders ; \r
\r
: <balloon-bomber> ( -- cpu )\r
- balloon-bomber new cpu-init ;\r
+ balloon-bomber new cpu-init ;\r
\r
CONSTANT: rom-info {\r
{ 0x0000 "ballbomb/tn01" }\r
{ 0x1000 "ballbomb/tn03" }\r
{ 0x1800 "ballbomb/tn04" }\r
{ 0x4000 "ballbomb/tn05-1" }\r
- }\r
+}\r
\r
-: run-balloon ( -- ) \r
- [ "Balloon Bomber" <balloon-bomber> rom-info (run) ] with-ui ;\r
+: run-balloon ( -- )\r
+ [ "Balloon Bomber" <balloon-bomber> rom-info (run) ] with-ui ;\r
\r
MAIN: run-balloon\r
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 ;
! 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 ;
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 ;
C-TYPE: udev
FUNCTION: udev* udev_ref (
- udev* udev ) ;
+ udev* udev ) ;
FUNCTION: void udev_unref (
- udev* udev ) ;
+ udev* udev ) ;
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 ) ;
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 ) ;
TUPLE: lunar-rescue < space-invaders ; \r
\r
: <lunar-rescue> ( -- cpu )\r
- lunar-rescue new cpu-init ;\r
+ lunar-rescue new cpu-init ;\r
\r
CONSTANT: rom-info {\r
{ 0x0000 "lrescue/lrescue.1" }\r
{ 0x1800 "lrescue/lrescue.4" }\r
{ 0x4000 "lrescue/lrescue.5" }\r
{ 0x4800 "lrescue/lrescue.6" }\r
- }\r
+}\r
\r
: run-lunar ( -- ) \r
- [ "Lunar Rescue" <lunar-rescue> rom-info (run) ] with-ui ;\r
+ [ "Lunar Rescue" <lunar-rescue> rom-info (run) ] with-ui ;\r
\r
MAIN: run-lunar\r
":" %
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 ;
<PRIVATE
: (keys) ( xml -- seq )
"Contents" tags-named [
- [ "Key" tag-named children>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) ;
: delete-bucket ( bucket -- )
"/" H{ } clone "DELETE" <s3-request>
dup s3-url <delete-request> sign-http-request http-request 2drop ;
-
+
: put-object ( data mime-type bucket key headers -- )
[ "/" prepend ] dip "PUT" <s3-request>
over >>mime-type
CONSTANT: game-height 256
: make-opengl-bitmap ( -- array )
- game-height game-width 3 * * uchar <c-array> ;
+ game-height game-width 3 * * uchar <c-array> ;
: 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
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
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 ;
: <space-invaders> ( -- 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? ;
{ 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
: <invaders-gadget> ( 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 }
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* <invaders-gadget> t >>windowed? swap open-window ;
+ over load-rom* <invaders-gadget> 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" <space-invaders> rom-info (run)
- ] with-ui ;
+ [
+ "Space Invaders" <space-invaders> rom-info (run)
+ ] with-ui ;
MAIN: run-invaders
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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
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
projects / factor.git / commitdiff