64b0db8e30
entries x and y in the list produced by the sort call, if x's bfp = y's bfp, x should come before y if x's efp < y's efp. The idea is that enclosing entries should always come later in the list. this affects only languages where two expressions can start at the same character position. pdhtml.ss expanded capability of ez-grammar with support for simpl parsing of binary operators w/precedence and associativity and automatically generated markdown grammar descriptions. ez-grammar-test.ss now also doubles as a test of pdhtml for algebraic languages. mats/examples.ms, examples/ez-grammar.ss, examples/ez-grammar-test.ss, examples/Makefile original commit: 53b8d16a1e86f3956585dbec0c7b573e485f7844
571 lines
18 KiB
Scheme
571 lines
18 KiB
Scheme
;;; Copyright 2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; This file contains a sample parser defined via the ez-grammar system
|
|
;;; and a simple test of the parser.
|
|
|
|
;;; This file is organized as follows:
|
|
;;;
|
|
;;; - (streams) library providing the required exports for ez-grammar and
|
|
;;; the parser.
|
|
;;;
|
|
;;; - (state-case) library exporting the state-case macro, copped from
|
|
;;; cmacros.ss, for use by the lexer.
|
|
;;;
|
|
;;; - (lexer) library providing a simple lexer that reads characters
|
|
;;; from a port and produces a corresponding stream of tokens.
|
|
;;;
|
|
;;; - (parser) library providing the sample parser.
|
|
;;;
|
|
;;; - ez-grammar-test procedure that tests the sample parser.
|
|
;;;
|
|
;;; Instructions for running the test are at the end of this file.
|
|
|
|
(library (streams)
|
|
(export stream-cons stream-car stream-cdr stream-nil stream-null?
|
|
stream-map stream stream-append2 stream-append-all stream-last-forced)
|
|
(import (chezscheme))
|
|
|
|
(define stream-cons
|
|
(lambda (x thunk)
|
|
(cons x thunk)))
|
|
|
|
(define stream-car
|
|
(lambda (x)
|
|
(car x)))
|
|
|
|
(define stream-cdr
|
|
(lambda (x)
|
|
(when (procedure? (cdr x)) (set-cdr! x ((cdr x))))
|
|
(cdr x)))
|
|
|
|
(define stream-nil '())
|
|
|
|
(define stream-null?
|
|
(lambda (x)
|
|
(null? x)))
|
|
|
|
(define stream-map
|
|
(lambda (f x)
|
|
(if (stream-null? x)
|
|
'()
|
|
(stream-cons (f (stream-car x))
|
|
(lambda ()
|
|
(stream-map f (stream-cdr x)))))))
|
|
|
|
(define stream
|
|
(lambda xs
|
|
xs))
|
|
|
|
(define stream-append2
|
|
(lambda (xs thunk)
|
|
(if (null? xs)
|
|
(thunk)
|
|
(stream-cons (stream-car xs)
|
|
(lambda ()
|
|
(stream-append2 (stream-cdr xs) thunk))))))
|
|
|
|
(define stream-append-all
|
|
(lambda (stream$) ;; stream of streams
|
|
(if (stream-null? stream$)
|
|
stream$
|
|
(stream-append2 (stream-car stream$)
|
|
(lambda () (stream-append-all (stream-cdr stream$)))))))
|
|
|
|
(define stream-last-forced
|
|
(lambda (x)
|
|
(and (not (null? x))
|
|
(let loop ([x x])
|
|
(let ([next (cdr x)])
|
|
(if (pair? next)
|
|
(loop next)
|
|
(car x)))))))
|
|
)
|
|
|
|
(library (state-case)
|
|
(export state-case eof)
|
|
(import (chezscheme))
|
|
|
|
;;; from Chez Scheme Version 9.5.1 cmacros.ss
|
|
(define-syntax state-case
|
|
(lambda (x)
|
|
(define state-case-test
|
|
(lambda (cvar k)
|
|
(with-syntax ((cvar cvar))
|
|
(syntax-case k (-)
|
|
(char
|
|
(char? (datum char))
|
|
#'(char=? cvar char))
|
|
((char1 - char2)
|
|
(and (char? (datum char1)) (char? (datum char2)))
|
|
#'(char<=? char1 cvar char2))
|
|
(predicate
|
|
(identifier? #'predicate)
|
|
#'(predicate cvar))))))
|
|
(define state-case-help
|
|
(lambda (cvar clauses)
|
|
(syntax-case clauses (else)
|
|
(((else exp1 exp2 ...))
|
|
#'(begin exp1 exp2 ...))
|
|
((((k ...) exp1 exp2 ...) . more)
|
|
(with-syntax (((test ...)
|
|
(map (lambda (k) (state-case-test cvar k))
|
|
#'(k ...)))
|
|
(rest (state-case-help cvar #'more)))
|
|
#'(if (or test ...) (begin exp1 exp2 ...) rest)))
|
|
(((k exp1 exp2 ...) . more)
|
|
(with-syntax ((test (state-case-test cvar #'k))
|
|
(rest (state-case-help cvar #'more)))
|
|
#'(if test (begin exp1 exp2 ...) rest))))))
|
|
(syntax-case x (eof)
|
|
((_ cvar (eof exp1 exp2 ...) more ...)
|
|
(identifier? #'cvar)
|
|
(with-syntax ((rest (state-case-help #'cvar #'(more ...))))
|
|
#'(if (eof-object? cvar)
|
|
(begin exp1 exp2 ...)
|
|
rest))))))
|
|
|
|
(define-syntax eof
|
|
(lambda (x)
|
|
(syntax-error x "misplaced aux keyword")))
|
|
)
|
|
|
|
(library (lexer)
|
|
(export token? token-type token-value token-bfp token-efp lexer)
|
|
(import (chezscheme) (state-case) (streams))
|
|
|
|
(define-record-type token
|
|
(nongenerative)
|
|
(fields type value bfp efp))
|
|
|
|
;; test lexer
|
|
(define lexer
|
|
(lambda (fn ip)
|
|
(define $prev-pos 0)
|
|
(define $pos 0)
|
|
(define ($get-char)
|
|
(set! $pos (+ $pos 1))
|
|
(get-char ip))
|
|
(define ($unread-char c)
|
|
(set! $pos (- $pos 1))
|
|
(unread-char c ip))
|
|
(define ($ws!) (set! $prev-pos $pos))
|
|
(define ($make-token type value)
|
|
(let ([tok (make-token type value $prev-pos $pos)])
|
|
(set! $prev-pos $pos)
|
|
tok))
|
|
(define ($lex-error c)
|
|
(errorf #f "unexpected ~a at character ~s of ~a"
|
|
(if (eof-object? c)
|
|
"eof"
|
|
(format "character '~c'" c))
|
|
$pos fn))
|
|
(define-syntax lex-error
|
|
(syntax-rules ()
|
|
[(_ ?c)
|
|
(let ([c ?c])
|
|
($lex-error c)
|
|
(void))]))
|
|
(let-values ([(sp get-buf) (open-string-output-port)])
|
|
(define (return-token type value)
|
|
(stream-cons ($make-token type value) lex))
|
|
(module (identifier-initial? identifier-subsequent?)
|
|
(define identifier-initial?
|
|
(lambda (c)
|
|
(char-alphabetic? c)))
|
|
(define identifier-subsequent?
|
|
(lambda (c)
|
|
(or (char-alphabetic? c)
|
|
(char-numeric? c)))))
|
|
(define-syntax define-state-case
|
|
(syntax-rules ()
|
|
[(_ ?def-id ?char-id clause ...)
|
|
(define (?def-id)
|
|
(let ([?char-id ($get-char)])
|
|
(state-case ?char-id clause ...)))]))
|
|
(define-state-case lex c
|
|
[eof stream-nil]
|
|
[char-whitespace? ($ws!) (lex)]
|
|
[char-numeric? (lex-number c)]
|
|
[#\/ (seen-slash)]
|
|
[identifier-initial? (put-char sp c) (lex-identifier)]
|
|
[#\( (return-token 'lparen #\()]
|
|
[#\) (return-token 'rparen #\))]
|
|
[#\! (return-token 'bang #\!)]
|
|
[#\+ (seen-plus)]
|
|
[#\- (seen-minus)]
|
|
[#\= (seen-equals)]
|
|
[#\* (return-token 'binop '*)]
|
|
[#\, (return-token 'sep #\,)]
|
|
[#\; (return-token 'sep #\;)]
|
|
[else (lex-error c)])
|
|
(module (lex-identifier)
|
|
(define (id) (return-token 'id (string->symbol (get-buf))))
|
|
(define-state-case next c
|
|
[eof (id)]
|
|
[identifier-subsequent? (put-char sp c) (next)]
|
|
[else ($unread-char c) (id)])
|
|
(define (lex-identifier) (next)))
|
|
(define-state-case seen-plus c
|
|
[eof (return-token 'binop '+)]
|
|
[char-numeric? (lex-signed-number #\+ c)]
|
|
[else (return-token 'binop '+)])
|
|
(define-state-case seen-minus c
|
|
[eof (return-token 'binop '-)]
|
|
[char-numeric? (lex-signed-number #\- c)]
|
|
[else (return-token 'binop '-)])
|
|
(define-state-case seen-equals c
|
|
[eof (return-token 'binop '=)]
|
|
[#\> (return-token 'big-arrow #f)]
|
|
[else (return-token 'binop '=)])
|
|
(module (lex-number lex-signed-number)
|
|
(define (finish-number)
|
|
(let ([str (get-buf)])
|
|
(let ([n (string->number str 10)])
|
|
(unless n (errorf 'lexer "unexpected number literal ~a" str))
|
|
(return-token 'integer n))))
|
|
(define (num)
|
|
(let ([c ($get-char)])
|
|
(state-case c
|
|
[eof (finish-number)]
|
|
[char-numeric? (put-char sp c) (num)]
|
|
[else ($unread-char c) (finish-number)])))
|
|
(define (lex-signed-number s c)
|
|
(put-char sp s)
|
|
(lex-number c))
|
|
(define (lex-number c)
|
|
(state-case c
|
|
[eof (assert #f)]
|
|
[char-numeric? (put-char sp c) (num)]
|
|
[else (assert #f)])))
|
|
(define-state-case seen-slash c
|
|
[eof (return-token 'binop '/)]
|
|
[#\* (lex-block-comment)]
|
|
[#\/ (lex-comment)]
|
|
[else (return-token 'binop '/)])
|
|
(define-state-case lex-comment c
|
|
[eof (lex)]
|
|
[#\newline ($ws!) (lex)]
|
|
[else (lex-comment)])
|
|
(define (lex-block-comment)
|
|
(define-state-case maybe-end-comment c
|
|
[eof (lex-error c)]
|
|
[#\/ ($ws!) (lex)]
|
|
[else (lex-block-comment)])
|
|
(let ([c ($get-char)])
|
|
(state-case c
|
|
[eof (lex-error c)]
|
|
[#\* (maybe-end-comment)]
|
|
[else (lex-block-comment)])))
|
|
(lex))))
|
|
|
|
(record-writer (record-type-descriptor token)
|
|
(lambda (x p wr)
|
|
(put-char p #\[)
|
|
(wr (token-type x) p)
|
|
(put-char p #\,)
|
|
(put-char p #\space)
|
|
(wr (token-value x) p)
|
|
(put-char p #\])
|
|
(put-char p #\:)
|
|
(wr (token-bfp x) p)
|
|
(put-char p #\-)
|
|
(wr (token-efp x) p)))
|
|
)
|
|
|
|
(module parser ()
|
|
(export parse *sfd*)
|
|
(import (chezscheme) (streams) (lexer))
|
|
(define *sfd*)
|
|
(module (define-grammar is sat parse-consumed-all? parse-result-value grammar-trace make-src)
|
|
(define (sep->parser sep)
|
|
(cond
|
|
[(char? sep) (sat (lambda (x) (and (eq? (token-type x) 'sep) (eq? (token-value x) sep))))]
|
|
[(symbol? sep) (sat (lambda (x) (eq? (token-type x) sep)))]
|
|
[else (errorf "don't know how to parse separator: ~s" sep)]))
|
|
(meta define (constant? x) (let ([x (syntax->datum x)]) (or (string? x) (char? x))))
|
|
(define constant->parser
|
|
(lambda (const)
|
|
(define (token-sat type val)
|
|
(sat (lambda (x)
|
|
(let ([ans (and (token? x) (eqv? (token-type x) type) (eqv? (token-value x) val))])
|
|
(when (grammar-trace) (printf " ~s is [~s, ~a]? => ~s~%" x type val ans))
|
|
ans))))
|
|
(if (string? const)
|
|
(case const
|
|
[else (token-sat 'id (string->symbol const))])
|
|
(case const
|
|
[#\( (token-sat 'lparen const)]
|
|
[#\) (token-sat 'rparen const)]
|
|
[#\! (token-sat 'bang const)]
|
|
[else (errorf 'constant->parser "don't know how to construct a parser for ~a" const)]))))
|
|
(meta define (constant->markdown k)
|
|
(format "~a" k))
|
|
(define binop->parser
|
|
(lambda (binop)
|
|
(define (binop-sat type val)
|
|
(is val
|
|
(where [x <- item] (and (token? x) (eq? (token-type x) type) (eq? (token-value x) val)))))
|
|
(define (unexpected) (errorf 'binop->parser "don't know how to construct a parser for ~a" binop))
|
|
(if (string? binop)
|
|
(binop-sat 'binop
|
|
(case binop
|
|
["=" '=]
|
|
["+" '+]
|
|
["-" '-]
|
|
["*" '*]
|
|
["/" '/]
|
|
[else (unexpected)]))
|
|
(unexpected))))
|
|
(define make-src
|
|
(lambda (bfp efp)
|
|
(make-source-object *sfd* bfp efp)))
|
|
(include "ez-grammar.ss"))
|
|
|
|
(define token
|
|
(case-lambda
|
|
[(type)
|
|
(is (token-value x)
|
|
(where
|
|
[x <- (sat (lambda (x)
|
|
(let ([ans (eq? (token-type x) type)])
|
|
(when (grammar-trace) (printf " ~s is ~s? => ~s~%" x type ans))
|
|
ans)))]))]
|
|
[(type val)
|
|
(is (token-value x)
|
|
(where
|
|
[x <- (sat (lambda (x)
|
|
(let ([ans (and
|
|
(eq? (token-type x) type)
|
|
(eqv? (token-value x) val))])
|
|
(when (grammar-trace) (printf " ~s is [~s, ~s]? => ~s~%" x type val ans))
|
|
ans)))]))]))
|
|
|
|
(define identifier (token 'id))
|
|
|
|
(define integer (token 'integer))
|
|
|
|
(define-grammar expr (markdown-directory ".")
|
|
(TERMINALS
|
|
(identifier (x y) (DESCRIPTION ("An identifier is ...")))
|
|
(integer (i) (DESCRIPTION ("An integer literal is ..."))))
|
|
(expr (e)
|
|
(BINOP src ((RIGHT "=") (LEFT "+" "-") (LEFT "*" "/")) t) =>
|
|
(lambda (src op x y)
|
|
(make-annotation `(,op ,x ,y) src `(,op ,(annotation-stripped x) ,(annotation-stripped y)))))
|
|
(term (t)
|
|
[test-SEP+ :: src "sepplus" #\( (SEP+ e #\;) #\) =>
|
|
(lambda (src e+)
|
|
(make-annotation `(SEP+ ,@e+) src `(SEP+ ,@(map annotation-stripped e+))))]
|
|
[test-SEP* :: src "sepstar" #\( (SEP* e #\,) #\) =>
|
|
(lambda (src e*)
|
|
(make-annotation `(SEP* ,@e*) src `(SEP* ,@(map annotation-stripped e*))))]
|
|
[test-OPT :: src "opt" #\( (OPT e #f) #\) =>
|
|
(lambda (src maybe-e)
|
|
(if maybe-e
|
|
(make-annotation `(OPT ,maybe-e) src `(OPT ,(annotation-stripped maybe-e)))
|
|
(make-annotation `(OPT) src `(OPT))))]
|
|
[test-K+ :: src "kplus" #\( (K+ e) #\) =>
|
|
(lambda (src e+)
|
|
(make-annotation `(K+ ,@e+) src `(K+ ,@(map annotation-stripped e+))))]
|
|
[test-K* :: src "kstar" #\( (K* e) #\) =>
|
|
(lambda (src e*)
|
|
(make-annotation `(K* ,@e*) src `(K* ,@(map annotation-stripped e*))))]
|
|
[varref :: src x =>
|
|
(lambda (src id)
|
|
(make-annotation `(id ,id) src `(id ,id)))]
|
|
[intref :: src i =>
|
|
(lambda (src n)
|
|
(make-annotation `(int ,n) src `(int ,n)))]
|
|
[group :: src #\( e #\) =>
|
|
(lambda (src e)
|
|
`(group ,src ,e))]))
|
|
|
|
(define parse
|
|
(lambda (fn ip)
|
|
(let ([token-stream (lexer fn ip)])
|
|
(define (oops)
|
|
(let ([last-token (stream-last-forced token-stream)])
|
|
(if last-token
|
|
(errorf 'parse "parse error at or before character ~s of ~a" (token-bfp last-token) fn)
|
|
(errorf 'parse "no expressions found in ~a" fn))))
|
|
;;; return the first result, if any, for which the input stream was entirely consumed.
|
|
(let loop ([res* (expr token-stream)])
|
|
(if (null? res*)
|
|
(oops)
|
|
(let ([res (car res*)])
|
|
(if (parse-consumed-all? res)
|
|
(parse-result-value res)
|
|
(loop (cdr res*))))))))))
|
|
|
|
(define run
|
|
(lambda (fn)
|
|
(import parser)
|
|
(let* ([ip (open-file-input-port fn)]
|
|
[sfd (make-source-file-descriptor fn ip #t)]
|
|
[ip (transcoded-port ip (native-transcoder))])
|
|
(fluid-let ([*sfd* sfd])
|
|
(eval
|
|
`(let ()
|
|
(define-syntax define-ops
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ op ...)
|
|
#`(begin
|
|
(define-syntax op
|
|
(lambda (x)
|
|
(let ([src (annotation-source (syntax->annotation x))])
|
|
(with-syntax ([bfp (source-object-bfp src)] [efp (source-object-efp src)])
|
|
(syntax-case x ()
|
|
[(_ e (... ...)) #'`(op (bfp . efp) ,e (... ...))])))))
|
|
...)])))
|
|
(define-ops SEP+ SEP* OPT K+ K* id int group)
|
|
(define-ops = + - * /)
|
|
(define x 'x)
|
|
(define y 'y)
|
|
(define z 'z)
|
|
,(dynamic-wind
|
|
void
|
|
(lambda () (parse fn ip))
|
|
(lambda () (close-input-port ip)))))))))
|
|
|
|
(define (ez-grammar-test)
|
|
(define n 0)
|
|
(define test
|
|
(lambda (line* okay?)
|
|
(set! n (+ n 1))
|
|
(let ([fn (format "testfile~s" n)])
|
|
(with-output-to-file fn
|
|
(lambda () (for-each (lambda (line) (printf "~a\n" line)) line*))
|
|
'replace)
|
|
(let ([result (parameterize ([compile-profile #t] [compile-interpret-simple #f])
|
|
(guard (c [else c]) (run fn)))])
|
|
(guard (c [else #f]) (profile-dump-html))
|
|
(delete-file fn)
|
|
(delete-file "profile.html")
|
|
(delete-file (format "~a.html" fn))
|
|
(unless (okay? result)
|
|
(printf "test ~s failed\n" n)
|
|
(printf " test code:")
|
|
(for-each (lambda (line) (printf " ~a\n" line)) line*)
|
|
(printf " result:\n ")
|
|
(if (condition? result)
|
|
(begin (display-condition result) (newline))
|
|
(parameterize ([pretty-initial-indent 4])
|
|
(pretty-print result)))
|
|
(newline))))))
|
|
|
|
(define-syntax returns
|
|
(syntax-rules ()
|
|
[(_ k) (lambda (x) (equal? x 'k))]))
|
|
|
|
(define-syntax oops
|
|
(syntax-rules ()
|
|
[(_ (c) e1 e2 ...)
|
|
(lambda (c) (and (condition? c) e1 e2 ...))]))
|
|
|
|
(test
|
|
'(
|
|
"1347"
|
|
)
|
|
(returns
|
|
(int (0 . 4) 1347)))
|
|
|
|
(test
|
|
'(
|
|
"3 /*"
|
|
)
|
|
(oops (c)
|
|
(equal? (condition-message c) "unexpected ~a at character ~s of ~a")
|
|
(equal? (condition-irritants c) '("eof" 6 "testfile2"))))
|
|
|
|
(test
|
|
'(
|
|
"3 / 4 + 5 opt(6)"
|
|
)
|
|
(oops (c)
|
|
(equal? (condition-message c) "parse error at or before character ~s of ~a")
|
|
(equal? (condition-irritants c) '(10 "testfile3"))))
|
|
|
|
(test
|
|
'(
|
|
"x = y = 5"
|
|
)
|
|
(returns
|
|
(=
|
|
(0 . 9)
|
|
(id (0 . 1) x)
|
|
(= (4 . 9) (id (4 . 5) y) (int (8 . 9) 5)))))
|
|
|
|
(test
|
|
'(
|
|
"x = y = x + 5 - z * 7 + 8 / z"
|
|
)
|
|
(returns
|
|
(=
|
|
(0 . 29)
|
|
(id (0 . 1) x)
|
|
(=
|
|
(4 . 29)
|
|
(id (4 . 5) y)
|
|
(+
|
|
(8 . 29)
|
|
(-
|
|
(8 . 21)
|
|
(+ (8 . 13) (id (8 . 9) x) (int (12 . 13) 5))
|
|
(* (16 . 21) (id (16 . 17) z) (int (20 . 21) 7)))
|
|
(/ (24 . 29) (int (24 . 25) 8) (id (28 . 29) z)))))))
|
|
|
|
(test
|
|
'(
|
|
"opt(opt(opt()))"
|
|
)
|
|
(returns
|
|
(OPT (0 . 15) (OPT (4 . 14) (OPT (8 . 13))))))
|
|
|
|
(test
|
|
'(
|
|
"kstar(3 4 kplus(1 2 3 kstar()))"
|
|
)
|
|
(returns
|
|
(K* (0 . 31)
|
|
(int (6 . 7) 3)
|
|
(int (8 . 9) 4)
|
|
(K+ (10 . 30)
|
|
(int (16 . 17) 1)
|
|
(int (18 . 19) 2)
|
|
(int (20 . 21) 3)
|
|
(K* (22 . 29))))))
|
|
|
|
(test
|
|
'(
|
|
"sepplus( opt() ; opt(5) ; sepstar(17, 34) ; sepstar())"
|
|
)
|
|
(returns
|
|
(SEP+ (0 . 54)
|
|
(OPT (9 . 14))
|
|
(OPT (17 . 23) (int (21 . 22) 5))
|
|
(SEP* (26 . 41) (int (34 . 36) 17) (int (38 . 40) 34))
|
|
(SEP* (44 . 53)))))
|
|
|
|
(delete-file "expr.md")
|
|
(printf "~s tests ran\n" n)
|
|
)
|
|
|
|
#!eof
|
|
|
|
The following should print only "<n> tests ran".
|
|
|
|
echo '(ez-grammar-test)' | ../bin/scheme -q ez-grammar-test.ss
|