Skip to content

Instantly share code, notes, and snippets.

@ktakashi
Created November 14, 2017 22:05
Show Gist options
  • Save ktakashi/7aa16d6d7f5c3e703d12e01dda2f28b9 to your computer and use it in GitHub Desktop.
Save ktakashi/7aa16d6d7f5c3e703d12e01dda2f28b9 to your computer and use it in GitHub Desktop.
Experimental PEG
(import (rnrs) (sagittarius generators) (srfi :117))
;; peg consumes generator
(define $return
(case-lambda
((v) (lambda (g) (values 'success v g)))
((v state) (lambda (g) (values state v g)))
((v state g) (lambda (_) (values state v g)))))
(define ($? pred)
(lambda (g)
(let ((v (g)))
(if (pred v)
(values 'success v g)
(values 'fail v g)))))
(define (make-memoize-generator g)
(define queue (list-queue))
(define use g)
(define (make-queue-generator)
(lambda ()
(when use (set! use #f))
(if (list-queue-empty? queue)
(eof-object)
(list-queue-remove-front! queue))))
(values
(lambda ()
(glet1 v (use)
(list-queue-add-back! queue v)
v))
(gappend (make-queue-generator) g)))
(define ($try parser)
(lambda (g)
(let*-values (((new-g memo-g) (make-memoize-generator g))
((s v _) (parser new-g)))
(case s
((success) (values s v g))
(else (values s v memo-g))))))
(define ($eof g)
(let-values (((new-g memo-g) (make-memoize-generator g)))
(let ((v (new-g)))
(if (eof-object? v)
(values 'success v memo-g)
(values 'fail v memo-g)))))
(define ($not parser)
(lambda (g)
(let-values (((s v ng) (parser g)))
(case s
((success) (values 'fail v ng))
(else (values 'success v ng))))))
(define ($or . expr)
(lambda (g)
(let loop ((e* expr) (g g))
(let-values (((new-g memo-g) (make-memoize-generator g)))
(if (null? e*)
(values 'fail #f memo-g)
(let-values (((s v ng) ((car e*) new-g)))
(case s
((success) (values s v ng))
(else (loop (cdr expr) memo-g)))))))))
(define ($and . expr)
(lambda (g)
(let-values (((new-g memo-g) (make-memoize-generator g)))
(let loop ((e* expr) (g new-g))
(if (null? e*)
(values 'success #t g)
(let-values (((s v ng) ((car e*) g)))
(case s
((success)
(if (null? (cdr e*))
(values s v ng)
(loop (cdr expr) ng)))
(else (values s v memo-g)))))))))
(define ($debug parser)
(lambda (s)
(let-values (((r v s) (parser s)))
(display "status : ") (write r) (newline)
(display "result : ") (write v) (newline)
(display "rest : ") (write s) (newline)
(values r v s))))
(define-syntax $let*
(syntax-rules ()
((_ ((var expr)) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (body ng))
(else (values r var ng))))))
((_ ((var expr) rest ...) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (($let* (rest ...) body) ng))
(else (values r var ng))))))))
(define-syntax $and-let*
(syntax-rules ()
((_ "parse" () (b ...) body)
($let* (b ...) body))
((_ "parse" ((e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (d e)) body))
((_ "parse" ((v e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (v e)) body))
((_ (e ...) body)
($and-let* "parse" (e ...) () body))))
(define %expr1
($and-let* ((a %mulexp)
( ($? (lambda (v) (eq? (car v) '+))) )
(b %mulexp))
($return (+ a b))))
(define %expr2
($let* ((a %mulexp))
($return a)))
(define %expr ($or %expr1 %expr2))
(define %mulexp1
($and-let* ((a %simple)
( ($? (lambda (v) (eq? (car v) '*))) )
(b %simple))
($return (* a b))))
(define %mulexp2
($let* ((a %simple))
($return a)))
(define %mulexp ($or %mulexp1 %mulexp2))
(define %simple1
($let* ((a ($? (lambda (v) (eq? (car v) 'num))))) ($return (cdr a))))
(define %simple2
($and-let* (( ($= (lambda (v) (eq? (car v) 'oparen))) )
(a %expr)
( ($? (lambda (v) (eq? (car v) 'cparen))) ))
($return (cdr a))))
(define %simple ($or %simple1 %simple2))
% sash test.scm [~/project/sagittarius]
;; (repeat count (let* ((g (generator '((num . 1) (+) (num . 2) (*) (num . 3))))) (assert (= 7 (parse-result-semantic-value (calc (base-generator->results g)))))))
;; 2.419242 real 2.687000 user 0.015000 sys
;; (repeat count (let ((g (list->generator '((num . 1) (+) (num . 2) (*) (num . 3))))) (let-values (((s v g) (%expr g))) (assert (= 7 v)))))
;; 2.976559 real 3.453000 user 0.094000 sys
(import (rnrs) (packrat) (time))
(define (generator tokens)
(let ((stream tokens))
(lambda ()
(if (null? stream)
(values #f #f)
(let ((base-token (car stream)))
(set! stream (cdr stream))
(values #f base-token))))))
(define calc (packrat-parser expr
(expr ((a <- mulexp '+ b <- mulexp)
(+ a b))
((a <- mulexp) a))
(mulexp ((a <- simple '* b <- simple)
(* a b))
((a <- simple) a))
(simple ((a <- 'num) a)
(('oparen a <- expr 'cparen) a))))
(define-syntax repeat
(syntax-rules ()
((_ n expr expr* ...)
(let ((thunk (lambda () expr expr* ...)))
(do ((t n) (i 0 (+ i 1)))
((= i t))
(thunk))))))
(define count 10000)
(load "peg.scm")
(time
(repeat count
(let* ((g (generator '((num . 1) (+) (num . 2) (*) (num . 3)))))
(assert (= 7 (parse-result-semantic-value
(calc (base-generator->results g))))))))
(time
(repeat count
(let ((g (list->generator '((num . 1) (+) (num . 2) (*) (num . 3)))))
(let-values (((s v g) (%expr g)))
(assert (= 7 v))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment