From 61ef67beb7d0ec623b9bd0923d0242db45d01210 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 23 Jul 2008 13:01:30 +0000 Subject: [PATCH] remove example parser that doesn't work svn: r10872 --- .../parser-tools/examples/example-parser.ss | 280 ------------------ 1 file changed, 280 deletions(-) delete mode 100644 collects/parser-tools/examples/example-parser.ss diff --git a/collects/parser-tools/examples/example-parser.ss b/collects/parser-tools/examples/example-parser.ss deleted file mode 100644 index 6eecc75625..0000000000 --- a/collects/parser-tools/examples/example-parser.ss +++ /dev/null @@ -1,280 +0,0 @@ -(module example-parser mzscheme - (require parser-tools/lex - parser-tools/yacc - (prefix : parser-tools/lex-sre) - srfi/1/list) - - (provide malgol-lexer malgol-parser) - - - (define-tokens regular (ID LITNUM STRING LBRACK RBRACK COMMA LPAREN RPAREN)) - (define-empty-tokens keywords (PROCEDURE SEMI BEGIN IN END IF THEN ELSE EQUALS EOF - ARROW TRUE FALSE DATATYPE CASES)) - - (display (equal? (token-ID "foo") (token-ID "foo"))) (newline) - - (define-lex-abbrevs - (lower-letter (:/ "a" "z")) - (upper-letter (:/ #\A #\Z)) - (id-start (:or lower-letter upper-letter "+" "-" "*" "_")) - (digit (:/ "0" "9")) - (id-cont (:or id-start digit))) - - (define malgol-lexer - (lexer ((eof) (token-EOF)) - (whitespace (malgol-lexer input-port)) - ("=" (token-EQUALS)) - (";" (token-SEMI)) - ("begin" (token-BEGIN)) - ("end" (token-END)) - ((:+ digit) (token-LITNUM lexeme)) - ((:: id-start (:* id-cont)) (token-ID lexeme)) - ((:: #\" (:* (:or (:~ #\") "\\\"")) #\") (token-STRING (substring lexeme 1 (- (string-length lexeme) 1)))))) - - - ;; keyword-filter : string -> token - (define (keyword-filter str) - (let ([maybe-kwd (assoc str keyword-list)]) - (if maybe-kwd - ((cadr maybe-kwd)) - (token-ID str)))) - - (define keyword-list - `(("--" ,token-ARROW) - ("true" ,token-TRUE) - ("false" ,token-FALSE) - ("in" ,token-IN) - ("procedure" ,token-PROCEDURE) - ("if" ,token-IF) - ("then" ,token-THEN) - ("else" ,token-ELSE) - ("begin" ,token-BEGIN) - ("end" ,token-END) - ("datatype" ,token-DATATYPE) - ("cases" ,token-CASES))) - - (define p1 "procedure mapem >; -begin in - b <(+),if (3) then 4 else 9;,true,\"abc\\\"def\"> d -end - -procedure dufus a; < -- > begin -int = f; -in -z b c (d e) -end - -c - -") - - (define p2 "procedure mapem ; - f; any l;; - begin in - if (equal ) then null - else - begin - any = l; - in - > - end - ; - end - -3 - - -") - - - (print-struct #t) - (define (make-lexer str) - (let ([ip (open-input-string str)]) - (lambda () (malgol-lexer ip)))) - - #;(define a (map (lambda (x) (malgol-lexer i)) (iota 51))) - - - (define malgol-parser - (parser (start program) - #;(debug "/tmp/brox") - (tokens regular keywords) - (grammar (program ((datatype-defs proc-defs exps) (list $2 $3))) - (datatype-defs [(datatype-def datatype-defs) (cons $1 $2)] - [() null]) - (datatype-def [(DATATYPE ID BEGIN variant-defs END) (make-datatype $2 $4)]) - (variant-defs [(variant-def variant-defs) (cons $1 $2)] - [() null]) - (variant-def [(ID typepattern SEMI) (make-variant $1 $2)]) - (proc-defs ((proc-def proc-defs) (cons $1 $2)) - (() null)) - (proc-def ((PROCEDURE ID namepattern SEMI funtypepattern whereform) (make-fundef (string->symbol $2) $3 $6))) - (namepattern ((ID) (string->symbol $1)) - ((LBRACK namepattern COMMA namepattern namepattern2 RBRACK) (cons $2 (cons $4 $5)))) - (namepattern2 ((COMMA namepattern namepattern2) (cons $2 $3)) - (() null)) - (typepattern ((ID) (string->symbol $1)) - ((LBRACK typepattern COMMA typepattern typepattern2 RBRACK) (cons $2 (cons $4 $5))) - ((funtypepattern) $1)) - (typepattern2 ((COMMA typepattern typepattern2) (cons $2 $3)) - (() null)) - (funtypepattern ((LBRACK typepattern ARROW typepattern RBRACK) (list 'arrow $2 $4))) - (exps ((exps single-exp) (make-funcall $1 $2)) - ((single-exp) $1)) - (single-exp ((ID) (string->symbol $1)) - ((LBRACK exps COMMA exps tuplecont RBRACK) (make-tuple (cons $2 (cons $4 $5)))) - ((LITNUM) (string->number $1)) - ((TRUE) #t) - ((FALSE) #f) - ((STRING) $1) - ((IF exps THEN exps ELSE exps SEMI) (make-if-s $2 $4 $6)) - ((LPAREN exps RPAREN) $2) - ((whereform) $1) - [(CASES ID exps SEMI BEGIN cases-clauses END) (make-cases $2 $3 $6)]) - (cases-clauses [(cases-clause cases-clauses) (cons $1 $2)] - [() null]) - (cases-clause [(ID namepattern exps SEMI) (make-cases-clause $1 $2 $3)]) - (tuplecont (() null) - ((COMMA exps tuplecont) (cons $2 $3))) - (whereform ((BEGIN defseq IN exps END) (unwind-where $2 $4))) - (defseq (() null) - ((proc-def SEMI defseq) (cons $1 $3)) - ((typepattern namepattern EQUALS exps SEMI defseq) (cons (list $1 $2 $4) $6)))) - (end EOF) - (error (lambda (a b c) (error 'malgol-parser "error occurred, ~v ~v ~v" a b c))) - )) - - ;; unwind-where : (listof (or/c funcall? (list/c type pattern rhs))) - (define (unwind-where defs-n-procs body) - (fold-right (lambda (def-or-proc body) - (cond [(fundef? def-or-proc) - (make-where body (fundef-name def-or-proc) def-or-proc)] - [else (make-where body (cadr def-or-proc) (caddr def-or-proc))])) - body - defs-n-procs)) - - (define (parse-test str result) - (assert equal? (malgol-parser (make-lexer str)) - result)) - - (define (tup . args) - (make-tuple args)) - - (define ts - (make-test-suite - "foo" - (make-test-case "constants" - (parse-test "23" '(() 23)) - (parse-test "true" '(() #t)) - (parse-test "false" '(() #f)) - (parse-test "\"abc\\\"def\"" '(() "abc\\\"def"))) - (make-test-case "simple exps" - (parse-test "x" '(() x)) - (parse-test "x y" (list null (make-funcall 'x 'y))) - (parse-test "" (list null (tup (make-funcall 'x 'y) 'x))) - (parse-test "if true then true else false;" (list null (make-if-s #t #t #f))) - (parse-test "(<2,<2,x (y)>>)" (list null (tup 2 (tup 2 (make-funcall 'x 'y)))))) - (make-test-case "wheres" - (parse-test "begin any x = 3 ; in y end" (list null (make-where 'y 'x 3))) - (parse-test "begin q = <3,4> ; any = 4 ; in x end" - (list null - (make-where - (make-where 'x - '(z y) - 4) - 'q - (tup 3 4)))) - (parse-test "begin any q = 4; procedure z ; <> -- any> begin in 3 end; any x = 5; in 13 end" - (list null - (make-where - (make-where - (make-where 13 'x '5) - 'z - (make-fundef 'z (list 'x 'y) 3)) - 'q - 4)))) - (make-test-case "procs" - (parse-test "procedure x y ; begin in y end 3" - (list (list (make-fundef 'x 'y 'y)) 3)) - (parse-test "procedure id x ; begin in x end procedure g x ; begin in 14 end 3" - (list (list (make-fundef 'id 'x 'x) - (make-fundef 'g 'x 14)) - 3))) - (make-test-case "factorial" - (parse-test #<<@ -procedure factorial x ; - begin in - if equal then - 1 - else - * )> - ; - end - -factorial 6 -@ - (list (list (make-fundef 'factorial 'x - (make-if-s (make-funcall 'equal - (make-tuple (list 'x 0))) - 1 - (make-funcall '* - (make-tuple - (list 'x - (make-funcall - 'factorial - (make-funcall - '- - (make-tuple (list 'x 1)))))))))) - (make-funcall 'factorial 6))) - - (parse-test #<<@ -procedure fordax ; <> -- > - begin - z = <3,4>; - procedure inner z ; < -- > begin in + end; - any q = 14; - in - z q - end - -fordax -@ - - (list - (list - (make-fundef - 'fordax - '(y z) - (make-where - (make-where (make-where (make-funcall 'z 'q) 'q 14) - 'inner - (make-fundef 'inner 'z (make-funcall '+ (make-tuple (list 'z 3))))) - 'z - (make-tuple (list 3 4))))) - (make-funcall 'fordax (make-tuple (list 'brug 'zorb))))) -) - )) - - (test/text-ui ts) - - (define p - (malgol-parser (make-lexer #<<@ -procedure fordax ; <> -- > - begin - z = <3,4>; - procedure inner z ; < -- > begin in + end; - any q = 14; - in - z q - end - -fordax -@ - ))) - #;(equal? (parse-string "procedure foo x ; any x;; begin any y = 3; in y end 3") - (list (make-fundef ))) - (define result (malgol-parser (make-lexer p1))) - #;(define result2 (malgol-parser (make-lexer p2))) -) - -