packrat.scm

(use srfi-1)

;;; PEGタームは，入力文字列と解析位置を与えると，解析結果を返す関数．
;;; 解析に成功すると(次の位置 . 意味値)のペアを，失敗すると#fを返す．

;;; 解析結果ペア

(define (make-result pos value) (cons pos value))
(define (position result) (car result))
(define (value result) (cdr result))

;;; check-char は，文字cを与えると，文字cを解析するPEGタームを返す高階関数．
;;; 成功すれば，文字cを意味値として返す．

(define ((check-char c) string pos)
  (if (and (< pos (string-length string))
	   (char=? (string-ref string pos) c))
      (make-result (+ pos 1) c)
      #f))

;;; nt は，非終端記号(PEGターム)を参照するためのラッパー．
;;; call-by-value なので必要

(define-macro (nt name)
  `(lambda (string pos) (,name string pos)))

;;; fail は，常に失敗するPEGターム．

(define (fail string pos) #f)

;;; no-op は，常に成功するPEGターム．

(define (no-op string pos) (make-result pos 'ignore))

;;; seq は，複数のPEGタームを受け取り，逐次に解析するPEGタームを返す高階関数．

(define ((seq-aux term1 term2) string pos)
    (cond ((term1 string pos)
	   => (lambda (p1)
		(term2 string (position p1))))
	  (else #f)))

(define (seq . terms)
  (reduce-right seq-aux no-op terms))

;;; alt は，複数のPEGタームを受け取り，順序つき選択のPEGタームを返す高階関数．

(define ((alt-aux choice1 choice2) string pos)
    (or (choice1 string pos)
	(choice2 string pos)))

(define (alt . choices)
  (reduce-right alt-aux fail choices))

;;; return は，PEGタームtermとSchemeの関数thunkを受け取り，PEGタームを返す高階関数．
;;; term が失敗すると，(return term thunk)も失敗する．
;;; term が成功したとき，termの返した意味値を引数としてthunkを呼びだす．
;;;    thunk が #f を返すと失敗する．
;;;    thunk が #f 以外を返すと，term の返した「次の位置」と，thunk の
;;;     返した値のペアが (return term thunk)の解析結果となる．

(define ((return term thunk) string pos)
  (cond ((term string pos)
	 => (lambda (result)
	      (let ((v (thunk (value result))))
		(and v (make-result (position result) v)))))
	(else #f)))

;;; bind は，PEGタームtermとSchemeの関数thunkを受け取り，PEGタームを返す高階関数．
;;; term が失敗すると，(bind term thunk)も失敗する．
;;; term が成功したとき，termの返した意味値を引数としてthunkを呼びだす．
;;;    thunk は，PEGタームを返さなければならない．
;;;    term の返した「次の位置」を引数にして，thunkの返したPEGタームを呼び出し，
;;;    その結果が (bind term thunk) の結果となる．

(define ((bind term thunk) string pos)
  (cond ((term string pos)
	 => (lambda (result)
	      ((thunk (value result)) string (position result))))
	(else #f)))

;;; 任意のScheme関数をメモ化する高階関数．

(define (memoize fun)
  (let ((h (make-hash-table 'equal?))
	(not-found '(unique-cons)))
    (lambda args
      (let ((v (hash-table-get h args not-found)))
	(if (eq? v not-found)
	    (let ((new-v (apply fun args)))
	      (hash-table-put! h args new-v)
	      new-v)
	    v)))))

;;; メモ化せずに実行するための memoize 関数．(比較用)
; (define memoize (lambda (x) x))


;;; E <- T {->v1} '+' E {->v2, return v1 + v2}
;;;      / T

(define E (memoize
	   (alt (bind (nt T)
		      (lambda (v1)
			(seq (check-char #\+)
			     (return (nt E)
				     (lambda (v2)
				       (+ v1 v2))))))
		(nt T))))


;;; T <- P {->v1} '*' T {->v2, return v1 * v2}
;;;      / P

(define T (memoize
	   (alt (bind (nt P)
		      (lambda (v1)
			(seq (check-char #\*)
			     (return (nt T)
				     (lambda (v2)
				       (* v1 v2))))))
		(nt P))))

;;; P <- '0' / '1' / ... / '9' / '(' E {->v} ')' {->ignore, return v}

(define P (memoize
	   (alt
	    (return (check-char #\0) digit->integer)
	    (return (check-char #\1) digit->integer)
	    (return (check-char #\2) digit->integer)
	    (return (check-char #\3) digit->integer)
	    (return (check-char #\4) digit->integer)
	    (return (check-char #\5) digit->integer)
	    (return (check-char #\6) digit->integer)
	    (return (check-char #\7) digit->integer)
	    (return (check-char #\8) digit->integer)
	    (return (check-char #\9) digit->integer)
	    (seq (check-char #\()
		 (bind (nt E)
		       (lambda (v)
			 (return (check-char #\))
				 (lambda (ignore) v))))))))

;;; テスト
; (time (E "((((((((0))))))))" 0))