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

db4
Slava Pestov 2008-07-10 20:32:26 -05:00
commit fb32480ec2
7 changed files with 535 additions and 462 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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