Re: Q on (language <lang> spec)

[Matt Wette <matthew.wette@verizon.net>]

[-- Attachment #1: Type: text/plain, Size: 4039 bytes --]


> On Oct 17, 2015, at 12:02 PM, Matt Wette <matthew.wette@verizon.net> wrote:
> I am playing with the compiler tower and have been digging through the (system base language) module to try to get my hands around writing to the compiler tower.  .

Here is a simple calculator example that I have working with my own intermediate (SXML based) language. 

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:

;;; Copyright (C) 2015 Matthew R. Wette
;;;
;;; 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 <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)))


[-- Attachment #2: Type: text/html, Size: 14131 bytes --]