summaryrefslogtreecommitdiff
path: root/module/language/lua/compile-tree-il.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/lua/compile-tree-il.scm')
-rw-r--r--module/language/lua/compile-tree-il.scm398
1 files changed, 398 insertions, 0 deletions
diff --git a/module/language/lua/compile-tree-il.scm b/module/language/lua/compile-tree-il.scm
new file mode 100644
index 000000000..9999797ac
--- /dev/null
+++ b/module/language/lua/compile-tree-il.scm
@@ -0,0 +1,398 @@
+;;; Guile Lua --- compiler
+
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language lua compile-tree-il)
+ #:use-module (language tree-il)
+ #:use-module ((srfi srfi-1) #:select (map!))
+ #:use-module (srfi srfi-39)
+ #:use-module ((system base syntax) #:select (record-case))
+ #:use-module (rnrs control)
+
+ #:use-module (language lua common)
+ #:use-module (language lua parser)
+ #:use-module (language lua runtime)
+
+ #:export (compile-tree-il))
+
+;; utilities
+
+(define *runtime-name* '(language lua runtime))
+(define no-arguments '(() #f #f #f () ()))
+
+
+(define (ref-runtime src name)
+ (make-module-ref src *runtime-name* name #t))
+
+(define (make-runtime-application src name arguments)
+ "Apply a function in the (language lua runtime) module"
+ (make-application src (ref-runtime src name) arguments))
+
+(define (make-lua-conditional src condition then else)
+ "Generate a conditional with (@ (language lua runtime) true?)"
+ (make-conditional src (make-runtime-application src 'true? (list condition)) then else))
+
+(define (make-table-ref src table index)
+ (make-runtime-application src 'index
+ (list table (if (symbol? index) (make-const src (symbol->string index)) index))))
+
+(define (make-table-set! src table index exp)
+ (make-runtime-application src 'new-index!
+ (list table (if (symbol? index) (make-const src (symbol->string index)) index) exp)))
+
+(define (apply-named-lua-function src name get-body)
+ (let* ((name (gensym (string-append " " name)))
+ (parameters (list name)))
+ (make-application
+ src
+ (make-module-ref src '(guile) 'catch #t)
+ (list
+ (make-const src 'lua-break)
+ (make-argless-lambda src
+ (make-let
+ src
+ parameters parameters
+ (list (make-lambda src '() (get-body name)))
+ (make-application src (make-lexical-ref src name name) '())))
+ (make-arg-ignoring-lambda src
+ (make-void src))))))
+
+(define (while-loop->tree-il src condition body)
+ "Create a WHILE loop, used by both WHILE and REPEAT."
+ (apply-named-lua-function
+ src "while"
+ (lambda (loop)
+ (make-lua-conditional
+ src
+ condition
+ (make-sequence src
+ (list body (make-application src (make-lexical-ref src loop loop) '())))
+ (make-void src)))))
+
+;; calling conventions
+(define (make-plain-lambda-case src args gensyms body . alternate)
+ (make-lambda-case src args #f #f #f '() (or gensyms args) body (and (not (null? alternate)) (car alternate))))
+
+(define (make-plain-lambda src args gensyms body . alternate)
+ (make-lambda src '() (apply make-plain-lambda-case (append (list src args gensyms body) alternate))))
+
+(define (make-arg-ignoring-lambda src body)
+ (make-lambda src '() (make-lambda-case src '() #f '_ #f '() (list (gensym "_")) body #f)))
+
+(define (make-argless-lambda src body)
+ (make-plain-lambda src '() #f body))
+
+(define (adjust-to-single-value src exp)
+ "adjust an expression so that it only returns one result; the rest are dropped silently"
+ (define value-gensym (gensym "%value"))
+ (define adjust-gensym (gensym "%adjust"))
+ (make-letrec src
+ #t
+ '(%adjust)
+ (list adjust-gensym)
+ (list
+ (make-plain-lambda
+ src
+ '(%value)
+ (list value-gensym)
+ (make-lexical-ref src '%value value-gensym)))
+ (make-application
+ src
+ (make-primitive-ref src 'call-with-values)
+ (list (make-argless-lambda src exp) (make-lexical-ref src '%adjust adjust-gensym)))))
+
+;; main compiler
+
+(define context (make-parameter #f))
+
+(define* (compile exp #:optional last-in-list?)
+ (define* (map-compile exps #:optional care-about-last?)
+ (let lp ((ls exps)
+ (tree '()))
+ (if (null? ls)
+ (reverse! tree)
+ (lp (cdr ls) (cons (compile (car ls) (and care-about-last? (null? (cdr ls)))) tree)))))
+
+ (record-case exp
+ ((ast-sequence src exps)
+ (if (null? exps)
+ (make-void src)
+ (make-sequence src (map-compile exps))))
+
+ ((ast-literal src exp)
+ (if (eq? exp *unspecified*)
+ (make-void src)
+ (make-const src exp)))
+
+ ((ast-return src exp)
+ (make-application src (make-primitive-ref src 'return)
+ (list (make-application src
+ (make-primitive-ref src 'values)
+ (if (list? exp) (map-compile exp #t) (list (compile exp)))))))
+
+ ((ast-function src name arguments argument-gensyms variable-arguments? body)
+ ;; ... is always attached because lua functions must ignore
+ ;; variable arguments; the parser will catch it if ... is used in a
+ ;; function that doesn't have ... in the parameter list
+ (make-lambda src (if name `((name . ,name)) '()) (make-lambda-case src '() arguments '... #f (map (lambda (x) (make-const src #nil)) arguments) (append! argument-gensyms (list '...)) (compile body) #f)))
+
+ ((ast-function-call src operator operands)
+ #| (let* ((proc (compile operator))
+ (args (make-application src (make-primitive-ref src 'list) (map-compile operands)))
+ (app-args (make-application src (make-primitive-ref src 'list) (list proc args)))
+ (app (make-application src (make-primitive-ref src 'apply) (list (make-primitive-ref src 'apply) app-args)))) |#
+ (let* ((proc (compile operator))
+ (app (make-application src proc (map-compile operands))))
+ (if (ast-global-ref? operator)
+ (make-sequence src (list
+ (make-application src (make-module-ref src '(language lua runtime) 'check-global-function #t)
+ (list (make-const src (ast-global-ref-name operator))
+ proc))
+ app))
+ app)))
+
+ ((ast-local-block src names gensyms initial-values exp)
+ (make-let src names gensyms (map-compile initial-values) (compile exp)))
+
+ ((ast-local-ref src name gensym)
+ (make-lexical-ref src name gensym))
+
+ ((ast-local-set src name gensym exp)
+ (make-lexical-set src name gensym (compile exp)))
+
+ ((ast-global-ref src name)
+ (make-table-ref src (ref-runtime src '*global-env-table*) name))
+
+ ((ast-global-set src name exp)
+ (make-table-set! src (ref-runtime src '*global-env-table*) name (compile exp)))
+
+ ((ast-table-ref src table key)
+ (make-table-ref src (compile table) (compile key)))
+
+ ((ast-table-set src table key exp)
+ (make-table-set! src (compile table) (compile key) (compile exp)))
+
+ ((ast-condition src test then else)
+ (make-conditional src (compile test) (compile then) (compile else)))
+
+ ((ast-while-loop src condition body)
+ (parameterize
+ ((context 'while-loop))
+ (while-loop->tree-il src (compile condition) (compile body))))
+
+ ;; TODO: in order for this to have the same semantics as lua, all
+ ;; potential subforms of while should introduce their own context,
+ ;; so you can't use break inside of a function inside a while loop
+ ;; for instance
+ ((ast-break src)
+ (unless (or-eqv? (context) 'while-loop 'list-for-loop 'numeric-for-loop)
+ (syntax-error src "no loop to break"))
+ (make-application src (make-module-ref src '(guile) 'throw #t) (list (make-const src 'lua-break)))
+ )
+
+ ((ast-list-for-loop src names gs-names exps body)
+ (let* ((gs-iterator (gensym "iterator"))
+ (gs-state (gensym "state"))
+ (gs-variable (gensym "variable"))
+ (gs-iterator2 (gensym "iterator"))
+ (gs-state2 (gensym "state"))
+ (gs-variable2 (gensym "variable"))
+ (gs-loop (gensym "loop")))
+ (parse-tree-il
+ `(letrec*
+ ;; names
+ (iterator state variable loop)
+ ;; gensyms
+ (,gs-iterator ,gs-state ,gs-variable ,gs-loop)
+ ;; vals
+ ((void) (void) (void)
+ (lambda ()
+ (lambda-case
+ (,no-arguments
+ (begin
+ ;; even more complicated, assigning the values to the loop variables
+ (apply (primitive call-with-values)
+ (lambda () (lambda-case (,no-arguments (apply (lexical iterator ,gs-iterator) (lexical state ,gs-state) (lexical variable ,gs-variable)))))
+ (lambda () (lambda-case ((,names #f #f #f () ,gs-names)
+ ;; almost to the actual loop body, hang in there
+ (begin
+ (set! (lexical variable ,gs-variable) (lexical ,(car names) ,(car gs-names)))
+ (if (apply (primitive eq?) (lexical variable ,gs-variable) (const #nil))
+ (apply (@ (guile) throw) (const lua-break))
+ (void))
+ ,(parameterize ((context 'list-for-loop)) (unparse-tree-il (compile body)))
+ (apply (lexical loop ,gs-loop))))))))))))
+ ;; initialize variables and start loop
+ (begin
+ (apply (primitive call-with-values)
+ (lambda () (lambda-case (,no-arguments ,(unparse-tree-il (make-sequence src (map-compile exps))))))
+ (lambda () (lambda-case (((iterator state variable) #f #f #f () (,gs-iterator2 ,gs-state2 ,gs-variable2))
+ (begin
+ (set! (lexical iterator ,gs-iterator) (lexical iterator ,gs-iterator2))
+ (set! (lexical state ,gs-state) (lexical state ,gs-state2))
+ (set! (lexical variable ,gs-variable) (lexical variable ,gs-variable2)))))))
+ (apply (@ (guile) catch)
+ (const lua-break)
+ (lambda () (lambda-case (,no-arguments
+ (apply (lexical loop ,gs-loop)))))
+ (lambda () (lambda-case (((key) #f #f #f () (,(gensym "key"))) (void))))))))))
+
+ ;; TODO: in order for this to have the same semantics as lua, all
+ ;; potential subforms of while should introduce their own context,
+ ;; so you can't use break inside of a function inside a while loop
+ ;; for instance
+
+ ((ast-numeric-for-loop src named initial limit step body)
+ ;; as per 5.1 manual 2.4.5, the numeric for loop can be decomposed into simpler forms
+ ;; still doesn't have proper behavior, should be able to return and break inside a loop
+ (let* ((gs-named (gensym (symbol->string named)))
+ (gs-variable (gensym "variable"))
+ (gs-limit (gensym "limit"))
+ (gs-step (gensym "step"))
+ (gs-loop (gensym "loop"))
+ (while-condition
+ `(if (apply (primitive >) (lexical step ,gs-step) (const 0))
+ (if (apply (primitive <=) (lexical variable ,gs-variable) (lexical limit ,gs-limit))
+ (apply (lexical loop ,gs-loop))
+ (void))
+ (void))))
+ (parse-tree-il
+ `(letrec*
+ ;; names
+ (,named variable limit step loop)
+ ;; gensyms
+ (,gs-named ,gs-variable ,gs-limit ,gs-step ,gs-loop)
+ ;; vals
+ ,(cons
+ '(const #f)
+ (append
+ (map (lambda (x) `(apply (@ (language lua runtime) tonumber) ,(unparse-tree-il (compile x)))) (list initial limit step))
+ ;; loop body
+ (list
+ `(lambda ()
+ (lambda-case
+ ;; no arguments
+ ((() #f #f #f () ())
+ ;; body
+ (begin
+ (set! (lexical ,named ,gs-named) (lexical variable ,gs-variable))
+ ,(parameterize ((context 'numeric-for-loop)) (unparse-tree-il (compile body)))
+ (set! (lexical variable ,gs-variable) (apply (primitive +) (lexical variable ,gs-variable) (lexical step ,gs-step)))
+ ,while-condition
+ )))))))
+ ;; body
+ (begin
+ ;; if not (var and limit and step) then error() end
+ (if (apply (primitive not)
+ (if (apply (@ (language lua runtime) true?) (lexical variable ,gs-variable))
+ (if (apply (@ (language lua runtime) true?) (lexical limit ,gs-limit))
+ (if (apply (@ (language lua runtime) true?) (lexical step ,gs-step))
+ (const #t)
+ (const #f))
+ (const #f))
+ (const #f)))
+ (apply (@ (guile) error))
+ (void))
+ ,while-condition
+ )))))
+
+ ((ast-table-literal src fields)
+ (let* ((table (make-runtime-application src 'make-table '())))
+ (if (not (null? fields))
+ ;; if the table's fields are initialized inside of the literal, we need
+ ;; to store it in a variable and initialize its values
+ (let* ((temp-name (gensym " table"))
+ (names (list temp-name))
+ (ref (make-lexical-ref src temp-name temp-name)))
+ (make-let
+ src
+ names names
+ (list table)
+ (make-sequence
+ src
+ (append!
+ (map
+ (lambda (x)
+ (let* ((key (compile (car x)))
+ (value (compile (cdr x))))
+ (make-runtime-application src 'new-index! (list (make-lexical-ref src temp-name temp-name) key value))))
+ fields)
+ (list ref)))))
+ ;; otherwise we can just return the fresh table
+ table)))
+
+ ((ast-unary-operation src operator right)
+ ;; reduce simple negative numbers, like -5, to literals
+ (if (and (eq? operator #\-) (ast-literal? right) (number? (ast-literal-exp right)))
+ (make-const src (- (ast-literal-exp right)))
+ (make-application
+ src
+ (case operator
+ ((#\-) (ref-runtime src 'unm))
+ ((#\#) (ref-runtime src 'len))
+ ((not) (make-primitive-ref src 'not)))
+ (list (compile right)))))
+
+ ((ast-binary-operation src operator left right)
+ (let ((left (compile left))
+ (right (compile right)))
+ (case operator
+ ((#\+ #\- #\* #\/ #\^ #\< #\> #:<= #:>= #:== #:~= #:concat)
+ (let* ((result
+ (make-runtime-application
+ src
+ (case operator
+ ((#\+) 'add)
+ ((#\-) 'sub)
+ ((#\*) 'mul)
+ ((#\/) 'div)
+ ((#\^) 'pow)
+ ((#\<) 'lt)
+ ((#\>) 'lt)
+ ((#:<=) 'le)
+ ((#:>=) 'le)
+ ((#:==) 'eq)
+ ((#:~=) 'neq)
+ ((#:concat) 'concat)
+ (else (error #:COMPILE "unhandled binary operator" operator)))
+ ;; reverse order of arguments for >, >= so they can be implemented on top of <, <=
+ (if (or (eq? operator #\>) (eq? operator #:>=))
+ (list right left)
+ (list left right)))))
+ result))
+ ((#:or)
+ (make-lua-conditional
+ src
+ left
+ left
+ right))
+ ((#:and)
+ (make-lua-conditional
+ src
+ left
+ right
+ left))
+ (else (error #:COMPILE "unknown binary operator" operator)))))
+ ))
+
+;; exported compiler function
+(define (compile-tree-il exp env opts)
+ (parameterize
+ ((context #f))
+ (values (compile exp) env env)))