Experimental PEG

peg.scm

(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))

result.log

% 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

test.scm

(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))))))