scheme@(guile-user)> ,L calc

Happy hacking with calc! To switch back, type `,L scheme'.

calc@(guile-user)> a = (2.5 + 4.5)/(9.3 - 1)

calc@(guile-user)> ,L scheme

Happy hacking with Scheme! To switch back, type `,L calc'.

scheme@(guile-user)> a

$1 = 0.8433734939759036

The implementation consists of the files spec.scm, parser.scm and compiler.scm which are listed below.

All files are:

;;;

;;; This program is free software: you can redistribute it and/or modify

;;; it under the terms of the GNU General Public License as published by

;;; the Free Software Foundation, either version 3 of the License, or

;;; (at your option) any later version.

and to appear at https://savannah.nongnu.org/projects/nyacc.

spec.scm:

(define-module (language calc spec)

#:export (calc)

#:use-module (system base language)

#:use-module (nyacc lang calc parser)

#:use-module (nyacc lang calc compiler))

(define (calc-reader port env)

(let ((iport (current-input-port)))

(dynamic-wind

(lambda () (set-current-input-port port))

(lambda () (calc-parse #:debug #f))

(lambda () (set-current-input-port iport)))))

(define-language calc

#:title "calc"

#:reader calc-reader

#:compilers `((tree-il . ,calc-sxml->tree-il))

#:printer write)

parser.scm:

(define-module (nyacc lang calc parser)

#:export (calc-parse calc-spec calc-mach)

#:use-module (nyacc lalr)

#:use-module (nyacc lex)

#:use-module (nyacc parse)

)

(define calc-spec

(lalr-spec

(prec< (left "+" "-") (left "*" "/"))

(start stmt-list-proxy)

(grammar

(stmt-list-proxy

(stmt-list "\n" ($$ (cons 'stmt-list (reverse $1)))))

(stmt-list

(stmt ($$ (list $1)))

(stmt-list ";" stmt ($$ (cons $3 $1))))

(stmt

(ident "=" expr ($$ `(assn-stmt ,$1 ,$3)))

(expr ($$ `(expr-stmt ,$1)))

( ($$ '(empty-stmt))))

(expr

(expr "+" expr ($$ `(add ,$1 ,$3)))

(expr "-" expr ($$ `(sub ,$1 ,$3)))

(expr "*" expr ($$ `(mul ,$1 ,$3)))

(expr "/" expr ($$ `(div ,$1 ,$3)))

('$fixed ($$ `(fixed ,$1)))

('$float ($$ `(float ,$1)))

("(" expr ")" ($$ $2)))

(ident ('$ident ($$ `(ident ,$1))))

)))

(define calc-mach

(compact-machine

(hashify-machine

(make-lalr-machine calc-spec))))

(define calc-parse

(let ((gen-lexer (make-lexer-generator (assq-ref calc-mach 'mtab)

#:space-chars " \t"))

(parser (make-lalr-ia-parser calc-mach)))

(lambda* (#:key (debug #f)) (parser (gen-lexer) #:debug debug))))

compiler.scm:

(define-module (nyacc lang calc compiler)

#:export (calc-sxml->tree-il)

#:use-module (sxml match)

#:use-module (sxml fold)

;;#:use-module (system base language)

#:use-module (language tree-il))

(define (fup tree)

(sxml-match tree

((fixed ,fx) `(const ,(string->number fx)))

((float ,fl) `(const ,(string->number fl)))

((ident ,id) `(toplevel ,(string->symbol id)))

((add ,lt ,rt) `(apply (toplevel +) ,lt ,rt))

((sub ,lt ,rt) `(apply (toplevel -) ,lt ,rt))

((mul ,lt ,rt) `(apply (toplevel *) ,lt ,rt))

((div ,lt ,rt) `(apply (toplevel /) ,lt ,rt))

((assn-stmt (toplevel ,lhs) ,rhs) `(define ,lhs ,rhs))

((empty-stmt) '(begin))

((stmt-list ,items ...) `(begin ,items ...))

(,otherwise tree)))

(define (calc-sxml->tree-il exp env opts)

(let* ((tree (foldt fup identity exp))

(code (parse-tree-il tree)))

(values code env env)))