ikarus/lab/lalr-example-calc.scm

204 lines
4.7 KiB
Scheme
Raw Normal View History

;;;
;;;; Simple calculator in Scheme
;;;
;;
;; @created "Tue Jan 6 12:47:23 2004"
;; @modified "Mon Oct 25 11:07:24 2004"
;; @author "Dominique Boucher"
;; @copyright "Dominique Boucher"
;;
;; 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.
;;;
;;;; The LALR(1) parser
;;;
(import (rnrs) (rnrs mutable-pairs) (lalr))
(define calc-parser
(lalr-parser
;; --- Options
;; output a parser, called calc-parser, in a separate file - calc.yy.scm,
;(output: calc-parser "calc.yy.scm")
;; output the LALR table to calc.out
;(out-table: "calc.out")
;; there should be no conflict
(expect: 0)
;; --- token definitions
(ID NUM = LPAREN RPAREN NEWLINE COMMA
(left: + -)
(left: * /)
(nonassoc: uminus))
(lines (lines line) : (display-result $2)
(line) : (display-result $1))
;; --- rules
(line (assign NEWLINE) : $1
(expr NEWLINE) : $1
(error NEWLINE) : #f)
(assign (ID = expr) : (add-binding $1 $3))
(expr (expr + expr) : (+ $1 $3)
(expr - expr) : (- $1 $3)
(expr * expr) : (* $1 $3)
(expr / expr) : (/ $1 $3)
(- expr (prec: uminus)) : (- $2)
(ID) : (get-binding $1)
(ID LPAREN args RPAREN) : (invoke-proc $1 $3)
(NUM) : $1
(LPAREN expr RPAREN) : $2)
(args () : '()
(expr arg-rest) : (cons $1 $2))
(arg-rest (COMMA expr arg-rest) : (cons $2 $3)
() : '())))
(define (display-result v)
(if v
(begin
(display "==> ")
(display v)
(newline))))
;;;
;;;; The lexer
;;;
(define (make-lexer errorp)
(lambda ()
(letrec ((skip-spaces
(lambda ()
(let loop ((c (peek-char)))
(if (and (not (eof-object? c))
(or (char=? c #\space) (char=? c #\tab)))
(begin
(read-char)
(loop (peek-char)))))))
(read-number
(lambda (l)
(let ((c (peek-char)))
(if (char-numeric? c)
(read-number (cons (read-char) l))
(string->number (apply string (reverse l)))))))
(read-id
(lambda (l)
(let ((c (peek-char)))
(if (char-alphabetic? c)
(read-id (cons (read-char) l))
(string->symbol (apply string (reverse l))))))))
;; -- skip spaces
(skip-spaces)
;; -- read the next token
(let loop ((c (read-char)))
(cond
((eof-object? c) '*eoi*)
((char=? c #\newline) 'NEWLINE)
((char=? c #\+) '+)
((char=? c #\-) '-)
((char=? c #\*) '*)
((char=? c #\/) '/)
((char=? c #\=) '=)
((char=? c #\,) 'COMMA)
((char=? c #\() 'LPAREN)
((char=? c #\)) 'RPAREN)
((char-numeric? c) (cons 'NUM (read-number (list c))))
((char-alphabetic? c) (cons 'ID (read-id (list c))))
(else
(errorp "PARSE ERROR : illegal character: " c)
(skip-spaces)
(loop (read-char))))))))
(define (read-line)
(let loop ((c (read-char)))
(if (and (not (eof-object? c))
(not (char=? c #\newline)))
(loop (read-char)))))
;;;
;;;; 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 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 k)
(letrec ((errorp
(lambda args
(for-each display args) (newline)))
(start
(lambda ()
(calc-parser (make-lexer errorp) errorp))))
(start))))))
(calc)