続cl-yacc

どうしようか迷ったけど、いいや貼り付けてしまえ。

とりあえず、文法をうまくかけるかどうか、ということが問題。

自分の脳みそではあんまり考えられないけど、何かの文法をパクっても、どうせ途中でオレオレルールになるだろうから、試行錯誤しながら書いてみる。

(defun test-parse (file)
  (with-open-file (s file :direction :input)
    (yacc:parse-with-lexer
     (list-lexer-c
      (read-c-like s))
     *c-like*)))

(eval-when (compile load eval)
  (defun i2p (a b c)
    "Infix to Prefix"
    (list b a c))
  (defun k-2-3 (a b c)
    (declare (ignore a c))
    b))

(defun read-c-like (stream)
  (let ((*readtable* (copy-readtable *readtable*)))
    (loop :for ch across ";,(){}"
       :do
       (set-macro-character
	ch
	#'(lambda (stream ch)
	    (declare (ignore stream))
	    (intern (string ch) :keyword))))

    (loop :for ch across "%/*"
       :do
       (set-macro-character
	ch
	#'(lambda (stream ch)
	    (declare (ignore stream))
	    (intern (string ch)))))

    (set-macro-character
     #\=
     (lambda (stream ch)
       (declare (ignore ch))
       (if (char= #\= (peek-char nil stream))
	   (progn (read-char stream)
		  :==)
	   :=)))
    (set-macro-character
     #\<
     (lambda (stream ch)
       (declare (ignore ch))
       (if (char= #\= (peek-char nil stream))
	   (progn (read-char stream)
		  '<=)
	   '<)))
    (set-macro-character
     #\>
     (lambda (stream ch)
       (declare (ignore ch))
       (if (char= #\= (peek-char nil stream))
	   (progn (read-char stream)
		  '>=)
	   '>)))
    (set-macro-character
     #\+
     (lambda (stream ch)
       (declare (ignore ch))
       (if (char= #\+ (peek-char nil stream))
	   (progn (read-char stream)
		  :++)
	   '+)))
    (set-macro-character
     #\-
     (lambda (stream ch)
       (declare (ignore ch))
       (if (char= #\- (peek-char nil stream))
	   (progn (read-char stream)
		  :--)
	   '-)))
    (loop
       :while (listen stream)
       :collect
       ;;シンボル中のアンダースコアを読み込んだ後にハイフンに直す
       (let ((obj (read stream)))
	 (if (symbolp obj)
	     (let ((name (symbol-name obj)))
	       (intern
		(map 'string
		     #'(lambda (ch)
			 (if (char= ch #\_)
			     #\-
			     ch))
		     name)
		(symbol-package obj)))
	     obj)))))

(defun list-lexer-c (list)
  #'(lambda ()
      (let ((val (pop list)))
	(if (null val)
	    (values nil nil)
	    (let ((terminal
		   (cond
		     ((member val '(+ - * / %
				    := :== < > <= >=
				    :++ :--)) val)
		     ((eq :|(| val) :lparen)
		     ((eq :|)| val) :rparen)
		     ((eq :|{| val) :bstart)
		     ((eq :|}| val) :bend)
		     ((eq :|;| val) :eend)
		     ((eq :|,| val) :sep)
		     ((integerp val) :num)
		     ((stringp val) :string)
		     ((eq 'for val) :for)
		     ((eq 'if val) :if)
		     ((eq 'else val) :else)
		     ((eq 'return val) :return)
		     ((member val '(string int void)) :type)
		     ((symbolp val) :name)
		     (t (error "Unexpected value ~A" val)))))
	      (values terminal val))))))

(yacc::define-parser *c-like*
  (:start-symbol PROGRAM)
  (:terminals
   (:type :name :num :string
	  + :++ - :-- * / % := :== < <= > >=
	  :for :if :else
	  :return
	  :struct
	  :bstart :bend			;block {}
	  :sep				; separator ,
	  :eend				; ;
	  :lparen :rparen))
  (:precedence				;演算子優先順位
   ((:left * / %)
    (:left + -)
    (:left :== <= >= < >)))

  (PROGRAM
   (DEFS #'(lambda (defs) `(progn ,@defs))))
  (DEFS
      (DEF DEFS #'cons)
      (DEF #'list))
  (DEF
      DEFVAR
      DEFUN)
  (DEFVAR
      ;;=> type name;
      (:type :name :eend
	     #'(lambda (type name $3) `(defparameter ,name)))
    ;;=> type name = expression;
    (:type :name := EXPRESSION :eend
	   #'(lambda (type name $3 expression $4)
	       `(defparameter ,name ,expression))))
  (DEFUN
      ;;=> int hoge(args){bodies}
      (:type :name :lparen DEFUN-ARGS :rparen :bstart BODIES :bend
	     #'(lambda (type name $3 args $5 $6 bodies $8)
		 `(defun ,name ,args
		    (block nil ,@bodies))))
      (:type :name :lparen :rparen :bstart BODIES :bend
       #'(lambda (type name $3 $4 $5 bodies $6)
	   `(defun ,name () (block nil ,@bodies)))))
  (DEFUN-ARGS
      ;;=> int n , int m
      (:type :name :sep DEFUN-ARGS
	     #'(lambda (type name $3 args)
		 (cons name args)))
      (:type :name #'(lambda (type name) (list name))))
  (FUNCALL
   (:name :lparen ARGS :rparen
	  #'(lambda (name $2 args $4)
	      `(,name ,@args)))
   (:name :lparen :rparen
	  #'(lambda (name $2 $3)
	      `(,name))))
  (ARGS
   (ARG #'list)
   (ARG :sep ARGS #'(lambda (arg $2 args) (cons arg args))))
  (ARG
   EXPRESSION
   FUNCALL
   LITERALL)
  (LITERALL
   :name
   :num
   :string)
  (EXPRESSIONS
   (EXPRESSION #'list)
   (EXPRESSION :sep EXPRESSIONS
	       #'(lambda (exp $2 exprs)
		   (cons exp exprs))))
  (EXPRESSION
   (expression + expression #'i2p)
   (expression - expression #'i2p)
   (expression * expression #'i2p)
   (expression / expression #'i2p)
   (expression % expression
	       #'(lambda (exp1 $2 exp2)
		   `(mod ,exp1 ,exp2)))
   (expression :== expression
	       #'(lambda ($1 $2 $3) `(equal ,$1 ,$3)))
   (expression < expression #'i2p)
   (expression <= expression #'i2p)
   (expression > expression #'i2p)
   (expression >= expression #'i2p)
   exp-term)
  (exp-term
   LITERALL
   (:- exp-term)
   SUBST
   FUNCALL
   (|(| expression |)| #'k-2-3))
  ;;代入
  (SUBST
   (:name := EXPRESSION
	  #'(lambda (name $2 expr)
	      `(setf ,name ,expr)))
   ;;後置インクリメント
   (:name :++
	  #'(lambda (name $2)
	      `(prog1 ,name
		 (incf ,name))))
   ;;前置インクリメント
   (:++ :name
	#'(lambda ($1 name)
	    `(incf ,name)))
   (:name :--
	  #'(lambda (name $2)
	      `(prog1 ,name
		 (decf ,name))))
   (:-- :name
	#'(lambda ($1 name)
	    `(decf ,name))))
  ;;関数やブロック内の変数宣言はletに展開する
  (LET-FORM
   (:type :name := EXPRESSION :eend BODIES
	  #'(lambda (type name $3 expr $5 bodies)
	      `(let ((,name ,expr)) ,@bodies)))
   (:type :name :eend BODIES
	  #'(lambda (type name $3 bodies)
	      `(let (,name) ,@bodies))))
  (IF-FORM
   (:if :lparen expression :rparen :bstart bodies :bend
	#'(lambda ($1 $2 $3 $4 $5 $6 $7)
	    `(when ,$3  ,@$6)))
   (:if :lparen expression :rparen :bstart bodies :bend :else :bstart bodies :bend
	#'(lambda ($1 $2 $3 $4 $5 $6 $7 $8 $9 $10 $11)
	    `(if ,$3 (progn ,@$6) (progn ,@$10))))
   (:if :lparen expression :rparen :bstart bodies :bend :else body
	#'(lambda ($1 $2 $3 $4 $5 $6 $7 $8 $9)
	    `(if ,$3 (progn ,@$6) ,$9))))
  (FOR-FORM
   (:for :lparen :type :name :=
	 EXPRESSION :eend EXPRESSION :eend EXPRESSIONS :rparen :bstart BODIES :bend
	 #'(lambda ($1 $2 type name $5 expr1 $7 expr2 $9 exprs
		    $11 $12 bodies $14)
	     `(loop :with ,name = ,expr1
		 :while ,expr2
		 :do ,@bodies ,@exprs)))
   (:for :lparen :name :=
	 EXPRESSION :eend EXPRESSION :eend EXPRESSIONS :rparen
	 :bstart BODIES :bend
	 #'(lambda ($1 $2 name $4 expr1 $6 expr2 $8 exprs $10 $11 bodies $13)
	     `(progn
		(setf ,name ,expr1)
		`(loop
		    :while ,expr2
		    :do ,@bodies ,@exprs))))
   (:for :lparen :eend EXPRESSION :eend EXPRESSIONS :rparen
	 :bstart BODIES :bend
	 #'(lambda ($1 $2 $3 expr2 $5 exprs $7 $8 bodies $10)
	     `(loop :while ,expr2
		 :do ,@bodies ,@exprs))))
  (BODIES
   (BODY BODIES #'cons)
   (BODY #'list))
  (BODY
   RETURN-FORM
   LET-FORM
   (:name := EXPRESSION :eend #'(lambda (name $2 expr $4) `(setf ,name ,expr)))
   FOR-FORM
   IF-FORM
   (EXPRESSION :eend #'(lambda (expr $2) expr)))
  (RETURN-FORM
   (:return :eend #'(lambda ($1 $2) `(return)))
   (:return EXPRESSION :eend #'(lambda ($1 expr $3) `(return ,expr))))
  )

read-c-likeで読み込んだリストを引数にしてlist-lexer-cを呼び出し、さらにその返り値をyacc:parse-with-lexerにパーサの定義とともに渡す。

とりあえず、FizzBuzzを書くいてみると、こうなる。

void fizzbuzz(int n)
{
  for(int a=1;a<=n;a++)
    {
      if(a%15==0)
	{
	  format(t,"FizzBuzz");
	}
      else if(a%5==0)
	{
	  format(t,"Buzz");
	}
      else if(a%3==0)
	{
	  format(t,"Fizz");
	}
      else
	{
	  format(t,"~D",a);
	}
      terpri();
    }
}

if~else ifとネストできるが、{}は必須。パースした結果は以下のとおり。

(PROGN
  (DEFUN FIZZBUZZ (N)
    (BLOCK NIL
      (LOOP :WITH A = 1
	 :WHILE (<= A N)
	 :DO (IF (EQUAL (MOD A 15) 0) (PROGN (FORMAT T "FizzBuzz"))
		 (IF (EQUAL (MOD A 5) 0) (PROGN (FORMAT T "Buzz"))
		     (IF (EQUAL (MOD A 3) 0) (PROGN (FORMAT T "Fizz"))
			 (PROGN (FORMAT T "~D" A)))))
	 (TERPRI)
	 (PROG1 A
	   (INCF A))))))

スキルが無かろうと、ひたすら適当な文法をつづれば、一応動く。素晴らしい。