mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 04:40:29 +02:00
Code Activity

add lua language implementation

Browse source 
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.
This commit is contained in:
No Itisnt 2010-06-03 03:12:41 -05:00 • committed by Ian Price
parent 6871327742
commit a30c18c22a
16 changed files with 3242 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

13
module/Makefile.am
View file

@ -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 \

50
module/language/lua/common.scm Normal file
View file

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

398
module/language/lua/compile-tree-il.scm Normal file
View file

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

335
module/language/lua/lexer.scm Normal file
View file

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

892
module/language/lua/parser.scm Normal file
View file

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

606
module/language/lua/runtime.scm Normal file
View file

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

33
module/language/lua/spec.scm Normal file
View file

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

185
module/language/lua/standard/io.scm Normal file
View file

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

136
module/language/lua/standard/math.scm Normal file
View file

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

108
module/language/lua/standard/os.scm Normal file
View file

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

103
module/language/lua/standard/table.scm Normal file
View file

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

4
test-suite/Makefile.am
View file

@ -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 \

112
test-suite/tests/lua-eval-2.test Normal file
View file

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

115
test-suite/tests/lua-eval.test Normal file
View file

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

75
test-suite/tests/lua-lexer.test Normal file
View file

@ -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 "*" #\*)
))

77
test-suite/tests/lua-standard-library.test Normal file
View file

@ -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]")
)