From 20b517d7daee13cff78a43236aea1510c9507627 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 21:44:11 +1200 Subject: [PATCH 1/9] Covert cpu.8080 to use pegs --- extra/cpu/8080/emulator/emulator.factor | 723 +++++++++++++----------- 1 file changed, 396 insertions(+), 327 deletions(-) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index ca650a4f01..d29ed23bf0 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -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 ] <@ ; + [[ 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 ] <@ ; + [[ 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 ] <@ ; + [[ 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,103 @@ 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 ; : 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] action ; : RLCA-instruction ( -- parser ) "RLCA" simple-instruction ; @@ -918,364 +921,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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first2 swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first { } swap curry ] 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* [ first2 swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first2 swap curry ] 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* [ first3 append swap curry ] 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* [ first3 append swap curry ] 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 From 38ae977befe096c4014e231d23d753dc5ce77e2d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 21:57:55 +1200 Subject: [PATCH 2/9] Cleanup some cpu-8080 code --- extra/cpu/8080/emulator/emulator.factor | 135 +++++++++++++----------- 1 file changed, 72 insertions(+), 63 deletions(-) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index d29ed23bf0..21392d43b1 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -798,6 +798,15 @@ SYMBOLS: $1 $2 $3 $4 ; #! in a pattern hashtable to return the instruction quotation pattern. 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 ; @@ -805,87 +814,87 @@ SYMBOLS: $1 $2 $3 $4 ; [ "RET-NN" "RET" complex-instruction , "nn" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-0-instruction ( -- parser ) [ "RST-0" "RST" complex-instruction , "0" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-8-instruction ( -- parser ) [ "RST-8" "RST" complex-instruction , "8" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-10H-instruction ( -- parser ) [ "RST-10H" "RST" complex-instruction , "10H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-18H-instruction ( -- parser ) [ "RST-18H" "RST" complex-instruction , "18H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-20H-instruction ( -- parser ) [ "RST-20H" "RST" complex-instruction , "20H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-28H-instruction ( -- parser ) [ "RST-28H" "RST" complex-instruction , "28H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-30H-instruction ( -- parser ) [ "RST-30H" "RST" complex-instruction , "30H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : RST-38H-instruction ( -- parser ) [ "RST-38H" "RST" complex-instruction , "38H" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : JP-NN-instruction ( -- parser ) [ "JP-NN" "JP" complex-instruction , "nn" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : JP-F|FF,NN-instruction ( -- parser ) [ "JP-F|FF,NN" "JP" complex-instruction , all-flags sp , ",nn" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : JP-(RR)-instruction ( -- parser ) [ "JP-(RR)" "JP" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : CALL-NN-instruction ( -- parser ) [ "CALL-NN" "CALL" complex-instruction , "nn" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : CALL-F|FF,NN-instruction ( -- parser ) [ "CALL-F|FF,NN" "CALL" complex-instruction , all-flags sp , ",nn" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : RLCA-instruction ( -- parser ) "RLCA" simple-instruction ; @@ -924,134 +933,134 @@ SYMBOLS: $1 $2 $3 $4 ; [ "DEC-R" "DEC" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : DEC-RR-instruction ( -- parser ) [ "DEC-RR" "DEC" complex-instruction , 16-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : DEC-(RR)-instruction ( -- parser ) [ "DEC-(RR)" "DEC" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : POP-RR-instruction ( -- parser ) [ "POP-RR" "POP" complex-instruction , all-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : PUSH-RR-instruction ( -- parser ) [ "PUSH-RR" "PUSH" complex-instruction , all-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : INC-R-instruction ( -- parser ) [ "INC-R" "INC" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : INC-RR-instruction ( -- parser ) [ "INC-RR" "INC" complex-instruction , 16-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : INC-(RR)-instruction ( -- parser ) [ "INC-(RR)" "INC" complex-instruction , all-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : RET-F|FF-instruction ( -- parser ) [ "RET-F|FF" "RET" complex-instruction , all-flags sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : AND-N-instruction ( -- parser ) [ "AND-N" "AND" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : AND-R-instruction ( -- parser ) [ "AND-R" "AND" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : AND-(RR)-instruction ( -- parser ) [ "AND-(RR)" "AND" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : XOR-N-instruction ( -- parser ) [ "XOR-N" "XOR" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : XOR-R-instruction ( -- parser ) [ "XOR-R" "XOR" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : XOR-(RR)-instruction ( -- parser ) [ "XOR-(RR)" "XOR" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : OR-N-instruction ( -- parser ) [ "OR-N" "OR" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : OR-R-instruction ( -- parser ) [ "OR-R" "OR" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : OR-(RR)-instruction ( -- parser ) [ "OR-(RR)" "OR" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : CP-N-instruction ( -- parser ) [ "CP-N" "CP" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : CP-R-instruction ( -- parser ) [ "CP-R" "CP" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : CP-(RR)-instruction ( -- parser ) [ "CP-(RR)" "CP" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : ADC-R,N-instruction ( -- parser ) [ "ADC-R,N" "ADC" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : ADC-R,R-instruction ( -- parser ) [ @@ -1059,7 +1068,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : ADC-R,(RR)-instruction ( -- parser ) [ @@ -1067,14 +1076,14 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : SBC-R,N-instruction ( -- parser ) [ "SBC-R,N" "SBC" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : SBC-R,R-instruction ( -- parser ) [ @@ -1082,7 +1091,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : SBC-R,(RR)-instruction ( -- parser ) [ @@ -1090,32 +1099,32 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : SUB-R-instruction ( -- parser ) [ "SUB-R" "SUB" complex-instruction , 8-bit-registers sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : SUB-(RR)-instruction ( -- parser ) [ "SUB-(RR)" "SUB" complex-instruction , 16-bit-registers indirect sp , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : SUB-N-instruction ( -- parser ) [ "SUB-N" "SUB" complex-instruction , "n" token sp hide , - ] seq* [ first { } swap curry ] action ; + ] seq* [ no-params ] action ; : ADD-R,N-instruction ( -- parser ) [ "ADD-R,N" "ADD" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : ADD-R,R-instruction ( -- parser ) [ @@ -1123,7 +1132,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : ADD-RR,RR-instruction ( -- parser ) [ @@ -1131,7 +1140,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : ADD-R,(RR)-instruction ( -- parser ) [ @@ -1139,7 +1148,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-RR,NN-instruction ( -- parser ) #! LD BC,nn @@ -1147,7 +1156,7 @@ SYMBOLS: $1 $2 $3 $4 ; "LD-RR,NN" "LD" complex-instruction , 16-bit-registers sp , ",nn" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-R,N-instruction ( -- parser ) #! LD B,n @@ -1155,14 +1164,14 @@ SYMBOLS: $1 $2 $3 $4 ; "LD-R,N" "LD" complex-instruction , 8-bit-registers sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-(RR),N-instruction ( -- parser ) [ "LD-(RR),N" "LD" complex-instruction , 16-bit-registers indirect sp , ",n" token hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-(RR),R-instruction ( -- parser ) #! LD (BC),A @@ -1171,7 +1180,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers indirect sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-R,R-instruction ( -- parser ) [ @@ -1179,7 +1188,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 8-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-RR,RR-instruction ( -- parser ) [ @@ -1187,7 +1196,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-R,(RR)-instruction ( -- parser ) [ @@ -1195,7 +1204,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , 16-bit-registers indirect , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : LD-(NN),RR-instruction ( -- parser ) [ @@ -1203,7 +1212,7 @@ SYMBOLS: $1 $2 $3 $4 ; "nn" token indirect sp hide , "," token hide , 16-bit-registers , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-(NN),R-instruction ( -- parser ) [ @@ -1211,7 +1220,7 @@ SYMBOLS: $1 $2 $3 $4 ; "nn" token indirect sp hide , "," token hide , 8-bit-registers , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-RR,(NN)-instruction ( -- parser ) [ @@ -1219,7 +1228,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , "nn" token indirect hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : LD-R,(NN)-instruction ( -- parser ) [ @@ -1227,7 +1236,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , "nn" token indirect hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : OUT-(N),R-instruction ( -- parser ) [ @@ -1235,7 +1244,7 @@ SYMBOLS: $1 $2 $3 $4 ; "n" token indirect sp hide , "," token hide , 8-bit-registers , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : IN-R,(N)-instruction ( -- parser ) [ @@ -1243,7 +1252,7 @@ SYMBOLS: $1 $2 $3 $4 ; 8-bit-registers sp , "," token hide , "n" token indirect hide , - ] seq* [ first2 swap curry ] action ; + ] seq* [ one-param ] action ; : EX-(RR),RR-instruction ( -- parser ) [ @@ -1251,7 +1260,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers indirect sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : EX-RR,RR-instruction ( -- parser ) [ @@ -1259,7 +1268,7 @@ SYMBOLS: $1 $2 $3 $4 ; 16-bit-registers sp , "," token hide , 16-bit-registers , - ] seq* [ first3 append swap curry ] action ; + ] seq* [ two-params ] action ; : 8080-generator-parser ( -- parser ) [ From 51faed0945341b4f0b4e3b6d0c50588ba0651de4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 22:52:15 +1200 Subject: [PATCH 3/9] Make pegs seq parser use short circuiting && --- extra/peg/peg.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 868072efa5..d1302107ea 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -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 @@ -410,8 +411,10 @@ TUPLE: seq-parser parsers ; M: seq-parser (compile) ( peg -- quot ) [ [ input-slice V{ } clone ] % - parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ - compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each + [ + parsers>> unclip compiled-parser 1quotation [ parse-seq-element ] curry , + [ compiled-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each + ] { } make , \ && , ] [ ] make ; TUPLE: choice-parser parsers ; From 46b0df263138251239af63ea75034e4c5ba8b90a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 10 Jul 2008 23:09:29 +1200 Subject: [PATCH 4/9] Use || in peg choice code generation --- extra/peg/peg.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index d1302107ea..eec4007c02 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -421,9 +421,10 @@ 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>> [ compiled-parser ] map + unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each + ] { } make , \ || , ] [ ] make ; TUPLE: repeat0-parser p1 ; From 9fc2175403a4108f90f6593aaac53a82b114d597 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 02:27:28 +1200 Subject: [PATCH 5/9] peg refactorings --- extra/peg/parsers/parsers.factor | 2 +- extra/peg/peg.factor | 38 ++++++++++++++++++-------------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index f6c2820ac2..b5b2886a5e 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -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 ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index eec4007c02..147e5b892e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -280,7 +280,13 @@ GENERIC: (compile) ( peg -- quot ) gensym 2dup swap peg>> (compile) 0 1 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. @@ -290,7 +296,7 @@ GENERIC: (compile) ( peg -- quot ) dup compiled>> [ nip ] [ - gensym tuck >>compiled 2dup parser-body 0 1 define-declared dupd "peg" set-word-prop + preset-parser-word [ define-parser-word ] keep ] if* ; SYMBOL: delayed @@ -299,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 define-declared + call compile-parser 1quotation 0 1 define-declared ] assoc-each ; : compile ( parser -- word ) [ H{ } clone delayed [ - compiled-parser fixup-delayed + compile-parser fixup-delayed ] with-variable ] with-compilation-unit ; @@ -412,8 +418,8 @@ M: seq-parser (compile) ( peg -- quot ) [ [ input-slice V{ } clone ] % [ - parsers>> unclip compiled-parser 1quotation [ parse-seq-element ] curry , - [ compiled-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each + parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry , + [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each ] { } make , \ && , ] [ ] make ; @@ -422,7 +428,7 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( peg -- quot ) [ [ - parsers>> [ compiled-parser ] map + parsers>> [ compile-parser ] map unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each ] { } make , \ || , ] [ ] make ; @@ -439,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 , swap (repeat) ] ; @@ -453,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 , swap (repeat) repeat1-empty-check ] ; @@ -463,7 +469,7 @@ TUPLE: optional-parser p1 ; [ input-slice f ] unless* ; M: optional-parser (compile) ( peg -- quot ) - p1>> compiled-parser 1quotation '[ @ check-optional ] ; + p1>> compile-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; @@ -475,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 ; @@ -484,7 +490,7 @@ TUPLE: ensure-parser p1 ; [ ignore ] [ 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 ; @@ -492,7 +498,7 @@ TUPLE: ensure-not-parser p1 ; [ drop f ] [ ignore ] 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 ; @@ -504,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 @@ -516,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 @ ] ; @@ -535,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> From 14cc510844e8dea99580eb1e532d06cb73943c40 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:23:03 +1200 Subject: [PATCH 6/9] Fix fjsc failing tests --- extra/fjsc/fjsc-tests.factor | 22 ++++++------ extra/fjsc/fjsc.factor | 68 ++++++++++++++++++------------------ 2 files changed, 45 insertions(+), 45 deletions(-) diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index ce968128be..766e2ec60c 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -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 diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index ec3d92f78b..ecefd862d3 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel peg strings promises 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 ; IN: fjsc TUPLE: ast-number value ; @@ -41,7 +41,7 @@ C: ast-hashtable digit? not and and ; -MEMO: 'identifier-ends' ( -- parser ) +: 'identifier-ends' ( -- parser ) [ [ blank? not ] keep [ CHAR: " = not ] keep @@ -52,22 +52,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 [ + ] seq* [ concat >string f ] action ; DEFER: 'expression' -MEMO: 'effect-name' ( -- parser ) +: 'effect-name' ( -- parser ) [ [ blank? not ] keep [ CHAR: ) = not ] keep @@ -75,98 +75,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 [ + ] seq* [ first2 ] action ; -MEMO: 'define' ( -- parser ) +: 'define' ( -- parser ) [ ":" token sp hide , 'identifier' sp [ ast-identifier-value ] action , 'stack-effect' sp optional , 'expression' , ";" token sp hide , - ] { } make seq [ first3 ] action ; + ] seq* [ first3 ] action ; -MEMO: 'quotation' ( -- parser ) +: 'quotation' ( -- parser ) [ "[" token sp hide , 'expression' [ ast-expression-values ] action , "]" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'array' ( -- parser ) +: 'array' ( -- parser ) [ "{" token sp hide , 'expression' [ ast-expression-values ] action , "}" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'word' ( -- parser ) +: 'word' ( -- parser ) [ "\\" token sp hide , 'identifier' sp , - ] { } make seq [ first ast-identifier-value f ] action ; + ] seq* [ first ast-identifier-value f ] action ; -MEMO: 'atom' ( -- parser ) +: 'atom' ( -- parser ) [ 'identifier' , 'integer' [ ] action , 'string' [ ] action , - ] { } make choice ; + ] 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 ] action ; + ] seq* [ drop ] action ; -MEMO: 'USE:' ( -- parser ) +: 'USE:' ( -- parser ) [ "USE:" token sp hide , 'identifier' sp , - ] { } make seq [ first ast-identifier-value ] action ; + ] seq* [ first ast-identifier-value ] action ; -MEMO: 'IN:' ( -- parser ) +: 'IN:' ( -- parser ) [ "IN:" token sp hide , 'identifier' sp , - ] { } make seq [ first ast-identifier-value ] action ; + ] seq* [ first ast-identifier-value ] action ; -MEMO: 'USING:' ( -- parser ) +: 'USING:' ( -- parser ) [ "USING:" token sp hide , 'identifier' sp [ ast-identifier-value ] action repeat1 , ";" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'hashtable' ( -- parser ) +: 'hashtable' ( -- parser ) [ "H{" token sp hide , 'expression' [ ast-expression-values ] action , "}" token sp hide , - ] { } make seq [ first ] action ; + ] seq* [ first ] action ; -MEMO: 'parsing-word' ( -- parser ) +: 'parsing-word' ( -- parser ) [ 'USE:' , 'USING:' , 'IN:' , - ] { } make choice ; + ] choice* ; -MEMO: 'expression' ( -- parser ) +: 'expression' ( -- parser ) [ [ 'comment' , @@ -177,10 +177,10 @@ MEMO: 'expression' ( -- parser ) 'hashtable' sp , 'word' sp , 'atom' sp , - ] { } make choice repeat0 [ ] action + ] choice* repeat0 [ ] action ] delay ; -MEMO: 'statement' ( -- parser ) +: 'statement' ( -- parser ) 'expression' ; GENERIC: (compile) ( ast -- ) From 8208661ed806ebe97966ee196974ca024674c1d4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:28:47 +1200 Subject: [PATCH 7/9] Use new style accessors in fjsc --- extra/fjsc/fjsc.factor | 119 ++++++++++++++++++----------------------- 1 file changed, 52 insertions(+), 67 deletions(-) diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index ecefd862d3..5f1f977d20 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -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 ascii peg.parsers ; +io.streams.string assocs ascii peg.parsers accessors ; IN: fjsc TUPLE: ast-number value ; @@ -20,21 +20,6 @@ TUPLE: ast-using names ; TUPLE: ast-in name ; TUPLE: ast-hashtable elements ; -C: ast-number -C: ast-identifier -C: ast-string -C: ast-quotation -C: ast-array -C: ast-define -C: ast-expression -C: ast-word -C: ast-comment -C: ast-stack-effect -C: ast-use -C: ast-using -C: ast-in -C: ast-hashtable - : identifier-middle? ( ch -- bool ) [ blank? not ] keep [ "}];\"" member? not ] keep @@ -61,7 +46,7 @@ C: ast-hashtable 'identifier-middle' , 'identifier-ends' , ] seq* [ - concat >string f + concat >string f ast-identifier boa ] action ; @@ -83,43 +68,43 @@ DEFER: 'expression' 'effect-name' sp repeat0 , ")" token sp hide , ] seq* [ - first2 + first2 ast-stack-effect boa ] action ; : 'define' ( -- parser ) [ ":" token sp hide , - 'identifier' sp [ ast-identifier-value ] action , + 'identifier' sp [ value>> ] action , 'stack-effect' sp optional , 'expression' , ";" token sp hide , - ] seq* [ first3 ] action ; + ] seq* [ first3 ast-define boa ] action ; : 'quotation' ( -- parser ) [ "[" token sp hide , - 'expression' [ ast-expression-values ] action , + 'expression' [ values>> ] action , "]" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-quotation boa ] action ; : 'array' ( -- parser ) [ "{" token sp hide , - 'expression' [ ast-expression-values ] action , + 'expression' [ values>> ] action , "}" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-array boa ] action ; : 'word' ( -- parser ) [ "\\" token sp hide , 'identifier' sp , - ] seq* [ first ast-identifier-value f ] action ; + ] seq* [ first value>> f ast-word boa ] action ; : 'atom' ( -- parser ) [ 'identifier' , - 'integer' [ ] action , - 'string' [ ] action , + 'integer' [ ast-number boa ] action , + 'string' [ ast-string boa ] action , ] choice* ; : 'comment' ( -- parser ) @@ -131,33 +116,33 @@ DEFER: 'expression' [ dup CHAR: \n = swap CHAR: \r = or not ] satisfy repeat0 , - ] seq* [ drop ] action ; + ] seq* [ drop ast-comment boa ] action ; : 'USE:' ( -- parser ) [ "USE:" token sp hide , 'identifier' sp , - ] seq* [ first ast-identifier-value ] action ; + ] seq* [ first value>> ast-use boa ] action ; : 'IN:' ( -- parser ) [ "IN:" token sp hide , 'identifier' sp , - ] seq* [ first ast-identifier-value ] action ; + ] seq* [ first value>> ast-in boa ] action ; : 'USING:' ( -- parser ) [ "USING:" token sp hide , - 'identifier' sp [ ast-identifier-value ] action repeat1 , + 'identifier' sp [ value>> ] action repeat1 , ";" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-using boa ] action ; : 'hashtable' ( -- parser ) [ "H{" token sp hide , - 'expression' [ ast-expression-values ] action , + 'expression' [ values>> ] action , "}" token sp hide , - ] seq* [ first ] action ; + ] seq* [ first ast-hashtable boa ] action ; : 'parsing-word' ( -- parser ) [ @@ -177,7 +162,7 @@ DEFER: 'expression' 'hashtable' sp , 'word' sp , 'atom' sp , - ] choice* repeat0 [ ] action + ] choice* repeat0 [ ast-expression boa ] action ] delay ; : 'statement' ( -- parser ) @@ -187,7 +172,7 @@ 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 boa ; M: symbol (parse-factor-quotation) ( object -- ast ) - dup >string swap vocabulary>> ; + dup >string swap vocabulary>> ast-identifier boa ; M: word (parse-factor-quotation) ( object -- ast ) - dup name>> swap vocabulary>> ; + dup name>> swap vocabulary>> ast-identifier boa ; M: string (parse-factor-quotation) ( object -- ast ) - ; + ast-string boa ; M: quotation (parse-factor-quotation) ( object -- ast ) [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-quotation boa ; M: array (parse-factor-quotation) ( object -- ast ) [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-array boa ; M: hashtable (parse-factor-quotation) ( object -- ast ) >alist [ [ (parse-factor-quotation) , ] each - ] { } make ; + ] { } make ast-hashtable boa ; M: wrapper (parse-factor-quotation) ( object -- ast ) - wrapped>> dup name>> swap vocabulary>> ; + 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 ; + ] { } 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 ; From d808d49f68beef9d37ae647e82eb998b1fe1b933 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:33:09 +1200 Subject: [PATCH 8/9] Fix lisp.parser unit tests --- extra/lisp/parser/parser-tests.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 4aa8154690..d722390f9a 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -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 \ No newline at end of file From 59857a455b3e072633f15a895ce66ff49b1082d2 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Jul 2008 11:34:12 +1200 Subject: [PATCH 9/9] Fix lisp unit tests --- extra/lisp/lisp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 1dd285ed7c..bc425df12c 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -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 ;