280 lines
10 KiB
Scheme
280 lines
10 KiB
Scheme
(module example-parser mzscheme
|
|
(require (lib "lex.ss" "parser-tools")
|
|
(lib "yacc.ss" "parser-tools")
|
|
(prefix : (lib "lex-sre.ss" "parser-tools"))
|
|
(lib "list.ss" "srfi" "1"))
|
|
|
|
(provide malgol-lexer malgol-parser)
|
|
|
|
|
|
(define-tokens regular (ID LITNUM STRING))
|
|
(define-empty-tokens keywords (PROCEDURE SEMI BEGIN IN END IF ELSE EQUALS EOF))
|
|
|
|
(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 example-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 <z,b,<c,d>>; <any -- any>
|
|
begin in
|
|
b <(+),if (3) then 4 else 9;,true,\"abc\\\"def\"> d
|
|
end
|
|
|
|
procedure dufus a; <<any,any,any> -- <any,any>> begin
|
|
int <a,b,z> = f<a,b>;
|
|
in
|
|
z b c (d e)
|
|
end
|
|
|
|
c
|
|
|
|
")
|
|
|
|
(define p2 "procedure mapem <f,l>;
|
|
<any -- any> f; any l;;
|
|
begin in
|
|
if (equal <l,null>) then null
|
|
else
|
|
begin
|
|
any <firstl,lastl> = l;
|
|
in
|
|
<f firstl,mapem <f,lastl>>
|
|
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 "<x y,x>" (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 <a,a> q = <3,4> ; any <z,y> = 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 <x,y> ; <<any,<any -- any>> -- 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 ; <int -- int> begin in y end 3"
|
|
(list (list (make-fundef 'x 'y 'y)) 3))
|
|
(parse-test "procedure id x ; <any -- any> begin in x end procedure g x ; <any -- any> 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 ; <any -- any>
|
|
begin in
|
|
if equal <x,0> then
|
|
1
|
|
else
|
|
* <x,factorial (- <x,1>)>
|
|
;
|
|
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 <y,z> ; <<any,<int,any>> -- <any,any>>
|
|
begin
|
|
<int,int> z = <3,4>;
|
|
procedure inner z ; <<int,any> -- <any,any>> begin in + <z,3> end;
|
|
any q = 14;
|
|
in
|
|
z q
|
|
end
|
|
|
|
fordax <brug,zorb>
|
|
@
|
|
|
|
(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 <y,z> ; <<any,<int,any>> -- <any,any>>
|
|
begin
|
|
<int,int> z = <3,4>;
|
|
procedure inner z ; <<int,any> -- <any,any>> begin in + <z,3> end;
|
|
any q = 14;
|
|
in
|
|
z q
|
|
end
|
|
|
|
fordax <brug,zorb>
|
|
@
|
|
)))
|
|
#;(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)))
|
|
)
|
|
|
|
|