compiler.rkt

#lang nanopass
(require (prefix-in racket: mzlib/match) ; to get the short match syntax
         (for-syntax nanopass/base))

;;;
;;; Core Scheme to JavaScript
;;;

;; This compiler compiles a program in CoreScheme (CS)
;; via the Admistrative Normal Form of CoreScheme (ACS)
;; into JavaScript.

;; The compiler uses the Racket version of the Nanopass 
;; framework for writing compilers with many small passes.

;;;
;;; CoreScheme (CS)
;;; 

;; The terms M and values V of CoreScheme are given by:

;;    M ::= V                    ; V in Values
;;       |  (let (x M1) M2)      
;;       |  (if0 M1 M2 M3)
;;       |  (M M1 ...)
;;       |  (O M1 ...)           ; O in PrimitiveOperations

;;    V ::= c                    ; c in Constants
;;       |  x                    ; x in Variables
;;       |  (λ (x1 ...) M)       

;; Note: In (λ (x1 ...) M) the xi are mutually distinct
;;       and are bound in M.
;;       In (let (x M1) M2) the x is bound in M2.

;;;
;;; Terminals: Primitives, Constants, and, Variables
;;;

;; The representation of terminals are determined here.
;; In this simple compiler symbols are used to represent
;; identifiers (a better representation would use syntax 
;; objects).

(define primitives '(+ - * /))

(define (Primitive? v)
  (and (memq v primitives) #t))

(define (Constant? v)
  (or (number? v)
      (boolean? v)))

(define (Variable? v)
  (and (symbol? v)
       (not (Primitive? v))))

;;;
;;; CoreScheme CS
;;;

;; Now we are ready to define the language.

(define-language LCS
  (entry Term)           ; a full program is a term
  (terminals
   (Variable  (x))
   (Primitive (O))
   (Constant  (c)))
  ; Non-terminals : Value and Term
  (Value (V)
    c                     ; constant
    x                     ; variable reference
    (λ (x1 ...) M))       ; abstraction
  (Term (M)
    V                     ; return
    (let (x M1) M2)       ; bind
    (if0 M1 M2 M3)        ; branch
    (O M1 ...)            ; application of primitive operation
    (call M M1 ...) =>    ; application
    (M M1 ...)))          ; (unparse applications without the call prefix)

;; The (define-language LCS ...) automatically defines
;; a number of structures representing a program in LCS.

;;;
;;; PARSE (convert S-expression into nanopass structures)
;;;

;; In order to get a value representing an LCS program,
;; we need to convert a program represented as an S-expression
;; into the Nanopass structures.

;; parse is written as a pass from e with type * (i.e. anything) into an LCS-struct.
(define-pass parse : * (S-exp) -> LCS ()
  (definitions 
    (define (Term* Ms) (map Term Ms)))
  ; Term : s-expression -> LCS:Term-struct
  (Value : * (V) -> Value ()
    (with-output-language (LCS Value)
      ;(displayln (list 'parse-Value V))
      (racket:match V
        [(? Constant?  c)     `,c]
        [(? Variable?  x)     `,x]
        [('λ (x1 ...) M)      `(λ (,x1 ...) ,(Term M))]
        [_ (error 'parse-Value "got: ~a" V)])))
  (Term : * (M) -> Term ()
    (with-output-language (LCS Term) ; rebinds quasiquote to construct Lsrc records
      ;(displayln (list 'parse-Term M))
      (racket:match M                 ; (match is bound to a special nanopass pattern matcher)
        [(? Constant? V)           `,(Value V)]
        [(? Variable? V)           `,(Value V)]
        [('λ (x1 ...) M1)          `,(Value M)]
        [('let (x M1) M2)          `(let (,x ,(Term M1)) ,(Term M2))]
        [('if0 M1 M2 M3)           `(if0 ,(Term M1) ,(Term M2) ,(Term M3))]
        [((? Primitive? O) M1 ...) `(,O ,(Term* M1) ...)]
        [(M M1 ...)                `(call ,(Term M) ,(Term* M1) ...)]
        [_ (error 'parse-Term "got: ~a" M)])))
  ; start parsing
  (Term S-exp))

;; The (define-language LCS ...) defines an unparser unpase-LCS
;; from LCS structures to S-expression, which we can use to
;; test our parser.

(module+ test (require rackunit)
  (check-equal? (unparse-LCS (parse '3))                       '3)
  (check-equal? (unparse-LCS (parse '(if0 1 2 3)))             '(if0 1 2 3))
  (check-equal? (unparse-LCS (parse '(+ 1 2)))                 '(+ 1 2))
  (check-equal? (unparse-LCS (parse '(+ 1 2 3)))               '(+ 1 2 3))
  (check-equal? (unparse-LCS (parse '(let (x 1) x)))           '(let (x 1) x))
  (check-equal? (unparse-LCS (parse '((λ (x y) (+ x y) 1 2)))) '((λ (x y) (+ x y) 1 2))))

;;; Examples

(parse '((λ (x) x) 4))  

(let ([M (parse '((λ (x) x) 4))])
    (nanopass-case (LCS Term) M
      [(call ,M ,M1 ...) (list 'call M M1)]
      [else  'huh]))

(parse '(let (y 5) 6))

;; Uncomment this last example to see the error

#;(let ([M (parse '(let (y 5) 6))])
    (nanopass-case (LCS Term) M
      [(let (,x ,M) ,M1 ...) (list M M1)]
      [else  'huh]))