;;;
;;;; Simple calculator in Scheme
;;;
;; Simple arithmetic calculator. 
;; 
;;   This program illustrates the use of the lalr-scm parser generator
;; for Scheme. It is NOT robust, since calling a function with 
;; the wrong number of arguments may generate an error that will
;; cause the calculator to crash.


(import (chicken port) (chicken format) lalr-driver)

(define-syntax tok
  (syntax-rules ()
    ((tok loc t) (make-lexical-token (quasiquote t) loc #f))
    ((tok loc t l) (make-lexical-token (quasiquote t) loc l))))

;; parser
(include "calc.yy.scm")
;; lexer
(include "calc.l.scm")


(define (force-output) #f)
(define lexer-error error)

;;;
;;;;   Environment management
;;;


(define *env* (list (cons '$$ 0)))


(define (init-bindings)
  (set-cdr! *env* '())
  (add-binding 'cos cos)
  (add-binding 'sin sin)
  (add-binding 'tan tan)
  (add-binding 'expt expt)
  (add-binding 'sqrt sqrt))


(define (add-binding var val)
  (set! *env* (cons (cons var val) *env*))
  val)


(define (get-binding var)
  (let ((p (assq var *env*)))
    (if p
        (cdr p)
        0)))


(define (invoke-proc proc-name args)
  (let ((proc (get-binding proc-name)))
    (if (procedure? proc)
        (apply proc args)
        (begin
          (display "ERROR: invalid procedure:")
          (display proc-name)
          (newline)
          0))))


;;;
;;;;   The main program
;;;


(define (display-result v)
  (if v
      (begin
        (display v)
        (newline)))
  (display-prompt))


(define (display-prompt)
  (display "[calculator]> ")
  (force-output))

(define calc
  (lambda ()
    (call-with-current-continuation
     (lambda (k)
       (display "********************************") (newline)
       (display "*  Mini calculator in Scheme   *") (newline)
       (display "*                              *") (newline)
       (display "* Enter expressions followed   *") (newline)
       (display "* by [RETURN] or 'quit()' to   *") (newline)
       (display "* exit.                        *") (newline)
       (display "********************************") (newline)
       (init-bindings)
       (add-binding 'quit (lambda () (k #t)))
       (letrec ((errorp
                 (lambda (message . args)
                   (display message)
                   (if (and (pair? args) 
                            (lexical-token? (car args)))
                       (let ((token (car args)))
                         (display (or (lexical-token-value token)
                                      (lexical-token-category token)))
                         (let ((source (lexical-token-source token)))
                           (if (source-location? source)
                               (let ((line (source-location-line source))   
				     (column (source-location-column source)))
				 (if (and (number? line) (number? column))
				     (begin
				       (display " (at line ")
				       (display line)
				       (display ", column ")
				       (display (+ 1 column))
				       (display ")")))))))
                       (for-each display args))
                   (newline)))
                (start
                 (lambda ()
                   (lexer-init 'port (current-input-port))
                   (calc-parser lexer errorp))))
	 (display-prompt)
         (start))))))

(calc)