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

switch some vocabs to 4 spaces.

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

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

@ -5,7 +5,7 @@ IN: csv.tests
! I like to name my unit tests
: 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

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

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

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

@ -187,13 +187,22 @@ M: real absq sq ; inline
: >=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
@ -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. ? ] }
[

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

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

636
basis/peg/peg.factor
View File

@ -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> parse-result
@ -21,37 +21,38 @@ C: <parse-error> 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 <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
@ -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 <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 [
<parse-result>
] [
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 ;

4
basis/ui/ui.factor
View File

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

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

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

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

@ -14,7 +14,7 @@ IN: balloon-bomber
TUPLE: balloon-bomber < space-invaders ;
: <balloon-bomber> ( -- 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" <balloon-bomber> rom-info (run) ] with-ui ;
: run-balloon ( -- )
[ "Balloon Bomber" <balloon-bomber> rom-info (run) ] with-ui ;
MAIN: run-balloon

36
extra/ctags/ctags.factor
View File

@ -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 ;
(ctags) sort-keys swap ctags-write ;

442
extra/fjsc/fjsc.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
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 ;

210
extra/libudev/libudev.factor
View File

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

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

@ -14,7 +14,7 @@ IN: lunar-rescue
TUPLE: lunar-rescue < space-invaders ;
: <lunar-rescue> ( -- 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" <lunar-rescue> rom-info (run) ] with-ui ;
[ "Lunar Rescue" <lunar-rescue> rom-info (run) ] with-ui ;
MAIN: run-lunar

20
extra/s3/s3.factor
View File

@ -54,12 +54,12 @@ TUPLE: s3-request path mime-type date method headers bucket data ;
":" %
signature secret-key get sha1 hmac-bytes >base64 %
] "" 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 ;
<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) ;
@ -138,7 +138,7 @@ PRIVATE>
: 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

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

@ -37,11 +37,11 @@ CONSTANT: game-width 224
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
@ -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 ;
: <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? ;
@ -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
: <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 }
@ -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* <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

46
extra/update/update.factor
View File

@ -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
MAIN: update

86
extra/wordtimer/wordtimer.factor
View File

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