diff --git a/module/Makefile.am b/module/Makefile.am index 0e6fdf67d..b0ef70bce 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -71,6 +71,7 @@ SOURCES = \ $(SCRIPTS_SOURCES) \ $(ECMASCRIPT_LANG_SOURCES) \ $(ELISP_LANG_SOURCES) \ + $(LUA_LANG_SOURCES) \ $(BRAINFUCK_LANG_SOURCES) \ $(LIB_SOURCES) \ $(WEB_SOURCES) @@ -175,6 +176,18 @@ ELISP_LANG_SOURCES = \ language/elisp/runtime/value-slot.scm \ language/elisp/spec.scm +LUA_LANG_SOURCES = \ + language/lua/common.scm \ + language/lua/runtime.scm \ + language/lua/lexer.scm \ + language/lua/parser.scm \ + language/lua/compile-tree-il.scm \ + language/lua/standard/io.scm \ + language/lua/standard/math.scm \ + language/lua/standard/os.scm \ + language/lua/standard/table.scm \ + language/lua/spec.scm + BRAINFUCK_LANG_SOURCES = \ language/brainfuck/parse.scm \ language/brainfuck/compile-scheme.scm \ diff --git a/module/language/lua/common.scm b/module/language/lua/common.scm new file mode 100644 index 000000000..e68f1dda8 --- /dev/null +++ b/module/language/lua/common.scm @@ -0,0 +1,50 @@ +;;; Guile Lua --- common lua functionality + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua common) + + #:use-module (ice-9 format) + + #:export (syntax-error or-eqv?)) + +(define (syntax-error src string . arguments) + "Throw an error tagged with 'lua-syntax, and print detailed source +code information when available. STRING and ARGUMENTS are given to FORMAT." + (throw 'lua-syntax + (string-append + (if src + (format #f "~a@~a.~a" + (cdr (assq 'filename src)) + (cdr (assq 'line src)) + (if (assq 'column src) + (cdr (assq 'column src)) + "[no column available]")) + "[no source code information given]") + ": " + (apply format (cons string arguments))))) + +;; I was using CASE, but this is more succinct +;; (or-eqv? 1 #f 1) => (or (eqv? 1 #f) (eqv? 1 1)) +(define-syntax or-eqv? + (syntax-rules () + ((_ test '(value ...)) + (or (eqv? test 'value) ...)) + ((_ test value ...) + (or (eqv? test value) ...)))) diff --git a/module/language/lua/compile-tree-il.scm b/module/language/lua/compile-tree-il.scm new file mode 100644 index 000000000..9999797ac --- /dev/null +++ b/module/language/lua/compile-tree-il.scm @@ -0,0 +1,398 @@ +;;; Guile Lua --- compiler + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua compile-tree-il) + #:use-module (language tree-il) + #:use-module ((srfi srfi-1) #:select (map!)) + #:use-module (srfi srfi-39) + #:use-module ((system base syntax) #:select (record-case)) + #:use-module (rnrs control) + + #:use-module (language lua common) + #:use-module (language lua parser) + #:use-module (language lua runtime) + + #:export (compile-tree-il)) + +;; utilities + +(define *runtime-name* '(language lua runtime)) +(define no-arguments '(() #f #f #f () ())) + + +(define (ref-runtime src name) + (make-module-ref src *runtime-name* name #t)) + +(define (make-runtime-application src name arguments) + "Apply a function in the (language lua runtime) module" + (make-application src (ref-runtime src name) arguments)) + +(define (make-lua-conditional src condition then else) + "Generate a conditional with (@ (language lua runtime) true?)" + (make-conditional src (make-runtime-application src 'true? (list condition)) then else)) + +(define (make-table-ref src table index) + (make-runtime-application src 'index + (list table (if (symbol? index) (make-const src (symbol->string index)) index)))) + +(define (make-table-set! src table index exp) + (make-runtime-application src 'new-index! + (list table (if (symbol? index) (make-const src (symbol->string index)) index) exp))) + +(define (apply-named-lua-function src name get-body) + (let* ((name (gensym (string-append " " name))) + (parameters (list name))) + (make-application + src + (make-module-ref src '(guile) 'catch #t) + (list + (make-const src 'lua-break) + (make-argless-lambda src + (make-let + src + parameters parameters + (list (make-lambda src '() (get-body name))) + (make-application src (make-lexical-ref src name name) '()))) + (make-arg-ignoring-lambda src + (make-void src)))))) + +(define (while-loop->tree-il src condition body) + "Create a WHILE loop, used by both WHILE and REPEAT." + (apply-named-lua-function + src "while" + (lambda (loop) + (make-lua-conditional + src + condition + (make-sequence src + (list body (make-application src (make-lexical-ref src loop loop) '()))) + (make-void src))))) + +;; calling conventions +(define (make-plain-lambda-case src args gensyms body . alternate) + (make-lambda-case src args #f #f #f '() (or gensyms args) body (and (not (null? alternate)) (car alternate)))) + +(define (make-plain-lambda src args gensyms body . alternate) + (make-lambda src '() (apply make-plain-lambda-case (append (list src args gensyms body) alternate)))) + +(define (make-arg-ignoring-lambda src body) + (make-lambda src '() (make-lambda-case src '() #f '_ #f '() (list (gensym "_")) body #f))) + +(define (make-argless-lambda src body) + (make-plain-lambda src '() #f body)) + +(define (adjust-to-single-value src exp) + "adjust an expression so that it only returns one result; the rest are dropped silently" + (define value-gensym (gensym "%value")) + (define adjust-gensym (gensym "%adjust")) + (make-letrec src + #t + '(%adjust) + (list adjust-gensym) + (list + (make-plain-lambda + src + '(%value) + (list value-gensym) + (make-lexical-ref src '%value value-gensym))) + (make-application + src + (make-primitive-ref src 'call-with-values) + (list (make-argless-lambda src exp) (make-lexical-ref src '%adjust adjust-gensym))))) + +;; main compiler + +(define context (make-parameter #f)) + +(define* (compile exp #:optional last-in-list?) + (define* (map-compile exps #:optional care-about-last?) + (let lp ((ls exps) + (tree '())) + (if (null? ls) + (reverse! tree) + (lp (cdr ls) (cons (compile (car ls) (and care-about-last? (null? (cdr ls)))) tree))))) + + (record-case exp + ((ast-sequence src exps) + (if (null? exps) + (make-void src) + (make-sequence src (map-compile exps)))) + + ((ast-literal src exp) + (if (eq? exp *unspecified*) + (make-void src) + (make-const src exp))) + + ((ast-return src exp) + (make-application src (make-primitive-ref src 'return) + (list (make-application src + (make-primitive-ref src 'values) + (if (list? exp) (map-compile exp #t) (list (compile exp))))))) + + ((ast-function src name arguments argument-gensyms variable-arguments? body) + ;; ... is always attached because lua functions must ignore + ;; variable arguments; the parser will catch it if ... is used in a + ;; function that doesn't have ... in the parameter list + (make-lambda src (if name `((name . ,name)) '()) (make-lambda-case src '() arguments '... #f (map (lambda (x) (make-const src #nil)) arguments) (append! argument-gensyms (list '...)) (compile body) #f))) + + ((ast-function-call src operator operands) + #| (let* ((proc (compile operator)) + (args (make-application src (make-primitive-ref src 'list) (map-compile operands))) + (app-args (make-application src (make-primitive-ref src 'list) (list proc args))) + (app (make-application src (make-primitive-ref src 'apply) (list (make-primitive-ref src 'apply) app-args)))) |# + (let* ((proc (compile operator)) + (app (make-application src proc (map-compile operands)))) + (if (ast-global-ref? operator) + (make-sequence src (list + (make-application src (make-module-ref src '(language lua runtime) 'check-global-function #t) + (list (make-const src (ast-global-ref-name operator)) + proc)) + app)) + app))) + + ((ast-local-block src names gensyms initial-values exp) + (make-let src names gensyms (map-compile initial-values) (compile exp))) + + ((ast-local-ref src name gensym) + (make-lexical-ref src name gensym)) + + ((ast-local-set src name gensym exp) + (make-lexical-set src name gensym (compile exp))) + + ((ast-global-ref src name) + (make-table-ref src (ref-runtime src '*global-env-table*) name)) + + ((ast-global-set src name exp) + (make-table-set! src (ref-runtime src '*global-env-table*) name (compile exp))) + + ((ast-table-ref src table key) + (make-table-ref src (compile table) (compile key))) + + ((ast-table-set src table key exp) + (make-table-set! src (compile table) (compile key) (compile exp))) + + ((ast-condition src test then else) + (make-conditional src (compile test) (compile then) (compile else))) + + ((ast-while-loop src condition body) + (parameterize + ((context 'while-loop)) + (while-loop->tree-il src (compile condition) (compile body)))) + + ;; TODO: in order for this to have the same semantics as lua, all + ;; potential subforms of while should introduce their own context, + ;; so you can't use break inside of a function inside a while loop + ;; for instance + ((ast-break src) + (unless (or-eqv? (context) 'while-loop 'list-for-loop 'numeric-for-loop) + (syntax-error src "no loop to break")) + (make-application src (make-module-ref src '(guile) 'throw #t) (list (make-const src 'lua-break))) + ) + + ((ast-list-for-loop src names gs-names exps body) + (let* ((gs-iterator (gensym "iterator")) + (gs-state (gensym "state")) + (gs-variable (gensym "variable")) + (gs-iterator2 (gensym "iterator")) + (gs-state2 (gensym "state")) + (gs-variable2 (gensym "variable")) + (gs-loop (gensym "loop"))) + (parse-tree-il + `(letrec* + ;; names + (iterator state variable loop) + ;; gensyms + (,gs-iterator ,gs-state ,gs-variable ,gs-loop) + ;; vals + ((void) (void) (void) + (lambda () + (lambda-case + (,no-arguments + (begin + ;; even more complicated, assigning the values to the loop variables + (apply (primitive call-with-values) + (lambda () (lambda-case (,no-arguments (apply (lexical iterator ,gs-iterator) (lexical state ,gs-state) (lexical variable ,gs-variable))))) + (lambda () (lambda-case ((,names #f #f #f () ,gs-names) + ;; almost to the actual loop body, hang in there + (begin + (set! (lexical variable ,gs-variable) (lexical ,(car names) ,(car gs-names))) + (if (apply (primitive eq?) (lexical variable ,gs-variable) (const #nil)) + (apply (@ (guile) throw) (const lua-break)) + (void)) + ,(parameterize ((context 'list-for-loop)) (unparse-tree-il (compile body))) + (apply (lexical loop ,gs-loop)))))))))))) + ;; initialize variables and start loop + (begin + (apply (primitive call-with-values) + (lambda () (lambda-case (,no-arguments ,(unparse-tree-il (make-sequence src (map-compile exps)))))) + (lambda () (lambda-case (((iterator state variable) #f #f #f () (,gs-iterator2 ,gs-state2 ,gs-variable2)) + (begin + (set! (lexical iterator ,gs-iterator) (lexical iterator ,gs-iterator2)) + (set! (lexical state ,gs-state) (lexical state ,gs-state2)) + (set! (lexical variable ,gs-variable) (lexical variable ,gs-variable2))))))) + (apply (@ (guile) catch) + (const lua-break) + (lambda () (lambda-case (,no-arguments + (apply (lexical loop ,gs-loop))))) + (lambda () (lambda-case (((key) #f #f #f () (,(gensym "key"))) (void)))))))))) + + ;; TODO: in order for this to have the same semantics as lua, all + ;; potential subforms of while should introduce their own context, + ;; so you can't use break inside of a function inside a while loop + ;; for instance + + ((ast-numeric-for-loop src named initial limit step body) + ;; as per 5.1 manual 2.4.5, the numeric for loop can be decomposed into simpler forms + ;; still doesn't have proper behavior, should be able to return and break inside a loop + (let* ((gs-named (gensym (symbol->string named))) + (gs-variable (gensym "variable")) + (gs-limit (gensym "limit")) + (gs-step (gensym "step")) + (gs-loop (gensym "loop")) + (while-condition + `(if (apply (primitive >) (lexical step ,gs-step) (const 0)) + (if (apply (primitive <=) (lexical variable ,gs-variable) (lexical limit ,gs-limit)) + (apply (lexical loop ,gs-loop)) + (void)) + (void)))) + (parse-tree-il + `(letrec* + ;; names + (,named variable limit step loop) + ;; gensyms + (,gs-named ,gs-variable ,gs-limit ,gs-step ,gs-loop) + ;; vals + ,(cons + '(const #f) + (append + (map (lambda (x) `(apply (@ (language lua runtime) tonumber) ,(unparse-tree-il (compile x)))) (list initial limit step)) + ;; loop body + (list + `(lambda () + (lambda-case + ;; no arguments + ((() #f #f #f () ()) + ;; body + (begin + (set! (lexical ,named ,gs-named) (lexical variable ,gs-variable)) + ,(parameterize ((context 'numeric-for-loop)) (unparse-tree-il (compile body))) + (set! (lexical variable ,gs-variable) (apply (primitive +) (lexical variable ,gs-variable) (lexical step ,gs-step))) + ,while-condition + ))))))) + ;; body + (begin + ;; if not (var and limit and step) then error() end + (if (apply (primitive not) + (if (apply (@ (language lua runtime) true?) (lexical variable ,gs-variable)) + (if (apply (@ (language lua runtime) true?) (lexical limit ,gs-limit)) + (if (apply (@ (language lua runtime) true?) (lexical step ,gs-step)) + (const #t) + (const #f)) + (const #f)) + (const #f))) + (apply (@ (guile) error)) + (void)) + ,while-condition + ))))) + + ((ast-table-literal src fields) + (let* ((table (make-runtime-application src 'make-table '()))) + (if (not (null? fields)) + ;; if the table's fields are initialized inside of the literal, we need + ;; to store it in a variable and initialize its values + (let* ((temp-name (gensym " table")) + (names (list temp-name)) + (ref (make-lexical-ref src temp-name temp-name))) + (make-let + src + names names + (list table) + (make-sequence + src + (append! + (map + (lambda (x) + (let* ((key (compile (car x))) + (value (compile (cdr x)))) + (make-runtime-application src 'new-index! (list (make-lexical-ref src temp-name temp-name) key value)))) + fields) + (list ref))))) + ;; otherwise we can just return the fresh table + table))) + + ((ast-unary-operation src operator right) + ;; reduce simple negative numbers, like -5, to literals + (if (and (eq? operator #\-) (ast-literal? right) (number? (ast-literal-exp right))) + (make-const src (- (ast-literal-exp right))) + (make-application + src + (case operator + ((#\-) (ref-runtime src 'unm)) + ((#\#) (ref-runtime src 'len)) + ((not) (make-primitive-ref src 'not))) + (list (compile right))))) + + ((ast-binary-operation src operator left right) + (let ((left (compile left)) + (right (compile right))) + (case operator + ((#\+ #\- #\* #\/ #\^ #\< #\> #:<= #:>= #:== #:~= #:concat) + (let* ((result + (make-runtime-application + src + (case operator + ((#\+) 'add) + ((#\-) 'sub) + ((#\*) 'mul) + ((#\/) 'div) + ((#\^) 'pow) + ((#\<) 'lt) + ((#\>) 'lt) + ((#:<=) 'le) + ((#:>=) 'le) + ((#:==) 'eq) + ((#:~=) 'neq) + ((#:concat) 'concat) + (else (error #:COMPILE "unhandled binary operator" operator))) + ;; reverse order of arguments for >, >= so they can be implemented on top of <, <= + (if (or (eq? operator #\>) (eq? operator #:>=)) + (list right left) + (list left right))))) + result)) + ((#:or) + (make-lua-conditional + src + left + left + right)) + ((#:and) + (make-lua-conditional + src + left + right + left)) + (else (error #:COMPILE "unknown binary operator" operator))))) + )) + +;; exported compiler function +(define (compile-tree-il exp env opts) + (parameterize + ((context #f)) + (values (compile exp) env env))) diff --git a/module/language/lua/lexer.scm b/module/language/lua/lexer.scm new file mode 100644 index 000000000..63c4ffac0 --- /dev/null +++ b/module/language/lua/lexer.scm @@ -0,0 +1,335 @@ +;;; Guile Lua --- tokenizer + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +;; This is a simple lexer. It generally matches up Lua data types with +;; Scheme. Reserved words in Lua, like 'not', are returned as keywords, +;; like '#:not'. Operators are returned as keywords like #:==, or +;; characters like #\+ when they're only a character long. Identifiers +;; are returned as symbols +(define-module (language lua lexer) + + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-14) + #:use-module (srfi srfi-39) + + #:use-module (language lua common) + + #:export (make-lexer) + #:export-syntax (define-lua-lexer initialize-lua-lexer!)) + +(define stdout (current-output-port)) + +(define (source-info port) + `((backtrace . #f) + (filename . ,(port-filename port)) + (line . ,(port-line port)) + (column . ,(port-column port)))) + +;; Character predicates + +;; Lua only accepts ASCII characters as of 5.2, so we define our own +;; charsets here +(define (char-predicate string) + (define char-set (string->char-set string)) + (lambda (c) + (and (not (eof-object? c)) (char-set-contains? char-set c)))) + +(define is-digit? (char-predicate "0123456789")) +(define is-name-first? (char-predicate "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_")) +(define (is-name? c) (or (is-name-first? c) (is-digit? c))) +(define (is-newline? c) (and (char? c) (or (char=? c #\newline) (char=? c #\cr)))) + +(define (possible-keyword token) + "Convert a symbol to a keyword if it is a reserved word in Lua" + (if (or-eqv? token '(return function end if then elseif else true false nil or and do while repeat until local for break in not)) + (symbol->keyword token) + token)) + +(define (make-lexer port) + ;; Buffer management + (define buffer (open-output-string)) + + (define (drop-buffer) + "Clear the buffer and drop the contents" + (truncate-file buffer 0)) + + (define (clear-buffer) + "Clear the buffer and return a string of the contents" + (define string (get-output-string buffer)) + (drop-buffer) + string) + + ;; Source code information + (define saved-source-info #f) + + (define (save-source-info) + "Save source code information for a particular location e.g. the beginning +of an identifier" + (set! saved-source-info (source-info port))) + + (define (get-source-info) + "Get source code information" + (if saved-source-info + saved-source-info + (source-info port))) + + (define (save-and-next!) + "Shorthand for (write-char (read-char))" + (write-char (read-char))) + + (define (eat-comment) + "Consume a comment" + (let consume ((c (read-char))) + (cond ((eof-object? c) #f) + ((eq? c #\newline) #f) + (else (consume (read-char)))))) + + (define (get-long-string-nesting-level) + "Return the nesting level of a bracketed string, or -1 if it is not one" + (define delimiter (read-char)) + (let* ((count + (let loop ((count 0)) + (if (eq? (peek-char) #\=) + (begin + (read-char) + (loop (+ count 1))) + count)))) + (if (eq? (peek-char) delimiter) count -1))) + + (define (read-long-string string? nest) + "Read a long string or comment" + ;; Skip second bracket + (read-char) + ;; Discard initial newlines, which is what Lua does + (while (is-newline? (peek-char)) + (read-char)) + ;; Read string contents + (let loop ((c (peek-char))) + (cond + ;; Error out if end-of-file is encountered + ((eof-object? c) + (syntax-error (get-source-info) (string-append "unfinished long " (if string? "string" "comment")))) + ;; Check to see if we've reached the end + ((char=? c #\]) + (let* ((nest2 (get-long-string-nesting-level))) + (if (= nest nest2) + (begin + (read-char) ;; drop ] + (if string? + (clear-buffer) + (drop-buffer))) + ;; Compensate for eating up the nesting levels + (begin + (save-and-next!) + (let lp ((n nest2)) + (if (= n 0) + #f + (begin + (write-char #\=) + (lp (- n 1))))) + (write-char #\]) + (loop (peek-char)))))) + ;; Save character and continue + (else (save-and-next!) + (loop (peek-char)))))) + + ;; read a single or double quoted string, with escapes + (define (read-string delimiter) + (read-char) ;; consume delimiter + (let loop ((c (peek-char))) + (cond + ;; string ends early + ((or (eof-object? c) (eq? c #\cr) (eq? c #\newline)) + (syntax-error (get-source-info) "unfinished string ~S" c)) + ;; string escape + ((char=? c #\\) + ;; discard \ and read next character + (let* ((escape (begin (read-char) (read-char)))) + (write-char + (case escape + ((#\a) #\alarm) + ((#\b) #\backspace) + ((#\f) #\page) + ((#\n) #\newline) + ((#\r) #\return) + ((#\t) #\tab) + ((#\v) #\vtab) + ((#\x) (syntax-error (get-source-info) "hex escapes unsupported")) + ((#\d) (syntax-error (get-source-info) "decimal escapes unsupported")) + (else escape))) + (loop (peek-char)))) + (else + (if (eq? c delimiter) + (read-char) ;; terminate loop and discard delimiter + (begin + (save-and-next!) + (loop (peek-char))))))) + (clear-buffer)) + + (define (read-number string) + (save-source-info) + (let* ((main (string-append (or string "") (begin + (while (or (is-digit? (peek-char)) (eq? (peek-char) #\.)) + (save-and-next!)) + (clear-buffer)))) + (exponent + (if (or (eq? (peek-char) #\e) (eq? (peek-char) #\E)) + (begin + (read-char) + (if (eq? (peek-char) #\+) + (read-char) + (if (eq? (peek-char) #\-) + (save-and-next!))) + (if (not (is-digit? (peek-char))) + (syntax-error (get-source-info) "expecting number after exponent sign")) + (while (is-digit? (peek-char)) + (save-and-next!)) + (clear-buffer)) + #f)) + (final (string->number main))) + (if exponent + (* final (expt 10 (string->number exponent))) + final))) + + (define (lex) + (parameterize ((current-input-port port) + (current-output-port buffer)) + (set! saved-source-info #f) + (let loop () + (define c (peek-char)) + (case c + ;; Skip spaces + ((#\newline #\return #\space #\page #\tab #\vtab) (read-char) (loop)) + + ;; Either a minus (-), or a long comment, which is a - followed by a bracketed string + ((#\-) + (read-char) + (if (eq? (peek-char) #\-) + ;; It's a comment + (begin + (read-char) + ;; Long comment + (if (eq? (peek-char) #\[) + (let* ((nest (get-long-string-nesting-level))) + (drop-buffer) + (if (not (negative? nest)) + (begin + (read-long-string #f nest) + (drop-buffer) + (loop)) + ;; If it's not actually a long comment, drop it + (begin (drop-buffer) (eat-comment) (loop)))) + (begin (eat-comment) (loop)))) + ;; It's a regular minus + #\-)) + + ;; ~= + ((#\~) + (read-char) + (if (eq? (peek-char) #\=) + (begin (read-char) #:~=) + (syntax-error (get-source-info) "expected = after ~ but got ~c" c))) + + ;; < or <= + ((#\<) + (read-char) + (if (eq? (peek-char) #\=) (begin (read-char) #:<=) #\<)) + + ;; > or >= + ((#\>) + (read-char) + (if (eq? (peek-char) #\=) (begin (read-char) #:>=) #\>)) + + ;; = or == + ((#\=) + (read-char) + (if (eq? (peek-char) #\=) + (begin (read-char) #:==) + #:=)) + + ;; . can mean one of: floating point number (.12345), table field access (plain .), + ;; concatenation operator (..) or the variable argument indicator (...) + ((#\.) + (read-char) + (if (is-digit? (peek-char)) + (read-number ".") + (if (eq? (peek-char) #\.) + (begin + (read-char) + (if (eq? (peek-char) #\.) + (begin (read-char) #:dots) + #:concat)) + #\.))) + + ;; Double-quoted string + ((#\") (read-string #\")) + + ;; Single-quoted string + ((#\') (read-string #\')) + + ;; Bracketed string + ((#\[) + (save-source-info) + (let* ((nest (get-long-string-nesting-level))) + (if (eq? nest -1) + #\[ + (read-long-string #t nest)))) + + ;; Characters that are allowed to fall through directly to the parser + ((#\; #\( #\) #\, + #\+ #\/ #\* + #\^ #\{ #\} #\] #\: #\#) (read-char)) + + ;; Numbers + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (save-source-info) + (save-and-next!) + (read-number #f)) + + (else + (cond ((eof-object? c) c) + ;; Identifier or keyword + ((is-name-first? c) + (save-and-next!) + (save-source-info) + (while (is-name? (peek-char)) + (save-and-next!)) + (possible-keyword (string->symbol (clear-buffer)))) + (else (syntax-error (get-source-info) "disallowed character ~c" c)))) + ) ; case + ) ; loop + ) ; parameterize + ) ; lex + (values get-source-info lex)) ; make-lexer + +(define-syntax define-lua-lexer + (syntax-rules () + ((_ a b) + (begin + (define a #f) + (define b #f))))) + +(define-syntax initialize-lua-lexer! + (syntax-rules () + ((_ port a b) + (receive (get-source-info lex) + (make-lexer port) + (set! a get-source-info) + (set! b lex))))) \ No newline at end of file diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm new file mode 100644 index 000000000..70a1f7a8a --- /dev/null +++ b/module/language/lua/parser.scm @@ -0,0 +1,892 @@ +;;; Guile Lua --- parser + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +;; parser.scm --- lua parser + +;; This parser is based heavily on Lua's parser. It does not use +;; lalr-scm, because Lua's grammar is a little too plucky. Unlike Lua's +;; parser, it returns an abstract syntax tree instead of incrementally +;; compiling the source. + +(define-module (language lua parser) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (rnrs control) + + #:use-module (language lua common) + #:use-module (language lua lexer) + #:use-module (language lua runtime) + + #:export (make-parser read-lua)) + +;; Implicitly named records +(letrec-syntax + ((define-record + (lambda (stx) + (define (id template-id . rest) + (datum->syntax template-id (string->symbol (apply string-append (map (lambda (x) (if (string? x) x (symbol->string (syntax->datum x)))) rest))))) + (syntax-case stx () + ((_ name field ...) + (with-syntax + ((constructor (id #'name "make-" #'name)) + (predicate (id #'name #'name "?")) + ((setter ...) + (map (lambda (x) (id #'name #'name "-" x "!")) #'(field ...))) + ((getter ...) + (map (lambda (x) (id #'name #'name "-" x)) #'(field ...)))) + + #'(begin + (define-record-type name + (constructor field ...) + predicate + (field getter setter) ...) + (export name) + (export constructor) + (export predicate) + (export getter) + ... + (export setter) + ... + )))))) + + (define-ast + (lambda (stx) + (define (id template-id . rest) + (datum->syntax template-id (string->symbol (apply string-append (map (lambda (x) (if (string? x) x (symbol->string (syntax->datum x)))) rest))))) + + (syntax-case stx () + ((_ "aux" name field ...) + #`(define-record #,(id #'name "ast-" #'name) #,(id #'name "src") field ...)) + + ((_ (name field ...) ...) + #`(begin + (define-ast "aux" name field ...) + ...)))))) + + ;; Environments & bindings + (define-record environment parent bindings) + (define-record binding name gensym type) + + ;; Abstract syntax tree -- all of these records are automatically + ;; prefixed with 'ast- and have an SRC field attached. + (define-ast + (unary-not exp) + (literal exp) + (sequence exps) + (return exp) + (condition test then else) + (local-block names gensyms initial-values exp) + (unary-operation operator right) + (local-ref name gensym) + (local-set name gensym exp) + (global-ref name) + (global-set name exp) + (table-ref table key) + (table-set table key exp) + (table-literal fields) + (while-loop condition body) + (numeric-for-loop named initial limit step body) + (list-for-loop names gs-names exps body) + (break) + (function name arguments argument-gensyms variable-arguments? body) + (function-call operator operands) + (binary-operation operator left right) + (variable-arguments)) + + ) ; letrec-syntax + +;; Constants +(define *nil-literal* (make-ast-literal #f #nil)) +(define *void-literal* (make-ast-literal #f *unspecified*)) +(define *default-for-step* (make-ast-literal #f 1)) + +(define (end-of-chunk? token) + "Returns true if TOKEN denotes the end of a grammatical chunk." + (or (or-eqv? token #:else #:elseif #:end #:until) (eof-object? token))) + +(define (token/type t) + (cond ((number? t) 'NUMBER) + ((eof-object? t) 'EOS) + ((symbol? t) 'NAME) + ((string? t) 'STRING) + (else + (case t + ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\# +#:function #:end #:if #:return #:elseif #:then #:else #:true #:false +#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in) t) + (else (error 'TOKEN/TYPE t)))))) + +;; infix operator parsing +(define (binary-operator? t) + "Return #t if the token may be a binary operator" + (or-eqv? t #\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or #:concat)) + +(define (unary-operator? t) + "Return #t if the token may be a unary operator" + (or-eqv? t #\- #\# #:not)) + +;; Operator precedence +(define *unary-priority* 80) + +(define (priority o) + "Return the priority of a given operator token" + (case o + ((#:or) 10) + ((#:and) 20) + ((#:== #:~= #:<= #:>= #\< #\>) 30) + ((#\+ #\-) 60) + ((#\* #\/ #\%) 70) + ((#\^ #:concat) 99))) + +;;;;; TREE-IL UTILITIES + +(define (make-lua-assignment left right) + "Generate an assignment from a variable and an expression" + (cond ((ast-global-ref? left) + (make-ast-global-set (ast-global-ref-src left) (ast-global-ref-name left) right)) + ((ast-local-ref? left) + (make-ast-local-set (ast-local-ref-src left) (ast-local-ref-name left) (ast-local-ref-gensym left) right)) + ((ast-table-ref? left) + (make-ast-table-set (ast-table-ref-src left) (ast-table-ref-table left) (ast-table-ref-key left) right)) + (else + (error 'MAKE-LUA-ASSIGNMENT "should not happen")))) + +(define (wrap-expression-in-environment src e x) + "Wrap an expression in an enclosing lexical environment if necessary" + (let* ((bindings (map cdr (environment-bindings e))) + (locals (filter-map (lambda (b) (if (eq? (binding-type b) 'local) b #f)) bindings))) + (if (null? locals) + x + (make-ast-local-block src (map binding-name locals) (map binding-gensym locals) (map (lambda (c) *nil-literal*) locals) x)))) + +;;;;; PARSER + +(define (make-parser port) + ;; Variables that will be set to the results of MAKE-LEXER. + (define-lua-lexer get-source-info lexer) + + ;; We need two tokens of lookahead + (define token2 #f) + + (define (lookahead!) + (set! token2 (lexer))) + + ;; Current token + (define token) + + ;; Lexical environment + (define environment #f) + + ;; True if inside a function and the function accepts variable arguments + (define *vararg-function* #f) + + ;;;;; ENVIRONMENTS + (define (enter-environment!) + "Create a new environment, and set ENVIRONMENT to it" + (set! environment + (make-environment environment '()))) + + (define (leave-environment!) + "Set ENVIRONMENT to the current ENVIRONMENT's parent" + (if (not environment) + (error 'LEAVE-ENVIRONMENT! "should not happen")) + (set! environment + (environment-parent environment))) + + ;; Type may be 'parameter or 'local + (define (environment-define! name type) + "Define a new variable with NAME and TYPE" + (if (not (member name (environment-bindings environment))) + (environment-bindings! environment (alist-cons name + (make-binding + name + (gensym (string-append " " (symbol->string name))) + type) + (environment-bindings environment))))) + + ;; Environment lookup procedures -- these fail silently and return #f, + ;; because Lua allows global variables to be referenced without being + ;; predefined + + (define (environment-lookup-aux name . e) + "Given a variable's NAME, look up its binding." + (set! e (if (null? e) environment (car e ))) + (if e + (let ((binding (assq-ref (environment-bindings e) name))) + (if binding + binding + (environment-lookup-aux name (environment-parent e)))) + #f)) + + (define (environment-lookup-gensym name) + "Given a variable's NAME, look up its gensym" + (define binding (environment-lookup-aux name)) + (if binding + (binding-gensym binding) + #f)) + + (define (environment-lookup-type name) + "Given a variable's NAME, look up its global" + (define binding (environment-lookup-aux name)) + (if binding + (binding-type binding) + #f)) + + (define (resolve-ref src name) + "Determine whether a variable reference is global or local" + (let* ((binding (environment-lookup-gensym name))) + (if binding + (make-ast-local-ref src name binding) + (make-ast-global-ref src name)))) + + ;;;;; LEXER INTERACTION + + (define (advance-aux) + "Read a new token and store it in TOKEN" + (if token2 + (begin + (set! token token2) + (set! token2 #f)) + (set! token (lexer)))) + + (define-syntax advance! + (syntax-rules () + ((_ x) (begin (advance-aux) x)) + ((_) (advance-aux)))) + + (define (assert-token-type type) + "Throw an error if the current token does not have the expected type" + (if (not (equal? (token/type token) type)) + (syntax-error (get-source-info) "expected ~a" type))) + + (define (maybe-skip-next! c) + "Skip a token" + (if (equal? token c) + (advance! #t) + #f)) + + (define (enforce-next! expect) + "Throw an error if the current token is not the expected token" + (unless (maybe-skip-next! expect) + (syntax-error (get-source-info) "expected '~A' but got '~A'" expect token))) + + ;;;;; GRAMMAR + + ;; single-name -> NAME + (define (single-name . return-src?) + (define save token) + (define src (get-source-info)) + (assert-token-type 'NAME) + (advance!) + (if (not (null? return-src?)) + (values src save) + save)) + + ;; single-variable -> single-name + (define (single-variable) + (receive (src save) + (single-name #:return-src #t) + (resolve-ref src save))) + + ;; application-arguments -> '(' [ expression-list ] ')' | STRING | TABLE + (define (application-arguments) + (cond ((eq? (token/type token) 'STRING) + (let* ((string token)) + (advance!) + (list (make-ast-literal #f string)))) + ((eq? token #\{) + ;; TODO: table constructor + ;; '(' + (list (table-literal))) + ((eq? token #\() + (advance!) + (if (eq? token #\)) + ;; ')' + (advance! '()) + ;; [ expression-list ] + (let* ((arguments (expression-list))) + ;; ')' + (enforce-next! #\)) + arguments))) + (else (error 'APPLICATION-ARGUMENTS "should not happen")))) + + ;; prefix-expression -> NAME | '(' expression ')' + (define (prefix-expression) + (cond + ;; NAME + ((eq? (token/type token) 'NAME) (single-variable)) + ;; '(' + ((eq? token #\() + (begin + (advance!) + ;; expression + (let* ((save (expression))) + ;; ')' + (enforce-next! #\)) + ;; finished + save))) + (else (syntax-error (get-source-info) "unexpected symbol ~a" token)))) + + ;; index -> '[' expression ']' + (define (index) + (enforce-next! #\[) + (let* ((indice (expression))) + (enforce-next! #\]) + indice)) + + ;; field-selector -> '.' NAME + (define (field-selector src prefix) + (make-ast-table-ref src prefix (make-ast-literal src (symbol->string (single-name))))) + + ;; primary-expression -> prefix-expression { field-selector [ application-arguments ] | index | application-arguments } + (define (primary-expression) + (define src (get-source-info)) + ;; prefix-expression + (define prefix (prefix-expression)) + (let lp ((expr prefix)) + (case (token/type token) + ;; field-selector + ((#\.) (advance!) (lp (field-selector src expr))) + ;; index + ((#\[) + (let* ((indice (index))) + (lp (make-ast-table-ref src expr indice)))) + ;; ':' NAME application-arguments + ((#\:) + (advance!) + (assert-token-type 'NAME) + (let* ((name (single-name))) + (lp + (make-ast-function-call src + (make-ast-table-ref src expr (make-ast-literal src (symbol->string name))) + (cons expr (application-arguments)))))) + ;; application-arguments + ((#\( STRING #\{) + (lp (make-ast-function-call src expr (application-arguments)))) + (else expr)))) + + ;; expression-statement -> function | assignment + (define (expression-statement) + (define primary (primary-expression)) + (if (ast-function-call? primary) + primary + (assignment primary))) + + + ;; record-field -> (NAME | index) '=' expression + (define (record-field) + (let* ((indice + (cond + ;; NAME + ((eq? (token/type token) 'NAME) + (let ((tmp (make-ast-literal #f (symbol->string token)))) + (advance!) + tmp)) + ;; index + (else (index)))) + (value + (begin + ;; '=' + (enforce-next! #:=) + ;; expression + (expression)))) + (values indice value))) + + ;; field -> expression | record-field + (define (field) + (case (token/type token) + ((NAME) + (lookahead!) + (if (eq? token2 #:=) + (record-field) + (values #f (expression)))) + ((#\[) (record-field)) + (else (values #f (expression))))) + + ;; field-separator -> ',' | ';' + ;; table-fields -> [ field { field-separator field } [ field-separator ] ] + (define (table-fields src) + (if (eq? token #\}) + '() + (let loop ((implicit-indice 1) + (tree '())) + (if (eq? token #\}) + (reverse! tree) + (receive + (indice expr) + (field) + ;; field-separator + (maybe-skip-next! #\,) + (maybe-skip-next! #\;) + + (loop + (if (not indice) (+ implicit-indice 1) implicit-indice) + (cons + (cons (or indice (make-ast-literal src implicit-indice)) expr) + tree))))))) + + ;; table-literal -> '{' table-fields '}' + (define (table-literal) + (define src (get-source-info)) + ;; '{' + (enforce-next! #\{) + ;; bind the table to a temporary variable with LET as it's needed in order to initialize the table + (let* ((result (make-ast-table-literal src (table-fields src)))) + result + (enforce-next! #\}) + result)) + + ;; parameter-list -> [ parameter { ',' parameter } ] + (define (parameter-list function-name) + (if (eq? token #\)) + (values '() #f) + (let lp ((parameters '())) + ;; parameter + (let* ((parameters + (if (eq? (token/type token) 'NAME) + (append! parameters (list token)) + (if (eq? token #:dots) + (values parameters #f) + (syntax-error (get-source-info) "expected either a name or ... in the parameter list of '~a', but got ~a" function-name token)))) + (last-token token)) + (advance!) + (if (eq? token #\,) + (if (eq? last-token #:dots) + (syntax-error (get-source-info) "expected ')' after ... in the parameter list of '~a'" function-name) + (advance! (lp parameters))) + (values parameters (eq? last-token #:dots))))))) + + ;; function-body -> '(' parameter-list ')' chunk END + (define* (function-body #:optional (src (get-source-info)) (implicit-self? #f) (name 'anonymous)) + ;; '(' + (enforce-next! #\() + ;; parameter-list + (receive (parameters variable-arguments?) + (parameter-list name) + (let* ((old-vararg-function *vararg-function*)) + (set! *vararg-function* variable-arguments?) + (enforce-next! #\)) + ;; create function + (enter-environment!) + (when implicit-self? + (environment-define! 'self 'parameter)) + (for-each (lambda (p) (environment-define! p 'parameter)) parameters) + ;; chunk + (let* ((body (chunk)) + (parameter-gensyms (map environment-lookup-gensym parameters)) + (result + (make-ast-function src (if (eq? name 'anonymous) #f name) + (if implicit-self? (append parameters '(self)) parameters) + (if implicit-self? (append parameter-gensyms (list (environment-lookup-gensym 'self))) parameter-gensyms) + variable-arguments? (if (null? body) *void-literal* body)))) + (leave-environment!) + ;; END + (enforce-next! #:end) + (set! *vararg-function* old-vararg-function) + result)))) + + ;; expression-list -> expression { ',' expression } + (define (expression-list) + (let loop ((tree (list (expression)))) + ;; { ',' expression } + (if (maybe-skip-next! #\,) + (loop (cons (expression) tree)) + ;; finished + (reverse! tree)))) + + ;; simple-expression -> (nil | true | false | NUMBER | STRING) | table-literal | FUNCTION function-body + (define (simple-expression) + (define src (get-source-info)) + (receive + (advance? result) + (case (token/type token) + ;; (nil | true | false | NUMBER | STRING) + ((#:true #:false #:nil NUMBER STRING) + (values + #t + (make-ast-literal + src + (cond ((eq? token #:true) #t) + ((eq? token #:false) #f) + ((eq? token #:nil) #nil) + (else token))))) + ;; table-literal + ((#\{) (values #f (table-literal))) + ;; ... + ((#:dots) + (unless *vararg-function* + (syntax-error src "cannot use '...' outside of a variable arguments function")) + (values #t (make-ast-variable-arguments src))) + ;; FUNCTION function-body + ((#:function) (advance!) (values #f (function-body src))) + ;; primary-expression + (else (values #f (primary-expression)))) + (if advance? + (advance!)) + result)) + + ;; subexpression -> (simple-expression | unary-operator subexpression) { binary-operator subexpression } + (define (subexpression limit) + (define left) + ;; test for preceding unary operator + (set! left + ;; (simple-expression | unary-operator subexpression) + (if (unary-operator? token) + ;; unary-operator subexpression + (let* ((src (get-source-info)) + (operator token)) + (advance!) + (make-ast-unary-operation src operator (subexpression *unary-priority*))) + ;; simple-expression + ;; note: simple-expression may advance the current token + (simple-expression))) + + (let loop ((left left)) + ;; { binary-operator subexpression } + (if (and (binary-operator? token) (> (priority token) limit)) + (let* ((src (get-source-info)) + (operator token)) + (advance!) + ;; read next expression with higher priorities + (let* ((right (subexpression (priority operator)))) + (loop (make-ast-binary-operation src operator left right)))) + ;; finished + left))) + + ;; expression -> subexpression + (define (expression) + (subexpression 0)) + + ;; while-statement -> WHILE expression DO chunk END + (define (while-statement) + (define src (get-source-info)) + ;; WHILE + (advance!) + ;; expression + (let* ((condition (expression))) + ;; DO + (enforce-next! #:do) + ;; chunk + (let* ((body (chunk))) + ;; END + (enforce-next! #:end) + (make-ast-while-loop src condition body)))) + + ;; return-statement -> RETURN expression-list + (define (return-statement) + (define src (get-source-info)) + + ;; RETURN + (advance!) + + (make-ast-return src (if (or (end-of-chunk? token) (eq? token #\;)) + *void-literal* + (expression-list)))) + + (define (parse-assignment src left right) + ;; and then parses it, branching to handle overflows on either side if necessary + (make-ast-sequence + src + (let loop ((left left) + (right right) + (tree '())) + (cond + ;; no overflows, and finished + ((and (null? left) (null? right)) + (reverse! tree)) + ;; no overflows, not finished + ((and (not (null? left)) (not (null? right))) + (loop (cdr left) + (cdr right) + (cons (make-lua-assignment (car left) (car right)) tree))) + ;; overflow on right, evaluate extra expressions on the right + ((and (null? left) (not (null? right))) + (reverse! (append! right tree))) + ;; overflow on left, set all overflowed expressions to nil + ((and (not (null? left)) (null? right)) + (let loop ((tree tree) + (rest left)) + (let* ((il (make-lua-assignment (car rest) *nil-literal*)) + (rest (cdr rest))) + (if (null? rest) + (reverse! (cons il tree)) + (loop (cons il tree) (cdr rest)))))) + (else (error 'PARSE-ASSIGNMENT "should not happen")))))) + + ;; assignment -> '=' expression-list | ',' primary-expression assignment + (define (assignment first) + ;; assignments are unfortunately complicated because multiple variables may + ;; be assigned to multiple expressions in a single assignment, and the + ;; number of variables and expressions need not match + + ;; so this function accumulates the entire assignment + (let* ((src (get-source-info)) + (left (let loop ((x first) + (tree '())) + (set! tree (cons x tree)) + (if (eq? token #\,) + (advance! (loop (primary-expression) tree)) + (reverse! tree)))) + + (right (begin + (enforce-next! #:=) + (expression-list)))) + (parse-assignment src left right) + + ) ; let* + ) ; assignment + + ;; then-chunk -> (IF | ELSEIF) expression THEN chunk + (define (then-chunk) + ;; IF | ELSEIF + (advance!) + ;; expression + (let* ((condition (expression))) + ;; THEN + (enforce-next! #:then) + ;; chunk + (let* ((body (chunk))) + (values condition body)))) + + ;; if-statement -> then-chunk { then-chunk } [ELSE chunk] END + (define (if-statement) + (define if-src (get-source-info)) + (define x + (receive (test then) + (then-chunk) + (make-ast-condition + if-src test then + (let lp () + (define src (get-source-info)) + (if (eq? token #:elseif) + (receive (test then) + (then-chunk) + (make-ast-condition src test then (lp))) + (if (eq? token #:else) + (advance! (chunk)) + *void-literal*)))))) + (enforce-next! #:end) + x) + + ;; repeat-statement -> REPEAT chunk UNTIL expression + (define (repeat-statement) + (define src (get-source-info)) + ;; REPEAT + (advance!) + ;; chunk + (let* ((body (chunk))) + ;; UNTIL + (enforce-next! #:until) + ;; expression + (let* ((condition (expression))) + (make-ast-while-loop + src + (make-ast-unary-operation src 'not condition) + body)))) + + ;; function-statement -> FUNCTION NAME { field-selector } [ ':' NAME ] function-body + (define (function-statement) + (define src (get-source-info)) + ;; FUNCTION NAME + (define name (advance! (single-name))) + + (receive (prefix type) + (let lp ((last-expr (resolve-ref src name))) + (if (eq? token #\.) + ;; { '.' NAME } + (let* ((name (advance! (single-name)))) + (if (eq? token #\() + (values (cons name last-expr) 'table-function) + (lp (make-ast-table-ref src last-expr name)))) + ;; [ ':' NAME ] + (if (eq? token #\:) + (let* ((name (advance! (single-name)))) + (values (cons name last-expr) 'table-method)) + (values last-expr 'function)))) + (define body (function-body src (eq? type 'table-method) name)) + (case type + ((table-function table-method) + (make-ast-table-set src (cdr prefix) (make-ast-literal src (symbol->string (car prefix))) body)) + ((function) (make-lua-assignment prefix body)) + (else (error 'FUNCTION-STATEMENT "should not happen"))))) + + ;; local-statement -> LOCAL NAME { ',' NAME } [ '=' expression-list ] + (define (local-statement) + (define src (get-source-info)) + ;; LOCAL + ;; (already advanced by calling function) + + (let lp ((names '())) + ;; NAME + (assert-token-type 'NAME) + (set! names (cons token names)) + (advance!) + (if (maybe-skip-next! #\,) + ;; { ',' NAME } + (lp names) + (begin + (for-each (lambda (n) (environment-define! n 'local)) names) + (if (maybe-skip-next! #:=) + ;; [ '=' expression-list ] + (let* ((left (map (lambda (x) (resolve-ref src x)) names)) + (right (expression-list))) + (parse-assignment src left (reverse! right))) + ;; otherwise, it's not a declaration, not an assignment, and evaluates to nothing + *void-literal*))))) + + (define (local-function-statement) + (assert-token-type 'NAME) + (let* ((name token)) + (environment-define! name 'local) + (advance!) + (make-ast-local-set (get-source-info) name (environment-lookup-gensym name) (function-body)))) + + ;; for-body + (define (for-body) + (enforce-next! #:do) + (let* ((body (chunk))) + (enforce-next! #:end) + body)) + + ;; numeric-for -> FOR NAME '=' expression ',' expression ',' expression DO chunk END + (define (numeric-for src name) + (define step *default-for-step*) + (advance!) + (enforce-next! #:=) + (enter-environment!) + (environment-define! name 'local) + (let* ((initial (expression))) + (enforce-next! #\,) + (let* ((limit (expression))) + (when (eq? token #\,) + (advance!) + (set! step (expression))) + (let* ((result (make-ast-numeric-for-loop src name initial limit step (for-body)))) + (leave-environment!) + result)))) + + ;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END + (define (list-for src name) + (let* ((names + (let lp ((names (list name))) + (advance!) + (if (eq? token #\,) + (begin + (advance!) + (assert-token-type 'NAME) + (lp (cons token names))) + (reverse! names))))) + (enforce-next! #:in) + (let* ((exps (expression-list))) + (enforce-next! #:do) + (for-each + (lambda (name) + (environment-define! name 'hidden)) + names) + (let* ((body (chunk))) + (enforce-next! #:end) + (make-ast-list-for-loop src names (map environment-lookup-gensym names) exps body))))) + + ;; for-statement -> FOR (numeric-for | list-for) END + (define (for-statement) + (define src (get-source-info)) + (enforce-next! #:for) + (assert-token-type 'NAME) + (let* ((name token) + (result + (begin + (lookahead!) + (if (eq? token2 #:=) + (numeric-for src name) + (if (or-eqv? token2 #:in #\,) + (list-for src name) + (syntax-error src "expected = or in after for variable")))))) + result)) + + ;; break-statement -> BREAK + (define (break-statement) + (enforce-next! #:break) + (make-ast-break (get-source-info))) + + ;; statement + (define (statement) + (case token + ((#\;) (advance!) (statement)) + ;; statement -> return + ((#:return #:break) + (values + #t + (case token + ((#:return) (return-statement)) + ((#:break) (break-statement))))) + ((#:if #:function #:do #:while #:repeat #:local #:for) + (values + #f + (case token + ((#:repeat) (repeat-statement)) + ((#:while) (while-statement)) + ((#:if) (if-statement)) + ((#:function) (function-statement)) + ((#:local) + (advance!) + (if (maybe-skip-next! #:function) + (local-function-statement) + (local-statement))) + ((#:for) (for-statement)) + ((#:do) + (begin + (advance!) + (let* ((body (chunk))) + (enforce-next! #:end) + body)))))) + ;; statement -> function | assignment + (else (values #f (expression-statement))))) + + ;; chunk -> { statement [ ';' ] } + (define (chunk) + (define src (get-source-info)) + (let loop ((is-last (end-of-chunk? token)) + (tree '())) + (if is-last + (begin + (maybe-skip-next! #\;) + (wrap-expression-in-environment + src + environment + (make-ast-sequence src (reverse! tree)))) + (receive + (is-last node) + (statement) + (loop (or (end-of-chunk? token) is-last) (cons node tree)))))) + + (initialize-lua-lexer! port get-source-info lexer) + + ;; toplevel local environment + (enter-environment!) + ;; read first token + (advance!) + ;; return parser + chunk) + +(define (read-lua port) + (define parser (make-parser port)) + (parser)) diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm new file mode 100644 index 000000000..6cf30d335 --- /dev/null +++ b/module/language/lua/runtime.scm @@ -0,0 +1,606 @@ +;;; Guile Lua --- runtime functionality + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua runtime) + #:use-module (language lua common) + + #:use-module (rnrs control) + #:use-module ((srfi srfi-1) #:select (filter!)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-69) + #:use-module ((srfi srfi-98) #:select (get-environment-variable)) + #:use-module ((system base compile) #:select (compile read-and-compile)) + + #:export ( + runtime-error + + ;; semantics + false? true? + + ;; misc + value-type->string + assert-type + assert-table + assert-string + assert-number + + ;; tables + make-table + table? + table-slots + table-metatable + table-metatable! + table-length + + ;; userdata + userdata + userdata-metatable + register-userdata! + + ;; metatable + might-have-metatable? + get-metatable + dispatch-metatable-event + + ;; table interaction + index + new-index! + get-field + + ;; operators + len unm eq lt le gt ge add sub mul div pow + neq concat + + ;; modules + make-module-table + + ;; global environment + *global-env-table* + save-fenv + check-global-function + ) + + #:export-syntax (table-slots table? table-metatable table-metatable!) + + ) ; define-module + +;; Local Variables: +;; eval: (put 'define-global 'scheme-indent-function 1) +;; End: + +(define (runtime-error string . arguments) + "Throw an error tagged with 'lua-runtime" + (throw 'lua-runtime (apply format (cons (string-append "LUA: ERROR: " string "\n") arguments)))) + +(define (runtime-warning string . arguments) + (apply format (cons #t (cons (string-append "LUA: RUNTIME WARNING: " string "\n") arguments)))) + +;;;;; SEMANTICS + +(define (false? x) + "Wrapper for Scheme's false semantics that considers #nil to be false" + (or (eq? x #f) (eq? x #nil))) + +(define (true? x) + "Inversion of false?" + (not (false? x))) + +;;;;; MISCELLANEOUS + +(define (value-type->string x) + (cond ((table? x) "table") + ((string? x) "string") + ((number? x) "number") + ((boolean? x) "boolean") + ((eq? x #nil) "nil") + ((procedure? x) "function") + ;; TODO: value-type->string must recognize threads + (else "userdata"))) + +(define (assert-type argument caller expected value predicate) + (if (not (predicate value)) + (runtime-error (format #f "bad argument ~a to '~a' (~a expected, got ~a)" argument caller expected (value-type->string value))))) + +(define-syntax define-assert + (syntax-rules () + ((_ name string predicate) + (define (name argument caller value) (assert-type argument caller string value predicate))))) + +(define-assert assert-table "table" table?) +(define-assert assert-string "string" string?) +(define-assert assert-number "number" number?) + +;;;;; TABLES + +(define-record-type table + (%make-table metatable slots) + table? + (metatable table-metatable table-metatable!) + (slots table-slots)) + +(define (make-table) + (%make-table #f (make-hash-table))) + +(define (table? x) (table? x)) +(define (table-metatable x) (table-metatable x)) +(define (table-metatable! x y) (table-metatable! x y)) + +;;;;; USERDATA + +;; Userdata is tracked by this property. It can be #f, indicating the +;; object is not userdata, #t, indicating the object is userdata but has +;; no metatable, or an actual table, which counts as the metatable. +(define userdata-property (make-object-property)) + +(define userdata? userdata-property) +(define (userdata-metatable x) + (and (table? (userdata-property x)) (userdata-property x))) + +(define* (register-userdata! x #:optional metatable) + (set! (userdata? x) (or metatable #t))) + +;;;;; METATABLES + +(define (might-have-metatable? x) + (or (table? x) (userdata? x))) + +(define (get-metatable x) + (cond ((table? x) (table-metatable x)) + ((userdata? x) (userdata-metatable x)) + (else #f))) + +;;;;; TABLE INTERACTION + +(define (dispatch-metatable-event key default x . arguments) + (let* ((metatable (get-metatable x))) + (apply + (if metatable + (hash-table-ref/default (table-slots metatable) key default) + default) + arguments))) + +;; see manual section 2.5.5 +(define (table-length table) + (let* ((numeric-keys (sort! (filter! number? (hash-table-keys (table-slots table))) <))) + (if (eq? (car numeric-keys) 1) + (let lp ((cell (car numeric-keys)) + (rest (cdr numeric-keys)) + (length 0)) + ;; length does not count "holes" + ;; so if a table has the keys 1,2,3 and 5, the length of the table is 3 + (if (or (> cell (+ length 1)) (null? rest)) + (+ length 1) ;; add one to length as though we had started from one + (lp (car rest) (cdr rest) cell))) + 0))) + +(define (index table key) + (dispatch-metatable-event + "__index" + (lambda (table key) (hash-table-ref/default (table-slots table) key #nil)) + table + table key)) + +(define (new-index! table key value) + (dispatch-metatable-event + "__newindex" + (lambda (table key value) (hash-table-set! (table-slots table) key value)) + table + table key value)) + +(define* (get-field table key #:optional (default #nil)) + (define result (index table key)) + (if (eq? result #nil) + default + result)) + +;;;;; OPERATORS +(define (len a) + "A function backing the unary # (length) operator" + (cond ((string? a) (string-length a)) + ((table? a) (table-length a)) + (else (runtime-error "attempt to get length of a ~A value" (value-type->string a))))) + +(define (unm a) + "A function backing the unary - (negation) operator" + (if (might-have-metatable? a) + (dispatch-metatable-event "__unm" - a a) + (- a))) + +(define (builtin-eq a b) + "A function backing the == operator" + (equal? a b)) + +(define (builtin-concat a b) + (when (or (table? a) (table? b)) + (runtime-error "attempt to concatenate a table value")) + (when (or (eq? a #nil) (eq? b #nil)) + (runtime-error "attempt to concatenate a nil value")) + (when (or (boolean? a) (boolean? b)) + (runtime-error "attempt to concatenate a boolean value")) + (format #f "~a~a" a b)) + +(define (neq a b) + "An inversion of eq" + (not (eq a b))) + +(define (ge a b) + "A function backing the >= (greater-than-or-equal-to) operator" + (not (lt a b))) + +(define (gt a b) + "A function backing the > (greater-than) operator" + (not (le a b))) + +;; This macro could be even cooler and generate the slot names as well as the +;; parsers name/function mappings at expand-time +(letrec-syntax + ((define-binary-operators + (syntax-rules () + ((_ (name slot-name default) ...) + (begin + (define-binary-operators () name slot-name default) + ...)) + ((_ () name slot-name default) + (begin + (define (name a b) + (cond ((might-have-metatable? a) + (dispatch-metatable-event slot-name default a a b)) + ((might-have-metatable? b) + (dispatch-metatable-event slot-name default b a b)) + (else (default a b))))))))) + (define-binary-operators + (add "__add" +) + (sub "__sub" -) + (mul "__mul" *) + (div "__div" /) + (pow "__pow" expt) + (le "__le" <=) + (lt "__lt" <) + (eq "__eq" builtin-eq) + (concat "__concat" builtin-concat))) + +;;;;; MODULES + +;; A metatable for tables backed by modules +(define module-metatable (make-table)) + +(hash-table-set! + (table-slots module-metatable) "__index" + (lambda (table key) + (define slots (table-slots table)) + (if (hash-table-exists? slots key) + (hash-table-ref slots key) + (let ((key (string->symbol key)) + (module (hash-table-ref slots 'module))) + (if (not (module-defined? module key)) + #nil + (module-ref module key #f)))))) + +(define (make-module-table name) + (define table (make-table)) + (table-metatable! table module-metatable) + (hash-table-set! (table-slots table) 'module (resolve-module name)) + table) + +;;;;; GLOBAL ENVIRONMENT + +(define *global-env-table* (make-table)) + +;; Saves _G and returns a function that will restore it +(define (save-fenv table) + "Saves *global-env-table* and returns a function to restore it" + (let* ((save *global-env-table*)) + (set! *global-env-table* table) + (lambda () + (set! *global-env-table* save)))) + +(define (check-global-function name value) + (when (eq? value #nil) + (runtime-error "attempt to call global '~a' (a nil value)" name))) + +;;;;; BUILT-INS + +(define-syntax define-global + (syntax-rules (do-not-export) + ((_ (do-not-export name) value) + (begin + (define name value) + (new-index! *global-env-table* (symbol->string 'name) name))) + ((_ (name . rest) body ...) + (define-global name (lambda rest body ...))) + ((_ name value) + (begin + (define name value) + (export name) + (new-index! *global-env-table* (symbol->string 'name) name))))) + +(define-global (assert v . opts) + (define message (if (null? opts) "assertion failed" (car opts))) + (if (false? v) + (runtime-error message) + (apply values (cons v opts)))) + +;; NOTE: collectgarbage cannot be fully implemented because it expects +;; an incremental garbage collector that matches lua's interface; libgc +;; can be incremental but i don't think we can turn that on from guile +;; currently, and even if we could i'm not sure that libgc exposes what +;; lua wants +(define-global collectgarbage + (lambda* (opt #:optional (arg #nil)) + (define (ignore) (runtime-warning "collectgarbage cannot respect command ~a" opt)) + (assert-type 1 "collectgarbage" "string" opt string?) + (cond ((string=? opt "stop") (ignore)) + ((string=? opt "restart") (ignore)) + ((string=? opt "collect") (gc)) + ((string=? opt "count") (ignore)) + ((string=? opt "step") (ignore)) + ((string=? opt "setpause") (ignore)) + ((string=? opt "setstepmul") (ignore)) + (else (runtime-error "bad argument #1 to 'collectgarbage' (invalid option ~a)" opt))))) + +(define-global (dofile filename) + (assert-string 1 "dofile" filename) + (runtime-warning "dofile cannot return the values of the chunk and instead will return #nil") + (call-with-input-file filename + (lambda (file) + (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value))) + #nil) + +(define-global (do-not-export error) + (lambda* (message #:optional level) + (runtime-warning "level argument to error is not respected") + (throw 'lua-error message))) + +;; global variable table +(define-global _G *global-env-table*) + +(define-global (getmetatable table) + (assert-table 1 "getmetatable" table) + (let* ((mt (table-metatable table))) + (if (eq? mt #f) + #nil + mt))) + +(define-global (ipairs table) + (assert-table 1 "ipairs" table) + (values + (lambda (table indice) + (set! indice (+ indice 1)) + (let* ((value (index table indice))) + (if (eq? value #nil) + (values #nil #nil) + (values indice value))) + ) + table + 0)) + +(define (load-warning) + (runtime-warning "load, loadfile, and loadstring cannot return the results of evaluating a file")) + +(define (load-chunkname-warning chunkname) + (when chunkname + (runtime-warning "load and loadstring ignore chunkname"))) + +(define-global load + (lambda* (func #:optional chunkname) + (load-warning) + (load-chunkname-warning chunkname) + (lambda () + (compile + ((@ (language lua parser) read-lua) + (open-input-string + (let lp ((tree '()) + (result (func))) + (if (or (equal? func "") (eq? func #nil) (eq? func *unspecified*)) + (string-concatenate-reverse tree) + (lp (cons func tree) (func)))))) + #:from 'lua #:to 'value)))) + +(define-global loadfile + (lambda* (#:optional filename) + (load-warning) + (lambda () + (if filename + (call-with-input-file filename + (lambda (file) + (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value))) + (read-and-compile (current-input-port) #:from 'lua))))) + +(define-global loadstring + (lambda* (string #:optional chunkname) + (load-warning) + (load-chunkname-warning chunkname) + (lambda () + (compile ((@ (language lua parser) read-lua) (open-input-string string)) #:from 'lua #:to 'value)))) + +;; TODO: module + +(define-global next + (lambda* (table #:optional (index #nil)) + (assert-table 1 "next" table) + (let* ((keys (hash-table-keys (table-slots table)))) + ;; empty table = nil + (if (null? keys) + #nil + (begin + (if (eq? index #nil) + (let* ((next-index (list-ref keys 0))) + (values next-index (rawget table next-index))) + (let* ((key-ref (+ ((@ (srfi srfi-1) list-index) (lambda (x) (equal? x index)) keys) 1))) + (if (>= key-ref (length keys)) + (values #nil #nil) + (let* ((next-index (list-ref keys key-ref))) + (values next-index (rawget table next-index))))))))))) + +(define-global pairs + (lambda* (table) + (values next table #nil))) + +(define-global (pcall function . arguments) + (catch #t + (lambda () (apply function arguments)) + (lambda args (apply values (cons #f args))))) + +(define-global (print . arguments) + (for-each + (lambda (x) + (display (tostring x)) + (write-char #\tab)) + arguments) + (newline) + #nil) + +(define-global (rawequal v1 v2) + (equal? v1 v2)) + +(define-global (rawget table key) + (assert-table 1 "rawget" table) + (hash-table-ref (table-slots table) key)) + +(define-global (rawset table key value) + (assert-table 1 "rawset" table) + (hash-table-set! (table-slots table) key value)) + +(define-global (select index . rest) + (define rest-length (length rest)) + (cond ((number? index) + (let lp ((vals '()) + (i index)) + (if (> i rest-length) + (apply values (reverse! vals)) + (lp (cons (list-ref rest (- i 1)) vals) (+ i 1))))) + (else rest-length))) + +(define-global (setmetatable table metatable) + (assert-table 1 "setmetatable" table) + (assert-type 2 "setmetatable" "nil or table" metatable (lambda (x) (or (table? x) (eq? x #nil)))) + (table-metatable! table (if (eq? metatable #nil) #f metatable)) + table) + +;; NOTE: built-in 'tonumber' is implemented on string->number and may +;; not have the same semantics as lua's tonumber; it should be based on the lexer +(define-global tonumber + (lambda* (e #:optional (base 10)) + (cond ((number? e) e) + ((string? e) + (unless (or-eqv? base 2 8 10 16) + (runtime-warning "tonumber cannot respect bases other than 2, 8, 10, and 16")) + (string->number e base)) + (else #nil)))) + +(define-global (tostring e) + (cond ((string? e) e) + ((eqv? e #t) "true") + ((eqv? e #f) "false") + ((eqv? e #nil) "nil") + ((number? e) (number->string e)) + ((might-have-metatable? e) + (dispatch-metatable-event + "__tostring" + (lambda (table) (format #f "~A" e)) + e + e)) + (else (runtime-error "tostring cannot convert value ~A" e)))) + +(define-global (type v) + (value-type->string v)) + +(define-global unpack + (lambda* (array #:optional (i 1) j) + (assert-table 1 "unpack" array) + (unless j (set! j (table-length array))) + (apply values (reverse! + (let lp ((ls '()) + (i i)) + (if (> i j) + ls + (if (eq? #nil (index array i)) + ls + (lp (cons (index array i) ls) (+ i 1))))))))) + +;; _VERSION +;; contains a string describing the lua version +(define-global _VERSION "Guile/Lua 5.1") + +(define-global (xpcall f err) + (catch #t + (lambda () (values #t (f))) + (lambda args (values #f (err args))))) + +;;; MODULE SYSTEM + +;; package +(define-global package (make-table)) + +;; package.cpath +(new-index! package "cpath" (or (get-environment-variable "LUA_CPATH") + "./?.so;/usr/lib/lua/5.1/?.so;/usr/lib/lua/5.1/loadall.so")) +;; package.loaded +(define loaded (make-table)) +(new-index! package "loaded" loaded) + +;; package.loaders +(define loaders (make-table)) +(new-index! package "loaders" loaders) + +;; package.loadlib +(new-index! package "loadlib" (lambda (lib func . _) (runtime-error "loadlib not implemented"))) + +;; package.path +(new-index! package "path" (or (get-environment-variable "LUA_PATH") "./?.lua;/usr/share/lua/5.1/?.lua;/usr/share/lua/5.1/?/init.lua;/usr/lib/lua/5.1/?.lua;/usr/lib/lua/5.1/?/init.lua")) + +;; package.preload +(define preload (make-table)) +(new-index! package "preload" preload) + +;; package.seeall +(new-index! package "seeall" (lambda (module . _) (runtime-error "seeall unimplemented"))) + +;; arg +;; command line argument table +(define arg (make-table)) +(let lp ((rest (command-line)) + (i 0)) + (new-index! arg i (car rest)) + (if (not (null? (cdr rest))) + (lp (cdr rest) (1+ i)))) + +;; require +(define (register-loaded-module name table) + (rawset *global-env-table* name table) + (rawset loaded name table)) + +(define (module-exists? name) + (if (module-public-interface (resolve-module name)) + #t + #f)) + +(define-global (require module-name . _) + (assert-type 1 "require" "string" module-name string?) + ;; try to load module, if it's not already loaded + (if (not (hash-table-exists? (table-slots loaded) module-name)) + (let* ((std-module-name `(language lua standard ,(string->symbol module-name)))) + (if (module-exists? std-module-name) + (register-loaded-module module-name (make-module-table std-module-name))))) + + (if (not (hash-table-exists? (table-slots loaded) module-name)) + (runtime-error "require failed")) + (rawget loaded module-name)) + diff --git a/module/language/lua/spec.scm b/module/language/lua/spec.scm new file mode 100644 index 000000000..dac32d00c --- /dev/null +++ b/module/language/lua/spec.scm @@ -0,0 +1,33 @@ +;;; Guile Lua --- language specification + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua spec) + #:use-module (system base language) + #:use-module (language lua parser) + #:use-module (language lua compile-tree-il) + #:export (lua)) + +(define-language lua + #:title "Lua" + #:reader (lambda (port _) + (if (file-port? port) + (read-lua port))) + #:compilers `((tree-il . ,compile-tree-il)) + #:printer write) diff --git a/module/language/lua/standard/io.scm b/module/language/lua/standard/io.scm new file mode 100644 index 000000000..d18db9e2e --- /dev/null +++ b/module/language/lua/standard/io.scm @@ -0,0 +1,185 @@ +;;; Guile Lua --- io standard library + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua standard io) + #:use-module (language lua runtime) + + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (rnrs control)) + +;; io.file:read + +;; metatable for file objects +(define file (make-table)) + +(rawset file '__index + (lambda (self key) + (rawget file key))) + +(define stdin (current-input-port)) +(define stdout (current-output-port)) +(define stderr (current-error-port)) + +(define* (close #:optional (file stdout)) + (close-port file)) + +(rawset file 'close + (lambda (self) + (close self))) + +;; lua doesn't actually have an optional flush argument, but this is more in line with everything else +(define* (flush #:optional (file stdout)) + (force-output file)) + +(rawset file 'flush + (lambda (self) + (flush self))) + +(define* (input #:optional filename) + (if filename + (let* ((file (open filename))) + (set! stdin file) + file) + stdin)) + +(define (line-iterator file auto-close?) + (lambda () + (let* ((line (read-line file))) + (if (eof-object? line) + (begin + (if auto-close? + (close-port file)) + #nil) + line)))) + +(define* (lines #:optional filename) + (let* ((file (if filename (open filename) stdin))) + (line-iterator file (and filename)))) + +(rawset file 'lines + (lambda (self) + (line-iterator self #f))) + +(define* (open filename #:optional (mode "r")) + (assert-string 1 "io.open" filename) + (assert-string 2 "io.open" mode) + (let* ((handle (open-file filename mode))) + (register-userdata! handle file) + handle)) + +(define* (output #:optional filename) + (if filename + (let* ((file (open filename "w"))) + (set! stdout file) + file) + stdout)) + +(define* (popen prog #:optional (mode "r")) + (assert-string 2 "io.popen" mode) + (open-pipe + prog + (if (string=? mode "w") OPEN_WRITE OPEN_READ))) + +(define (default-read port) + (if (eof-object? (peek-char port)) + #nil + (read-line port))) + +(rawset file 'read + (lambda (self . formats) + (if (null? formats) + (default-read self) + (apply + values + (map + (lambda (self . formats) + (unless (or (number? format) (string? format)) + (runtime-error "'file:read' expects a string or number as format argument, but got ~a" format)) + (if (number? format) + (if (eof-object? (peek-char self)) + #nil + (let lp ((out (open-output-string)) + (i format)) + (if (= i 0) + (get-output-string out) + (let ((c (read-char self))) + (if (eof-object? self) + (get-output-string out) + (begin + (write-char c out) + (lp out (- i 1)))))))) + + (let* ((format-length (string-length format)) + (c1 (if (> format-length 0) (string-ref format 0) #f)) + (c2 (if (> format-length 1) (string-ref format 1) #f))) + (cond ((eq? c2 #\n) (runtime-error "'file:read' number reading is not yet supported")) + ((eq? c2 #\a) + (if (eof-object? (peek-char self)) + #nil + (let lp ((out (open-output-string))) + (let ((c (read-char self))) + (if (eof-object? c) + (get-output-string out) + (begin + (write-char c out) + (lp out))))))) + ((eq? c2 #\l) + (default-read self)) + (else + (runtime-error "file:read does not understand format ~a" format)))))) + formats))))) + +(rawset file 'seek + (lambda* (self #:optional (whence "cur") (offset 0)) + (assert-string 1 "file:seek" whence) + (assert-number 2 "file:seek" offset) + (seek self offset + (cond ((string=? whence "cur") SEEK_CUR) + ((string=? whence "set") SEEK_SET) + ((string=? whence "end") SEEK_END) + (else (runtime-error "invalid 'whence' argument to 'file:seek'; expected \"cur\", \"set\", or \"end\"")))))) + +(rawset file 'setvbuf + (lambda* (self mode #:optional size) + (assert-string 1 "file:setvbuf" mode) + (let* ((translated-mode + (cond ((string=? mode "no") _IONBF) + ((string=? mode "line") _IOLBF) + ((string=? mode "full") _IOFBF)))) + (if size + (setvbuf self mode) + (setvbuf self mode size))))) + +(rawset file 'write + (lambda* (self . args) + (for-each + (lambda (arg) + (unless (or (string? arg) (number? arg)) + (runtime-error "'file:write' expects string or number as argument but got '~a'" arg)) + (display arg self)) + args))) + +(define (type obj) + (if (port? obj) + (if (port-closed? obj) + "closed" + "file") + #nil)) diff --git a/module/language/lua/standard/math.scm b/module/language/lua/standard/math.scm new file mode 100644 index 000000000..91ccd174f --- /dev/null +++ b/module/language/lua/standard/math.scm @@ -0,0 +1,136 @@ +;;; Guile Lua --- math standard library + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua standard math) + #:use-module (language lua runtime)) + +;; TODO: math.modf +;; TODO: math.deg,rad,frexp,random not tested + +;; NOTE: as opposed to lua, math.sqrt accepts negative arguments, as +;; guile's numeric tower is capable of representing complex numbers + +(define huge +inf.0) +(define *nan* (nan)) +(define pi 3.14159265358979323846) +(define radians_per_degree (/ pi 180.0)) + +(letrec-syntax + ((wrap-builtins + (syntax-rules (rename rename2 variable-arity) + ;; we must know the arity of the wrapped procedure because lua ignores superfluous arguments whereas it is an error in scheme + + ;; simple wrap with new name and 1 argument + ((_ () (rename guile-name lua-name)) + (define (lua-name a . _) + ((@ (guile) guile-name) a))) + + ((_ () (rename2 guile-name lua-name)) + (define (lua-name a b . _) + ((@ (guile) guile-name) a b))) + + ;; simple wrap with 2 arguments + ((_ () (2 name)) + (define (name a b . _) + ((@ (guile) name) a b))) + + ;; simple wrap with variable arguments + ((_ () (variable-arity name)) + (define (name . _) + (apply (@ (guile) name) _))) + + ;; simple wrap with 1 argument + ((_ () name) + (define (name a . _) + ((@ (guile) name) a))) + + ;; 1) take all input and pass it to subtransformers + ((_ subform ...) + (begin + (wrap-builtins () subform) + ...))))) + (wrap-builtins + abs + acos + asin + atan + (rename ceiling ceil) + cos + cosh + exp + (rename2 remainder modf) + floor + log + log10 + sin + sinh + sqrt + (variable-arity max) + (variable-arity min) + (rename expt pow) + tan + tanh)) + +(define (atan2 x y) + (atan (/ x y))) + +;; copy the global random state for this module so we don't mutate it +(define randomstate (copy-random-state *random-state*)) + +(define (randomseed seed . _) + (set! randomstate (seed->random-state seed))) + +(define* (random #:optional m n #:rest _) + ;; this can be a little confusing because guile's random number + ;; generator only allows [0, N) but we need [0,1), [1,m] and [m,n] + (cond ((and (not m) (not n)) ((@ (guile) random) 1.0)) + ;; this is really [1,M) + ((and m) (+ 1 ((@ (guile) random) m))) + ((and m n) (+ m ((@ (guile) random) n))) + (else (error #:RANDOM "should not happen")))) + +(define (deg x) + (/ x radians_per_degree)) + +(define (rad x) + (* x radians_per_degree)) + +(define (ldexp x exp) + (cond ((= exp 0) x) + ((= exp *nan*) *nan*) + ((= exp +inf.0) +inf.0) + ((= exp -inf.0) -inf.0) + (else (* x (expt 2 exp))))) + +(define log2 + (let ((log2 (log 2))) + (lambda (x) + (/ (log x) log2)))) + +(define (frexp x) + (if (zero? x) + 0.0 + (let* ((l2 (log2 x)) + (e (floor (log2 x))) + (e (if (= l2 e) + (inexact->exact e) + (+ (inexact->exact e) 1))) + (f (/ x (expt 2 e)))) + f))) diff --git a/module/language/lua/standard/os.scm b/module/language/lua/standard/os.scm new file mode 100644 index 000000000..e4155a678 --- /dev/null +++ b/module/language/lua/standard/os.scm @@ -0,0 +1,108 @@ +;;; Guile Lua --- os standard library + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua standard os) + #:use-module (language lua runtime) + + #:use-module (srfi srfi-98)) + +(define (clock) + (tms:clock (times))) + +(define* (date #:optional (format "%c") time) + (let* ((utc? (eq? (string-ref format 0) #\!)) + ;; skip ! + (format (if utc? (string-copy format 1) format)) + (stm ((if utc? gmtime localtime) (or time (current-time))))) + (if time + (begin + (assert-number 2 "date" time) + (if (string=? format "*t") + (let* ((table (make-table))) + (rawset table "sec" (tm:sec stm)) + (rawset table "min" (tm:min stm)) + (rawset table "hour" (tm:hour stm)) + (rawset table "month" (+ 1 (tm:mon stm))) + (rawset table "year" (+ 1900 (tm:year stm))) + (rawset table "wday" (+ 1 (tm:wday stm))) + (rawset table "yday" (+ 1 (tm:yday stm))) + (rawset table "isdst" (> (tm:isdst stm) 0)) + table) + (strftime format stm))) + (strftime format stm)))) + +(define (difftime t2 t1) + (- t2 t1)) + +(define* (execute #:optional command) + (if (not command) + 1 + (system command))) + +(define* (exit #:optional (code 0)) + (primitive-exit code)) + +(define (getenv varname) + (or (get-environment-variable varname) #nil)) + +(define rename rename-file) + +(define (remove filename) + (if (file-is-directory? filename) + (rmdir filename) + (delete-file filename))) + +(define* (setlocale locale #:optional (category "all")) + (assert-string 2 "setlocale" category) + ((@ (guile) setlocale) + locale + (cond ((string=? category "all") LC_ALL) + ((string=? category "collate") LC_COLLATE) + ((string=? category "ctype") LC_CTYPE) + ((string=? category "messages") LC_MESSAGES) + ((string=? category "monetary") LC_MONETARY) + ((string=? category "numeric") LC_NUMERIC) + ((string=? category "time") LC_TIME)))) + +(define* (time #:optional table) + (if table + (begin + (assert-table 1 "time" table) + (let* ((sec (get-field table "sec" 0)) + (min (get-field table "min" 0)) + (hour (get-field table "hour" 12)) + (day (get-field table "day" -1)) + (month (- (get-field table "month" -1) 1)) + (year (- (get-field table "year" -1) 1900)) + (isdst (get-field table "isdst" 0)) + (result (make-vector 11 0))) + (set-tm:sec result sec) + (set-tm:min result min) + (set-tm:hour result hour) + (set-tm:mday result day) + (set-tm:mon result month) + (set-tm:year result year) + (set-tm:isdst result isdst) + (set-tm:zone result "") + (car (mktime result))) + ) + (current-time))) + +(define tmpname mkstemp!) diff --git a/module/language/lua/standard/table.scm b/module/language/lua/standard/table.scm new file mode 100644 index 000000000..738128225 --- /dev/null +++ b/module/language/lua/standard/table.scm @@ -0,0 +1,103 @@ +;;; Guile Lua --- table standard library + +;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language lua standard table) + #:use-module (language lua common) + #:use-module (language lua runtime) + + #:use-module (rnrs control) + #:use-module ((srfi srfi-1) #:select (filter!)) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-16) + #:use-module ((srfi srfi-69) #:select (hash-table-size hash-table-keys)) +) + +;; TODO - insert, remove, sort + +(define (add-field! table buffer i) + (define string (rawget table i)) + (unless (string? string) + (runtime-error "invalid value (~a) at index ~a in table for concat; expected string" string i)) + (display string buffer)) + +(define* (concat table #:optional (sep "") (i 1) (%last #f) #:rest _) + (define buffer (open-output-string)) + (assert-table 1 "concat" table) + (let* ((ht (table-slots table)) + (last (if (not %last) (table-length table) %last))) + (let lp ((i i)) + (if (< i last) + (begin + (add-field! table buffer i) + (display sep buffer) + (lp (+ i 1))) + (when (= i last) + (add-field! table buffer i))))) + (get-output-string buffer)) + +;; Arguments are named a1 and a2 because confusingly, the middle argument is optional +;; table.insert(table, [pos,] value) +(define (insert table . arguments) + (assert-table 1 "insert" table) + (receive + (pos value) + (apply + (case-lambda + ((value) + (values (table-length table) value)) + ((pos value) + (assert-number 1 "insert" pos) + (let* ((length (table-length table)) + (e (if (> pos length) pos length))) + (let lp ((i e)) + (when (> i pos) + (rawset table i (rawget table (- i 1))) + (lp (- i 1)))) + (values pos value))) + (else + (runtime-error "wrong number of arguments to 'insert'"))) + arguments) + (rawset table pos value))) + +(define (maxn table . _) + (assert-table 1 "maxn" table) + (let* ((result (sort! (filter! number? (hash-table-keys (table-slots table))) >))) + (if (null? result) + 0 + (car result)))) + +(define* (remove table #:optional pos) + (assert-table 1 "remove" table) + (let* ((e (table-length table))) + (unless pos (set! pos (table-length table))) + (assert-number 2 "remove" pos) + (if (eq? (table-length table) 0) + 0 + (let* ((result (rawget table pos))) + (let lp ((pos pos)) + (if (< pos e) + (begin + (rawset table pos (rawget table (+ pos 1))) + (lp (+ pos 1))) + (rawset table pos #nil))) + result)))) + +(define (sort . rest) + (runtime-error "table.sort UNIMPLEMENTED")) \ No newline at end of file diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index c4e4d1f55..34aee0198 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -69,6 +69,10 @@ SCM_TESTS = tests/00-initial-env.test \ tests/keywords.test \ tests/list.test \ tests/load.test \ + tests/lua-eval.test \ + tests/lua-eval-2.test \ + tests/lua-lexer.test \ + tests/lua-standard-library.test \ tests/match.test \ tests/match.test.upstream \ tests/modules.test \ diff --git a/test-suite/tests/lua-eval-2.test b/test-suite/tests/lua-eval-2.test new file mode 100644 index 000000000..c94694f59 --- /dev/null +++ b/test-suite/tests/lua-eval-2.test @@ -0,0 +1,112 @@ +;;;; lua-eval-2.test --- basic tests for builtin lua constructs, act II -*- mode: scheme -*- +;;;; +;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-lua) + #:use-module (ice-9 format) + #:use-module (language tree-il) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (system base compile) + #:use-module (test-suite lib) + + #:use-module (language lua parser) + + ) + +(with-test-prefix "lua-eval" + (define (from-string string) + (compile ((make-parser (open-input-string string))) + #:from 'lua + #:to 'value)) + (letrec-syntax + ((test + (syntax-rules () + ((_ string expect) + (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect))) + ((_ string) + (test string #t))))) + + ;; tables + (test "a={}; return a[0]" #nil) + (test "a={true}; return a[1]" #t) + (test "a = { false , true } ; return a[2];" #t) + (test "a = { false ; true ; } ; return a[2];" #t) + (test "a = { b = true }; return a.b" #t) + (test "a = { a = false , false ; b = true , true ; }; return a.b" #t) + (test "a = { a = false , false ; b = true , true ; }; return a[2]" #t) + + ;; locals + (test "local a; a = true; return a") + (test "local a = true; return a") + (test "local a,b=false,true; return b") + (test "local a,b,c=false,true,false; return b") + (test "local a,b,c=false,false,true; return c") + + ;; local function statements + (test "local function identity(x) return x end; return identity(true)") + + ;; metatable events + (test "table = {} setmetatable(table, { __add = function(a,b) return b end }) return table + 5" 5) + (test "table = {} setmetatable(table, { __add = function(a,b) return a end }) return 5 + table" 5) + + ;; field functions + (test "table = {} function table.identity(x) return x end return table.identity(true)") + + ;; repeat + (test "i=0; repeat i = i+1 until i == 5; return i" 5) + (test "i=5; repeat i = i-1 until i == 0; return i" 0) + + ;; length operator + (test "return #\"asdf\"" 4) + (test "table = {1,2,3,4}; return #table" 4) + + ;; _G + (test "a = true return _G.a") + (test "a = true return _G._G.a") + (test "a = true return _G._G._G.a") + + ;; concat + (test "return \"hello\"..\" world\"" "hello world") + + ;; built-in functions + (test "assert(true)" #t) + (test "print(T)" #nil) + (test "print(false or true)" #nil) + (test "table = {}; rawset(table, 0, true); return table[0]") + (test "table = {}; rawset(table, 0, true); return rawget(table, 0)") + + ;; methods + (test "table = {} function table:identity() return self end return table.identity(true)") + (test "table = {} function table.identity(self,x) return x end return table:identity(true)") + + ;; arguments default to nil + (test "function test(x) return x end return test()" #nil) + + ;; application with freestanding string or table as argument + (test "print {x=5}; return true") + (test "print \"hello world\"; return true") + + ;; variable arguments + #;(test "function test(...) print(...) end test(1,2)") + + ;; numeric for loop + (test "for x = 1,2,1 do print(true) end return true") + + ;; list for loop, and ipairs + (test "table = {1,2,3} for i,v in ipairs(table) do print(i,v) end return true") + )) diff --git a/test-suite/tests/lua-eval.test b/test-suite/tests/lua-eval.test new file mode 100644 index 000000000..93e346e88 --- /dev/null +++ b/test-suite/tests/lua-eval.test @@ -0,0 +1,115 @@ +;;;; lua-eval.test --- basic tests for builtin lua constructs -*- mode: scheme -*- +;;;; +;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-lua) + #:use-module (ice-9 format) + #:use-module (language tree-il) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (system base compile) + #:use-module (test-suite lib) + + #:use-module (language lua parser) + + ) + +(with-test-prefix "lua-eval" + (define (from-string string) + (compile ((make-parser (open-input-string string))) + #:from 'lua + #:to 'value)) + (letrec-syntax + ((test + (syntax-rules () + ((_ string expect) + (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect))) + ((_ string) + (test string #t))))) + + (test "return true") + (test "return false" #f) + (test "return nil" #nil) + (test "return 12345" 12345) + (test "return 12345.6789" 12345.6789) + (test "return \"string\"" "string") + (test "return (true)") + (test "return (false == false)") + (test "return;" *unspecified*) + (test "return [[string]]" "string") + (test "return [=[string]=]" "string") + + ;; exercise the operator precedence parser + (test "return 2" 2) + (test "return 2 + 2" 4) + (test "return 1 + 2 * 3" 7) + (test "return 1 * 2 + 3" 5) + (test "return 1 + 2 ^ 3 * 4 - 5" 28) + (test "return 1 ^ 2 - 3 * 4 + 5" -6) + (test "return 1 + -6" -5) + + ;; logical operators + (test "return false or true") + (test "return true or false") + (test "return false or false or true") + (test "return false or nil and true" #nil) + (test "return true and true") + (test "return true and nil" #nil) + (test "return true and false and nil" #f) + + ;; conditionals + (test "if true then return true end") + (test "if false then return false else return true end") + (test "if true then return true else return false end") + (test "if false then return false elseif true then return true elseif false then return false else return false end") + (test "if false then return false elseif false then return false elseif true then return true else return false end") + (test "if false then return false elseif false then return false elseif false then return false else return true end") + + ;; function expressions + (test "(function(x) return x end)(true)") + + ;; undefined variables are implicitly nil + (test "return undefined == nil") + (test "return undefined ~= nil" #f) + + ;; assignments + (test "variable = true; return variable") + (test "a,b = 1,2; return a" 1) + (test "a,b=1,2;return b" 2) + (test "a,b,c=false,true,false; return b") + (test "a,b=1;return b" #nil) + + ;; function statements + (test "function noargs() return true end noargs()") + (test "function identity(x) return x end return identity(21)" 21) + (test "function fib(n) if n < 2 then return n else return fib(n-1) + fib(n-2) end end return fib(20)" 6765) + (test "function fib(n) if n < 2 then return n else return fib(n-1) + fib(n-2) end end return fib(20)" 6765) + + ;; do + (test "do return true end") + (test "do if false then return false elseif false then return false elseif false then return false else return true end end") + + ;; parenthetical expressions + (test "return (true);") + (test "return (2 + (2))" 4) + + ;; while + (test "while true do return true end") + (test "i=0; while i<5 do i=i+1 end return i" 5) + (test "while true do do break end return false end return true") + + )) diff --git a/test-suite/tests/lua-lexer.test b/test-suite/tests/lua-lexer.test new file mode 100644 index 000000000..c70b09441 --- /dev/null +++ b/test-suite/tests/lua-lexer.test @@ -0,0 +1,75 @@ +;;;; lua-lexer.test --- lua lexer test suite -*- mode: scheme -*- +;;;; +;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-lua-lexer) + #:use-module (ice-9 format) + #:use-module (srfi srfi-8) + #:use-module (test-suite lib) + + #:use-module (language lua lexer)) + +(with-test-prefix "lua-lexer" + (define (from-string string) + (define-lua-lexer get-source-info lex) + (call-with-input-string + string + (lambda (port) + + (initialize-lua-lexer! port get-source-info lex) + (lex)))) + + (let-syntax + ((test + (syntax-rules (eof) + ((_ string expect) + (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect))) + ((_ (eof string)) + (pass-if (format "~a => #" string) (eof-object? (from-string string))))))) + + (test (eof " ")) + (test (eof "-- comment")) + (test (eof "--[[long +comment]]")) + + (test "[[long string]]" "long string") + (test "[=[[==[longer string]==]]=]" "[==[longer string]==]") + + ;; numbers + (test "12345" 12345) + (test "12345.6789" 12345.6789) + (test "12.34e5" 1234000.0) + (test ".34e5" 34000.0) + + ;; string escapes + (test "'\\a\\b\\f\\n\\r\\t\\v'" + "\a\b\f\n\r\t\v") + (test "'\\''" + "'") + + ;; operators, keywords, identifiers + (test "name" 'name) + (test "return" #:return) + (test ".." #:concat) + (test "..." #:dots) + (test ";" #\;) + (test "-" #\-) + (test "+" #\+) + (test "/" #\/) + (test "*" #\*) + +)) diff --git a/test-suite/tests/lua-standard-library.test b/test-suite/tests/lua-standard-library.test new file mode 100644 index 000000000..6f37f7e4a --- /dev/null +++ b/test-suite/tests/lua-standard-library.test @@ -0,0 +1,77 @@ +;;;; lua standard library test -*- mode: scheme -*- +;;;; +;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-lua) + #:use-module (ice-9 format) + #:use-module (language tree-il) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (system base compile) + #:use-module (test-suite lib) + + #:use-module (language lua parser) + + ) + +(define (from-string string) + (compile ((make-parser (open-input-string string))) + #:from 'lua + #:to 'value)) + +(define-syntax + test + (syntax-rules () + ((_ string expect) + (pass-if (format "~S => ~S" string expect) (equal? (from-string string) expect))) + ((_ string) + (test string #t)))) + +(with-test-prefix "lua-builtin" + (test "assert(true)") + (test "rawequal(true,true)") + (test "return tonumber('2')" 2) +) + +(with-test-prefix "lua-math" + (test "require 'math'; return true") + (test "return math.abs(-1)" 1) + (test "return math.asin(1)" (asin 1)) + (test "return math.acos(5)" (acos 5)) + (test "return math.atan(2/1)" (atan (/ 2 1))) + (test "return math.atan2(2,1)" (atan (/ 2 1))) + (test "return math.ceil(0.5)" (ceiling 0.5)) + (test "return math.cos(1)" (cos 1)) + (test "return math.cosh(1)" (cosh 1)) + (test "return math.floor(0.5)" (floor 0.5)) + (test "return math.log(10)" (log 10)) + (test "return math.log10(5)" (log10 5)) + (test "return math.sqrt(4)" (sqrt 4)) + (test "return math.sin(5)" (sin 5)) + (test "return math.sinh(5)" (sinh 5)) + (test "return math.tan(5)" (tan 5)) + (test "return math.tanh(5)" (tanh 5)) + (test "return math.ldexp(4,3)" 32) + (test "return math.modf(6,4)" 2) + ) + +(with-test-prefix "lua-table" + (test "require 'table'; return true") + (test "t = {}; t[1] = true; t[555] = true; t[1234] = true; return table.maxn(t)" 1234) + (test "return table.concat({\"1\", \"2\", \"3\"}, \" \")" "1 2 3") + (test "t = {}; t[1] = true; t[2] = false; table.insert(t, 2, true); return t[2]") +)