[MIT Scheme] Calculator

프로그래밍 언어 / 2003년 1학기 / 한상영 교수님

[입력파일 예시]
A := B + C
B := 3
C := 5
PRINT D
PRINT A
B := 8
PRINT A
RESET
PRINT A

[calculator.scm]
(define inport (open-input-file "calculator.in"))
(define outport (open-output-file "calculator.out"))

(define a ''undef) (define a-rec 0)
(define b ''undef) (define b-rec 0)
(define c ''undef) (define c-rec 0)
(define d ''undef) (define d-rec 0)
(define e ''undef) (define e-rec 0)
(define env (the-environment))

(define adjust (lambda (x)
       (let ((next (read x)))
               (if (eof-object? next) '()
                       (if (list? next) (cons next (adjust x))
                               (if (eqv? next '+) (cons '+ (adjust x))
                                       (if (eqv? next '-) (cons '- (adjust x))
                                               (if (eqv? next '*) (cons '* (adjust x))
                                                       (cons next (adjust x))))))))))

(define zzun-eval (lambda (x)
       (if (list? x)
               (if (> (length x) 4)
                       (if (eqv? (fourth x) '*)
                               (zzun-eval (cons (first x) (cons (second x) (cons (list (third x) (fourth x) (fifth x)) (list-tail x 5)))))
                               (zzun-eval (cons (zzun-eval (list-head x 3)) (list-tail x 3))))
                       (if (= (length x) 4)
                               (zzun-eval (list (first x) (second x) (list (third x) (fourth x))))
                               (if (= (length x) 3)
                                       (let
                                               ((fff (zzun-eval (first x))) (ttt (zzun-eval (third x))))
                                               (if (or (eqv? fff 'undef) (eqv? ttt 'undef))
                                                       'undef
                                                       (apply (eval (second x) ()) (list fff ttt))))
                                       (if (= (length x) 2)
                                               (eval x env)
                                               (if (= (length x) 1)
                                                       (zzun-eval (first x)))))))
               (if (symbol? x)
                       (if        (or
                                       (and (eqv? x 'a) (= a-rec 1))
                                       (and (eqv? x 'b) (= b-rec 1))
                                       (and (eqv? x 'c) (= c-rec 1))
                                       (and (eqv? x 'd) (= d-rec 1))
                                       (and (eqv? x 'e) (= e-rec 1))
                               ) 'undef
                               (begin        
                                       (if (eqv? x 'a)
                                               (set! a-rec 1)
                                               (if (eqv? x 'b)
                                                       (set! b-rec 1)
                                                       (if (eqv? x 'c)
                                                               (set! c-rec 1)
                                                               (if (eqv? x 'd)
                                                                       (set! d-rec 1)
                                                                       (if (eqv? e 'a)
                                                                               (set! e-rec 1))))))
                                       (zzun-eval (eval x env))))                                
                       x))))

(let loop ((cur-token (read inport)))
       (if (eof-object? cur-token) #f
               (begin
                       (if (eqv? cur-token 'PRINT)
                               (begin
                                       (display (zzun-eval (read inport)) outport)
                                       (set! a-rec 0) (set! b-rec 0) (set! c-rec 0) (set! d-rec 0) (set! e-rec 0)
                                       (display #\newline outport)))
                       (if (eqv? cur-token 'RESET)
                               (begin
                                       (set! a ''undef)
                                       (set! b ''undef)
                                       (set! c ''undef)
                                       (set! d ''undef)
                                       (set! e ''undef)))
                       (if (eqv? cur-token 'a)
                               (if (eqv? ':= (read inport))
                                       (begin
                                               (read-char inport)
                                               (set! a (adjust (string->input-port (read-line inport)))))))
                       (if (eqv? cur-token 'b)
                               (if (eqv? ':= (read inport))
                                       (begin
                                               (read-char inport)
                                               (set! b (adjust (string->input-port (read-line inport)))))))
                       (if (eqv? cur-token 'c)
                               (if (eqv? ':= (read inport))
                                       (begin
                                               (read-char inport)
                                               (set! c (adjust (string->input-port (read-line inport)))))))
                       (if (eqv? cur-token 'd)
                               (if (eqv? ':= (read inport))
                                       (begin
                                               (read-char inport)
                                               (set! d (adjust (string->input-port (read-line inport)))))))
                       (if (eqv? cur-token 'e)
                               (if (eqv? ':= (read inport))
                                       (begin
                                               (read-char inport)
                                               (set! e (adjust (string->input-port (read-line inport)))))))
                       (loop (read inport)))))

(close-output-port outport)
(close-input-port inport)