Skip to content

Instantly share code, notes, and snippets.

@tyage

tyage/packrat.scm

Created Feb 9, 2014
Embed
What would you like to do?
(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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.