archives/2005/09/14

Scheme/reverse-polish-notation-calculator

ひらいさんとのやりとりの後で、

うーん、いまいちエラー処理がかっこ悪いような気がします。
http://d.hatena.ne.jp/ha-tan/20050914/1126649914

が出た時点でお茶吹いた。

エラー処理がちょっとおさまり悪いですかねぇ。
ひらいさんのWiki:2005-09-08

え、え〜と……

これだけでは何なので、

せっかくだからutil.matchを使って書いてみた。かなり邪道っぽいコードになった。

せっかくだからreplに(pはしないけど)。

せっかくだから使える命令はforth風。

bye: 終了
d: forthの"."
s: forthの".s"
drop
dup
over
rot
swap
四則演算

入力例

2 3 4 + swap / d

とかすれ。

ソース

$ cat rpncalc.scm
#!/usr/bin/env gosh

(use util.match)
(use rfc.base64)
(use gauche.charconv)

(define global-stack '())

(define (rpcalc expr stack)
  (define (not-num? n)
    (not (number? n)))
  (if (null? expr)
      stack
      (let ((newstack (cons (car expr) stack)))
        (match newstack
               (('bye _ ...)
                (print "BYE!")
                (exit))
               (('d _ ...)
                (cond ((null? stack)
                       (print "no room")
                       '())
                      (else (display (car stack))(display " ")
                            (rpcalc (cdr expr) (cdr stack)))))
               (('s _ ...)
                (rpcalc-write stack)
                (rpcalc (cdr expr) stack))
               (('drop a b ...)
                (rpcalc (cdr expr) b))
               (('dup a b ...)
                (rpcalc (cdr expr) (cons a (cons a b))))
               (('over a b c ...)
                (rpcalc (cdr expr) (cons b (cons a (cons b c)))))
               (('rot a b c d ...)
                (rpcalc (cdr expr) (cons c (cons a (cons b d)))))
               (('swap a b c ...)
                (rpcalc (cdr expr) (cons b (cons a c))))
               (('+ a b c ...)
                (rpcalc (cdr expr) (cons (+ b a) c)))
               (('- a b c ...)
                (rpcalc (cdr expr) (cons (- b a) c)))
               (('* a b c ...)
                (rpcalc (cdr expr) (cons (* b a) c)))
               (('/ a b c ...)
                (rpcalc (cdr expr) (cons (/ b a) c)))
               (((? not-num? _) _)
                (print "no room")
                stack)
               (((? not-num? a) _ ...)
                (format #t "not number '~a'\n" a)
                stack)
               ((a ...)
                (rpcalc (cdr expr) newstack))))))

(define (rpcalc-read)
  (read-from-string (string-append "(" (read-line) ")")))

(define (rpcalc-write stack)
  (display (regexp-replace-all #/^[\(](.*)[\)]$/
                               (write-to-string (reverse stack)) "\\1 ")))

(define (rpcalc-eval expr env)
  (set! global-stack (rpcalc expr global-stack)))

(define (rpcalc-print ...)
  (print "ok"))

(define (rpcalc-prompt)
  #t)

(print (ces-convert
        (base64-decode-string
"GyRCPWs2bCQ3JCQ5UyRsJD8lVyVtJTAlaSVfJXMlMDhAOGwzJiRLOkYkUzVfQCQ8ZyQsISob
KEIKCiAKCiAbJEIhISEhISEbKEJ8GyRCITEbKEJ8fBskQiExGyhCfCAKIBskQiEhISEhMxso
QnwbKEklGyhCIBskQiJPGyhCIBsoSSUbKEJ8GyRCJU4hITNkJGwka0tAJSIlJCU5JEckOSRo
ITwbKEIgCiAbJEIhISEhISEbKEJ8GyRCITIbKEJ8fBskQiEyGyhCfCAKGyRCISEhISEhGyhC
ICAbJEIiQBsoQiAgGyRCIkAhISEhGyhCIA==")
        "utf-8"))

(read-eval-print-loop rpcalc-read rpcalc-eval rpcalc-print rpcalc-prompt)

Comments