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

Merge branch 'master' of git://double.co.nz/git/factor

db4
Slava Pestov 2008-07-10 20:32:26 -05:00
parent 78c3b25f60 59857a455b
commit fb32480ec2
7 changed files with 535 additions and 462 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

732
extra/cpu/8080/emulator/emulator.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: accessors kernel math sequences words arrays io io.files USING: accessors kernel math sequences words arrays io io.files
namespaces math.parser assocs quotations parser lexer math.parser assocs quotations parser lexer
parser-combinators tools.time io.encodings.binary sequences.deep peg peg.ebnf peg.parsers tools.time io.encodings.binary sequences.deep
symbols combinators ; symbols combinators fry namespaces ;
IN: cpu.8080.emulator IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@ -748,24 +748,15 @@ SYMBOLS: $1 $2 $3 $4 ;
#! is the getter word for that register with stack effect #! is the getter word for that register with stack effect
#! ( cpu -- value ). The second item is the setter word with #! ( cpu -- value ). The second item is the setter word with
#! stack effect ( value cpu -- ). #! stack effect ( value cpu -- ).
"A" token <EBNF
"B" token <|> main=("A" | "B" | "C" | "D" | "E" | "H" | "L") => [[ register-lookup ]]
"C" token <|> EBNF> ;
"D" token <|>
"E" token <|>
"H" token <|>
"L" token <|> [ register-lookup ] <@ ;
: all-flags ( -- parser ) : all-flags ( -- parser )
#! A parser for 16-bit flags. #! A parser for 16-bit flags.
"NZ" token <EBNF
"NC" token <|> main=("NZ" | "NC" | "PO" | "PE" | "Z" | "C" | "P" | "M") => [[ flag-lookup ]]
"PO" token <|> EBNF> ;
"PE" token <|>
"Z" token <|>
"C" token <|>
"P" token <|>
"M" token <|> [ flag-lookup ] <@ ;
: 16-bit-registers ( -- parser ) : 16-bit-registers ( -- parser )
#! A parser for 16-bit registers. On a successfull parse the #! A parser for 16-bit registers. On a successfull parse the
@ -773,23 +764,21 @@ SYMBOLS: $1 $2 $3 $4 ;
#! is the getter word for that register with stack effect #! is the getter word for that register with stack effect
#! ( cpu -- value ). The second item is the setter word with #! ( cpu -- value ). The second item is the setter word with
#! stack effect ( value cpu -- ). #! stack effect ( value cpu -- ).
"AF" token <EBNF
"BC" token <|> main=("AF" | "BC" | "DE" | "HL" | "SP") => [[ register-lookup ]]
"DE" token <|> EBNF> ;
"HL" token <|>
"SP" token <|> [ register-lookup ] <@ ;
: all-registers ( -- parser ) : all-registers ( -- parser )
#! Return a parser that can parse the format #! Return a parser that can parse the format
#! for 8 bit or 16 bit registers. #! for 8 bit or 16 bit registers.
8-bit-registers 16-bit-registers <|> ; [ 16-bit-registers , 8-bit-registers , ] choice* ;
: indirect ( parser -- parser ) : indirect ( parser -- parser )
#! Given a parser, return a parser which parses the original #! Given a parser, return a parser which parses the original
#! wrapped in brackets, representing an indirect reference. #! wrapped in brackets, representing an indirect reference.
#! eg. BC -> (BC). The value of the original parser is left in #! eg. BC -> (BC). The value of the original parser is left in
#! the parse tree. #! the parse tree.
"(" token swap &> ")" token <& ; "(" ")" surrounded-by ;
: generate-instruction ( vector string -- quot ) : generate-instruction ( vector string -- quot )
#! Generate the quotation for an instruction, given the instruction in #! Generate the quotation for an instruction, given the instruction in
@ -800,89 +789,112 @@ SYMBOLS: $1 $2 $3 $4 ;
#! Return a parser for then instruction identified by the token. #! Return a parser for then instruction identified by the token.
#! The parser return parses the token only and expects no additional #! The parser return parses the token only and expects no additional
#! arguments to the instruction. #! arguments to the instruction.
token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ; token [ '[ { } , generate-instruction ] ] action ;
: complex-instruction ( type token -- parser ) : complex-instruction ( type token -- parser )
#! Return a parser for an instruction identified by the token. #! Return a parser for an instruction identified by the token.
#! The instruction is expected to take additional arguments by #! The instruction is expected to take additional arguments by
#! being combined with other parsers. Then 'type' is used for a lookup #! being combined with other parsers. Then 'type' is used for a lookup
#! in a pattern hashtable to return the instruction quotation pattern. #! in a pattern hashtable to return the instruction quotation pattern.
token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ; token swap [ nip '[ , generate-instruction ] ] curry action ;
: no-params ( ast -- ast )
first { } swap curry ;
: one-param ( ast -- ast )
first2 swap curry ;
: two-params ( ast -- ast )
first3 append swap curry ;
: NOP-instruction ( -- parser ) : NOP-instruction ( -- parser )
"NOP" simple-instruction ; "NOP" simple-instruction ;
: RET-NN-instruction ( -- parser ) : RET-NN-instruction ( -- parser )
"RET-NN" "RET" complex-instruction [
"nn" token sp <& "RET-NN" "RET" complex-instruction ,
just [ { } clone swap curry ] <@ ; "nn" token sp hide ,
] seq* [ no-params ] action ;
: RST-0-instruction ( -- parser ) : RST-0-instruction ( -- parser )
"RST-0" "RST" complex-instruction [
"0" token sp <& "RST-0" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "0" token sp hide ,
] seq* [ no-params ] action ;
: RST-8-instruction ( -- parser ) : RST-8-instruction ( -- parser )
"RST-8" "RST" complex-instruction [
"8" token sp <& "RST-8" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "8" token sp hide ,
] seq* [ no-params ] action ;
: RST-10H-instruction ( -- parser ) : RST-10H-instruction ( -- parser )
"RST-10H" "RST" complex-instruction [
"10H" token sp <& "RST-10H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "10H" token sp hide ,
] seq* [ no-params ] action ;
: RST-18H-instruction ( -- parser ) : RST-18H-instruction ( -- parser )
"RST-18H" "RST" complex-instruction [
"18H" token sp <& "RST-18H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "18H" token sp hide ,
] seq* [ no-params ] action ;
: RST-20H-instruction ( -- parser ) : RST-20H-instruction ( -- parser )
"RST-20H" "RST" complex-instruction [
"20H" token sp <& "RST-20H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "20H" token sp hide ,
] seq* [ no-params ] action ;
: RST-28H-instruction ( -- parser ) : RST-28H-instruction ( -- parser )
"RST-28H" "RST" complex-instruction [
"28H" token sp <& "RST-28H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "28H" token sp hide ,
] seq* [ no-params ] action ;
: RST-30H-instruction ( -- parser ) : RST-30H-instruction ( -- parser )
"RST-30H" "RST" complex-instruction [
"30H" token sp <& "RST-30H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "30H" token sp hide ,
] seq* [ no-params ] action ;
: RST-38H-instruction ( -- parser ) : RST-38H-instruction ( -- parser )
"RST-38H" "RST" complex-instruction [
"38H" token sp <& "RST-38H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "38H" token sp hide ,
] seq* [ no-params ] action ;
: JP-NN-instruction ( -- parser ) : JP-NN-instruction ( -- parser )
"JP-NN" "JP" complex-instruction [
"nn" token sp <& "JP-NN" "JP" complex-instruction ,
just [ { } clone swap curry ] <@ ; "nn" token sp hide ,
] seq* [ no-params ] action ;
: JP-F|FF,NN-instruction ( -- parser ) : JP-F|FF,NN-instruction ( -- parser )
"JP-F|FF,NN" "JP" complex-instruction [
all-flags sp <&> "JP-F|FF,NN" "JP" complex-instruction ,
",nn" token <& all-flags sp ,
just [ first2 swap curry ] <@ ; ",nn" token hide ,
] seq* [ one-param ] action ;
: JP-(RR)-instruction ( -- parser ) : JP-(RR)-instruction ( -- parser )
"JP-(RR)" "JP" complex-instruction [
16-bit-registers indirect sp <&> "JP-(RR)" "JP" complex-instruction ,
just [ first2 swap curry ] <@ ; 16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: CALL-NN-instruction ( -- parser ) : CALL-NN-instruction ( -- parser )
"CALL-NN" "CALL" complex-instruction [
"nn" token sp <& "CALL-NN" "CALL" complex-instruction ,
just [ { } clone swap curry ] <@ ; "nn" token sp hide ,
] seq* [ no-params ] action ;
: CALL-F|FF,NN-instruction ( -- parser ) : CALL-F|FF,NN-instruction ( -- parser )
"CALL-F|FF,NN" "CALL" complex-instruction [
all-flags sp <&> "CALL-F|FF,NN" "CALL" complex-instruction ,
",nn" token <& all-flags sp ,
just [ first2 swap curry ] <@ ; ",nn" token hide ,
] seq* [ one-param ] action ;
: RLCA-instruction ( -- parser ) : RLCA-instruction ( -- parser )
"RLCA" simple-instruction ; "RLCA" simple-instruction ;
@ -918,364 +930,430 @@ SYMBOLS: $1 $2 $3 $4 ;
"RRA" simple-instruction ; "RRA" simple-instruction ;
: DEC-R-instruction ( -- parser ) : DEC-R-instruction ( -- parser )
"DEC-R" "DEC" complex-instruction 8-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "DEC-R" "DEC" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: DEC-RR-instruction ( -- parser ) : DEC-RR-instruction ( -- parser )
"DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "DEC-RR" "DEC" complex-instruction ,
16-bit-registers sp ,
] seq* [ one-param ] action ;
: DEC-(RR)-instruction ( -- parser ) : DEC-(RR)-instruction ( -- parser )
"DEC-(RR)" "DEC" complex-instruction [
16-bit-registers indirect sp <&> "DEC-(RR)" "DEC" complex-instruction ,
just [ first2 swap curry ] <@ ; 16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: POP-RR-instruction ( -- parser ) : POP-RR-instruction ( -- parser )
"POP-RR" "POP" complex-instruction all-registers sp <&> [
just [ first2 swap curry ] <@ ; "POP-RR" "POP" complex-instruction ,
all-registers sp ,
] seq* [ one-param ] action ;
: PUSH-RR-instruction ( -- parser ) : PUSH-RR-instruction ( -- parser )
"PUSH-RR" "PUSH" complex-instruction all-registers sp <&> [
just [ first2 swap curry ] <@ ; "PUSH-RR" "PUSH" complex-instruction ,
all-registers sp ,
] seq* [ one-param ] action ;
: INC-R-instruction ( -- parser ) : INC-R-instruction ( -- parser )
"INC-R" "INC" complex-instruction 8-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "INC-R" "INC" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: INC-RR-instruction ( -- parser ) : INC-RR-instruction ( -- parser )
"INC-RR" "INC" complex-instruction 16-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "INC-RR" "INC" complex-instruction ,
16-bit-registers sp ,
] seq* [ one-param ] action ;
: INC-(RR)-instruction ( -- parser ) : INC-(RR)-instruction ( -- parser )
"INC-(RR)" "INC" complex-instruction [
all-registers indirect sp <&> just [ first2 swap curry ] <@ ; "INC-(RR)" "INC" complex-instruction ,
all-registers indirect sp ,
] seq* [ one-param ] action ;
: RET-F|FF-instruction ( -- parser ) : RET-F|FF-instruction ( -- parser )
"RET-F|FF" "RET" complex-instruction all-flags sp <&> [
just [ first2 swap curry ] <@ ; "RET-F|FF" "RET" complex-instruction ,
all-flags sp ,
] seq* [ one-param ] action ;
: AND-N-instruction ( -- parser ) : AND-N-instruction ( -- parser )
"AND-N" "AND" complex-instruction [
"n" token sp <& "AND-N" "AND" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: AND-R-instruction ( -- parser ) : AND-R-instruction ( -- parser )
"AND-R" "AND" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "AND-R" "AND" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: AND-(RR)-instruction ( -- parser ) : AND-(RR)-instruction ( -- parser )
"AND-(RR)" "AND" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "AND-(RR)" "AND" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: XOR-N-instruction ( -- parser ) : XOR-N-instruction ( -- parser )
"XOR-N" "XOR" complex-instruction [
"n" token sp <& "XOR-N" "XOR" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: XOR-R-instruction ( -- parser ) : XOR-R-instruction ( -- parser )
"XOR-R" "XOR" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "XOR-R" "XOR" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: XOR-(RR)-instruction ( -- parser ) : XOR-(RR)-instruction ( -- parser )
"XOR-(RR)" "XOR" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "XOR-(RR)" "XOR" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: OR-N-instruction ( -- parser ) : OR-N-instruction ( -- parser )
"OR-N" "OR" complex-instruction [
"n" token sp <& "OR-N" "OR" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: OR-R-instruction ( -- parser ) : OR-R-instruction ( -- parser )
"OR-R" "OR" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "OR-R" "OR" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: OR-(RR)-instruction ( -- parser ) : OR-(RR)-instruction ( -- parser )
"OR-(RR)" "OR" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "OR-(RR)" "OR" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: CP-N-instruction ( -- parser ) : CP-N-instruction ( -- parser )
"CP-N" "CP" complex-instruction [
"n" token sp <& "CP-N" "CP" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: CP-R-instruction ( -- parser ) : CP-R-instruction ( -- parser )
"CP-R" "CP" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "CP-R" "CP" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: CP-(RR)-instruction ( -- parser ) : CP-(RR)-instruction ( -- parser )
"CP-(RR)" "CP" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "CP-(RR)" "CP" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: ADC-R,N-instruction ( -- parser ) : ADC-R,N-instruction ( -- parser )
"ADC-R,N" "ADC" complex-instruction [
8-bit-registers sp <&> "ADC-R,N" "ADC" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: ADC-R,R-instruction ( -- parser ) : ADC-R,R-instruction ( -- parser )
"ADC-R,R" "ADC" complex-instruction [
8-bit-registers sp <&> "ADC-R,R" "ADC" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: ADC-R,(RR)-instruction ( -- parser ) : ADC-R,(RR)-instruction ( -- parser )
"ADC-R,(RR)" "ADC" complex-instruction [
8-bit-registers sp <&> "ADC-R,(RR)" "ADC" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: SBC-R,N-instruction ( -- parser ) : SBC-R,N-instruction ( -- parser )
"SBC-R,N" "SBC" complex-instruction [
8-bit-registers sp <&> "SBC-R,N" "SBC" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: SBC-R,R-instruction ( -- parser ) : SBC-R,R-instruction ( -- parser )
"SBC-R,R" "SBC" complex-instruction [
8-bit-registers sp <&> "SBC-R,R" "SBC" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: SBC-R,(RR)-instruction ( -- parser ) : SBC-R,(RR)-instruction ( -- parser )
"SBC-R,(RR)" "SBC" complex-instruction [
8-bit-registers sp <&> "SBC-R,(RR)" "SBC" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: SUB-R-instruction ( -- parser ) : SUB-R-instruction ( -- parser )
"SUB-R" "SUB" complex-instruction [
8-bit-registers sp <&> "SUB-R" "SUB" complex-instruction ,
just [ first2 swap curry ] <@ ; 8-bit-registers sp ,
] seq* [ one-param ] action ;
: SUB-(RR)-instruction ( -- parser ) : SUB-(RR)-instruction ( -- parser )
"SUB-(RR)" "SUB" complex-instruction [
16-bit-registers indirect sp <&> "SUB-(RR)" "SUB" complex-instruction ,
just [ first2 swap curry ] <@ ; 16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: SUB-N-instruction ( -- parser ) : SUB-N-instruction ( -- parser )
"SUB-N" "SUB" complex-instruction [
"n" token sp <& "SUB-N" "SUB" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: ADD-R,N-instruction ( -- parser ) : ADD-R,N-instruction ( -- parser )
"ADD-R,N" "ADD" complex-instruction [
8-bit-registers sp <&> "ADD-R,N" "ADD" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: ADD-R,R-instruction ( -- parser ) : ADD-R,R-instruction ( -- parser )
"ADD-R,R" "ADD" complex-instruction [
8-bit-registers sp <&> "ADD-R,R" "ADD" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: ADD-RR,RR-instruction ( -- parser ) : ADD-RR,RR-instruction ( -- parser )
"ADD-RR,RR" "ADD" complex-instruction [
16-bit-registers sp <&> "ADD-RR,RR" "ADD" complex-instruction ,
"," token <& 16-bit-registers sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: ADD-R,(RR)-instruction ( -- parser ) : ADD-R,(RR)-instruction ( -- parser )
"ADD-R,(RR)" "ADD" complex-instruction [
8-bit-registers sp <&> "ADD-R,(RR)" "ADD" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: LD-RR,NN-instruction ( -- parser ) : LD-RR,NN-instruction ( -- parser )
#! LD BC,nn #! LD BC,nn
"LD-RR,NN" "LD" complex-instruction [
16-bit-registers sp <&> "LD-RR,NN" "LD" complex-instruction ,
",nn" token <& 16-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",nn" token hide ,
] seq* [ one-param ] action ;
: LD-R,N-instruction ( -- parser ) : LD-R,N-instruction ( -- parser )
#! LD B,n #! LD B,n
"LD-R,N" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,N" "LD" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: LD-(RR),N-instruction ( -- parser ) : LD-(RR),N-instruction ( -- parser )
"LD-(RR),N" "LD" complex-instruction [
16-bit-registers indirect sp <&> "LD-(RR),N" "LD" complex-instruction ,
",n" token <& 16-bit-registers indirect sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: LD-(RR),R-instruction ( -- parser ) : LD-(RR),R-instruction ( -- parser )
#! LD (BC),A #! LD (BC),A
"LD-(RR),R" "LD" complex-instruction [
16-bit-registers indirect sp <&> "LD-(RR),R" "LD" complex-instruction ,
"," token <& 16-bit-registers indirect sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: LD-R,R-instruction ( -- parser ) : LD-R,R-instruction ( -- parser )
"LD-R,R" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,R" "LD" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: LD-RR,RR-instruction ( -- parser ) : LD-RR,RR-instruction ( -- parser )
"LD-RR,RR" "LD" complex-instruction [
16-bit-registers sp <&> "LD-RR,RR" "LD" complex-instruction ,
"," token <& 16-bit-registers sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: LD-R,(RR)-instruction ( -- parser ) : LD-R,(RR)-instruction ( -- parser )
"LD-R,(RR)" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,(RR)" "LD" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: LD-(NN),RR-instruction ( -- parser ) : LD-(NN),RR-instruction ( -- parser )
"LD-(NN),RR" "LD" complex-instruction [
"nn" token indirect sp <& "LD-(NN),RR" "LD" complex-instruction ,
"," token <& "nn" token indirect sp hide ,
16-bit-registers <&> "," token hide ,
just [ first2 swap curry ] <@ ; 16-bit-registers ,
] seq* [ one-param ] action ;
: LD-(NN),R-instruction ( -- parser ) : LD-(NN),R-instruction ( -- parser )
"LD-(NN),R" "LD" complex-instruction [
"nn" token indirect sp <& "LD-(NN),R" "LD" complex-instruction ,
"," token <& "nn" token indirect sp hide ,
8-bit-registers <&> "," token hide ,
just [ first2 swap curry ] <@ ; 8-bit-registers ,
] seq* [ one-param ] action ;
: LD-RR,(NN)-instruction ( -- parser ) : LD-RR,(NN)-instruction ( -- parser )
"LD-RR,(NN)" "LD" complex-instruction [
16-bit-registers sp <&> "LD-RR,(NN)" "LD" complex-instruction ,
"," token <& 16-bit-registers sp ,
"nn" token indirect <& "," token hide ,
just [ first2 swap curry ] <@ ; "nn" token indirect hide ,
] seq* [ one-param ] action ;
: LD-R,(NN)-instruction ( -- parser ) : LD-R,(NN)-instruction ( -- parser )
"LD-R,(NN)" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,(NN)" "LD" complex-instruction ,
"," token <& 8-bit-registers sp ,
"nn" token indirect <& "," token hide ,
just [ first2 swap curry ] <@ ; "nn" token indirect hide ,
] seq* [ one-param ] action ;
: OUT-(N),R-instruction ( -- parser ) : OUT-(N),R-instruction ( -- parser )
"OUT-(N),R" "OUT" complex-instruction [
"n" token indirect sp <& "OUT-(N),R" "OUT" complex-instruction ,
"," token <& "n" token indirect sp hide ,
8-bit-registers <&> "," token hide ,
just [ first2 swap curry ] <@ ; 8-bit-registers ,
] seq* [ one-param ] action ;
: IN-R,(N)-instruction ( -- parser ) : IN-R,(N)-instruction ( -- parser )
"IN-R,(N)" "IN" complex-instruction [
8-bit-registers sp <&> "IN-R,(N)" "IN" complex-instruction ,
"," token <& 8-bit-registers sp ,
"n" token indirect <& "," token hide ,
just [ first2 swap curry ] <@ ; "n" token indirect hide ,
] seq* [ one-param ] action ;
: EX-(RR),RR-instruction ( -- parser ) : EX-(RR),RR-instruction ( -- parser )
"EX-(RR),RR" "EX" complex-instruction [
16-bit-registers indirect sp <&> "EX-(RR),RR" "EX" complex-instruction ,
"," token <& 16-bit-registers indirect sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: EX-RR,RR-instruction ( -- parser ) : EX-RR,RR-instruction ( -- parser )
"EX-RR,RR" "EX" complex-instruction [
16-bit-registers sp <&> "EX-RR,RR" "EX" complex-instruction ,
"," token <& 16-bit-registers sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: 8080-generator-parser ( -- parser ) : 8080-generator-parser ( -- parser )
NOP-instruction [
RST-0-instruction <|> NOP-instruction ,
RST-8-instruction <|> RST-0-instruction ,
RST-10H-instruction <|> RST-8-instruction ,
RST-18H-instruction <|> RST-10H-instruction ,
RST-20H-instruction <|> RST-18H-instruction ,
RST-28H-instruction <|> RST-20H-instruction ,
RST-30H-instruction <|> RST-28H-instruction ,
RST-38H-instruction <|> RST-30H-instruction ,
JP-F|FF,NN-instruction <|> RST-38H-instruction ,
JP-NN-instruction <|> JP-F|FF,NN-instruction ,
JP-(RR)-instruction <|> JP-NN-instruction ,
CALL-F|FF,NN-instruction <|> JP-(RR)-instruction ,
CALL-NN-instruction <|> CALL-F|FF,NN-instruction ,
CPL-instruction <|> CALL-NN-instruction ,
CCF-instruction <|> CPL-instruction ,
SCF-instruction <|> CCF-instruction ,
DAA-instruction <|> SCF-instruction ,
RLA-instruction <|> DAA-instruction ,
RRA-instruction <|> RLA-instruction ,
RLCA-instruction <|> RRA-instruction ,
RRCA-instruction <|> RLCA-instruction ,
HALT-instruction <|> RRCA-instruction ,
DI-instruction <|> HALT-instruction ,
EI-instruction <|> DI-instruction ,
AND-N-instruction <|> EI-instruction ,
AND-R-instruction <|> AND-N-instruction ,
AND-(RR)-instruction <|> AND-R-instruction ,
XOR-N-instruction <|> AND-(RR)-instruction ,
XOR-R-instruction <|> XOR-N-instruction ,
XOR-(RR)-instruction <|> XOR-R-instruction ,
OR-N-instruction <|> XOR-(RR)-instruction ,
OR-R-instruction <|> OR-N-instruction ,
OR-(RR)-instruction <|> OR-R-instruction ,
CP-N-instruction <|> OR-(RR)-instruction ,
CP-R-instruction <|> CP-N-instruction ,
CP-(RR)-instruction <|> CP-R-instruction ,
DEC-RR-instruction <|> CP-(RR)-instruction ,
DEC-R-instruction <|> DEC-RR-instruction ,
DEC-(RR)-instruction <|> DEC-R-instruction ,
POP-RR-instruction <|> DEC-(RR)-instruction ,
PUSH-RR-instruction <|> POP-RR-instruction ,
INC-RR-instruction <|> PUSH-RR-instruction ,
INC-R-instruction <|> INC-RR-instruction ,
INC-(RR)-instruction <|> INC-R-instruction ,
LD-RR,NN-instruction <|> INC-(RR)-instruction ,
LD-R,N-instruction <|> LD-RR,NN-instruction ,
LD-R,R-instruction <|> LD-RR,RR-instruction ,
LD-RR,RR-instruction <|> LD-R,N-instruction ,
LD-(RR),N-instruction <|> LD-R,R-instruction ,
LD-(RR),R-instruction <|> LD-(RR),N-instruction ,
LD-R,(RR)-instruction <|> LD-(RR),R-instruction ,
LD-(NN),RR-instruction <|> LD-R,(RR)-instruction ,
LD-(NN),R-instruction <|> LD-(NN),RR-instruction ,
LD-RR,(NN)-instruction <|> LD-(NN),R-instruction ,
LD-R,(NN)-instruction <|> LD-RR,(NN)-instruction ,
ADC-R,N-instruction <|> LD-R,(NN)-instruction ,
ADC-R,R-instruction <|> ADC-R,(RR)-instruction ,
ADC-R,(RR)-instruction <|> ADC-R,N-instruction ,
ADD-R,N-instruction <|> ADC-R,R-instruction ,
ADD-R,R-instruction <|> ADD-R,N-instruction ,
ADD-RR,RR-instruction <|> ADD-R,(RR)-instruction ,
ADD-R,(RR)-instruction <|> ADD-R,R-instruction ,
SBC-R,N-instruction <|> ADD-RR,RR-instruction ,
SBC-R,R-instruction <|> SBC-R,N-instruction ,
SBC-R,(RR)-instruction <|> SBC-R,R-instruction ,
SUB-R-instruction <|> SBC-R,(RR)-instruction ,
SUB-(RR)-instruction <|> SUB-R-instruction ,
SUB-N-instruction <|> SUB-(RR)-instruction ,
RET-F|FF-instruction <|> SUB-N-instruction ,
RET-NN-instruction <|> RET-F|FF-instruction ,
OUT-(N),R-instruction <|> RET-NN-instruction ,
IN-R,(N)-instruction <|> OUT-(N),R-instruction ,
EX-(RR),RR-instruction <|> IN-R,(N)-instruction ,
EX-RR,RR-instruction <|> EX-(RR),RR-instruction ,
just ; EX-RR,RR-instruction ,
] choice* [ call ] action ;
: instruction-quotations ( string -- emulate-quot ) : instruction-quotations ( string -- emulate-quot )
#! Given an instruction string, return the emulation quotation for #! Given an instruction string, return the emulation quotation for
#! it. This will later be expanded to produce the disassembly and #! it. This will later be expanded to produce the disassembly and
#! assembly quotations. #! assembly quotations.
8080-generator-parser some parse call ; 8080-generator-parser parse ;
SYMBOL: last-instruction SYMBOL: last-instruction
SYMBOL: last-opcode SYMBOL: last-opcode

22
extra/fjsc/fjsc-tests.factor
View File

@ -4,31 +4,31 @@ USING: kernel tools.test peg fjsc ;
IN: fjsc.tests IN: fjsc.tests
{ T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"55 2abc1 100" 'expression' parse parse-result-ast "55 2abc1 100" 'expression' parse
] unit-test ] unit-test
{ T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"[ 55 2abc1 100 ]" 'quotation' parse parse-result-ast "[ 55 2abc1 100 ]" 'quotation' parse
] unit-test ] unit-test
{ T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"{ 55 2abc1 100 }" 'array' parse parse-result-ast "{ 55 2abc1 100 }" 'array' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [ { T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [
"( -- d e f )" 'stack-effect' parse parse-result-ast "( -- d e f )" 'stack-effect' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [ { T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [
"( a b c -- d e f )" 'stack-effect' parse parse-result-ast "( a b c -- d e f )" 'stack-effect' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [ { T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [
"( a b c -- )" 'stack-effect' parse parse-result-ast "( a b c -- )" 'stack-effect' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ } V{ } } } [ { T{ ast-stack-effect f V{ } V{ } } } [
"( -- )" 'stack-effect' parse parse-result-ast "( -- )" 'stack-effect' parse
] unit-test ] unit-test
{ f } [ { f } [
@ -37,18 +37,18 @@ IN: fjsc.tests
{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [ { T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse parse-result-ast "\"abcd\"" 'statement' parse
] unit-test ] unit-test
{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [ { T{ ast-expression f V{ T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse parse-result-ast "USE: foo" 'statement' parse
] unit-test ] unit-test
{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [ { T{ ast-expression f V{ T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse parse-result-ast "IN: foo" 'statement' parse
] unit-test ] unit-test
{ T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [ { T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [
"USING: foo bar ;" 'statement' parse parse-result-ast "USING: foo bar ;" 'statement' parse
] unit-test ] unit-test

165
extra/fjsc/fjsc.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Chris Double. All Rights Reserved. ! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel peg strings promises sequences math USING: accessors kernel peg strings sequences math
math.parser namespaces words quotations arrays hashtables io math.parser namespaces words quotations arrays hashtables io
io.streams.string assocs memoize ascii peg.parsers ; io.streams.string assocs ascii peg.parsers accessors ;
IN: fjsc IN: fjsc
TUPLE: ast-number value ; TUPLE: ast-number value ;
@ -20,28 +20,13 @@ TUPLE: ast-using names ;
TUPLE: ast-in name ; TUPLE: ast-in name ;
TUPLE: ast-hashtable elements ; TUPLE: ast-hashtable elements ;
C: <ast-number> ast-number
C: <ast-identifier> ast-identifier
C: <ast-string> ast-string
C: <ast-quotation> ast-quotation
C: <ast-array> ast-array
C: <ast-define> ast-define
C: <ast-expression> ast-expression
C: <ast-word> ast-word
C: <ast-comment> ast-comment
C: <ast-stack-effect> ast-stack-effect
C: <ast-use> ast-use
C: <ast-using> ast-using
C: <ast-in> ast-in
C: <ast-hashtable> ast-hashtable
: identifier-middle? ( ch -- bool ) : identifier-middle? ( ch -- bool )
[ blank? not ] keep [ blank? not ] keep
[ "}];\"" member? not ] keep [ "}];\"" member? not ] keep
digit? not digit? not
and and ; and and ;
MEMO: 'identifier-ends' ( -- parser ) : 'identifier-ends' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
[ CHAR: " = not ] keep [ CHAR: " = not ] keep
@ -52,22 +37,22 @@ MEMO: 'identifier-ends' ( -- parser )
and and and and and and and and and and
] satisfy repeat0 ; ] satisfy repeat0 ;
MEMO: 'identifier-middle' ( -- parser ) : 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy repeat1 ; [ identifier-middle? ] satisfy repeat1 ;
MEMO: 'identifier' ( -- parser ) : 'identifier' ( -- parser )
[ [
'identifier-ends' , 'identifier-ends' ,
'identifier-middle' , 'identifier-middle' ,
'identifier-ends' , 'identifier-ends' ,
] { } make seq [ ] seq* [
concat >string f <ast-identifier> concat >string f ast-identifier boa
] action ; ] action ;
DEFER: 'expression' DEFER: 'expression'
MEMO: 'effect-name' ( -- parser ) : 'effect-name' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
[ CHAR: ) = not ] keep [ CHAR: ) = not ] keep
@ -75,98 +60,98 @@ MEMO: 'effect-name' ( -- parser )
and and and and
] satisfy repeat1 [ >string ] action ; ] satisfy repeat1 [ >string ] action ;
MEMO: 'stack-effect' ( -- parser ) : 'stack-effect' ( -- parser )
[ [
"(" token hide , "(" token hide ,
'effect-name' sp repeat0 , 'effect-name' sp repeat0 ,
"--" token sp hide , "--" token sp hide ,
'effect-name' sp repeat0 , 'effect-name' sp repeat0 ,
")" token sp hide , ")" token sp hide ,
] { } make seq [ ] seq* [
first2 <ast-stack-effect> first2 ast-stack-effect boa
] action ; ] action ;
MEMO: 'define' ( -- parser ) : 'define' ( -- parser )
[ [
":" token sp hide , ":" token sp hide ,
'identifier' sp [ ast-identifier-value ] action , 'identifier' sp [ value>> ] action ,
'stack-effect' sp optional , 'stack-effect' sp optional ,
'expression' , 'expression' ,
";" token sp hide , ";" token sp hide ,
] { } make seq [ first3 <ast-define> ] action ; ] seq* [ first3 ast-define boa ] action ;
MEMO: 'quotation' ( -- parser ) : 'quotation' ( -- parser )
[ [
"[" token sp hide , "[" token sp hide ,
'expression' [ ast-expression-values ] action , 'expression' [ values>> ] action ,
"]" token sp hide , "]" token sp hide ,
] { } make seq [ first <ast-quotation> ] action ; ] seq* [ first ast-quotation boa ] action ;
MEMO: 'array' ( -- parser ) : 'array' ( -- parser )
[ [
"{" token sp hide , "{" token sp hide ,
'expression' [ ast-expression-values ] action , 'expression' [ values>> ] action ,
"}" token sp hide , "}" token sp hide ,
] { } make seq [ first <ast-array> ] action ; ] seq* [ first ast-array boa ] action ;
MEMO: 'word' ( -- parser ) : 'word' ( -- parser )
[ [
"\\" token sp hide , "\\" token sp hide ,
'identifier' sp , 'identifier' sp ,
] { } make seq [ first ast-identifier-value f <ast-word> ] action ; ] seq* [ first value>> f ast-word boa ] action ;
MEMO: 'atom' ( -- parser ) : 'atom' ( -- parser )
[ [
'identifier' , 'identifier' ,
'integer' [ <ast-number> ] action , 'integer' [ ast-number boa ] action ,
'string' [ <ast-string> ] action , 'string' [ ast-string boa ] action ,
] { } make choice ; ] choice* ;
MEMO: 'comment' ( -- parser ) : 'comment' ( -- parser )
[ [
[ [
"#!" token sp , "#!" token sp ,
"!" token sp , "!" token sp ,
] { } make choice hide , ] choice* hide ,
[ [
dup CHAR: \n = swap CHAR: \r = or not dup CHAR: \n = swap CHAR: \r = or not
] satisfy repeat0 , ] satisfy repeat0 ,
] { } make seq [ drop <ast-comment> ] action ; ] seq* [ drop ast-comment boa ] action ;
MEMO: 'USE:' ( -- parser ) : 'USE:' ( -- parser )
[ [
"USE:" token sp hide , "USE:" token sp hide ,
'identifier' sp , 'identifier' sp ,
] { } make seq [ first ast-identifier-value <ast-use> ] action ; ] seq* [ first value>> ast-use boa ] action ;
MEMO: 'IN:' ( -- parser ) : 'IN:' ( -- parser )
[ [
"IN:" token sp hide , "IN:" token sp hide ,
'identifier' sp , 'identifier' sp ,
] { } make seq [ first ast-identifier-value <ast-in> ] action ; ] seq* [ first value>> ast-in boa ] action ;
MEMO: 'USING:' ( -- parser ) : 'USING:' ( -- parser )
[ [
"USING:" token sp hide , "USING:" token sp hide ,
'identifier' sp [ ast-identifier-value ] action repeat1 , 'identifier' sp [ value>> ] action repeat1 ,
";" token sp hide , ";" token sp hide ,
] { } make seq [ first <ast-using> ] action ; ] seq* [ first ast-using boa ] action ;
MEMO: 'hashtable' ( -- parser ) : 'hashtable' ( -- parser )
[ [
"H{" token sp hide , "H{" token sp hide ,
'expression' [ ast-expression-values ] action , 'expression' [ values>> ] action ,
"}" token sp hide , "}" token sp hide ,
] { } make seq [ first <ast-hashtable> ] action ; ] seq* [ first ast-hashtable boa ] action ;
MEMO: 'parsing-word' ( -- parser ) : 'parsing-word' ( -- parser )
[ [
'USE:' , 'USE:' ,
'USING:' , 'USING:' ,
'IN:' , 'IN:' ,
] { } make choice ; ] choice* ;
MEMO: 'expression' ( -- parser ) : 'expression' ( -- parser )
[ [
[ [
'comment' , 'comment' ,
@ -177,17 +162,17 @@ MEMO: 'expression' ( -- parser )
'hashtable' sp , 'hashtable' sp ,
'word' sp , 'word' sp ,
'atom' sp , 'atom' sp ,
] { } make choice repeat0 [ <ast-expression> ] action ] choice* repeat0 [ ast-expression boa ] action
] delay ; ] delay ;
MEMO: 'statement' ( -- parser ) : 'statement' ( -- parser )
'expression' ; 'expression' ;
GENERIC: (compile) ( ast -- ) GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- ) GENERIC: (literal) ( ast -- )
M: ast-number (literal) M: ast-number (literal)
ast-number-value number>string , ; value>> number>string , ;
M: ast-number (compile) M: ast-number (compile)
"factor.push_data(" , "factor.push_data(" ,
@ -196,7 +181,7 @@ M: ast-number (compile)
M: ast-string (literal) M: ast-string (literal)
"\"" , "\"" ,
ast-string-value , value>> ,
"\"" , ; "\"" , ;
M: ast-string (compile) M: ast-string (compile)
@ -205,14 +190,14 @@ M: ast-string (compile)
"," , ; "," , ;
M: ast-identifier (literal) M: ast-identifier (literal)
dup ast-identifier-vocab [ dup vocab>> [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-identifier-vocab , dup vocab>> ,
"\",\"" , "\",\"" ,
ast-identifier-value , value>> ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-identifier-value , "\")" , "factor.find_word(\"" , value>> , "\")" ,
] if ; ] if ;
M: ast-identifier (compile) M: ast-identifier (compile)
@ -220,9 +205,9 @@ M: ast-identifier (compile)
M: ast-define (compile) M: ast-define (compile)
"factor.define_word(\"" , "factor.define_word(\"" ,
dup ast-define-name , dup name>> ,
"\",\"source\"," , "\",\"source\"," ,
ast-define-expression (compile) expression>> (compile)
"," , ; "," , ;
: do-expressions ( seq -- ) : do-expressions ( seq -- )
@ -242,17 +227,17 @@ M: ast-define (compile)
M: ast-quotation (literal) M: ast-quotation (literal)
"factor.make_quotation(\"source\"," , "factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions values>> do-expressions
")" , ; ")" , ;
M: ast-quotation (compile) M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," , "factor.push_data(factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions values>> do-expressions
")," , ; ")," , ;
M: ast-array (literal) M: ast-array (literal)
"[" , "[" ,
ast-array-elements [ "," , ] [ (literal) ] interleave elements>> [ "," , ] [ (literal) ] interleave
"]" , ; "]" , ;
M: ast-array (compile) M: ast-array (compile)
@ -260,7 +245,7 @@ M: ast-array (compile)
M: ast-hashtable (literal) M: ast-hashtable (literal)
"new Hashtable().fromAlist([" , "new Hashtable().fromAlist([" ,
ast-hashtable-elements [ "," , ] [ (literal) ] interleave elements>> [ "," , ] [ (literal) ] interleave
"])" , ; "])" , ;
M: ast-hashtable (compile) M: ast-hashtable (compile)
@ -268,22 +253,22 @@ M: ast-hashtable (compile)
M: ast-expression (literal) M: ast-expression (literal)
ast-expression-values [ values>> [
(literal) (literal)
] each ; ] each ;
M: ast-expression (compile) M: ast-expression (compile)
ast-expression-values do-expressions ; values>> do-expressions ;
M: ast-word (literal) M: ast-word (literal)
dup ast-word-vocab [ dup vocab>> [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-word-vocab , dup vocab>> ,
"\",\"" , "\",\"" ,
ast-word-value , value>> ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-word-value , "\")" , "factor.find_word(\"" , value>> , "\")" ,
] if ; ] if ;
M: ast-word (compile) M: ast-word (compile)
@ -299,17 +284,17 @@ M: ast-stack-effect (compile)
M: ast-use (compile) M: ast-use (compile)
"factor.use(\"" , "factor.use(\"" ,
ast-use-name , name>> ,
"\"," , ; "\"," , ;
M: ast-in (compile) M: ast-in (compile)
"factor.set_in(\"" , "factor.set_in(\"" ,
ast-in-name , name>> ,
"\"," , ; "\"," , ;
M: ast-using (compile) M: ast-using (compile)
"factor.using([" , "factor.using([" ,
ast-using-names [ names>> [
"," , "," ,
] [ ] [
"\"" , , "\"" , "\"" , , "\"" ,
@ -319,34 +304,34 @@ M: ast-using (compile)
GENERIC: (parse-factor-quotation) ( object -- ast ) GENERIC: (parse-factor-quotation) ( object -- ast )
M: number (parse-factor-quotation) ( object -- ast ) M: number (parse-factor-quotation) ( object -- ast )
<ast-number> ; ast-number boa ;
M: symbol (parse-factor-quotation) ( object -- ast ) M: symbol (parse-factor-quotation) ( object -- ast )
dup >string swap vocabulary>> <ast-identifier> ; dup >string swap vocabulary>> ast-identifier boa ;
M: word (parse-factor-quotation) ( object -- ast ) M: word (parse-factor-quotation) ( object -- ast )
dup name>> swap vocabulary>> <ast-identifier> ; dup name>> swap vocabulary>> ast-identifier boa ;
M: string (parse-factor-quotation) ( object -- ast ) M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ; ast-string boa ;
M: quotation (parse-factor-quotation) ( object -- ast ) M: quotation (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-quotation> ; ] { } make ast-quotation boa ;
M: array (parse-factor-quotation) ( object -- ast ) M: array (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-array> ; ] { } make ast-array boa ;
M: hashtable (parse-factor-quotation) ( object -- ast ) M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [ >alist [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-hashtable> ; ] { } make ast-hashtable boa ;
M: wrapper (parse-factor-quotation) ( object -- ast ) M: wrapper (parse-factor-quotation) ( object -- ast )
wrapped>> dup name>> swap vocabulary>> <ast-word> ; wrapped>> dup name>> swap vocabulary>> ast-word boa ;
GENERIC: fjsc-parse ( object -- ast ) GENERIC: fjsc-parse ( object -- ast )
@ -356,7 +341,7 @@ M: string fjsc-parse ( object -- ast )
M: quotation fjsc-parse ( object -- ast ) M: quotation fjsc-parse ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-expression> ; ] { } make ast-expression boa ;
: fjsc-compile ( ast -- string ) : fjsc-compile ( ast -- string )
[ [
@ -372,7 +357,7 @@ M: quotation fjsc-parse ( object -- ast )
: fc* ( string -- string ) : fc* ( string -- string )
[ [
'statement' parse parse-result-ast ast-expression-values do-expressions 'statement' parse parse-result-ast values>> do-expressions
] { } make [ write ] each ; ] { } make [ write ] each ;

2
extra/lisp/lisp.factor
View File

@ -99,7 +99,7 @@ PRIVATE>
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ; uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast compile-form ; lisp-expr compile-form ;
: lisp-eval ( str -- * ) : lisp-eval ( str -- * )
lisp-string>factor call ; lisp-string>factor call ;

24
extra/lisp/parser/parser-tests.factor
View File

@ -5,43 +5,43 @@ USING: lisp.parser tools.test peg peg.ebnf lists ;
IN: lisp.parser.tests IN: lisp.parser.tests
{ 1234 } [ { 1234 } [
"1234" "atom" \ lisp-expr rule parse parse-result-ast "1234" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ -42 } [ { -42 } [
"-42" "atom" \ lisp-expr rule parse parse-result-ast "-42" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ 37/52 } [ { 37/52 } [
"37/52" "atom" \ lisp-expr rule parse parse-result-ast "37/52" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ 123.98 } [ { 123.98 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast "123.98" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ "" } [ { "" } [
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast "\"\"" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ "aoeu" } [ { "aoeu" } [
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast "\"aoeu\"" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ "aoeu\"de" } [ { "aoeu\"de" } [
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ T{ lisp-symbol f "foobar" } } [ { T{ lisp-symbol f "foobar" } } [
"foobar" "atom" \ lisp-expr rule parse parse-result-ast "foobar" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ T{ lisp-symbol f "+" } } [ { T{ lisp-symbol f "+" } } [
"+" "atom" \ lisp-expr rule parse parse-result-ast "+" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ +nil+ } [ { +nil+ } [
"()" lisp-expr parse-result-ast "()" lisp-expr
] unit-test ] unit-test
{ T{ { T{
@ -54,7 +54,7 @@ IN: lisp.parser.tests
1 1
T{ cons f 2 T{ cons f "aoeu" +nil+ } } T{ cons f 2 T{ cons f "aoeu" +nil+ } }
} } } [ } } } [
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast "(foo 1 2 \"aoeu\")" lisp-expr
] unit-test ] unit-test
{ T{ cons f { T{ cons f
@ -64,5 +64,5 @@ IN: lisp.parser.tests
T{ cons f 2 +nil+ } } T{ cons f 2 +nil+ } }
} }
} [ } [
"(1 (3 4) 2)" lisp-expr parse-result-ast "(1 (3 4) 2)" lisp-expr
] unit-test ] unit-test

2
extra/peg/parsers/parsers.factor
View File

@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
M: just-parser (compile) ( parser -- quot ) M: just-parser (compile) ( parser -- quot )
just-parser-p1 compiled-parser just-pattern curry ; just-parser-p1 compile-parser just-pattern curry ;
: just ( parser -- parser ) : just ( parser -- parser )
just-parser boa wrap-peg ; just-parser boa wrap-peg ;

50
extra/peg/peg.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order vectors combinators combinators.lib vectors arrays math.parser math.order vectors combinators combinators.lib
combinators.short-circuit classes sets unicode.categories compiler.units parser classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ; words quotations effects memoize accessors locals effects splitting
combinators.short-circuit combinators.short-circuit.smart ;
IN: peg IN: peg
USE: prettyprint USE: prettyprint
@ -279,7 +280,13 @@ GENERIC: (compile) ( peg -- quot )
gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
[ execute-parser ] curry ; [ execute-parser ] curry ;
: compiled-parser ( parser -- word ) : preset-parser-word ( parser -- parser word )
gensym [ >>compiled ] keep ;
: define-parser-word ( parser word -- )
swap parser-body (( -- result )) define-declared ;
: compile-parser ( parser -- word )
#! Look to see if the given parser has been compiled. #! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it, #! If not, compile it to a temporary word, cache it,
#! and return it. Otherwise return the existing one. #! and return it. Otherwise return the existing one.
@ -289,7 +296,7 @@ GENERIC: (compile) ( peg -- quot )
dup compiled>> [ dup compiled>> [
nip nip
] [ ] [
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop preset-parser-word [ define-parser-word ] keep
] if* ; ] if* ;
SYMBOL: delayed SYMBOL: delayed
@ -298,13 +305,13 @@ SYMBOL: delayed
#! Work through all delayed parsers and recompile their #! Work through all delayed parsers and recompile their
#! words to have the correct bodies. #! words to have the correct bodies.
delayed get [ delayed get [
call compiled-parser 1quotation 0 1 <effect> define-declared call compile-parser 1quotation 0 1 <effect> define-declared
] assoc-each ; ] assoc-each ;
: compile ( parser -- word ) : compile ( parser -- word )
[ [
H{ } clone delayed [ H{ } clone delayed [
compiled-parser fixup-delayed compile-parser fixup-delayed
] with-variable ] with-variable
] with-compilation-unit ; ] with-compilation-unit ;
@ -410,17 +417,20 @@ TUPLE: seq-parser parsers ;
M: seq-parser (compile) ( peg -- quot ) M: seq-parser (compile) ( peg -- quot )
[ [
[ input-slice V{ } clone <parse-result> ] % [ input-slice V{ } clone <parse-result> ] %
parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ [
compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
[ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
] { } make , \ && ,
] [ ] make ; ] [ ] make ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( peg -- quot ) M: choice-parser (compile) ( peg -- quot )
[ [
f , [
parsers>> [ compiled-parser ] map parsers>> [ compile-parser ] map
unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
] { } make , \ || ,
] [ ] make ; ] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;
@ -435,7 +445,7 @@ TUPLE: repeat0-parser p1 ;
] if* ; inline ] if* ; inline
M: repeat0-parser (compile) ( peg -- quot ) M: repeat0-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compile-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) input-slice V{ } clone <parse-result> , swap (repeat)
] ; ] ;
@ -449,7 +459,7 @@ TUPLE: repeat1-parser p1 ;
] if* ; ] if* ;
M: repeat1-parser (compile) ( peg -- quot ) M: repeat1-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compile-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
] ; ] ;
@ -459,7 +469,7 @@ TUPLE: optional-parser p1 ;
[ input-slice f <parse-result> ] unless* ; [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( peg -- quot ) M: optional-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ @ check-optional ] ; p1>> compile-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ; TUPLE: semantic-parser p1 quot ;
@ -471,7 +481,7 @@ TUPLE: semantic-parser p1 quot ;
] if ; inline ] if ; inline
M: semantic-parser (compile) ( peg -- quot ) M: semantic-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi [ p1>> compile-parser 1quotation ] [ quot>> ] bi
'[ @ , check-semantic ] ; '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ; TUPLE: ensure-parser p1 ;
@ -480,7 +490,7 @@ TUPLE: ensure-parser p1 ;
[ ignore <parse-result> ] [ drop f ] if ; [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( peg -- quot ) M: ensure-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
@ -488,7 +498,7 @@ TUPLE: ensure-not-parser p1 ;
[ drop f ] [ ignore <parse-result> ] if ; [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( peg -- quot ) M: ensure-not-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
@ -500,7 +510,7 @@ TUPLE: action-parser p1 quot ;
] if ; inline ] if ; inline
M: action-parser (compile) ( peg -- quot ) M: action-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
@ -512,7 +522,7 @@ M: action-parser (compile) ( peg -- quot )
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot ) M: sp-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compile-parser 1quotation '[
input-slice left-trim-slice input-from pos set @ input-slice left-trim-slice input-from pos set @
] ; ] ;
@ -531,7 +541,7 @@ M: box-parser (compile) ( peg -- quot )
#! to produce the parser to be compiled. #! to produce the parser to be compiled.
#! This differs from 'delay' which calls #! This differs from 'delay' which calls
#! it at run time. #! it at run time.
quot>> call compiled-parser 1quotation ; quot>> call compile-parser 1quotation ;
PRIVATE> PRIVATE>