parser-class

;;; Read

(define-class parser ()
  ; クラス変数の初期状態は 'introduction とする
  ((phase 'introduction))
  ; 入力メソッド
  (input () ;(flush-output) ; Racket 実装依存。コンパイル用
         ; Racket の実装のせいか、read をletrec 内で定義した
         ; 再帰内で呼び出すと異常な動作になる為、出力機構自体を
         ; ループで包まないとならない。同じコードを二度書くのが
         ; メンドいんで、ローカルマクロで出力用ループを定義した。
         (let-syntax ((return-values
                       (syntax-rules ()
                         ((_ phase proc0 (proc1))
                          (values phase (let loop ((i (proc1)))
                                          (let ((fact (proc0 i)))
                                            (if (null? fact)
                                                (loop (proc1))
                                                fact))))))))
           (letrec ((input-integer
                     ; 整数の入力しか受け付けない
                     ; 違反した場合は空リストを返す
                     (lambda (var)
                       (if (integer? var)
                           var
                           '())))
                    (yes-or-no?
                     ; yes no に類する入力しか受け付けない
                     ; 違反した場合は空リストを返す
                     (lambda (var)
                       (letrec ((y-or-n?
                                 ; yes に類する入力には #t を返す
                                 ; no に類する入力には #f を返す
                                 (lambda (sym)
                                   (and (memq sym '(Y YES)) #t)))
                                (symbol-upcase
                                 ; 入力されたシンボルを大文字に直す
                                 (lambda (arg)
                                   (if (symbol? arg)
                                       (string->symbol 
                                        (string-upcase 
                                         (symbol->string arg)))
                                       '()))))
                         (let ((sym (symbol-upcase var)))
                           (if (memq sym '(Y YES N NO))
                               (y-or-n? sym)
                               '()))))))
             (let ((p (get-class-var parser phase)))
               (case p
                 ((input-integer) 
                  (return-values p input-integer (read)))
                 ((instruction play-again?) 
                  (return-values p yes-or-no? (read)))
                 (else (values p #f))))))))

(define-method input)