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