Merge branch 'master' of git://double.co.nz/git/factor
commit
fb32480ec2
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: accessors kernel math sequences words arrays io io.files
|
||||
namespaces math.parser assocs quotations parser lexer
|
||||
parser-combinators tools.time io.encodings.binary sequences.deep
|
||||
symbols combinators ;
|
||||
math.parser assocs quotations parser lexer
|
||||
peg peg.ebnf peg.parsers tools.time io.encodings.binary sequences.deep
|
||||
symbols combinators fry namespaces ;
|
||||
IN: cpu.8080.emulator
|
||||
|
||||
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
|
||||
#! ( cpu -- value ). The second item is the setter word with
|
||||
#! stack effect ( value cpu -- ).
|
||||
"A" token
|
||||
"B" token <|>
|
||||
"C" token <|>
|
||||
"D" token <|>
|
||||
"E" token <|>
|
||||
"H" token <|>
|
||||
"L" token <|> [ register-lookup ] <@ ;
|
||||
<EBNF
|
||||
main=("A" | "B" | "C" | "D" | "E" | "H" | "L") => [[ register-lookup ]]
|
||||
EBNF> ;
|
||||
|
||||
: all-flags ( -- parser )
|
||||
#! A parser for 16-bit flags.
|
||||
"NZ" token
|
||||
"NC" token <|>
|
||||
"PO" token <|>
|
||||
"PE" token <|>
|
||||
"Z" token <|>
|
||||
"C" token <|>
|
||||
"P" token <|>
|
||||
"M" token <|> [ flag-lookup ] <@ ;
|
||||
<EBNF
|
||||
main=("NZ" | "NC" | "PO" | "PE" | "Z" | "C" | "P" | "M") => [[ flag-lookup ]]
|
||||
EBNF> ;
|
||||
|
||||
: 16-bit-registers ( -- parser )
|
||||
#! 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
|
||||
#! ( cpu -- value ). The second item is the setter word with
|
||||
#! stack effect ( value cpu -- ).
|
||||
"AF" token
|
||||
"BC" token <|>
|
||||
"DE" token <|>
|
||||
"HL" token <|>
|
||||
"SP" token <|> [ register-lookup ] <@ ;
|
||||
<EBNF
|
||||
main=("AF" | "BC" | "DE" | "HL" | "SP") => [[ register-lookup ]]
|
||||
EBNF> ;
|
||||
|
||||
: all-registers ( -- parser )
|
||||
#! Return a parser that can parse the format
|
||||
#! for 8 bit or 16 bit registers.
|
||||
8-bit-registers 16-bit-registers <|> ;
|
||||
[ 16-bit-registers , 8-bit-registers , ] choice* ;
|
||||
|
||||
: indirect ( parser -- parser )
|
||||
#! Given a parser, return a parser which parses the original
|
||||
#! wrapped in brackets, representing an indirect reference.
|
||||
#! eg. BC -> (BC). The value of the original parser is left in
|
||||
#! the parse tree.
|
||||
"(" token swap &> ")" token <& ;
|
||||
"(" ")" surrounded-by ;
|
||||
|
||||
: generate-instruction ( vector string -- quot )
|
||||
#! 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.
|
||||
#! The parser return parses the token only and expects no additional
|
||||
#! arguments to the instruction.
|
||||
token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
|
||||
token [ '[ { } , generate-instruction ] ] action ;
|
||||
|
||||
: complex-instruction ( type token -- parser )
|
||||
#! Return a parser for an instruction identified by the token.
|
||||
#! The instruction is expected to take additional arguments by
|
||||
#! being combined with other parsers. Then 'type' is used for a lookup
|
||||
#! 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" simple-instruction ;
|
||||
|
||||
: RET-NN-instruction ( -- parser )
|
||||
"RET-NN" "RET" complex-instruction
|
||||
"nn" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"RET-NN" "RET" complex-instruction ,
|
||||
"nn" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-0-instruction ( -- parser )
|
||||
"RST-0" "RST" complex-instruction
|
||||
"0" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"RST-0" "RST" complex-instruction ,
|
||||
"0" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-8-instruction ( -- parser )
|
||||
"RST-8" "RST" complex-instruction
|
||||
"8" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"RST-8" "RST" complex-instruction ,
|
||||
"8" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-10H-instruction ( -- parser )
|
||||
"RST-10H" "RST" complex-instruction
|
||||
"10H" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"RST-10H" "RST" complex-instruction ,
|
||||
"10H" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-18H-instruction ( -- parser )
|
||||
"RST-18H" "RST" complex-instruction
|
||||
"18H" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"RST-18H" "RST" complex-instruction ,
|
||||
"18H" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-20H-instruction ( -- parser )
|
||||
"RST-20H" "RST" complex-instruction
|
||||
"20H" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
: RST-20H-instruction ( -- parser )
|
||||
[
|
||||
"RST-20H" "RST" complex-instruction ,
|
||||
"20H" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-28H-instruction ( -- parser )
|
||||
"RST-28H" "RST" complex-instruction
|
||||
"28H" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
: RST-28H-instruction ( -- parser )
|
||||
[
|
||||
"RST-28H" "RST" complex-instruction ,
|
||||
"28H" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-30H-instruction ( -- parser )
|
||||
"RST-30H" "RST" complex-instruction
|
||||
"30H" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
: RST-30H-instruction ( -- parser )
|
||||
[
|
||||
"RST-30H" "RST" complex-instruction ,
|
||||
"30H" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: RST-38H-instruction ( -- parser )
|
||||
"RST-38H" "RST" complex-instruction
|
||||
"38H" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"RST-38H" "RST" complex-instruction ,
|
||||
"38H" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: JP-NN-instruction ( -- parser )
|
||||
"JP-NN" "JP" complex-instruction
|
||||
"nn" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"JP-NN" "JP" complex-instruction ,
|
||||
"nn" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: JP-F|FF,NN-instruction ( -- parser )
|
||||
"JP-F|FF,NN" "JP" complex-instruction
|
||||
all-flags sp <&>
|
||||
",nn" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"JP-F|FF,NN" "JP" complex-instruction ,
|
||||
all-flags sp ,
|
||||
",nn" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: JP-(RR)-instruction ( -- parser )
|
||||
"JP-(RR)" "JP" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"JP-(RR)" "JP" complex-instruction ,
|
||||
16-bit-registers indirect sp ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: CALL-NN-instruction ( -- parser )
|
||||
"CALL-NN" "CALL" complex-instruction
|
||||
"nn" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"CALL-NN" "CALL" complex-instruction ,
|
||||
"nn" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: CALL-F|FF,NN-instruction ( -- parser )
|
||||
"CALL-F|FF,NN" "CALL" complex-instruction
|
||||
all-flags sp <&>
|
||||
",nn" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"CALL-F|FF,NN" "CALL" complex-instruction ,
|
||||
all-flags sp ,
|
||||
",nn" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: RLCA-instruction ( -- parser )
|
||||
"RLCA" simple-instruction ;
|
||||
|
@ -918,364 +930,430 @@ SYMBOLS: $1 $2 $3 $4 ;
|
|||
"RRA" simple-instruction ;
|
||||
|
||||
: 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" "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)" "DEC" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"DEC-(RR)" "DEC" complex-instruction ,
|
||||
16-bit-registers indirect sp ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: 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" "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" "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" "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)" "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" "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" "AND" complex-instruction
|
||||
"n" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"AND-N" "AND" complex-instruction ,
|
||||
"n" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: 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)" "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" "XOR" complex-instruction
|
||||
"n" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"XOR-N" "XOR" complex-instruction ,
|
||||
"n" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: 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)" "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" "OR" complex-instruction
|
||||
"n" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"OR-N" "OR" complex-instruction ,
|
||||
"n" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: 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)" "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" "CP" complex-instruction
|
||||
"n" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"CP-N" "CP" complex-instruction ,
|
||||
"n" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: 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)" "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" "ADC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"ADC-R,N" "ADC" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
",n" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: ADC-R,R-instruction ( -- parser )
|
||||
"ADC-R,R" "ADC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"ADC-R,R" "ADC" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: ADC-R,(RR)-instruction ( -- parser )
|
||||
"ADC-R,(RR)" "ADC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"ADC-R,(RR)" "ADC" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers indirect ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: SBC-R,N-instruction ( -- parser )
|
||||
"SBC-R,N" "SBC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"SBC-R,N" "SBC" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
",n" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: SBC-R,R-instruction ( -- parser )
|
||||
"SBC-R,R" "SBC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"SBC-R,R" "SBC" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: SBC-R,(RR)-instruction ( -- parser )
|
||||
"SBC-R,(RR)" "SBC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"SBC-R,(RR)" "SBC" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers indirect ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: SUB-R-instruction ( -- parser )
|
||||
"SUB-R" "SUB" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"SUB-R" "SUB" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: SUB-(RR)-instruction ( -- parser )
|
||||
"SUB-(RR)" "SUB" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"SUB-(RR)" "SUB" complex-instruction ,
|
||||
16-bit-registers indirect sp ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: SUB-N-instruction ( -- parser )
|
||||
"SUB-N" "SUB" complex-instruction
|
||||
"n" token sp <&
|
||||
just [ { } clone swap curry ] <@ ;
|
||||
[
|
||||
"SUB-N" "SUB" complex-instruction ,
|
||||
"n" token sp hide ,
|
||||
] seq* [ no-params ] action ;
|
||||
|
||||
: ADD-R,N-instruction ( -- parser )
|
||||
"ADD-R,N" "ADD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"ADD-R,N" "ADD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
",n" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: ADD-R,R-instruction ( -- parser )
|
||||
"ADD-R,R" "ADD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"ADD-R,R" "ADD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: ADD-RR,RR-instruction ( -- parser )
|
||||
"ADD-RR,RR" "ADD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"ADD-RR,RR" "ADD" complex-instruction ,
|
||||
16-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: ADD-R,(RR)-instruction ( -- parser )
|
||||
"ADD-R,(RR)" "ADD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"ADD-R,(RR)" "ADD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers indirect ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: LD-RR,NN-instruction ( -- parser )
|
||||
#! LD BC,nn
|
||||
"LD-RR,NN" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
",nn" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"LD-RR,NN" "LD" complex-instruction ,
|
||||
16-bit-registers sp ,
|
||||
",nn" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: LD-R,N-instruction ( -- parser )
|
||||
#! LD B,n
|
||||
"LD-R,N" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"LD-R,N" "LD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
",n" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: LD-(RR),N-instruction ( -- parser )
|
||||
"LD-(RR),N" "LD" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
: LD-(RR),N-instruction ( -- parser )
|
||||
[
|
||||
"LD-(RR),N" "LD" complex-instruction ,
|
||||
16-bit-registers indirect sp ,
|
||||
",n" token hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: LD-(RR),R-instruction ( -- parser )
|
||||
#! LD (BC),A
|
||||
"LD-(RR),R" "LD" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"LD-(RR),R" "LD" complex-instruction ,
|
||||
16-bit-registers indirect sp ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: LD-R,R-instruction ( -- parser )
|
||||
"LD-R,R" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"LD-R,R" "LD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: LD-RR,RR-instruction ( -- parser )
|
||||
"LD-RR,RR" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"LD-RR,RR" "LD" complex-instruction ,
|
||||
16-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: LD-R,(RR)-instruction ( -- parser )
|
||||
"LD-R,(RR)" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"LD-R,(RR)" "LD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers indirect ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: LD-(NN),RR-instruction ( -- parser )
|
||||
"LD-(NN),RR" "LD" complex-instruction
|
||||
"nn" token indirect sp <&
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"LD-(NN),RR" "LD" complex-instruction ,
|
||||
"nn" token indirect sp hide ,
|
||||
"," token hide ,
|
||||
16-bit-registers ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: LD-(NN),R-instruction ( -- parser )
|
||||
"LD-(NN),R" "LD" complex-instruction
|
||||
"nn" token indirect sp <&
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"LD-(NN),R" "LD" complex-instruction ,
|
||||
"nn" token indirect sp hide ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: LD-RR,(NN)-instruction ( -- parser )
|
||||
"LD-RR,(NN)" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
"nn" token indirect <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"LD-RR,(NN)" "LD" complex-instruction ,
|
||||
16-bit-registers sp ,
|
||||
"," token hide ,
|
||||
"nn" token indirect hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: LD-R,(NN)-instruction ( -- parser )
|
||||
"LD-R,(NN)" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
"nn" token indirect <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"LD-R,(NN)" "LD" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
"nn" token indirect hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: OUT-(N),R-instruction ( -- parser )
|
||||
"OUT-(N),R" "OUT" complex-instruction
|
||||
"n" token indirect sp <&
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"OUT-(N),R" "OUT" complex-instruction ,
|
||||
"n" token indirect sp hide ,
|
||||
"," token hide ,
|
||||
8-bit-registers ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: IN-R,(N)-instruction ( -- parser )
|
||||
"IN-R,(N)" "IN" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
"n" token indirect <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
[
|
||||
"IN-R,(N)" "IN" complex-instruction ,
|
||||
8-bit-registers sp ,
|
||||
"," token hide ,
|
||||
"n" token indirect hide ,
|
||||
] seq* [ one-param ] action ;
|
||||
|
||||
: EX-(RR),RR-instruction ( -- parser )
|
||||
"EX-(RR),RR" "EX" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"EX-(RR),RR" "EX" complex-instruction ,
|
||||
16-bit-registers indirect sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: EX-RR,RR-instruction ( -- parser )
|
||||
"EX-RR,RR" "EX" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
[
|
||||
"EX-RR,RR" "EX" complex-instruction ,
|
||||
16-bit-registers sp ,
|
||||
"," token hide ,
|
||||
16-bit-registers ,
|
||||
] seq* [ two-params ] action ;
|
||||
|
||||
: 8080-generator-parser ( -- parser )
|
||||
NOP-instruction
|
||||
RST-0-instruction <|>
|
||||
RST-8-instruction <|>
|
||||
RST-10H-instruction <|>
|
||||
RST-18H-instruction <|>
|
||||
RST-20H-instruction <|>
|
||||
RST-28H-instruction <|>
|
||||
RST-30H-instruction <|>
|
||||
RST-38H-instruction <|>
|
||||
JP-F|FF,NN-instruction <|>
|
||||
JP-NN-instruction <|>
|
||||
JP-(RR)-instruction <|>
|
||||
CALL-F|FF,NN-instruction <|>
|
||||
CALL-NN-instruction <|>
|
||||
CPL-instruction <|>
|
||||
CCF-instruction <|>
|
||||
SCF-instruction <|>
|
||||
DAA-instruction <|>
|
||||
RLA-instruction <|>
|
||||
RRA-instruction <|>
|
||||
RLCA-instruction <|>
|
||||
RRCA-instruction <|>
|
||||
HALT-instruction <|>
|
||||
DI-instruction <|>
|
||||
EI-instruction <|>
|
||||
AND-N-instruction <|>
|
||||
AND-R-instruction <|>
|
||||
AND-(RR)-instruction <|>
|
||||
XOR-N-instruction <|>
|
||||
XOR-R-instruction <|>
|
||||
XOR-(RR)-instruction <|>
|
||||
OR-N-instruction <|>
|
||||
OR-R-instruction <|>
|
||||
OR-(RR)-instruction <|>
|
||||
CP-N-instruction <|>
|
||||
CP-R-instruction <|>
|
||||
CP-(RR)-instruction <|>
|
||||
DEC-RR-instruction <|>
|
||||
DEC-R-instruction <|>
|
||||
DEC-(RR)-instruction <|>
|
||||
POP-RR-instruction <|>
|
||||
PUSH-RR-instruction <|>
|
||||
INC-RR-instruction <|>
|
||||
INC-R-instruction <|>
|
||||
INC-(RR)-instruction <|>
|
||||
LD-RR,NN-instruction <|>
|
||||
LD-R,N-instruction <|>
|
||||
LD-R,R-instruction <|>
|
||||
LD-RR,RR-instruction <|>
|
||||
LD-(RR),N-instruction <|>
|
||||
LD-(RR),R-instruction <|>
|
||||
LD-R,(RR)-instruction <|>
|
||||
LD-(NN),RR-instruction <|>
|
||||
LD-(NN),R-instruction <|>
|
||||
LD-RR,(NN)-instruction <|>
|
||||
LD-R,(NN)-instruction <|>
|
||||
ADC-R,N-instruction <|>
|
||||
ADC-R,R-instruction <|>
|
||||
ADC-R,(RR)-instruction <|>
|
||||
ADD-R,N-instruction <|>
|
||||
ADD-R,R-instruction <|>
|
||||
ADD-RR,RR-instruction <|>
|
||||
ADD-R,(RR)-instruction <|>
|
||||
SBC-R,N-instruction <|>
|
||||
SBC-R,R-instruction <|>
|
||||
SBC-R,(RR)-instruction <|>
|
||||
SUB-R-instruction <|>
|
||||
SUB-(RR)-instruction <|>
|
||||
SUB-N-instruction <|>
|
||||
RET-F|FF-instruction <|>
|
||||
RET-NN-instruction <|>
|
||||
OUT-(N),R-instruction <|>
|
||||
IN-R,(N)-instruction <|>
|
||||
EX-(RR),RR-instruction <|>
|
||||
EX-RR,RR-instruction <|>
|
||||
just ;
|
||||
[
|
||||
NOP-instruction ,
|
||||
RST-0-instruction ,
|
||||
RST-8-instruction ,
|
||||
RST-10H-instruction ,
|
||||
RST-18H-instruction ,
|
||||
RST-20H-instruction ,
|
||||
RST-28H-instruction ,
|
||||
RST-30H-instruction ,
|
||||
RST-38H-instruction ,
|
||||
JP-F|FF,NN-instruction ,
|
||||
JP-NN-instruction ,
|
||||
JP-(RR)-instruction ,
|
||||
CALL-F|FF,NN-instruction ,
|
||||
CALL-NN-instruction ,
|
||||
CPL-instruction ,
|
||||
CCF-instruction ,
|
||||
SCF-instruction ,
|
||||
DAA-instruction ,
|
||||
RLA-instruction ,
|
||||
RRA-instruction ,
|
||||
RLCA-instruction ,
|
||||
RRCA-instruction ,
|
||||
HALT-instruction ,
|
||||
DI-instruction ,
|
||||
EI-instruction ,
|
||||
AND-N-instruction ,
|
||||
AND-R-instruction ,
|
||||
AND-(RR)-instruction ,
|
||||
XOR-N-instruction ,
|
||||
XOR-R-instruction ,
|
||||
XOR-(RR)-instruction ,
|
||||
OR-N-instruction ,
|
||||
OR-R-instruction ,
|
||||
OR-(RR)-instruction ,
|
||||
CP-N-instruction ,
|
||||
CP-R-instruction ,
|
||||
CP-(RR)-instruction ,
|
||||
DEC-RR-instruction ,
|
||||
DEC-R-instruction ,
|
||||
DEC-(RR)-instruction ,
|
||||
POP-RR-instruction ,
|
||||
PUSH-RR-instruction ,
|
||||
INC-RR-instruction ,
|
||||
INC-R-instruction ,
|
||||
INC-(RR)-instruction ,
|
||||
LD-RR,NN-instruction ,
|
||||
LD-RR,RR-instruction ,
|
||||
LD-R,N-instruction ,
|
||||
LD-R,R-instruction ,
|
||||
LD-(RR),N-instruction ,
|
||||
LD-(RR),R-instruction ,
|
||||
LD-R,(RR)-instruction ,
|
||||
LD-(NN),RR-instruction ,
|
||||
LD-(NN),R-instruction ,
|
||||
LD-RR,(NN)-instruction ,
|
||||
LD-R,(NN)-instruction ,
|
||||
ADC-R,(RR)-instruction ,
|
||||
ADC-R,N-instruction ,
|
||||
ADC-R,R-instruction ,
|
||||
ADD-R,N-instruction ,
|
||||
ADD-R,(RR)-instruction ,
|
||||
ADD-R,R-instruction ,
|
||||
ADD-RR,RR-instruction ,
|
||||
SBC-R,N-instruction ,
|
||||
SBC-R,R-instruction ,
|
||||
SBC-R,(RR)-instruction ,
|
||||
SUB-R-instruction ,
|
||||
SUB-(RR)-instruction ,
|
||||
SUB-N-instruction ,
|
||||
RET-F|FF-instruction ,
|
||||
RET-NN-instruction ,
|
||||
OUT-(N),R-instruction ,
|
||||
IN-R,(N)-instruction ,
|
||||
EX-(RR),RR-instruction ,
|
||||
EX-RR,RR-instruction ,
|
||||
] choice* [ call ] action ;
|
||||
|
||||
: instruction-quotations ( string -- emulate-quot )
|
||||
#! Given an instruction string, return the emulation quotation for
|
||||
#! it. This will later be expanded to produce the disassembly and
|
||||
#! assembly quotations.
|
||||
8080-generator-parser some parse call ;
|
||||
8080-generator-parser parse ;
|
||||
|
||||
SYMBOL: last-instruction
|
||||
SYMBOL: last-opcode
|
||||
|
|
|
@ -4,31 +4,31 @@ USING: kernel tools.test peg fjsc ;
|
|||
IN: fjsc.tests
|
||||
|
||||
{ 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
|
||||
|
||||
{ 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
|
||||
|
||||
{ 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
|
||||
|
||||
{ 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
|
||||
|
||||
{ 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
|
||||
|
||||
{ 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
|
||||
|
||||
{ T{ ast-stack-effect f V{ } V{ } } } [
|
||||
"( -- )" 'stack-effect' parse parse-result-ast
|
||||
"( -- )" 'stack-effect' parse
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
@ -37,18 +37,18 @@ IN: fjsc.tests
|
|||
|
||||
|
||||
{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [
|
||||
"\"abcd\"" 'statement' parse parse-result-ast
|
||||
"\"abcd\"" 'statement' parse
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [
|
||||
"USE: foo" 'statement' parse parse-result-ast
|
||||
"USE: foo" 'statement' parse
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [
|
||||
"IN: foo" 'statement' parse parse-result-ast
|
||||
"IN: foo" 'statement' parse
|
||||
] unit-test
|
||||
|
||||
{ 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
|
||||
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006 Chris Double. All Rights Reserved.
|
||||
! 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
|
||||
io.streams.string assocs memoize ascii peg.parsers ;
|
||||
io.streams.string assocs ascii peg.parsers accessors ;
|
||||
IN: fjsc
|
||||
|
||||
TUPLE: ast-number value ;
|
||||
|
@ -20,28 +20,13 @@ TUPLE: ast-using names ;
|
|||
TUPLE: ast-in name ;
|
||||
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 )
|
||||
[ blank? not ] keep
|
||||
[ "}];\"" member? not ] keep
|
||||
digit? not
|
||||
and and ;
|
||||
|
||||
MEMO: 'identifier-ends' ( -- parser )
|
||||
: 'identifier-ends' ( -- parser )
|
||||
[
|
||||
[ blank? not ] keep
|
||||
[ CHAR: " = not ] keep
|
||||
|
@ -52,22 +37,22 @@ MEMO: 'identifier-ends' ( -- parser )
|
|||
and and and and and
|
||||
] satisfy repeat0 ;
|
||||
|
||||
MEMO: 'identifier-middle' ( -- parser )
|
||||
: 'identifier-middle' ( -- parser )
|
||||
[ identifier-middle? ] satisfy repeat1 ;
|
||||
|
||||
MEMO: 'identifier' ( -- parser )
|
||||
: 'identifier' ( -- parser )
|
||||
[
|
||||
'identifier-ends' ,
|
||||
'identifier-middle' ,
|
||||
'identifier-ends' ,
|
||||
] { } make seq [
|
||||
concat >string f <ast-identifier>
|
||||
] seq* [
|
||||
concat >string f ast-identifier boa
|
||||
] action ;
|
||||
|
||||
|
||||
DEFER: 'expression'
|
||||
|
||||
MEMO: 'effect-name' ( -- parser )
|
||||
: 'effect-name' ( -- parser )
|
||||
[
|
||||
[ blank? not ] keep
|
||||
[ CHAR: ) = not ] keep
|
||||
|
@ -75,98 +60,98 @@ MEMO: 'effect-name' ( -- parser )
|
|||
and and
|
||||
] satisfy repeat1 [ >string ] action ;
|
||||
|
||||
MEMO: 'stack-effect' ( -- parser )
|
||||
: 'stack-effect' ( -- parser )
|
||||
[
|
||||
"(" token hide ,
|
||||
'effect-name' sp repeat0 ,
|
||||
"--" token sp hide ,
|
||||
'effect-name' sp repeat0 ,
|
||||
")" token sp hide ,
|
||||
] { } make seq [
|
||||
first2 <ast-stack-effect>
|
||||
] seq* [
|
||||
first2 ast-stack-effect boa
|
||||
] action ;
|
||||
|
||||
MEMO: 'define' ( -- parser )
|
||||
: 'define' ( -- parser )
|
||||
[
|
||||
":" token sp hide ,
|
||||
'identifier' sp [ ast-identifier-value ] action ,
|
||||
'identifier' sp [ value>> ] action ,
|
||||
'stack-effect' sp optional ,
|
||||
'expression' ,
|
||||
";" token sp hide ,
|
||||
] { } make seq [ first3 <ast-define> ] action ;
|
||||
] seq* [ first3 ast-define boa ] action ;
|
||||
|
||||
MEMO: 'quotation' ( -- parser )
|
||||
: 'quotation' ( -- parser )
|
||||
[
|
||||
"[" token sp hide ,
|
||||
'expression' [ ast-expression-values ] action ,
|
||||
'expression' [ values>> ] action ,
|
||||
"]" token sp hide ,
|
||||
] { } make seq [ first <ast-quotation> ] action ;
|
||||
] seq* [ first ast-quotation boa ] action ;
|
||||
|
||||
MEMO: 'array' ( -- parser )
|
||||
: 'array' ( -- parser )
|
||||
[
|
||||
"{" token sp hide ,
|
||||
'expression' [ ast-expression-values ] action ,
|
||||
'expression' [ values>> ] action ,
|
||||
"}" token sp hide ,
|
||||
] { } make seq [ first <ast-array> ] action ;
|
||||
] seq* [ first ast-array boa ] action ;
|
||||
|
||||
MEMO: 'word' ( -- parser )
|
||||
: 'word' ( -- parser )
|
||||
[
|
||||
"\\" token sp hide ,
|
||||
'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' ,
|
||||
'integer' [ <ast-number> ] action ,
|
||||
'string' [ <ast-string> ] action ,
|
||||
] { } make choice ;
|
||||
'integer' [ ast-number boa ] action ,
|
||||
'string' [ ast-string boa ] action ,
|
||||
] choice* ;
|
||||
|
||||
MEMO: 'comment' ( -- parser )
|
||||
: 'comment' ( -- parser )
|
||||
[
|
||||
[
|
||||
"#!" token sp ,
|
||||
"!" token sp ,
|
||||
] { } make choice hide ,
|
||||
] choice* hide ,
|
||||
[
|
||||
dup CHAR: \n = swap CHAR: \r = or not
|
||||
] satisfy repeat0 ,
|
||||
] { } make seq [ drop <ast-comment> ] action ;
|
||||
] seq* [ drop ast-comment boa ] action ;
|
||||
|
||||
MEMO: 'USE:' ( -- parser )
|
||||
: 'USE:' ( -- parser )
|
||||
[
|
||||
"USE:" token sp hide ,
|
||||
'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 ,
|
||||
'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 ,
|
||||
'identifier' sp [ ast-identifier-value ] action repeat1 ,
|
||||
'identifier' sp [ value>> ] action repeat1 ,
|
||||
";" token sp hide ,
|
||||
] { } make seq [ first <ast-using> ] action ;
|
||||
] seq* [ first ast-using boa ] action ;
|
||||
|
||||
MEMO: 'hashtable' ( -- parser )
|
||||
: 'hashtable' ( -- parser )
|
||||
[
|
||||
"H{" token sp hide ,
|
||||
'expression' [ ast-expression-values ] action ,
|
||||
'expression' [ values>> ] action ,
|
||||
"}" token sp hide ,
|
||||
] { } make seq [ first <ast-hashtable> ] action ;
|
||||
] seq* [ first ast-hashtable boa ] action ;
|
||||
|
||||
MEMO: 'parsing-word' ( -- parser )
|
||||
: 'parsing-word' ( -- parser )
|
||||
[
|
||||
'USE:' ,
|
||||
'USING:' ,
|
||||
'IN:' ,
|
||||
] { } make choice ;
|
||||
] choice* ;
|
||||
|
||||
MEMO: 'expression' ( -- parser )
|
||||
: 'expression' ( -- parser )
|
||||
[
|
||||
[
|
||||
'comment' ,
|
||||
|
@ -177,17 +162,17 @@ MEMO: 'expression' ( -- parser )
|
|||
'hashtable' sp ,
|
||||
'word' sp ,
|
||||
'atom' sp ,
|
||||
] { } make choice repeat0 [ <ast-expression> ] action
|
||||
] choice* repeat0 [ ast-expression boa ] action
|
||||
] delay ;
|
||||
|
||||
MEMO: 'statement' ( -- parser )
|
||||
: 'statement' ( -- parser )
|
||||
'expression' ;
|
||||
|
||||
GENERIC: (compile) ( ast -- )
|
||||
GENERIC: (literal) ( ast -- )
|
||||
|
||||
M: ast-number (literal)
|
||||
ast-number-value number>string , ;
|
||||
value>> number>string , ;
|
||||
|
||||
M: ast-number (compile)
|
||||
"factor.push_data(" ,
|
||||
|
@ -196,7 +181,7 @@ M: ast-number (compile)
|
|||
|
||||
M: ast-string (literal)
|
||||
"\"" ,
|
||||
ast-string-value ,
|
||||
value>> ,
|
||||
"\"" , ;
|
||||
|
||||
M: ast-string (compile)
|
||||
|
@ -205,14 +190,14 @@ M: ast-string (compile)
|
|||
"," , ;
|
||||
|
||||
M: ast-identifier (literal)
|
||||
dup ast-identifier-vocab [
|
||||
dup vocab>> [
|
||||
"factor.get_word(\"" ,
|
||||
dup ast-identifier-vocab ,
|
||||
dup vocab>> ,
|
||||
"\",\"" ,
|
||||
ast-identifier-value ,
|
||||
value>> ,
|
||||
"\")" ,
|
||||
] [
|
||||
"factor.find_word(\"" , ast-identifier-value , "\")" ,
|
||||
"factor.find_word(\"" , value>> , "\")" ,
|
||||
] if ;
|
||||
|
||||
M: ast-identifier (compile)
|
||||
|
@ -220,9 +205,9 @@ M: ast-identifier (compile)
|
|||
|
||||
M: ast-define (compile)
|
||||
"factor.define_word(\"" ,
|
||||
dup ast-define-name ,
|
||||
dup name>> ,
|
||||
"\",\"source\"," ,
|
||||
ast-define-expression (compile)
|
||||
expression>> (compile)
|
||||
"," , ;
|
||||
|
||||
: do-expressions ( seq -- )
|
||||
|
@ -242,17 +227,17 @@ M: ast-define (compile)
|
|||
|
||||
M: ast-quotation (literal)
|
||||
"factor.make_quotation(\"source\"," ,
|
||||
ast-quotation-values do-expressions
|
||||
values>> do-expressions
|
||||
")" , ;
|
||||
|
||||
M: ast-quotation (compile)
|
||||
"factor.push_data(factor.make_quotation(\"source\"," ,
|
||||
ast-quotation-values do-expressions
|
||||
values>> do-expressions
|
||||
")," , ;
|
||||
|
||||
M: ast-array (literal)
|
||||
"[" ,
|
||||
ast-array-elements [ "," , ] [ (literal) ] interleave
|
||||
elements>> [ "," , ] [ (literal) ] interleave
|
||||
"]" , ;
|
||||
|
||||
M: ast-array (compile)
|
||||
|
@ -260,7 +245,7 @@ M: ast-array (compile)
|
|||
|
||||
M: ast-hashtable (literal)
|
||||
"new Hashtable().fromAlist([" ,
|
||||
ast-hashtable-elements [ "," , ] [ (literal) ] interleave
|
||||
elements>> [ "," , ] [ (literal) ] interleave
|
||||
"])" , ;
|
||||
|
||||
M: ast-hashtable (compile)
|
||||
|
@ -268,22 +253,22 @@ M: ast-hashtable (compile)
|
|||
|
||||
|
||||
M: ast-expression (literal)
|
||||
ast-expression-values [
|
||||
values>> [
|
||||
(literal)
|
||||
] each ;
|
||||
|
||||
M: ast-expression (compile)
|
||||
ast-expression-values do-expressions ;
|
||||
values>> do-expressions ;
|
||||
|
||||
M: ast-word (literal)
|
||||
dup ast-word-vocab [
|
||||
dup vocab>> [
|
||||
"factor.get_word(\"" ,
|
||||
dup ast-word-vocab ,
|
||||
dup vocab>> ,
|
||||
"\",\"" ,
|
||||
ast-word-value ,
|
||||
value>> ,
|
||||
"\")" ,
|
||||
] [
|
||||
"factor.find_word(\"" , ast-word-value , "\")" ,
|
||||
"factor.find_word(\"" , value>> , "\")" ,
|
||||
] if ;
|
||||
|
||||
M: ast-word (compile)
|
||||
|
@ -299,17 +284,17 @@ M: ast-stack-effect (compile)
|
|||
|
||||
M: ast-use (compile)
|
||||
"factor.use(\"" ,
|
||||
ast-use-name ,
|
||||
name>> ,
|
||||
"\"," , ;
|
||||
|
||||
M: ast-in (compile)
|
||||
"factor.set_in(\"" ,
|
||||
ast-in-name ,
|
||||
name>> ,
|
||||
"\"," , ;
|
||||
|
||||
M: ast-using (compile)
|
||||
"factor.using([" ,
|
||||
ast-using-names [
|
||||
names>> [
|
||||
"," ,
|
||||
] [
|
||||
"\"" , , "\"" ,
|
||||
|
@ -319,34 +304,34 @@ M: ast-using (compile)
|
|||
GENERIC: (parse-factor-quotation) ( object -- ast )
|
||||
|
||||
M: number (parse-factor-quotation) ( object -- ast )
|
||||
<ast-number> ;
|
||||
ast-number boa ;
|
||||
|
||||
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 )
|
||||
dup name>> swap vocabulary>> <ast-identifier> ;
|
||||
dup name>> swap vocabulary>> ast-identifier boa ;
|
||||
|
||||
M: string (parse-factor-quotation) ( object -- ast )
|
||||
<ast-string> ;
|
||||
ast-string boa ;
|
||||
|
||||
M: quotation (parse-factor-quotation) ( object -- ast )
|
||||
[
|
||||
[ (parse-factor-quotation) , ] each
|
||||
] { } make <ast-quotation> ;
|
||||
] { } make ast-quotation boa ;
|
||||
|
||||
M: array (parse-factor-quotation) ( object -- ast )
|
||||
[
|
||||
[ (parse-factor-quotation) , ] each
|
||||
] { } make <ast-array> ;
|
||||
] { } make ast-array boa ;
|
||||
|
||||
M: hashtable (parse-factor-quotation) ( object -- ast )
|
||||
>alist [
|
||||
[ (parse-factor-quotation) , ] each
|
||||
] { } make <ast-hashtable> ;
|
||||
] { } make ast-hashtable boa ;
|
||||
|
||||
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 )
|
||||
|
||||
|
@ -356,7 +341,7 @@ M: string fjsc-parse ( object -- ast )
|
|||
M: quotation fjsc-parse ( object -- ast )
|
||||
[
|
||||
[ (parse-factor-quotation) , ] each
|
||||
] { } make <ast-expression> ;
|
||||
] { } make ast-expression boa ;
|
||||
|
||||
: fjsc-compile ( ast -- string )
|
||||
[
|
||||
|
@ -372,7 +357,7 @@ M: quotation fjsc-parse ( object -- ast )
|
|||
|
||||
: fc* ( string -- string )
|
||||
[
|
||||
'statement' parse parse-result-ast ast-expression-values do-expressions
|
||||
'statement' parse parse-result-ast values>> do-expressions
|
||||
] { } make [ write ] each ;
|
||||
|
||||
|
||||
|
|
|
@ -99,7 +99,7 @@ PRIVATE>
|
|||
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
|
||||
|
||||
: lisp-string>factor ( str -- quot )
|
||||
lisp-expr parse-result-ast compile-form ;
|
||||
lisp-expr compile-form ;
|
||||
|
||||
: lisp-eval ( str -- * )
|
||||
lisp-string>factor call ;
|
||||
|
|
|
@ -5,43 +5,43 @@ USING: lisp.parser tools.test peg peg.ebnf lists ;
|
|||
IN: lisp.parser.tests
|
||||
|
||||
{ 1234 } [
|
||||
"1234" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"1234" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ -42 } [
|
||||
"-42" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"-42" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ 37/52 } [
|
||||
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"37/52" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ 123.98 } [
|
||||
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"123.98" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ "" } [
|
||||
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"\"" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ "aoeu" } [
|
||||
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"aoeu\"" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ "aoeu\"de" } [
|
||||
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "foobar" } } [
|
||||
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"foobar" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "+" } } [
|
||||
"+" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"+" "atom" \ lisp-expr rule parse
|
||||
] unit-test
|
||||
|
||||
{ +nil+ } [
|
||||
"()" lisp-expr parse-result-ast
|
||||
"()" lisp-expr
|
||||
] unit-test
|
||||
|
||||
{ T{
|
||||
|
@ -54,7 +54,7 @@ IN: lisp.parser.tests
|
|||
1
|
||||
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
|
||||
|
||||
{ T{ cons f
|
||||
|
@ -64,5 +64,5 @@ IN: lisp.parser.tests
|
|||
T{ cons f 2 +nil+ } }
|
||||
}
|
||||
} [
|
||||
"(1 (3 4) 2)" lisp-expr parse-result-ast
|
||||
"(1 (3 4) 2)" lisp-expr
|
||||
] unit-test
|
|
@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
|
|||
|
||||
|
||||
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 boa wrap-peg ;
|
||||
|
|
|
@ -2,8 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
|
||||
vectors arrays math.parser math.order vectors combinators combinators.lib
|
||||
combinators.short-circuit classes sets unicode.categories compiler.units parser
|
||||
words quotations effects memoize accessors locals effects splitting ;
|
||||
classes sets unicode.categories compiler.units parser
|
||||
words quotations effects memoize accessors locals effects splitting
|
||||
combinators.short-circuit combinators.short-circuit.smart ;
|
||||
IN: peg
|
||||
|
||||
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
|
||||
[ 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.
|
||||
#! If not, compile it to a temporary word, cache it,
|
||||
#! and return it. Otherwise return the existing one.
|
||||
|
@ -289,7 +296,7 @@ GENERIC: (compile) ( peg -- quot )
|
|||
dup compiled>> [
|
||||
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* ;
|
||||
|
||||
SYMBOL: delayed
|
||||
|
@ -298,13 +305,13 @@ SYMBOL: delayed
|
|||
#! Work through all delayed parsers and recompile their
|
||||
#! words to have the correct bodies.
|
||||
delayed get [
|
||||
call compiled-parser 1quotation 0 1 <effect> define-declared
|
||||
call compile-parser 1quotation 0 1 <effect> define-declared
|
||||
] assoc-each ;
|
||||
|
||||
: compile ( parser -- word )
|
||||
[
|
||||
H{ } clone delayed [
|
||||
compiled-parser fixup-delayed
|
||||
compile-parser fixup-delayed
|
||||
] with-variable
|
||||
] with-compilation-unit ;
|
||||
|
||||
|
@ -410,17 +417,20 @@ TUPLE: seq-parser parsers ;
|
|||
M: seq-parser (compile) ( peg -- quot )
|
||||
[
|
||||
[ 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 ;
|
||||
|
||||
TUPLE: choice-parser parsers ;
|
||||
|
||||
M: choice-parser (compile) ( peg -- quot )
|
||||
[
|
||||
f ,
|
||||
parsers>> [ compiled-parser ] map
|
||||
unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each
|
||||
[
|
||||
parsers>> [ compile-parser ] map
|
||||
unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
|
||||
] { } make , \ || ,
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: repeat0-parser p1 ;
|
||||
|
@ -435,7 +445,7 @@ TUPLE: repeat0-parser p1 ;
|
|||
] if* ; inline
|
||||
|
||||
M: repeat0-parser (compile) ( peg -- quot )
|
||||
p1>> compiled-parser 1quotation '[
|
||||
p1>> compile-parser 1quotation '[
|
||||
input-slice V{ } clone <parse-result> , swap (repeat)
|
||||
] ;
|
||||
|
||||
|
@ -449,7 +459,7 @@ TUPLE: repeat1-parser p1 ;
|
|||
] if* ;
|
||||
|
||||
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
|
||||
] ;
|
||||
|
||||
|
@ -459,7 +469,7 @@ TUPLE: optional-parser p1 ;
|
|||
[ input-slice f <parse-result> ] unless* ;
|
||||
|
||||
M: optional-parser (compile) ( peg -- quot )
|
||||
p1>> compiled-parser 1quotation '[ @ check-optional ] ;
|
||||
p1>> compile-parser 1quotation '[ @ check-optional ] ;
|
||||
|
||||
TUPLE: semantic-parser p1 quot ;
|
||||
|
||||
|
@ -471,7 +481,7 @@ TUPLE: semantic-parser p1 quot ;
|
|||
] if ; inline
|
||||
|
||||
M: semantic-parser (compile) ( peg -- quot )
|
||||
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi
|
||||
[ p1>> compile-parser 1quotation ] [ quot>> ] bi
|
||||
'[ @ , check-semantic ] ;
|
||||
|
||||
TUPLE: ensure-parser p1 ;
|
||||
|
@ -480,7 +490,7 @@ TUPLE: ensure-parser p1 ;
|
|||
[ ignore <parse-result> ] [ drop f ] if ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
@ -488,7 +498,7 @@ TUPLE: ensure-not-parser p1 ;
|
|||
[ drop f ] [ ignore <parse-result> ] if ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
@ -500,7 +510,7 @@ TUPLE: action-parser p1 quot ;
|
|||
] if ; inline
|
||||
|
||||
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 )
|
||||
#! Return a new string without any leading whitespace
|
||||
|
@ -512,7 +522,7 @@ M: action-parser (compile) ( peg -- quot )
|
|||
TUPLE: sp-parser p1 ;
|
||||
|
||||
M: sp-parser (compile) ( peg -- quot )
|
||||
p1>> compiled-parser 1quotation '[
|
||||
p1>> compile-parser 1quotation '[
|
||||
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.
|
||||
#! This differs from 'delay' which calls
|
||||
#! it at run time.
|
||||
quot>> call compiled-parser 1quotation ;
|
||||
quot>> call compile-parser 1quotation ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
Loading…
Reference in New Issue