MzSchemeのyacc.ss

(require (lib "yacc.ss" "parser-tools")
         (lib "lex.ss" "parser-tools"))

原理的には、yaccはlexがなくても使えます。
lexがなくてもトークンを返す関数を自分で書けば良いわけです。
ここではdefine-tokensとdefine-empty-tokensを 使うためだけに
lex.ssをrequireしています。

トークンの扱い方についてはlex.ssの解説を 参照してください。

lexer

3種類の括弧と数値と変数から成る言語をつくります。
まずlexerを (lexを使わずに) 書きます。

(define-empty-tokens my-empty-tokens (LB RB LP RP LS RS EOF))
(define-tokens my-tokens (NUM VAR))
(define (my-lex port)
  (let ((x (regexp-match #rx"[^][{}() \t\r\n]+|[][{}()]" port)))
    (if (not x) (token-EOF)
      (let ((s (bytes->string/utf-8 (car x))))
        (case (string-ref s 0)
          ((#\{) (token-LB))
          ((#\}) (token-RB))
          ((#\() (token-LP))
          ((#\)) (token-RP))
          ((#\[) (token-LS))
          ((#\]) (token-RS))
          (else
            (let ((x (string->number s)))
              (if x
                (token-NUM x)
                (token-VAR (string->symbol s))))))))))

parser

次にparserを書きましょう。

(define my-parse
  (parser
    (tokens my-tokens my-empty-tokens)
    (start s)
    (end EOF)
    (error (lambda (x y z) (display "syntax error\n")))
    (grammar
      (s
        (() #f)
        ((error s) $2)
        ((expr) $1))
      (expr
        ((LB expr RB expr) (my-cond $2 $4))
        ((LP expr RP expr) (my-app $2 $4))
        ((LS VAR RS expr) (my-abs $2 $4))
        ((NUM) (my-quote $1))
        ((VAR) (my-var $1))))))

理論的には、文法の構成要素は

• 終端記号 (tokensの部分)
• 非終端記号 (grammarの中で小文字で表されています)
• 生成規則 (grammarの部分)
• 開始記号 (startの部分)

です。

grammarの基本的な書式は
(grammar (非終端記号 ((記号 ...) 値)) ...)
です。
$1 $2 ... は (記号 ...) の対応する位置の値です。
$1 $2 ... を使って計算した値が左辺の非終端記号の値になります。
最終的にパーサの返す値は開始記号の値になります。
どんな値を返すかは自由です。
今回は

• 「環境」を表す連想リスト
• 「継続」を表す関数

の2つを引数とするクロージャを返すようにしてみました。

> (let ((p (open-input-string "((1)(2)+)((3)(4)+)+")))
    ((my-parse (lambda () (my-lex p))) env values))
10
> (my-eval "
    (10)
    ( [f][x]
        ((x)(0)=)
          { 1
          } ( ((x)(1)-)
              (f)f)
            (x)*)
    [f](f)f
  ")
3628800

以下はyaccとは関係ありませんが上のコードを実行するのに必要です。

;; continuation
(define (eval-eval x2 e k)
  (lambda (v1) (x2 e (eval-apply v1 k))))
(define (eval-apply v1 k)
  (lambda (v2) (v2 v1 k)))

;; expression
(define (my-var name)
  (lambda (e k)
    (let ((x (assq name e)))
      (if x (k (cdr x)) (raise "unbound variable")))))
(define (my-app x1 x2)
  (lambda (e k) (x1 e (eval-eval x2 e k))))
(define (my-abs name x)
  (lambda (e k) (k (val-abs name x e))))
(define (my-cond x1 x2)
  (lambda (e k) (k (val-cond x1 x2 e))))
(define (my-quote v)
  (lambda (e k) (k v)))

;; value
(define (val-abs name x e)
  (lambda (v k) (x (cons (cons name v) e) k)))
(define (val-cond x1 x2 e)
  (lambda (v k) ((if v x1 x2) e k)))

;; misc.
(define (val-bin op)
  (define (my-bin op)
    (lambda (e k) (k (op (cdar e) (cdadr e)))))
  ((my-abs 'x (my-abs 'y (my-bin op))) '() values))
(define env
  `((+ . ,(val-bin +))
    (- . ,(val-bin -))
    (* . ,(val-bin *))
    (/ . ,(val-bin /))
    (= . ,(val-bin =))))
(define (my-eval s)
  (let ((p (open-input-string s)))
    ((my-parse (lambda () (my-lex p))) env values)))