add lua language implementation

What is missing:

+ Functions: module, getfenv, setfenv, math.modf, table.sort

+ Parser: needs to be more flexible

+ Compiler: needs more extensive work to properly handle all possible
cases of variable arguments, multiple returns, and loops

+ Language: Variable arguments and unpacking of multiple returns. (For
example we need to be able to handle something as complex as
print(unpack({...})), which is easy with Lua's explicit stack but will
require lots of tree-il gymnastics, or perhaps modifications to better
allow different calling conventions. (For instance -- how would we
support Python or Ruby, where keyword arguments are gathered into a
hashtable and passed as a single argument?)

What is there:

A fair shot at supporting Lua 5.1, not quite a drop-in replacement, but
not far from that goal either.

module/Makefile.am

@@ -71,6 +71,7 @@ SOURCES =					\
   $(SCRIPTS_SOURCES)				\
   $(ECMASCRIPT_LANG_SOURCES)			\
   $(ELISP_LANG_SOURCES)				\
+  $(LUA_LANG_SOURCES)				\
   $(BRAINFUCK_LANG_SOURCES)			\
   $(LIB_SOURCES)				\
   $(WEB_SOURCES)
@@ -175,6 +176,18 @@ ELISP_LANG_SOURCES =				\
   language/elisp/runtime/value-slot.scm		\
   language/elisp/spec.scm
 
+LUA_LANG_SOURCES =				\
+  language/lua/common.scm			\
+  language/lua/runtime.scm			\
+  language/lua/lexer.scm			\
+  language/lua/parser.scm			\
+  language/lua/compile-tree-il.scm		\
+  language/lua/standard/io.scm			\
+  language/lua/standard/math.scm		\
+  language/lua/standard/os.scm			\
+  language/lua/standard/table.scm		\
+  language/lua/spec.scm
+
 BRAINFUCK_LANG_SOURCES =			\
   language/brainfuck/parse.scm			\
   language/brainfuck/compile-scheme.scm		\

module/language/lua/common.scm

@@ -0,0 +1,50 @@
+;;; Guile Lua --- common lua functionality
+
+;;; 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 common)
+
+  #:use-module (ice-9 format)
+
+  #:export (syntax-error or-eqv?))
+
+(define (syntax-error src string . arguments)
+  "Throw an error tagged with 'lua-syntax, and print detailed source
+code information when available. STRING and ARGUMENTS are given to FORMAT."
+  (throw 'lua-syntax
+         (string-append
+          (if src
+              (format #f "~a@~a.~a"
+                      (cdr (assq 'filename src))
+                      (cdr (assq 'line src))
+                      (if (assq 'column src)
+                          (cdr (assq 'column src))
+                          "[no column available]"))
+              "[no source code information given]")
+          ": "
+          (apply format (cons string arguments)))))
+
+;; I was using CASE, but this is more succinct
+;; (or-eqv? 1 #f 1) => (or (eqv? 1 #f) (eqv? 1 1))
+(define-syntax or-eqv?
+  (syntax-rules ()
+    ((_ test '(value ...))
+     (or (eqv? test 'value) ...))
+    ((_ test value ...)
+     (or (eqv? test value) ...))))

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)))

module/language/lua/lexer.scm

@@ -0,0 +1,335 @@
+;;; Guile Lua --- tokenizer
+
+;;; 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:
+
+;; This is a simple lexer. It generally matches up Lua data types with
+;; Scheme. Reserved words in Lua, like 'not', are returned as keywords,
+;; like '#:not'. Operators are returned as keywords like #:==, or
+;; characters like #\+ when they're only a character long. Identifiers
+;; are returned as symbols
+(define-module (language lua lexer)
+
+  #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-14)
+  #:use-module (srfi srfi-39)
+
+  #:use-module (language lua common)
+
+  #:export (make-lexer)
+  #:export-syntax (define-lua-lexer initialize-lua-lexer!))
+
+(define stdout (current-output-port))
+
+(define (source-info port)
+  `((backtrace . #f)
+    (filename . ,(port-filename port))
+    (line . ,(port-line port))
+    (column . ,(port-column port))))
+
+;; Character predicates
+
+;; Lua only accepts ASCII characters as of 5.2, so we define our own
+;; charsets here
+(define (char-predicate string)
+  (define char-set (string->char-set string))
+  (lambda (c)
+    (and (not (eof-object? c)) (char-set-contains? char-set c))))
+
+(define is-digit? (char-predicate "0123456789"))
+(define is-name-first? (char-predicate "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"))
+(define (is-name? c) (or (is-name-first? c) (is-digit? c)))
+(define (is-newline? c) (and (char? c) (or (char=? c #\newline) (char=? c #\cr))))
+
+(define (possible-keyword token)
+  "Convert a symbol to a keyword if it is a reserved word in Lua"
+  (if (or-eqv? token '(return function end if then elseif else true false nil or and do while repeat until local for break in not))
+      (symbol->keyword token)
+      token))
+
+(define (make-lexer port)
+  ;; Buffer management
+  (define buffer (open-output-string))
+
+  (define (drop-buffer)
+    "Clear the buffer and drop the contents"
+    (truncate-file buffer 0))
+
+  (define (clear-buffer)
+    "Clear the buffer and return a string of the contents"
+    (define string (get-output-string buffer))
+    (drop-buffer)
+    string)
+
+  ;; Source code information
+  (define saved-source-info #f)
+
+  (define (save-source-info)
+    "Save source code information for a particular location e.g. the beginning
+of an identifier"
+    (set! saved-source-info (source-info port)))
+
+  (define (get-source-info)
+    "Get source code information"
+    (if saved-source-info
+        saved-source-info
+        (source-info port)))
+
+  (define (save-and-next!)
+    "Shorthand for (write-char (read-char))"
+    (write-char (read-char)))
+
+  (define (eat-comment)
+    "Consume a comment"
+    (let consume ((c (read-char)))
+      (cond ((eof-object? c) #f)
+            ((eq? c #\newline) #f)
+            (else (consume (read-char))))))
+
+  (define (get-long-string-nesting-level)
+    "Return the nesting level of a bracketed string, or -1 if it is not one"
+    (define delimiter (read-char))
+    (let* ((count
+            (let loop ((count 0))
+              (if (eq? (peek-char) #\=)
+                  (begin
+                    (read-char)
+                    (loop (+ count 1)))
+                  count))))
+      (if (eq? (peek-char) delimiter) count -1)))
+
+  (define (read-long-string string? nest)
+    "Read a long string or comment"
+    ;; Skip second bracket
+    (read-char)
+    ;; Discard initial newlines, which is what Lua does
+    (while (is-newline? (peek-char))
+      (read-char))
+    ;; Read string contents
+    (let loop ((c (peek-char)))
+      (cond
+        ;; Error out if end-of-file is encountered
+        ((eof-object? c)
+         (syntax-error (get-source-info) (string-append "unfinished long " (if string? "string" "comment"))))
+        ;; Check to see if we've reached the end
+        ((char=? c #\])
+         (let* ((nest2 (get-long-string-nesting-level)))
+           (if (= nest nest2)
+               (begin
+                 (read-char) ;; drop ]
+                 (if string?
+                     (clear-buffer)
+                     (drop-buffer)))
+               ;; Compensate for eating up the nesting levels
+               (begin
+                 (save-and-next!)
+                 (let lp ((n nest2))
+                   (if (= n 0)
+                       #f
+                       (begin
+                         (write-char #\=)
+                         (lp (- n 1)))))
+                 (write-char #\])
+                 (loop (peek-char))))))
+        ;; Save character and continue
+        (else (save-and-next!)
+              (loop (peek-char))))))
+
+  ;; read a single or double quoted string, with escapes
+  (define (read-string delimiter)
+    (read-char) ;; consume delimiter
+    (let loop ((c (peek-char)))
+      (cond
+        ;; string ends early
+        ((or (eof-object? c) (eq? c #\cr) (eq? c #\newline))
+         (syntax-error (get-source-info) "unfinished string ~S" c))
+        ;; string escape
+        ((char=? c #\\)
+         ;; discard \ and read next character
+         (let* ((escape (begin (read-char) (read-char))))
+           (write-char
+            (case escape
+              ((#\a) #\alarm)
+              ((#\b) #\backspace)
+              ((#\f) #\page)
+              ((#\n) #\newline)
+              ((#\r) #\return)
+              ((#\t) #\tab)
+              ((#\v) #\vtab)
+              ((#\x) (syntax-error (get-source-info) "hex escapes unsupported"))
+              ((#\d) (syntax-error (get-source-info) "decimal escapes unsupported"))
+              (else escape)))
+           (loop (peek-char))))
+        (else
+         (if (eq? c delimiter)
+             (read-char) ;; terminate loop and discard delimiter
+             (begin
+               (save-and-next!)
+               (loop (peek-char)))))))
+    (clear-buffer))
+
+  (define (read-number string)
+    (save-source-info)
+    (let* ((main (string-append (or string "") (begin
+                                                 (while (or (is-digit? (peek-char)) (eq? (peek-char) #\.))
+                                                        (save-and-next!))
+                                                 (clear-buffer))))
+           (exponent
+            (if (or (eq? (peek-char) #\e) (eq? (peek-char) #\E))
+                (begin
+                  (read-char)
+                  (if (eq? (peek-char) #\+)
+                      (read-char)
+                      (if (eq? (peek-char) #\-)
+                          (save-and-next!)))
+                  (if (not (is-digit? (peek-char)))
+                      (syntax-error (get-source-info) "expecting number after exponent sign"))
+                  (while (is-digit? (peek-char))
+                         (save-and-next!))
+                  (clear-buffer))
+                #f))
+           (final (string->number main)))
+           (if exponent
+               (* final (expt 10 (string->number exponent)))
+               final)))
+
+  (define (lex)
+    (parameterize ((current-input-port port)
+                   (current-output-port buffer))
+      (set! saved-source-info #f)
+      (let loop ()
+        (define c (peek-char))
+        (case c
+          ;; Skip spaces
+          ((#\newline #\return #\space #\page #\tab #\vtab) (read-char) (loop))
+
+          ;; Either a minus (-), or a long comment, which is a - followed by a bracketed string
+          ((#\-)
+           (read-char)
+           (if (eq? (peek-char) #\-)
+               ;; It's a comment
+               (begin
+                 (read-char)
+                 ;; Long comment
+                 (if (eq? (peek-char) #\[)
+                     (let* ((nest (get-long-string-nesting-level)))
+                       (drop-buffer)
+                       (if (not (negative? nest))
+                           (begin
+                             (read-long-string #f nest)
+                             (drop-buffer)
+                             (loop))
+                           ;; If it's not actually a long comment, drop it
+                           (begin (drop-buffer) (eat-comment) (loop))))
+                     (begin (eat-comment) (loop))))
+               ;; It's a regular minus
+               #\-))
+
+          ;; ~=
+          ((#\~)
+           (read-char)
+           (if (eq? (peek-char) #\=)
+               (begin (read-char) #:~=)
+               (syntax-error (get-source-info) "expected = after ~ but got ~c" c)))
+
+          ;; < or <=
+          ((#\<)
+           (read-char)
+           (if (eq? (peek-char) #\=) (begin (read-char) #:<=) #\<))
+
+          ;; > or >=
+          ((#\>)
+           (read-char)
+           (if (eq? (peek-char) #\=) (begin (read-char) #:>=) #\>))
+
+          ;; = or ==
+          ((#\=)
+           (read-char)
+           (if (eq? (peek-char) #\=)
+               (begin (read-char) #:==)
+               #:=))
+
+          ;; . can mean one of: floating point number (.12345), table field access (plain .),
+          ;; concatenation operator (..) or the variable argument indicator (...)
+          ((#\.)
+           (read-char)
+           (if (is-digit? (peek-char))
+               (read-number ".")
+               (if (eq? (peek-char) #\.)
+                   (begin
+                     (read-char)
+                     (if (eq? (peek-char) #\.)
+                         (begin (read-char) #:dots)
+                         #:concat))
+                   #\.)))
+
+          ;; Double-quoted string
+          ((#\") (read-string #\"))
+
+          ;; Single-quoted string
+          ((#\') (read-string #\'))
+
+          ;; Bracketed string
+          ((#\[)
+           (save-source-info)
+           (let* ((nest (get-long-string-nesting-level)))
+             (if (eq? nest -1)
+                 #\[
+                 (read-long-string #t nest))))
+
+          ;; Characters that are allowed to fall through directly to the parser
+          ((#\; #\( #\) #\,
+            #\+ #\/ #\*
+            #\^ #\{ #\} #\] #\: #\#) (read-char))
+
+          ;; Numbers
+          ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+           (save-source-info)
+           (save-and-next!)
+           (read-number #f))
+
+          (else
+           (cond ((eof-object? c) c)
+                 ;; Identifier or keyword
+                 ((is-name-first? c)
+                  (save-and-next!)
+                  (save-source-info)
+                  (while (is-name? (peek-char))
+                    (save-and-next!))
+                  (possible-keyword (string->symbol (clear-buffer))))
+                 (else (syntax-error (get-source-info) "disallowed character ~c" c))))
+          ) ; case
+        ) ; loop
+      ) ; parameterize
+    ) ; lex
+  (values get-source-info lex)) ; make-lexer
+
+(define-syntax define-lua-lexer
+  (syntax-rules ()
+    ((_ a b)
+     (begin
+       (define a #f)
+       (define b #f)))))
+
+(define-syntax initialize-lua-lexer!
+  (syntax-rules ()
+    ((_ port a b)
+     (receive (get-source-info lex)
+              (make-lexer port)
+              (set! a get-source-info)
+              (set! b lex)))))

module/language/lua/parser.scm

@@ -0,0 +1,892 @@
+;;; Guile Lua --- parser
+
+;;; 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:
+
+;; parser.scm --- lua parser
+
+;; This parser is based heavily on Lua's parser. It does not use
+;; lalr-scm, because Lua's grammar is a little too plucky. Unlike Lua's
+;; parser, it returns an abstract syntax tree instead of incrementally
+;; compiling the source.
+
+(define-module (language lua parser)
+
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-9)
+  #:use-module (rnrs control)
+
+  #:use-module (language lua common)
+  #:use-module (language lua lexer)
+  #:use-module (language lua runtime)
+
+  #:export (make-parser read-lua))
+
+;; Implicitly named records
+(letrec-syntax
+    ((define-record
+      (lambda (stx)
+        (define (id template-id . rest)
+          (datum->syntax template-id (string->symbol (apply string-append (map (lambda (x) (if (string? x) x (symbol->string (syntax->datum x)))) rest)))))
+        (syntax-case stx ()
+          ((_ name field ...)
+           (with-syntax
+               ((constructor (id #'name "make-" #'name))
+                (predicate (id #'name #'name "?"))
+               ((setter ...)
+                (map (lambda (x) (id #'name #'name "-" x "!")) #'(field ...)))
+               ((getter ...)
+                (map (lambda (x) (id #'name #'name "-" x)) #'(field ...))))
+
+             #'(begin
+                 (define-record-type name
+                   (constructor field ...)
+                   predicate
+                   (field getter setter) ...)
+                 (export name)
+                 (export constructor)
+                 (export predicate)
+                 (export getter)
+                 ...
+                 (export setter)
+                 ...
+                 ))))))
+
+     (define-ast
+      (lambda (stx)
+        (define (id template-id . rest)
+          (datum->syntax template-id (string->symbol (apply string-append (map (lambda (x) (if (string? x) x (symbol->string (syntax->datum x)))) rest)))))
+
+        (syntax-case stx ()
+          ((_ "aux" name field ...)
+           #`(define-record #,(id #'name "ast-" #'name) #,(id #'name "src") field ...))
+
+          ((_ (name field ...) ...)
+           #`(begin
+               (define-ast "aux" name field ...)
+               ...))))))
+
+  ;; Environments & bindings
+  (define-record environment parent bindings)
+  (define-record binding name gensym type)
+
+  ;; Abstract syntax tree -- all of these records are automatically
+  ;; prefixed with 'ast- and have an SRC field attached.
+  (define-ast
+   (unary-not exp)
+   (literal exp)
+   (sequence exps)
+   (return exp)
+   (condition test then else)
+   (local-block names gensyms initial-values exp)
+   (unary-operation operator right)
+   (local-ref name gensym)
+   (local-set name gensym exp)
+   (global-ref name)
+   (global-set name exp)
+   (table-ref table key)
+   (table-set table key exp)
+   (table-literal fields)
+   (while-loop condition body)
+   (numeric-for-loop named initial limit step body)
+   (list-for-loop names gs-names exps body)
+   (break)
+   (function name arguments argument-gensyms variable-arguments? body)
+   (function-call operator operands)
+   (binary-operation operator left right)
+   (variable-arguments))
+
+  ) ; letrec-syntax
+
+;; Constants
+(define *nil-literal* (make-ast-literal #f #nil))
+(define *void-literal* (make-ast-literal #f *unspecified*))
+(define *default-for-step* (make-ast-literal #f 1))
+
+(define (end-of-chunk? token)
+  "Returns true if TOKEN denotes the end of a grammatical chunk."
+  (or (or-eqv? token #:else #:elseif #:end #:until) (eof-object? token)))
+
+(define (token/type t)
+  (cond ((number? t) 'NUMBER)
+        ((eof-object? t) 'EOS)
+        ((symbol? t) 'NAME)
+        ((string? t) 'STRING)
+        (else
+         (case t
+           ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
+#:function #:end #:if #:return #:elseif #:then #:else #:true #:false
+#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in) t)
+           (else (error 'TOKEN/TYPE t))))))
+
+;; infix operator parsing
+(define (binary-operator? t)
+  "Return #t if the token may be a binary operator"
+  (or-eqv? t #\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or #:concat))
+
+(define (unary-operator? t)
+  "Return #t if the token may be a unary operator"
+  (or-eqv? t #\- #\# #:not))
+
+;; Operator precedence
+(define *unary-priority* 80)
+
+(define (priority o)
+  "Return the priority of a given operator token"
+  (case o
+    ((#:or) 10)
+    ((#:and) 20)
+    ((#:== #:~= #:<= #:>= #\< #\>) 30)
+    ((#\+ #\-) 60)
+    ((#\* #\/ #\%) 70)
+    ((#\^ #:concat) 99)))
+
+;;;;; TREE-IL UTILITIES
+
+(define (make-lua-assignment left right)
+  "Generate an assignment from a variable and an expression"
+  (cond ((ast-global-ref? left)
+         (make-ast-global-set (ast-global-ref-src left) (ast-global-ref-name left) right))
+        ((ast-local-ref? left)
+         (make-ast-local-set (ast-local-ref-src left) (ast-local-ref-name left) (ast-local-ref-gensym left) right))
+        ((ast-table-ref? left)
+         (make-ast-table-set (ast-table-ref-src left) (ast-table-ref-table left) (ast-table-ref-key left) right))
+        (else
+         (error 'MAKE-LUA-ASSIGNMENT "should not happen"))))
+
+(define (wrap-expression-in-environment src e x)
+  "Wrap an expression in an enclosing lexical environment if necessary"
+  (let* ((bindings (map cdr (environment-bindings e)))
+         (locals (filter-map (lambda (b) (if (eq? (binding-type b) 'local) b #f)) bindings)))
+    (if (null? locals)
+        x
+        (make-ast-local-block src (map binding-name locals) (map binding-gensym locals) (map (lambda (c) *nil-literal*) locals) x))))
+
+;;;;; PARSER
+
+(define (make-parser port)
+  ;; Variables that will be set to the results of MAKE-LEXER.
+  (define-lua-lexer get-source-info lexer)
+
+  ;; We need two tokens of lookahead
+  (define token2 #f)
+
+  (define (lookahead!)
+    (set! token2 (lexer)))
+
+  ;; Current token
+  (define token)
+
+  ;; Lexical environment
+  (define environment #f)
+
+  ;; True if inside a function and the function accepts variable arguments
+  (define *vararg-function* #f)
+
+  ;;;;; ENVIRONMENTS
+  (define (enter-environment!)
+    "Create a new environment, and set ENVIRONMENT to it"
+    (set! environment
+      (make-environment environment '())))
+
+  (define (leave-environment!)
+    "Set ENVIRONMENT to the current ENVIRONMENT's parent"
+    (if (not environment)
+        (error 'LEAVE-ENVIRONMENT! "should not happen"))
+    (set! environment
+      (environment-parent environment)))
+
+  ;; Type may be 'parameter or 'local
+  (define (environment-define! name type)
+    "Define a new variable with NAME and TYPE"
+    (if (not (member name (environment-bindings environment)))
+        (environment-bindings! environment (alist-cons name
+                                                    (make-binding
+                                                     name
+                                                     (gensym (string-append " " (symbol->string name)))
+                                                     type)
+                                                    (environment-bindings environment)))))
+
+  ;; Environment lookup procedures -- these fail silently and return #f,
+  ;; because Lua allows global variables to be referenced without being
+  ;; predefined
+
+  (define (environment-lookup-aux name . e)
+    "Given a variable's NAME, look up its binding."
+    (set! e (if (null? e) environment (car e )))
+    (if e
+        (let ((binding (assq-ref (environment-bindings e) name)))
+          (if binding
+              binding
+              (environment-lookup-aux name (environment-parent e))))
+        #f))
+
+  (define (environment-lookup-gensym name)
+    "Given a variable's NAME, look up its gensym"
+    (define binding (environment-lookup-aux name))
+    (if binding
+        (binding-gensym binding)
+        #f))
+
+  (define (environment-lookup-type name)
+    "Given a variable's NAME, look up its global"
+    (define binding (environment-lookup-aux name))
+    (if binding
+        (binding-type binding)
+        #f))
+
+  (define (resolve-ref src name)
+    "Determine whether a variable reference is global or local"
+    (let* ((binding (environment-lookup-gensym name)))
+      (if binding
+          (make-ast-local-ref src name binding)
+          (make-ast-global-ref src name))))
+
+  ;;;;; LEXER INTERACTION
+
+  (define (advance-aux)
+    "Read a new token and store it in TOKEN"
+    (if token2
+        (begin
+          (set! token token2)
+          (set! token2 #f))
+        (set! token (lexer))))
+
+  (define-syntax advance!
+    (syntax-rules ()
+      ((_ x) (begin (advance-aux) x))
+      ((_) (advance-aux))))
+
+  (define (assert-token-type type)
+    "Throw an error if the current token does not have the expected type"
+    (if (not (equal? (token/type token) type))
+        (syntax-error (get-source-info) "expected ~a" type)))
+
+  (define (maybe-skip-next! c)
+    "Skip a token"
+    (if (equal? token c)
+        (advance! #t)
+        #f))
+
+  (define (enforce-next! expect)
+    "Throw an error if the current token is not the expected token"
+    (unless (maybe-skip-next! expect)
+      (syntax-error (get-source-info) "expected '~A' but got '~A'" expect token)))
+
+  ;;;;; GRAMMAR
+
+  ;; single-name -> NAME
+  (define (single-name . return-src?)
+    (define save token)
+    (define src (get-source-info))
+    (assert-token-type 'NAME)
+    (advance!)
+    (if (not (null? return-src?))
+        (values src save)
+        save))
+
+  ;; single-variable -> single-name
+  (define (single-variable)
+    (receive (src save)
+             (single-name #:return-src #t)
+             (resolve-ref src save)))
+
+  ;; application-arguments -> '(' [ expression-list ] ')' | STRING | TABLE
+  (define (application-arguments)
+    (cond ((eq? (token/type token) 'STRING)
+           (let* ((string token))
+             (advance!)
+             (list (make-ast-literal #f string))))
+          ((eq? token #\{)
+           ;; TODO: table constructor
+           ;; '('
+           (list (table-literal)))
+          ((eq? token #\()
+           (advance!)
+           (if (eq? token #\))
+               ;; ')'
+               (advance! '())
+               ;; [ expression-list ]
+               (let* ((arguments (expression-list)))
+                 ;; ')'
+                 (enforce-next! #\))
+                 arguments)))
+           (else (error 'APPLICATION-ARGUMENTS "should not happen"))))
+
+  ;; prefix-expression -> NAME | '(' expression ')'
+  (define (prefix-expression)
+    (cond
+      ;; NAME
+      ((eq? (token/type token) 'NAME) (single-variable))
+      ;; '('
+      ((eq? token #\()
+       (begin
+         (advance!)
+         ;; expression
+         (let* ((save (expression)))
+           ;; ')'
+           (enforce-next! #\))
+           ;; finished
+           save)))
+      (else (syntax-error (get-source-info) "unexpected symbol ~a" token))))
+
+  ;; index -> '[' expression ']'
+  (define (index)
+    (enforce-next! #\[)
+    (let* ((indice (expression)))
+      (enforce-next! #\])
+      indice))
+
+  ;; field-selector -> '.' NAME
+  (define (field-selector src prefix)
+    (make-ast-table-ref src prefix (make-ast-literal src (symbol->string (single-name)))))
+
+  ;; primary-expression -> prefix-expression { field-selector [ application-arguments ] | index | application-arguments }
+  (define (primary-expression)
+    (define src (get-source-info))
+    ;; prefix-expression
+    (define prefix (prefix-expression))
+    (let lp ((expr prefix))
+      (case (token/type token)
+          ;; field-selector
+          ((#\.) (advance!) (lp (field-selector src expr)))
+          ;; index
+          ((#\[)
+           (let* ((indice (index)))
+             (lp (make-ast-table-ref src expr indice))))
+          ;; ':' NAME application-arguments
+          ((#\:)
+           (advance!)
+           (assert-token-type 'NAME)
+           (let* ((name (single-name)))
+             (lp
+              (make-ast-function-call src
+              (make-ast-table-ref src expr (make-ast-literal src (symbol->string name)))
+              (cons expr (application-arguments))))))
+          ;; application-arguments
+          ((#\( STRING #\{)
+           (lp (make-ast-function-call src expr (application-arguments))))
+          (else expr))))
+
+  ;; expression-statement -> function | assignment
+  (define (expression-statement)
+    (define primary (primary-expression))
+    (if (ast-function-call? primary)
+        primary
+        (assignment primary)))
+
+
+  ;; record-field -> (NAME | index) '=' expression
+  (define (record-field)
+    (let* ((indice
+            (cond
+              ;; NAME
+              ((eq? (token/type token) 'NAME)
+               (let ((tmp (make-ast-literal #f (symbol->string token))))
+                 (advance!)
+                 tmp))
+              ;; index
+              (else (index))))
+           (value
+            (begin
+              ;; '='
+              (enforce-next! #:=)
+              ;; expression
+              (expression))))
+      (values indice value)))
+
+  ;; field -> expression | record-field
+  (define (field)
+    (case (token/type token)
+      ((NAME)
+       (lookahead!)
+       (if (eq? token2 #:=)
+           (record-field)
+           (values #f (expression))))
+      ((#\[) (record-field))
+      (else (values #f (expression)))))
+
+  ;; field-separator -> ',' | ';'
+  ;; table-fields -> [ field { field-separator field } [ field-separator ] ]
+  (define (table-fields src)
+    (if (eq? token #\})
+        '()
+        (let loop ((implicit-indice 1)
+                   (tree '()))
+          (if (eq? token #\})
+              (reverse! tree)
+              (receive
+               (indice expr)
+               (field)
+               ;; field-separator
+               (maybe-skip-next! #\,)
+               (maybe-skip-next! #\;)
+
+               (loop
+                (if (not indice) (+ implicit-indice 1) implicit-indice)
+                (cons
+                 (cons (or indice (make-ast-literal src implicit-indice)) expr)
+                 tree)))))))
+
+  ;; table-literal -> '{' table-fields '}'
+  (define (table-literal)
+    (define src (get-source-info))
+    ;; '{'
+    (enforce-next! #\{)
+    ;; bind the table to a temporary variable with LET as it's needed in order to initialize the table
+    (let* ((result (make-ast-table-literal src (table-fields src))))
+      result
+      (enforce-next! #\})
+      result))
+
+  ;; parameter-list -> [ parameter { ',' parameter } ]
+  (define (parameter-list function-name)
+    (if (eq? token #\))
+        (values '() #f)
+        (let lp ((parameters '()))
+          ;; parameter
+          (let* ((parameters
+                  (if (eq? (token/type token) 'NAME)
+                      (append! parameters (list token))
+                      (if (eq? token #:dots)
+                          (values parameters #f)
+                          (syntax-error (get-source-info) "expected either a name or ... in the parameter list of '~a', but got ~a" function-name token))))
+                 (last-token token))
+            (advance!)
+            (if (eq? token #\,)
+                (if (eq? last-token #:dots)
+                    (syntax-error (get-source-info) "expected ')' after ... in the parameter list of '~a'" function-name)
+                    (advance! (lp parameters)))
+                (values parameters (eq? last-token #:dots)))))))
+
+  ;; function-body -> '(' parameter-list ')' chunk END
+  (define* (function-body #:optional (src (get-source-info)) (implicit-self? #f) (name 'anonymous))
+    ;; '('
+    (enforce-next! #\()
+    ;; parameter-list
+    (receive (parameters variable-arguments?)
+             (parameter-list name)
+             (let* ((old-vararg-function *vararg-function*))
+               (set! *vararg-function* variable-arguments?)
+               (enforce-next! #\))
+               ;; create function
+               (enter-environment!)
+               (when implicit-self?
+                 (environment-define! 'self 'parameter))
+               (for-each (lambda (p) (environment-define! p 'parameter)) parameters)
+               ;; chunk
+               (let* ((body (chunk))
+                      (parameter-gensyms (map environment-lookup-gensym parameters))
+                      (result
+                       (make-ast-function src (if (eq? name 'anonymous) #f name)
+                                          (if implicit-self? (append parameters '(self)) parameters)
+                                          (if implicit-self? (append parameter-gensyms (list (environment-lookup-gensym 'self))) parameter-gensyms)
+                                          variable-arguments? (if (null? body) *void-literal* body))))
+                 (leave-environment!)
+                 ;; END
+                 (enforce-next! #:end)
+                 (set! *vararg-function* old-vararg-function)
+                 result))))
+
+  ;; expression-list -> expression { ',' expression }
+  (define (expression-list)
+    (let loop ((tree (list (expression))))
+      ;; { ',' expression }
+      (if (maybe-skip-next! #\,)
+          (loop (cons (expression) tree))
+          ;; finished
+          (reverse! tree))))
+
+  ;; simple-expression -> (nil | true | false | NUMBER | STRING) | table-literal | FUNCTION function-body
+  (define (simple-expression)
+    (define src (get-source-info))
+    (receive
+     (advance? result)
+     (case (token/type token)
+       ;; (nil | true | false | NUMBER | STRING)
+       ((#:true #:false #:nil NUMBER STRING)
+        (values
+          #t
+          (make-ast-literal
+           src
+           (cond ((eq? token #:true) #t)
+                 ((eq? token #:false) #f)
+                 ((eq? token #:nil) #nil)
+                 (else token)))))
+       ;; table-literal
+       ((#\{) (values #f (table-literal)))
+       ;; ...
+       ((#:dots)
+        (unless *vararg-function*
+          (syntax-error src "cannot use '...' outside of a variable arguments function"))
+        (values #t (make-ast-variable-arguments src)))
+       ;; FUNCTION function-body
+       ((#:function) (advance!) (values #f (function-body src)))
+       ;; primary-expression
+       (else (values #f (primary-expression))))
+     (if advance?
+         (advance!))
+     result))
+
+  ;; subexpression -> (simple-expression | unary-operator subexpression) { binary-operator subexpression }
+  (define (subexpression limit)
+    (define left)
+    ;; test for preceding unary operator
+    (set! left
+      ;; (simple-expression | unary-operator subexpression)
+      (if (unary-operator? token)
+          ;; unary-operator subexpression
+          (let* ((src (get-source-info))
+                 (operator token))
+            (advance!)
+            (make-ast-unary-operation src operator (subexpression *unary-priority*)))
+          ;; simple-expression
+          ;; note: simple-expression may advance the current token
+          (simple-expression)))
+
+    (let loop ((left left))
+      ;; { binary-operator subexpression }
+      (if (and (binary-operator? token) (> (priority token) limit))
+          (let* ((src (get-source-info))
+                 (operator token))
+            (advance!)
+            ;; read next expression with higher priorities
+            (let* ((right (subexpression (priority operator))))
+              (loop (make-ast-binary-operation src operator left right))))
+          ;; finished
+          left)))
+
+  ;; expression -> subexpression
+  (define (expression)
+    (subexpression 0))
+
+  ;; while-statement -> WHILE expression DO chunk END
+  (define (while-statement)
+    (define src (get-source-info))
+    ;; WHILE
+    (advance!)
+    ;; expression
+    (let* ((condition (expression)))
+      ;; DO
+      (enforce-next! #:do)
+      ;; chunk
+      (let* ((body (chunk)))
+        ;; END
+        (enforce-next! #:end)
+        (make-ast-while-loop src condition body))))
+
+  ;; return-statement -> RETURN expression-list
+  (define (return-statement)
+    (define src (get-source-info))
+
+    ;; RETURN
+    (advance!)
+
+    (make-ast-return src (if (or (end-of-chunk? token) (eq? token #\;))
+                         *void-literal*
+                         (expression-list))))
+
+  (define (parse-assignment src left right)
+      ;; and then parses it, branching to handle overflows on either side if necessary
+      (make-ast-sequence
+       src
+       (let loop ((left left)
+                  (right right)
+                  (tree '()))
+         (cond
+           ;; no overflows, and finished
+           ((and (null? left) (null? right))
+            (reverse! tree))
+           ;; no overflows, not finished
+           ((and (not (null? left)) (not (null? right)))
+            (loop (cdr left)
+                  (cdr right)
+                  (cons (make-lua-assignment (car left) (car right)) tree)))
+           ;; overflow on right, evaluate extra expressions on the right
+           ((and (null? left) (not (null? right)))
+            (reverse! (append! right tree)))
+           ;; overflow on left, set all overflowed expressions to nil
+           ((and (not (null? left)) (null? right))
+            (let loop ((tree tree)
+                       (rest left))
+              (let* ((il (make-lua-assignment (car rest) *nil-literal*))
+                     (rest (cdr rest)))
+                (if (null? rest)
+                    (reverse! (cons il tree))
+                    (loop (cons il tree) (cdr rest))))))
+           (else (error 'PARSE-ASSIGNMENT "should not happen"))))))
+
+  ;; assignment -> '=' expression-list | ',' primary-expression assignment
+  (define (assignment first)
+    ;; assignments are unfortunately complicated because multiple variables may
+    ;; be assigned to multiple expressions in a single assignment, and the
+    ;; number of variables and expressions need not match
+
+    ;; so this function accumulates the entire assignment
+    (let* ((src (get-source-info))
+           (left (let loop ((x first)
+                            (tree '()))
+                   (set! tree (cons x tree))
+                   (if (eq? token #\,)
+                       (advance! (loop (primary-expression) tree))
+                       (reverse! tree))))
+
+           (right (begin
+                    (enforce-next! #:=)
+                    (expression-list))))
+      (parse-assignment src left right)
+
+      ) ; let*
+    ) ; assignment
+
+  ;; then-chunk -> (IF | ELSEIF) expression THEN chunk
+  (define (then-chunk)
+    ;; IF | ELSEIF
+    (advance!)
+    ;; expression
+    (let* ((condition (expression)))
+      ;; THEN
+      (enforce-next! #:then)
+      ;; chunk
+      (let* ((body (chunk)))
+        (values condition body))))
+
+  ;; if-statement -> then-chunk { then-chunk } [ELSE chunk] END
+  (define (if-statement)
+    (define if-src (get-source-info))
+    (define x
+      (receive (test then)
+               (then-chunk)
+               (make-ast-condition
+                if-src test then
+                (let lp ()
+                  (define src (get-source-info))
+                  (if (eq? token #:elseif)
+                      (receive (test then)
+                               (then-chunk)
+                               (make-ast-condition src test then (lp)))
+                      (if (eq? token #:else)
+                          (advance! (chunk))
+                          *void-literal*))))))
+    (enforce-next! #:end)
+    x)
+
+  ;; repeat-statement -> REPEAT chunk UNTIL expression
+  (define (repeat-statement)
+    (define src (get-source-info))
+    ;; REPEAT
+    (advance!)
+    ;; chunk
+    (let* ((body (chunk)))
+      ;; UNTIL
+      (enforce-next! #:until)
+      ;; expression
+      (let* ((condition (expression)))
+        (make-ast-while-loop
+         src
+         (make-ast-unary-operation src 'not condition)
+         body))))
+
+  ;; function-statement -> FUNCTION NAME { field-selector } [ ':' NAME ] function-body
+  (define (function-statement)
+    (define src (get-source-info))
+    ;; FUNCTION NAME
+    (define name (advance! (single-name)))
+
+    (receive (prefix type)
+             (let lp ((last-expr (resolve-ref src name)))
+               (if (eq? token #\.)
+                   ;; { '.' NAME }
+                   (let* ((name (advance! (single-name))))
+                     (if (eq? token #\()
+                           (values (cons name last-expr) 'table-function)
+                           (lp (make-ast-table-ref src last-expr name))))
+                   ;; [ ':' NAME ]
+                   (if (eq? token #\:)
+                       (let* ((name (advance! (single-name))))
+                         (values (cons name last-expr) 'table-method))
+                       (values last-expr 'function))))
+             (define body (function-body src (eq? type 'table-method) name))
+             (case type
+               ((table-function table-method)
+                (make-ast-table-set src (cdr prefix) (make-ast-literal src (symbol->string (car prefix))) body))
+               ((function) (make-lua-assignment prefix body))
+               (else (error 'FUNCTION-STATEMENT "should not happen")))))
+
+  ;; local-statement -> LOCAL NAME { ',' NAME } [ '=' expression-list ]
+  (define (local-statement)
+    (define src (get-source-info))
+    ;; LOCAL
+    ;; (already advanced by calling function)
+
+    (let lp ((names '()))
+      ;; NAME
+      (assert-token-type 'NAME)
+      (set! names (cons token names))
+      (advance!)
+      (if (maybe-skip-next! #\,)
+          ;; { ',' NAME }
+          (lp names)
+          (begin
+            (for-each (lambda (n) (environment-define! n 'local)) names)
+            (if (maybe-skip-next! #:=)
+                ;; [ '=' expression-list ]
+                (let* ((left (map (lambda (x) (resolve-ref src x)) names))
+                       (right (expression-list)))
+                  (parse-assignment src left (reverse! right)))
+                ;; otherwise, it's not a declaration, not an assignment, and evaluates to nothing
+                *void-literal*)))))
+
+  (define (local-function-statement)
+    (assert-token-type 'NAME)
+    (let* ((name token))
+      (environment-define! name 'local)
+      (advance!)
+      (make-ast-local-set (get-source-info) name (environment-lookup-gensym name) (function-body))))
+
+  ;; for-body
+  (define (for-body)
+    (enforce-next! #:do)
+    (let* ((body (chunk)))
+      (enforce-next! #:end)
+      body))
+
+  ;; numeric-for -> FOR NAME '=' expression ',' expression ',' expression DO chunk END
+  (define (numeric-for src name)
+    (define step *default-for-step*)
+    (advance!)
+    (enforce-next! #:=)
+    (enter-environment!)
+    (environment-define! name 'local)
+    (let* ((initial (expression)))
+      (enforce-next! #\,)
+      (let* ((limit (expression)))
+        (when (eq? token #\,)
+          (advance!)
+          (set! step (expression)))
+        (let* ((result (make-ast-numeric-for-loop src name initial limit step (for-body))))
+          (leave-environment!)
+          result))))
+
+  ;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END
+  (define (list-for src name)
+    (let* ((names
+            (let lp ((names (list name)))
+              (advance!)
+              (if (eq? token #\,)
+                  (begin
+                    (advance!)
+                    (assert-token-type 'NAME)
+                    (lp (cons token names)))
+                  (reverse! names)))))
+      (enforce-next! #:in)
+      (let* ((exps (expression-list)))
+        (enforce-next! #:do)
+        (for-each
+         (lambda (name)
+           (environment-define! name 'hidden))
+         names)
+        (let* ((body (chunk)))
+          (enforce-next! #:end)
+          (make-ast-list-for-loop src names (map environment-lookup-gensym names) exps body)))))
+
+  ;; for-statement -> FOR (numeric-for | list-for) END
+  (define (for-statement)
+    (define src (get-source-info))
+    (enforce-next! #:for)
+    (assert-token-type 'NAME)
+    (let* ((name token)
+           (result
+            (begin
+              (lookahead!)
+              (if (eq? token2 #:=)
+                  (numeric-for src name)
+                  (if (or-eqv? token2 #:in #\,)
+                      (list-for src name)
+                      (syntax-error src "expected = or in after for variable"))))))
+      result))
+
+  ;; break-statement -> BREAK
+  (define (break-statement)
+    (enforce-next! #:break)
+    (make-ast-break (get-source-info)))
+
+  ;; statement
+  (define (statement)
+    (case token
+      ((#\;) (advance!) (statement))
+      ;; statement -> return
+      ((#:return #:break)
+       (values
+         #t
+         (case token
+           ((#:return) (return-statement))
+           ((#:break) (break-statement)))))
+      ((#:if #:function #:do #:while #:repeat #:local #:for)
+       (values
+         #f
+          (case token
+            ((#:repeat) (repeat-statement))
+            ((#:while) (while-statement))
+            ((#:if) (if-statement))
+            ((#:function) (function-statement))
+            ((#:local)
+             (advance!)
+             (if (maybe-skip-next! #:function)
+                 (local-function-statement)
+                 (local-statement)))
+            ((#:for) (for-statement))
+            ((#:do)
+             (begin
+               (advance!)
+               (let* ((body (chunk)))
+                 (enforce-next! #:end)
+                 body))))))
+      ;; statement -> function | assignment
+      (else (values #f (expression-statement)))))
+
+  ;; chunk -> { statement [ ';' ] }
+  (define (chunk)
+    (define src (get-source-info))
+    (let loop ((is-last (end-of-chunk? token))
+               (tree '()))
+      (if is-last
+          (begin
+            (maybe-skip-next! #\;)
+            (wrap-expression-in-environment
+             src
+             environment
+             (make-ast-sequence src (reverse! tree))))
+        (receive
+         (is-last node)
+         (statement)
+         (loop (or (end-of-chunk? token) is-last) (cons node tree))))))
+
+  (initialize-lua-lexer! port get-source-info lexer)
+
+  ;; toplevel local environment
+  (enter-environment!)
+  ;; read first token
+  (advance!)
+  ;; return parser
+  chunk)
+
+(define (read-lua port)
+  (define parser (make-parser port))
+  (parser))

module/language/lua/runtime.scm

@@ -0,0 +1,606 @@
+;;; Guile Lua --- runtime functionality
+
+;;; 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 runtime)
+  #:use-module (language lua common)
+
+  #:use-module (rnrs control)
+  #:use-module ((srfi srfi-1) #:select (filter!))
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-69)
+  #:use-module ((srfi srfi-98) #:select (get-environment-variable))
+  #:use-module ((system base compile) #:select (compile read-and-compile))
+
+  #:export (
+            runtime-error
+
+            ;; semantics
+            false? true?
+
+            ;; misc
+            value-type->string
+            assert-type
+            assert-table
+            assert-string
+            assert-number
+
+            ;; tables
+            make-table
+            table?
+            table-slots
+            table-metatable
+            table-metatable!
+            table-length
+
+            ;; userdata
+            userdata
+            userdata-metatable
+            register-userdata!
+
+            ;; metatable
+            might-have-metatable?
+            get-metatable
+            dispatch-metatable-event
+
+            ;; table interaction
+            index
+            new-index!
+            get-field
+
+            ;; operators
+            len unm eq lt le gt ge add sub mul div pow
+            neq concat
+
+            ;; modules
+            make-module-table
+
+            ;; global environment
+            *global-env-table*
+            save-fenv
+            check-global-function
+            )
+
+  #:export-syntax (table-slots table? table-metatable table-metatable!)
+
+  )                                     ; define-module
+
+;; Local Variables:
+;; eval: (put 'define-global 'scheme-indent-function 1)
+;; End:
+
+(define (runtime-error string . arguments)
+  "Throw an error tagged with 'lua-runtime"
+  (throw 'lua-runtime (apply format (cons (string-append "LUA: ERROR: " string "\n") arguments))))
+
+(define (runtime-warning string . arguments)
+  (apply format (cons #t (cons (string-append "LUA: RUNTIME WARNING: " string "\n") arguments))))
+
+;;;;; SEMANTICS
+
+(define (false? x)
+  "Wrapper for Scheme's false semantics that considers #nil to be false"
+  (or (eq? x #f) (eq? x #nil)))
+
+(define (true? x)
+  "Inversion of false?"
+  (not (false? x)))
+
+;;;;; MISCELLANEOUS
+
+(define (value-type->string x)
+  (cond ((table? x) "table")
+        ((string? x) "string")
+        ((number? x) "number")
+        ((boolean? x) "boolean")
+        ((eq? x #nil) "nil")
+        ((procedure? x) "function")
+        ;; TODO: value-type->string must recognize threads
+        (else "userdata")))
+
+(define (assert-type argument caller expected value predicate)
+  (if (not (predicate value))
+      (runtime-error (format #f "bad argument ~a to '~a' (~a expected, got ~a)" argument caller expected (value-type->string value)))))
+
+(define-syntax define-assert
+  (syntax-rules ()
+    ((_ name string predicate)
+     (define (name argument caller value) (assert-type argument caller string value predicate)))))
+
+(define-assert assert-table "table" table?)
+(define-assert assert-string "string" string?)
+(define-assert assert-number "number" number?)
+
+;;;;; TABLES
+
+(define-record-type table
+  (%make-table metatable slots)
+  table?
+  (metatable table-metatable table-metatable!)
+  (slots table-slots))
+
+(define (make-table)
+  (%make-table #f (make-hash-table)))
+
+(define (table? x) (table? x))
+(define (table-metatable x) (table-metatable x))
+(define (table-metatable! x y) (table-metatable! x y))
+
+;;;;; USERDATA
+
+;; Userdata is tracked by this property. It can be #f, indicating the
+;; object is not userdata, #t, indicating the object is userdata but has
+;; no metatable, or an actual table, which counts as the metatable.
+(define userdata-property (make-object-property))
+
+(define userdata? userdata-property)
+(define (userdata-metatable x)
+  (and (table? (userdata-property x)) (userdata-property x)))
+
+(define* (register-userdata! x #:optional metatable)
+  (set! (userdata? x) (or metatable #t)))
+
+;;;;; METATABLES
+
+(define (might-have-metatable? x)
+  (or (table? x) (userdata? x)))
+
+(define (get-metatable x)
+  (cond ((table? x) (table-metatable x))
+        ((userdata? x) (userdata-metatable x))
+        (else #f)))
+
+;;;;; TABLE INTERACTION
+
+(define (dispatch-metatable-event key default x . arguments)
+  (let* ((metatable (get-metatable x)))
+    (apply
+     (if metatable
+         (hash-table-ref/default (table-slots metatable) key default)
+         default)
+     arguments)))
+
+;; see manual section 2.5.5
+(define (table-length table)
+         (let* ((numeric-keys (sort! (filter! number? (hash-table-keys (table-slots table))) <)))
+           (if (eq? (car numeric-keys) 1)
+               (let lp ((cell (car numeric-keys))
+                        (rest (cdr numeric-keys))
+                        (length 0))
+                 ;; length does not count "holes"
+                 ;; so if a table has the keys 1,2,3 and 5, the length of the table is 3
+                 (if (or (> cell (+ length 1)) (null? rest))
+                     (+ length 1) ;; add one to length as though we had started from one
+                     (lp (car rest) (cdr rest) cell)))
+               0)))
+
+(define (index table key)
+  (dispatch-metatable-event
+   "__index"
+   (lambda (table key) (hash-table-ref/default (table-slots table) key #nil))
+   table
+   table key))
+
+(define (new-index! table key value)
+  (dispatch-metatable-event
+   "__newindex"
+   (lambda (table key value) (hash-table-set! (table-slots table) key value))
+   table
+   table key value))
+
+(define* (get-field table key #:optional (default #nil))
+  (define result (index table key))
+  (if (eq? result #nil)
+      default
+      result))
+
+;;;;; OPERATORS
+(define (len a)
+  "A function backing the unary # (length) operator"
+  (cond ((string? a) (string-length a))
+        ((table? a) (table-length a))
+        (else (runtime-error "attempt to get length of a ~A value" (value-type->string a)))))
+
+(define (unm a)
+  "A function backing the unary - (negation) operator"
+  (if (might-have-metatable? a)
+      (dispatch-metatable-event "__unm" - a a)
+      (- a)))
+
+(define (builtin-eq a b)
+  "A function backing the == operator"
+  (equal? a b))
+
+(define (builtin-concat a b)
+  (when (or (table? a) (table? b))
+    (runtime-error "attempt to concatenate a table value"))
+  (when (or (eq? a #nil) (eq? b #nil))
+    (runtime-error "attempt to concatenate a nil value"))
+  (when (or (boolean? a) (boolean? b))
+    (runtime-error "attempt to concatenate a boolean value"))
+  (format #f "~a~a" a b))
+
+(define (neq a b)
+  "An inversion of eq"
+  (not (eq a b)))
+
+(define (ge a b)
+  "A function backing the >= (greater-than-or-equal-to) operator"
+  (not (lt a b)))
+
+(define (gt a b)
+  "A function backing the > (greater-than) operator"
+  (not (le a b)))
+
+;; This macro could be even cooler and generate the slot names as well as the
+;; parsers name/function mappings at expand-time
+(letrec-syntax
+    ((define-binary-operators
+      (syntax-rules ()
+        ((_ (name slot-name default) ...)
+         (begin
+           (define-binary-operators () name slot-name default)
+           ...))
+        ((_ () name slot-name default)
+         (begin
+           (define (name a b)
+             (cond ((might-have-metatable? a)
+                    (dispatch-metatable-event slot-name default a a b))
+                   ((might-have-metatable? b)
+                    (dispatch-metatable-event slot-name default b a b))
+                   (else (default a b)))))))))
+  (define-binary-operators
+   (add "__add" +)
+   (sub "__sub" -)
+   (mul "__mul" *)
+   (div "__div" /)
+   (pow "__pow" expt)
+   (le "__le" <=)
+   (lt "__lt" <)
+   (eq "__eq" builtin-eq)
+   (concat "__concat" builtin-concat)))
+
+;;;;; MODULES
+
+;; A metatable for tables backed by modules
+(define module-metatable (make-table))
+
+(hash-table-set!
+ (table-slots module-metatable) "__index"
+ (lambda (table key)
+   (define slots (table-slots table))
+   (if (hash-table-exists? slots key)
+       (hash-table-ref slots key)
+       (let ((key (string->symbol key))
+             (module (hash-table-ref slots 'module)))
+         (if (not (module-defined? module key))
+             #nil
+             (module-ref module key #f))))))
+
+(define (make-module-table name)
+  (define table (make-table))
+  (table-metatable! table module-metatable)
+  (hash-table-set! (table-slots table) 'module (resolve-module name))
+  table)
+
+;;;;; GLOBAL ENVIRONMENT
+
+(define *global-env-table* (make-table))
+
+;; Saves _G and returns a function that will restore it
+(define (save-fenv table)
+  "Saves *global-env-table* and returns a function to restore it"
+  (let* ((save *global-env-table*))
+    (set! *global-env-table* table)
+    (lambda ()
+      (set! *global-env-table* save))))
+
+(define (check-global-function name value)
+  (when (eq? value #nil)
+    (runtime-error "attempt to call global '~a' (a nil value)" name)))
+
+;;;;; BUILT-INS
+
+(define-syntax define-global
+  (syntax-rules (do-not-export)
+    ((_ (do-not-export name) value)
+     (begin
+       (define name value)
+       (new-index! *global-env-table* (symbol->string 'name) name)))
+    ((_ (name . rest) body ...)
+     (define-global name (lambda rest body ...)))
+    ((_ name value)
+     (begin
+       (define name value)
+       (export name)
+       (new-index! *global-env-table* (symbol->string 'name) name)))))
+
+(define-global (assert v . opts)
+  (define message (if (null? opts) "assertion failed" (car opts)))
+  (if (false? v)
+      (runtime-error message)
+      (apply values (cons v opts))))
+
+;; NOTE: collectgarbage cannot be fully implemented because it expects
+;; an incremental garbage collector that matches lua's interface; libgc
+;; can be incremental but i don't think we can turn that on from guile
+;; currently, and even if we could i'm not sure that libgc exposes what
+;; lua wants
+(define-global collectgarbage
+  (lambda* (opt #:optional (arg #nil))
+    (define (ignore) (runtime-warning "collectgarbage cannot respect command ~a" opt))
+    (assert-type 1 "collectgarbage" "string" opt string?)
+    (cond ((string=? opt "stop") (ignore))
+          ((string=? opt "restart") (ignore))
+          ((string=? opt "collect") (gc))
+          ((string=? opt "count") (ignore))
+          ((string=? opt "step") (ignore))
+          ((string=? opt "setpause") (ignore))
+          ((string=? opt "setstepmul") (ignore))
+          (else (runtime-error "bad argument #1 to 'collectgarbage' (invalid option ~a)" opt)))))
+
+(define-global (dofile filename)
+  (assert-string 1 "dofile" filename)
+  (runtime-warning "dofile cannot return the values of the chunk and instead will return #nil")
+  (call-with-input-file filename
+    (lambda (file)
+      (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value)))
+  #nil)
+
+(define-global (do-not-export error)
+  (lambda* (message #:optional level)
+    (runtime-warning "level argument to error is not respected")
+    (throw 'lua-error message)))
+
+;; global variable table
+(define-global _G *global-env-table*)
+
+(define-global (getmetatable table)
+  (assert-table 1 "getmetatable" table)
+  (let* ((mt (table-metatable table)))
+    (if (eq? mt #f)
+        #nil
+        mt)))
+
+(define-global (ipairs table)
+  (assert-table 1 "ipairs" table)
+  (values
+    (lambda (table indice)
+      (set! indice (+ indice 1))
+      (let* ((value (index table indice)))
+        (if (eq? value #nil)
+            (values #nil #nil)
+            (values indice value)))
+      )
+    table
+    0))
+
+(define (load-warning)
+  (runtime-warning "load, loadfile, and loadstring cannot return the results of evaluating a file"))
+
+(define (load-chunkname-warning chunkname)
+  (when chunkname
+    (runtime-warning "load and loadstring ignore chunkname")))
+
+(define-global load
+  (lambda* (func #:optional chunkname)
+    (load-warning)
+    (load-chunkname-warning chunkname)
+    (lambda ()
+      (compile
+       ((@ (language lua parser) read-lua)
+        (open-input-string
+         (let lp ((tree '())
+                  (result (func)))
+           (if (or (equal? func "") (eq? func #nil) (eq? func *unspecified*))
+               (string-concatenate-reverse tree)
+               (lp (cons func tree) (func))))))
+       #:from 'lua #:to 'value))))
+
+(define-global loadfile
+  (lambda* (#:optional filename)
+    (load-warning)
+    (lambda ()
+      (if filename
+          (call-with-input-file filename
+            (lambda (file)
+              (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value)))
+          (read-and-compile (current-input-port) #:from 'lua)))))
+
+(define-global loadstring
+  (lambda* (string #:optional chunkname)
+    (load-warning)
+    (load-chunkname-warning chunkname)
+    (lambda ()
+      (compile ((@ (language lua parser) read-lua) (open-input-string string)) #:from 'lua #:to 'value))))
+
+;; TODO: module
+
+(define-global next
+  (lambda* (table #:optional (index #nil))
+    (assert-table 1 "next" table)
+    (let* ((keys (hash-table-keys (table-slots table))))
+      ;; empty table = nil
+      (if (null? keys)
+          #nil
+          (begin
+            (if (eq? index #nil)
+                (let* ((next-index (list-ref keys 0)))
+                  (values next-index (rawget table next-index)))
+                (let* ((key-ref (+ ((@ (srfi srfi-1) list-index) (lambda (x) (equal? x index)) keys) 1)))
+                  (if (>= key-ref (length keys))
+                      (values #nil #nil)
+                      (let* ((next-index (list-ref keys key-ref)))
+                        (values next-index (rawget table next-index)))))))))))
+
+(define-global pairs
+  (lambda* (table)
+    (values next table #nil)))
+
+(define-global (pcall function . arguments)
+  (catch #t
+         (lambda () (apply function arguments))
+         (lambda args (apply values (cons #f args)))))
+
+(define-global (print . arguments)
+  (for-each
+   (lambda (x)
+     (display (tostring x))
+     (write-char #\tab))
+   arguments)
+  (newline)
+  #nil)
+
+(define-global (rawequal v1 v2)
+  (equal? v1 v2))
+
+(define-global (rawget table key)
+  (assert-table 1 "rawget" table)
+  (hash-table-ref (table-slots table) key))
+
+(define-global (rawset table key value)
+  (assert-table 1 "rawset" table)
+  (hash-table-set! (table-slots table) key value))
+
+(define-global (select index . rest)
+  (define rest-length (length rest))
+  (cond ((number? index)
+         (let lp ((vals '())
+                  (i index))
+           (if (> i rest-length)
+               (apply values (reverse! vals))
+               (lp (cons (list-ref rest (- i 1)) vals) (+ i 1)))))
+        (else rest-length)))
+
+(define-global (setmetatable table metatable)
+  (assert-table 1 "setmetatable" table)
+  (assert-type 2 "setmetatable" "nil or table" metatable (lambda (x) (or (table? x) (eq? x #nil))))
+  (table-metatable! table (if (eq? metatable #nil) #f metatable))
+  table)
+
+;; NOTE: built-in 'tonumber' is implemented on string->number and may
+;; not have the same semantics as lua's tonumber; it should be based on the lexer
+(define-global tonumber
+  (lambda* (e #:optional (base 10))
+    (cond ((number? e) e)
+          ((string? e)
+           (unless (or-eqv? base 2 8 10 16)
+             (runtime-warning "tonumber cannot respect bases other than 2, 8, 10, and 16"))
+           (string->number e base))
+          (else #nil))))
+
+(define-global (tostring e)
+  (cond ((string? e) e)
+        ((eqv? e #t) "true")
+        ((eqv? e #f) "false")
+        ((eqv? e #nil) "nil")
+        ((number? e) (number->string e))
+        ((might-have-metatable? e)
+         (dispatch-metatable-event
+          "__tostring"
+          (lambda (table) (format #f "~A" e))
+          e
+          e))
+        (else (runtime-error "tostring cannot convert value ~A" e))))
+
+(define-global (type v)
+  (value-type->string v))
+
+(define-global unpack
+  (lambda* (array #:optional (i 1) j)
+    (assert-table 1 "unpack" array)
+    (unless j (set! j (table-length array)))
+    (apply values (reverse!
+     (let lp ((ls '())
+             (i i))
+       (if (> i j)
+           ls
+           (if (eq? #nil (index array i))
+               ls
+               (lp (cons (index array i) ls) (+ i 1)))))))))
+
+;; _VERSION
+;; contains a string describing the lua version
+(define-global _VERSION "Guile/Lua 5.1")
+
+(define-global (xpcall f err)
+  (catch #t
+         (lambda () (values #t (f)))
+         (lambda args (values #f (err args)))))
+
+;;; MODULE SYSTEM
+
+;; package
+(define-global package (make-table))
+
+;; package.cpath
+(new-index! package "cpath" (or (get-environment-variable "LUA_CPATH")
+                                "./?.so;/usr/lib/lua/5.1/?.so;/usr/lib/lua/5.1/loadall.so"))
+;; package.loaded
+(define loaded (make-table))
+(new-index! package "loaded" loaded)
+
+;; package.loaders
+(define loaders (make-table))
+(new-index! package "loaders" loaders)
+
+;; package.loadlib
+(new-index! package "loadlib" (lambda (lib func . _) (runtime-error "loadlib not implemented")))
+
+;; package.path
+(new-index! package "path" (or (get-environment-variable "LUA_PATH") "./?.lua;/usr/share/lua/5.1/?.lua;/usr/share/lua/5.1/?/init.lua;/usr/lib/lua/5.1/?.lua;/usr/lib/lua/5.1/?/init.lua"))
+
+;; package.preload
+(define preload (make-table))
+(new-index! package "preload" preload)
+
+;; package.seeall
+(new-index! package "seeall" (lambda (module . _) (runtime-error "seeall unimplemented")))
+
+;; arg
+;; command line argument table
+(define arg (make-table))
+(let lp ((rest (command-line))
+         (i 0))
+  (new-index! arg i (car rest))
+  (if (not (null? (cdr rest)))
+      (lp (cdr rest) (1+ i))))
+
+;; require
+(define (register-loaded-module name table)
+  (rawset *global-env-table* name table)
+  (rawset loaded name table))
+
+(define (module-exists? name)
+  (if (module-public-interface (resolve-module name))
+      #t
+      #f))
+
+(define-global (require module-name . _)
+  (assert-type 1 "require" "string" module-name string?)
+  ;; try to load module, if it's not already loaded
+  (if (not (hash-table-exists? (table-slots loaded) module-name))
+      (let* ((std-module-name `(language lua standard ,(string->symbol module-name))))
+        (if (module-exists? std-module-name)
+            (register-loaded-module module-name (make-module-table std-module-name)))))
+
+  (if (not (hash-table-exists? (table-slots loaded) module-name))
+      (runtime-error "require failed"))
+  (rawget loaded module-name))
+

module/language/lua/spec.scm

@@ -0,0 +1,33 @@
+;;; Guile Lua --- language specification
+
+;;; 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 spec)
+  #:use-module (system base language)
+  #:use-module (language lua parser)
+  #:use-module (language lua compile-tree-il)
+  #:export (lua))
+
+(define-language lua
+  #:title "Lua"
+  #:reader (lambda (port _)
+             (if (file-port? port)
+                 (read-lua port)))
+  #:compilers `((tree-il . ,compile-tree-il))
+  #:printer write)

module/language/lua/standard/io.scm

@@ -0,0 +1,185 @@
+;;; Guile Lua --- io standard library
+
+;;; 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 standard io)
+  #:use-module (language lua runtime)
+
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (rnrs control))
+
+;; io.file:read
+
+;; metatable for file objects
+(define file (make-table))
+
+(rawset file '__index
+        (lambda (self key)
+          (rawget file key)))
+
+(define stdin (current-input-port))
+(define stdout (current-output-port))
+(define stderr (current-error-port))
+
+(define* (close #:optional (file stdout))
+  (close-port file))
+
+(rawset file 'close
+        (lambda (self)
+          (close self)))
+
+;; lua doesn't actually have an optional flush argument, but this is more in line with everything else
+(define* (flush #:optional (file stdout))
+  (force-output file))
+
+(rawset file 'flush
+        (lambda (self)
+          (flush self)))
+
+(define* (input #:optional filename)
+  (if filename
+      (let* ((file (open filename)))
+        (set! stdin file)
+        file)
+      stdin))
+
+(define (line-iterator file auto-close?)
+  (lambda ()
+    (let* ((line (read-line file)))
+      (if (eof-object? line)
+          (begin
+            (if auto-close?
+                (close-port file))
+            #nil)
+          line))))
+
+(define* (lines #:optional filename)
+  (let* ((file (if filename (open filename) stdin)))
+    (line-iterator file (and filename))))
+
+(rawset file 'lines
+   (lambda (self)
+     (line-iterator self #f)))
+
+(define* (open filename #:optional (mode "r"))
+  (assert-string 1 "io.open" filename)
+  (assert-string 2 "io.open" mode)
+  (let* ((handle (open-file filename mode)))
+    (register-userdata! handle file)
+    handle))
+
+(define* (output #:optional filename)
+  (if filename
+      (let* ((file (open filename "w")))
+        (set! stdout file)
+        file)
+      stdout))
+
+(define* (popen prog #:optional (mode "r"))
+  (assert-string 2 "io.popen" mode)
+  (open-pipe
+   prog
+   (if (string=? mode "w") OPEN_WRITE OPEN_READ)))
+
+(define (default-read port)
+  (if (eof-object? (peek-char port))
+      #nil
+      (read-line port)))
+
+(rawset file 'read
+   (lambda (self . formats)
+     (if (null? formats)
+         (default-read self)
+         (apply
+          values
+          (map
+           (lambda (self . formats)
+             (unless (or (number? format) (string? format))
+               (runtime-error "'file:read' expects a string or number as format argument, but got ~a" format))
+             (if (number? format)
+                 (if (eof-object? (peek-char self))
+                     #nil
+                     (let lp ((out (open-output-string))
+                              (i format))
+                       (if (= i 0)
+                           (get-output-string out)
+                           (let ((c (read-char self)))
+                             (if (eof-object? self)
+                                 (get-output-string out)
+                                 (begin
+                                   (write-char c out)
+                                   (lp out (- i 1))))))))
+
+                 (let* ((format-length (string-length format))
+                        (c1 (if (> format-length 0) (string-ref format 0) #f))
+                        (c2 (if (> format-length 1) (string-ref format 1) #f)))
+                   (cond ((eq? c2 #\n) (runtime-error "'file:read' number reading is not yet supported"))
+                         ((eq? c2 #\a)
+                          (if (eof-object? (peek-char self))
+                              #nil
+                              (let lp ((out (open-output-string)))
+                                (let ((c (read-char self)))
+                                  (if (eof-object? c)
+                                      (get-output-string out)
+                                      (begin
+                                        (write-char c out)
+                                        (lp out)))))))
+                         ((eq? c2 #\l)
+                          (default-read self))
+                         (else
+                          (runtime-error "file:read does not understand format ~a" format))))))
+          formats)))))
+
+(rawset file 'seek
+  (lambda* (self #:optional (whence "cur") (offset 0))
+    (assert-string 1 "file:seek" whence)
+    (assert-number 2 "file:seek" offset)
+    (seek self offset
+          (cond ((string=? whence "cur") SEEK_CUR)
+                ((string=? whence "set") SEEK_SET)
+                ((string=? whence "end") SEEK_END)
+                (else (runtime-error "invalid 'whence' argument to 'file:seek'; expected \"cur\", \"set\", or \"end\""))))))
+
+(rawset file 'setvbuf
+   (lambda* (self mode #:optional size)
+     (assert-string 1 "file:setvbuf" mode)
+     (let* ((translated-mode
+             (cond ((string=? mode "no") _IONBF)
+                   ((string=? mode "line") _IOLBF)
+                   ((string=? mode "full") _IOFBF))))
+       (if size
+           (setvbuf self mode)
+           (setvbuf self mode size)))))
+
+(rawset file 'write
+  (lambda* (self . args)
+    (for-each
+      (lambda (arg)
+        (unless (or (string? arg) (number? arg))
+          (runtime-error "'file:write' expects string or number as argument but got '~a'" arg))
+        (display arg self))
+      args)))
+
+(define (type obj)
+  (if (port? obj)
+      (if (port-closed? obj)
+          "closed"
+          "file")
+      #nil))

module/language/lua/standard/math.scm

@@ -0,0 +1,136 @@
+;;; Guile Lua --- math standard library
+
+;;; 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 standard math)
+  #:use-module (language lua runtime))
+
+;; TODO: math.modf
+;; TODO: math.deg,rad,frexp,random not tested
+
+;; NOTE: as opposed to lua, math.sqrt accepts negative arguments, as
+;; guile's numeric tower is capable of representing complex numbers
+
+(define huge +inf.0)
+(define *nan* (nan))
+(define pi 3.14159265358979323846)
+(define radians_per_degree (/ pi 180.0))
+
+(letrec-syntax
+    ((wrap-builtins
+      (syntax-rules (rename rename2 variable-arity)
+        ;; we must know the arity of the wrapped procedure because lua ignores superfluous arguments whereas it is an error in scheme
+
+        ;; simple wrap with new name and 1 argument
+        ((_ () (rename guile-name lua-name))
+         (define (lua-name a . _)
+           ((@ (guile) guile-name) a)))
+
+        ((_ () (rename2 guile-name lua-name))
+         (define (lua-name a b . _)
+           ((@ (guile) guile-name) a b)))
+
+        ;; simple wrap with 2 arguments
+        ((_ () (2 name))
+         (define (name a b . _)
+           ((@ (guile) name) a b)))
+
+        ;; simple wrap with variable arguments
+        ((_ () (variable-arity name))
+         (define (name . _)
+           (apply (@ (guile) name) _)))
+
+        ;; simple wrap with 1 argument
+        ((_ () name)
+         (define (name a . _)
+           ((@ (guile) name) a)))
+
+        ;; 1) take all input and pass it to subtransformers
+        ((_ subform ...)
+         (begin
+           (wrap-builtins () subform)
+           ...)))))
+  (wrap-builtins
+   abs
+   acos
+   asin
+   atan
+   (rename ceiling ceil)
+   cos
+   cosh
+   exp
+   (rename2 remainder modf)
+   floor
+   log
+   log10
+   sin
+   sinh
+   sqrt
+   (variable-arity max)
+   (variable-arity min)
+   (rename expt pow)
+   tan
+   tanh))
+
+(define (atan2 x y)
+  (atan (/ x y)))
+
+;; copy the global random state for this module so we don't mutate it
+(define randomstate (copy-random-state *random-state*))
+
+(define (randomseed seed . _)
+  (set! randomstate (seed->random-state seed)))
+
+(define* (random #:optional m n #:rest _)
+  ;; this can be a little confusing because guile's random number
+  ;; generator only allows [0, N) but we need [0,1), [1,m] and [m,n]
+  (cond ((and (not m) (not n)) ((@ (guile) random) 1.0))
+        ;; this is really [1,M)
+        ((and m) (+ 1 ((@ (guile) random) m)))
+        ((and m n) (+ m ((@ (guile) random) n)))
+        (else (error #:RANDOM "should not happen"))))
+
+(define (deg x)
+  (/ x radians_per_degree))
+
+(define (rad x)
+  (* x radians_per_degree))
+
+(define (ldexp x exp)
+  (cond ((= exp 0) x)
+        ((= exp *nan*) *nan*)
+        ((= exp +inf.0) +inf.0)
+        ((= exp -inf.0) -inf.0)
+        (else (* x (expt 2 exp)))))
+
+(define log2
+  (let ((log2 (log 2)))
+    (lambda (x)
+      (/ (log x) log2))))
+
+(define (frexp x)
+  (if (zero? x)
+      0.0
+      (let* ((l2 (log2 x))
+             (e (floor (log2 x)))
+             (e (if (= l2 e)
+                    (inexact->exact e)
+                    (+ (inexact->exact e) 1)))
+             (f (/ x (expt 2 e))))
+        f)))

module/language/lua/standard/os.scm

@@ -0,0 +1,108 @@
+;;; Guile Lua --- os standard library
+
+;;; 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 standard os)
+  #:use-module (language lua runtime)
+
+  #:use-module (srfi srfi-98))
+
+(define (clock)
+  (tms:clock (times)))
+
+(define* (date #:optional (format "%c") time)
+  (let* ((utc? (eq? (string-ref format 0) #\!))
+         ;; skip !
+         (format (if utc? (string-copy format 1) format))
+         (stm ((if utc? gmtime localtime) (or time (current-time)))))
+    (if time
+        (begin
+          (assert-number 2 "date" time)
+          (if (string=? format "*t")
+              (let* ((table (make-table)))
+                (rawset table "sec" (tm:sec stm))
+                (rawset table "min" (tm:min stm))
+                (rawset table "hour" (tm:hour stm))
+                (rawset table "month" (+ 1 (tm:mon stm)))
+                (rawset table "year" (+ 1900 (tm:year stm)))
+                (rawset table "wday" (+ 1 (tm:wday stm)))
+                (rawset table "yday" (+ 1 (tm:yday stm)))
+                (rawset table "isdst" (> (tm:isdst stm) 0))
+                table)
+              (strftime format stm)))
+        (strftime format stm))))
+
+(define (difftime t2 t1)
+  (- t2 t1))
+
+(define* (execute #:optional command)
+  (if (not command)
+      1
+      (system command)))
+
+(define* (exit #:optional (code 0))
+  (primitive-exit code))
+
+(define (getenv varname)
+  (or (get-environment-variable varname) #nil))
+
+(define rename rename-file)
+
+(define (remove filename)
+  (if (file-is-directory? filename)
+      (rmdir filename)
+      (delete-file filename)))
+
+(define* (setlocale locale #:optional (category "all"))
+  (assert-string 2 "setlocale" category)
+  ((@ (guile) setlocale)
+   locale
+   (cond ((string=? category "all") LC_ALL)
+         ((string=? category "collate") LC_COLLATE)
+         ((string=? category "ctype") LC_CTYPE)
+         ((string=? category "messages") LC_MESSAGES)
+         ((string=? category "monetary") LC_MONETARY)
+         ((string=? category "numeric") LC_NUMERIC)
+         ((string=? category "time") LC_TIME))))
+
+(define* (time #:optional table)
+  (if table
+      (begin
+        (assert-table 1 "time" table)
+        (let* ((sec (get-field table "sec" 0))
+               (min (get-field table "min" 0))
+               (hour (get-field table "hour" 12))
+               (day (get-field table "day" -1))
+               (month (- (get-field table "month" -1) 1))
+               (year (- (get-field table "year" -1) 1900))
+               (isdst (get-field table "isdst" 0))
+               (result (make-vector 11 0)))
+          (set-tm:sec result sec)
+          (set-tm:min result min)
+          (set-tm:hour result hour)
+          (set-tm:mday result day)
+          (set-tm:mon result month)
+          (set-tm:year result year)
+          (set-tm:isdst result isdst)
+          (set-tm:zone result "")
+          (car (mktime result)))
+          )
+      (current-time)))
+
+(define tmpname mkstemp!)

module/language/lua/standard/table.scm

@@ -0,0 +1,103 @@
+;;; Guile Lua --- table standard library
+
+;;; 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 standard table)
+  #:use-module (language lua common)
+  #:use-module (language lua runtime)
+
+  #:use-module (rnrs control)
+  #:use-module ((srfi srfi-1) #:select (filter!))
+  #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-16)
+  #:use-module ((srfi srfi-69) #:select (hash-table-size hash-table-keys))
+)
+
+;; TODO - insert, remove, sort
+
+(define (add-field! table buffer i)
+  (define string (rawget table i))
+  (unless (string? string)
+    (runtime-error "invalid value (~a) at index ~a in table for concat; expected string" string i))
+  (display string buffer))
+
+(define* (concat table #:optional (sep "") (i 1) (%last #f) #:rest _)
+  (define buffer (open-output-string))
+  (assert-table 1 "concat" table)
+  (let* ((ht (table-slots table))
+         (last (if (not %last) (table-length table) %last)))
+    (let lp ((i i))
+      (if (< i last)
+          (begin
+            (add-field! table buffer i)
+            (display sep buffer)
+            (lp (+ i 1)))
+          (when (= i last)
+            (add-field! table buffer i)))))
+  (get-output-string buffer))
+
+;; Arguments are named a1 and a2 because confusingly, the middle argument is optional
+;; table.insert(table, [pos,] value)
+(define (insert table . arguments)
+  (assert-table 1 "insert" table)
+  (receive
+   (pos value)
+   (apply
+    (case-lambda
+      ((value)
+       (values (table-length table) value))
+      ((pos value)
+       (assert-number 1 "insert" pos)
+       (let* ((length (table-length table))
+              (e (if (> pos length) pos length)))
+         (let lp ((i e))
+           (when (> i pos)
+             (rawset table i (rawget table (- i 1)))
+             (lp (- i 1))))
+       (values pos value)))
+      (else
+       (runtime-error "wrong number of arguments to 'insert'")))
+    arguments)
+   (rawset table pos value)))
+
+(define (maxn table . _)
+  (assert-table 1 "maxn" table)
+  (let* ((result (sort! (filter! number? (hash-table-keys (table-slots table))) >)))
+    (if (null? result)
+        0
+        (car result))))
+
+(define* (remove table #:optional pos)
+  (assert-table 1 "remove" table)
+  (let* ((e (table-length table)))
+    (unless pos (set! pos (table-length table)))
+    (assert-number 2 "remove" pos)
+    (if (eq? (table-length table) 0)
+        0
+        (let* ((result (rawget table pos)))
+          (let lp ((pos pos))
+            (if (< pos e)
+                (begin
+                  (rawset table pos (rawget table (+ pos 1)))
+                  (lp (+ pos 1)))
+                (rawset table pos #nil)))
+          result))))
+
+(define (sort . rest)
+  (runtime-error "table.sort UNIMPLEMENTED"))

test-suite/Makefile.am

@@ -69,6 +69,10 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/keywords.test			\
 	    tests/list.test			\
 	    tests/load.test			\
+	    tests/lua-eval.test			\
+	    tests/lua-eval-2.test		\
+	    tests/lua-lexer.test		\
+	    tests/lua-standard-library.test	\
 	    tests/match.test			\
 	    tests/match.test.upstream		\
 	    tests/modules.test			\

test-suite/tests/lua-eval-2.test

@@ -0,0 +1,112 @@
+;;;; lua-eval-2.test --- basic tests for builtin lua constructs, act II  -*- mode: scheme -*-
+;;;;
+;;;; 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
+
+(define-module (test-lua)
+  #:use-module (ice-9 format)
+  #:use-module (language tree-il)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-8)
+  #:use-module (system base compile)
+  #:use-module (test-suite lib)
+
+  #:use-module (language lua parser)
+
+  )
+
+(with-test-prefix "lua-eval"
+  (define (from-string string)
+    (compile ((make-parser (open-input-string string)))
+             #:from 'lua
+             #:to 'value))
+  (letrec-syntax
+    ((test
+      (syntax-rules ()
+        ((_ string expect)
+         (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect)))
+        ((_ string)
+         (test string #t)))))
+
+    ;; tables
+    (test "a={}; return a[0]" #nil)
+    (test "a={true}; return a[1]" #t)
+    (test "a = { false , true } ; return a[2];" #t)
+    (test "a = { false ; true ; } ; return a[2];" #t)
+    (test "a = { b = true }; return a.b" #t)
+    (test "a = { a = false , false ; b = true , true ; }; return a.b" #t)
+    (test "a = { a = false , false ; b = true , true ; }; return a[2]" #t)
+
+    ;; locals
+    (test "local a; a = true; return a")
+    (test "local a = true; return a")
+    (test "local a,b=false,true; return b")
+    (test "local a,b,c=false,true,false; return b")
+    (test "local a,b,c=false,false,true; return c")
+
+    ;; local function statements
+    (test "local function identity(x) return x end; return identity(true)")
+
+    ;; metatable events
+    (test "table = {} setmetatable(table, { __add = function(a,b) return b end }) return table + 5" 5)
+    (test "table = {} setmetatable(table, { __add = function(a,b) return a end }) return 5 + table" 5)
+
+    ;; field functions
+    (test "table = {} function table.identity(x) return x end return table.identity(true)")
+
+    ;; repeat
+    (test "i=0; repeat i = i+1 until i == 5; return i" 5)
+    (test "i=5; repeat i = i-1 until i == 0; return i" 0)
+
+    ;; length operator
+    (test "return #\"asdf\"" 4)
+    (test "table = {1,2,3,4}; return #table" 4)
+
+    ;; _G
+    (test "a = true return _G.a")
+    (test "a = true return _G._G.a")
+    (test "a = true return _G._G._G.a")
+
+    ;; concat
+    (test "return \"hello\"..\" world\"" "hello world")
+
+    ;; built-in functions
+    (test "assert(true)" #t)
+    (test "print(T)" #nil)
+    (test "print(false or true)" #nil)
+    (test "table = {}; rawset(table, 0, true); return table[0]")
+    (test "table = {}; rawset(table, 0, true); return rawget(table, 0)")
+
+    ;; methods
+    (test "table = {} function table:identity() return self end return table.identity(true)")
+    (test "table = {} function table.identity(self,x) return x end return table:identity(true)")
+
+    ;; arguments default to nil
+    (test "function test(x) return x end return test()" #nil)
+
+    ;; application with freestanding string or table as argument
+    (test "print {x=5}; return true")
+    (test "print \"hello world\"; return true")
+
+    ;; variable arguments
+    #;(test "function test(...) print(...) end test(1,2)")
+
+    ;; numeric for loop
+    (test "for x = 1,2,1 do print(true) end return true")
+
+    ;; list for loop, and ipairs
+    (test "table = {1,2,3} for i,v in ipairs(table) do print(i,v) end return true")
+  ))

test-suite/tests/lua-eval.test

@@ -0,0 +1,115 @@
+;;;; lua-eval.test --- basic tests for builtin lua constructs  -*- mode: scheme -*-
+;;;;
+;;;; 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
+
+(define-module (test-lua)
+  #:use-module (ice-9 format)
+  #:use-module (language tree-il)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-8)
+  #:use-module (system base compile)
+  #:use-module (test-suite lib)
+
+  #:use-module (language lua parser)
+
+  )
+
+(with-test-prefix "lua-eval"
+  (define (from-string string)
+    (compile ((make-parser (open-input-string string)))
+             #:from 'lua
+             #:to 'value))
+  (letrec-syntax
+    ((test
+      (syntax-rules ()
+        ((_ string expect)
+         (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect)))
+        ((_ string)
+         (test string #t)))))
+
+    (test "return true")
+    (test "return false" #f)
+    (test "return nil" #nil)
+    (test "return 12345" 12345)
+    (test "return 12345.6789" 12345.6789)
+    (test "return \"string\"" "string")
+    (test "return (true)")
+    (test "return (false == false)")
+    (test "return;" *unspecified*)
+    (test "return [[string]]" "string")
+    (test "return [=[string]=]" "string")
+
+    ;; exercise the operator precedence parser
+    (test "return 2" 2)
+    (test "return 2 + 2" 4)
+    (test "return 1 + 2 * 3" 7)
+    (test "return 1 * 2 + 3" 5)
+    (test "return 1 + 2 ^ 3 * 4 - 5" 28)
+    (test "return 1 ^ 2 - 3 * 4 + 5" -6)
+    (test "return 1 + -6" -5)
+
+    ;; logical operators
+    (test "return false or true")
+    (test "return true or false")
+    (test "return false or false or true")
+    (test "return false or nil and true" #nil)
+    (test "return true and true")
+    (test "return true and nil" #nil)
+    (test "return true and false and nil" #f)
+
+    ;; conditionals
+    (test "if true then return true end")
+    (test "if false then return false else return true end")
+    (test "if true then return true else return false end")
+    (test "if false then return false elseif true then return true elseif false then return false else return false end")
+    (test "if false then return false elseif false then return false elseif true then return true else return false end")
+    (test "if false then return false elseif false then return false elseif false then return false else return true end")
+
+    ;; function expressions
+    (test "(function(x) return x end)(true)")
+
+    ;; undefined variables are implicitly nil
+    (test "return undefined == nil")
+    (test "return undefined ~= nil" #f)
+
+    ;; assignments
+    (test "variable = true; return variable")
+    (test "a,b = 1,2; return a" 1)
+    (test "a,b=1,2;return b" 2)
+    (test "a,b,c=false,true,false; return b")
+    (test "a,b=1;return b" #nil)
+
+    ;; function statements
+    (test "function noargs() return true end noargs()")
+    (test "function identity(x) return x end return identity(21)" 21)
+    (test "function fib(n) if n < 2 then return n else return fib(n-1) + fib(n-2) end end return fib(20)" 6765)
+    (test "function fib(n) if n < 2 then return n else return fib(n-1) + fib(n-2) end end return fib(20)" 6765)
+
+    ;; do
+    (test "do return true end")
+    (test "do if false then return false elseif false then return false elseif false then return false else return true end end")
+
+    ;; parenthetical expressions
+    (test "return (true);")
+    (test "return (2 + (2))" 4)
+
+    ;; while
+    (test "while true do return true end")
+    (test "i=0; while i<5 do i=i+1 end return i" 5)
+    (test "while true do do break end return false end return true")
+
+  ))

test-suite/tests/lua-lexer.test

@@ -0,0 +1,75 @@
+;;;; lua-lexer.test --- lua lexer test suite  -*- mode: scheme -*-
+;;;;
+;;;; 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
+
+(define-module (test-lua-lexer)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-8)
+  #:use-module (test-suite lib)
+
+  #:use-module (language lua lexer))
+
+(with-test-prefix "lua-lexer"
+  (define (from-string string)
+    (define-lua-lexer get-source-info lex)
+    (call-with-input-string
+     string
+     (lambda (port)
+
+       (initialize-lua-lexer! port get-source-info lex)
+       (lex))))
+
+  (let-syntax
+    ((test
+      (syntax-rules (eof)
+        ((_ string expect)
+         (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect)))
+        ((_ (eof string))
+         (pass-if (format "~a => #<eof>" string) (eof-object? (from-string string)))))))
+
+    (test (eof " "))
+    (test (eof "-- comment"))
+    (test (eof "--[[long
+comment]]"))
+
+    (test "[[long string]]" "long string")
+    (test "[=[[==[longer string]==]]=]" "[==[longer string]==]")
+
+    ;; numbers
+    (test "12345" 12345)
+    (test "12345.6789" 12345.6789)
+    (test "12.34e5" 1234000.0)
+    (test ".34e5" 34000.0)
+
+    ;; string escapes
+    (test "'\\a\\b\\f\\n\\r\\t\\v'"
+          "\a\b\f\n\r\t\v")
+    (test "'\\''"
+          "'")
+
+    ;; operators, keywords, identifiers
+    (test "name" 'name)
+    (test "return" #:return)
+    (test ".." #:concat)
+    (test "..." #:dots)
+    (test ";" #\;)
+    (test "-" #\-)
+    (test "+" #\+)
+    (test "/" #\/)
+    (test "*" #\*)
+
+))

test-suite/tests/lua-standard-library.test

@@ -0,0 +1,77 @@
+;;;; lua standard library test    -*- mode: scheme -*-
+;;;;
+;;;; 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
+
+(define-module (test-lua)
+  #:use-module (ice-9 format)
+  #:use-module (language tree-il)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-8)
+  #:use-module (system base compile)
+  #:use-module (test-suite lib)
+
+  #:use-module (language lua parser)
+
+  )
+
+(define (from-string string)
+  (compile ((make-parser (open-input-string string)))
+           #:from 'lua
+           #:to 'value))
+
+(define-syntax
+  test
+  (syntax-rules ()
+    ((_ string expect)
+     (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect)))
+    ((_ string)
+     (test string #t))))
+
+(with-test-prefix "lua-builtin"
+  (test "assert(true)")
+  (test "rawequal(true,true)")
+  (test "return tonumber('2')" 2)
+)
+
+(with-test-prefix "lua-math"
+  (test "require 'math'; return true")
+  (test "return math.abs(-1)" 1)
+  (test "return math.asin(1)" (asin 1))
+  (test "return math.acos(5)" (acos 5))
+  (test "return math.atan(2/1)" (atan (/ 2 1)))
+  (test "return math.atan2(2,1)" (atan (/ 2 1)))
+  (test "return math.ceil(0.5)" (ceiling 0.5))
+  (test "return math.cos(1)" (cos 1))
+  (test "return math.cosh(1)" (cosh 1))
+  (test "return math.floor(0.5)" (floor 0.5))
+  (test "return math.log(10)" (log 10))
+  (test "return math.log10(5)" (log10 5))
+  (test "return math.sqrt(4)" (sqrt 4))
+  (test "return math.sin(5)" (sin 5))
+  (test "return math.sinh(5)" (sinh 5))
+  (test "return math.tan(5)" (tan 5))
+  (test "return math.tanh(5)" (tanh 5))
+  (test "return math.ldexp(4,3)" 32)
+  (test "return math.modf(6,4)" 2)
+  )
+
+(with-test-prefix "lua-table"
+  (test "require 'table'; return true")
+  (test "t = {}; t[1] = true; t[555] = true; t[1234] = true; return table.maxn(t)" 1234)
+  (test "return table.concat({\"1\", \"2\", \"3\"}, \" \")" "1 2 3")
+  (test "t = {}; t[1] = true; t[2] = false; table.insert(t, 2, true); return t[2]")
+)