[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-44-g7494c
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-44-g7494cc5 |
|
Date: |
Thu, 17 Jun 2010 17:37:49 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=7494cc585e91869ecdcc761e971f21a21850ad00
The branch, lua has been updated
via 7494cc585e91869ecdcc761e971f21a21850ad00 (commit)
via cb27901b9c8bab3a76c372f5db100bf699fdb725 (commit)
via 002bc75d8720d27537f70b9ed66057edadf3f617 (commit)
from 0864403f1224c528ebae22b658732e845c97dfdb (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 7494cc585e91869ecdcc761e971f21a21850ad00
Author: No Itisnt <address@hidden>
Date: Thu Jun 17 12:37:03 2010 -0500
lua: Add table functions.
commit cb27901b9c8bab3a76c372f5db100bf699fdb725
Author: No Itisnt <address@hidden>
Date: Wed Jun 16 10:38:04 2010 -0500
lua: Split up into modules, fix ^ operator.
commit 002bc75d8720d27537f70b9ed66057edadf3f617
Author: No Itisnt <address@hidden>
Date: Wed Jun 16 10:28:42 2010 -0500
lua: Metatable events are now supported.
-----------------------------------------------------------------------
Summary of changes:
lua.scm | 1230 ----------------------------
module/language/lua/common.scm | 20 +
module/language/lua/global-environment.scm | 48 ++
module/language/lua/lexer.scm | 113 +++
module/language/lua/parser.scm | 756 +++++++++++++++++
module/language/lua/runtime.scm | 134 +++
module/language/lua/spec.scm | 12 +
test-suite/tests/lua.test | 223 +++++
8 files changed, 1306 insertions(+), 1230 deletions(-)
delete mode 100644 lua.scm
create mode 100644 module/language/lua/common.scm
create mode 100644 module/language/lua/global-environment.scm
create mode 100644 module/language/lua/lexer.scm
create mode 100644 module/language/lua/parser.scm
create mode 100644 module/language/lua/runtime.scm
create mode 100644 module/language/lua/spec.scm
create mode 100644 test-suite/tests/lua.test
diff --git a/lua.scm b/lua.scm
deleted file mode 100644
index 2a11a53..0000000
--- a/lua.scm
+++ /dev/null
@@ -1,1230 +0,0 @@
-;; note: everything is stuffed into one file for now. it will be split up
after reaching stability
-
-;; organization:
-
-;; - common utilities
-
-;; - lexer
-
-;; - parser
-;; -- parser utilities
-;; -- actual grammar, expressed as functions
-
-;; - global-environment
-;;
-;; currently the global environment is expressed as a module. it will
-;; probably remain so because it needs to be somewhat reflective to support
_G,
-;; a lua global variable that is set to a table representing the global
environment
-;;
-;; -- standard builtin functions
-
-;; - runtime
-;; -- misc. runtime functions, operator implementations (which will need to
support metatable events and lua's semantics, and so cannot simply be the
equivalent scheme functions)
-
-;; - tests
-
-(define-module (language lua common)
-
- #:use-module (ice-9 format)
-
- #:export (syntax-error runtime-error))
-
-(define (syntax-error src string . arguments)
- (throw
- 'lua-syntax
- (apply format (string-append "~A: " string)
- (cons (format "address@hidden"
- (cdr (assq 'filename src))
- (cdr (assq 'line src))
- (cdr (or (assq 'column src) '(#f . #f))))
- arguments))))
-
-(define (runtime-error src . rest)
- (apply throw (cons 'lua-runtime rest)))
-
-(define-module (language lua lexer)
- #:use-module (srfi srfi-14)
- #:use-module (srfi srfi-39)
-
- #:use-module (language lua common)
-
- #:export (make-lexer))
-
-(define (source-info port)
- `((backtrace . #f) (filename . ,(port-filename port))
- (line . ,(port-line port)) (column . ,(port-column port))))
-
-(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 (possible-keyword k)
- "Convert a symbol to a keyword if it is a reserved word in Lua"
- (case k
- ((return function end if then elseif else true false nil or and do while
local) (symbol->keyword k))
- (else k)))
-
-(define (make-lexer port)
- (define buffer (open-output-string))
- (define (clear-buffer)
- "Reset the buffer and return a string of the contents"
- (define string (get-output-string buffer))
- (truncate-file buffer 0)
- string)
- (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)
- (if saved-source-info
- saved-source-info
- (source-info port)))
- (define (lex)
- (parameterize ((current-input-port port)
- (current-output-port buffer))
- (set! saved-source-info #f)
- (let loop ()
- (define c (peek-char))
- (case c
- ;; spaces
- ((#\newline #\return #\space #\page #\tab #\vtab) (read-char) (loop))
- ;; comments and -
- ((#\-)
- (read-char)
- (if (eq? (peek-char) #\-)
- ;; it is a comment
- (let consume ((c (read-char)))
- (cond ((eof-object? c) (loop))
- ((eq? c #\newline) (loop))
- (else (consume (read-char)))))
- ;; it is a -
- #\-))
-
- ;; ~=
- ((#\~)
- (read-char)
- (if (eq? (peek-char) #\=)
- (begin (read-char) #:~=)
- (syntax-error (get-source-info) "expected = after ~ but got ~c"
c)))
- ;; = and ==
- ((#\=)
- (read-char)
- (if (eq? (peek-char) #\=)
- (begin (read-char) #:==)
- #:=))
- ;; TODO: ...
- ;; floating point number or table indice
- ((#\.) (read-char))
- ;; characters that are allowed directly through
- ((#\; #\( #\) #\,
- #\+ #\/ #\*
- #\< #\^ #\{ #\} #\[ #\]) (read-char))
- ;; numbers
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
- (write-char (read-char))
- (save-source-info)
- (while (is-digit? (peek-char))
- (write-char (read-char)))
- (string->number (clear-buffer)))
- ((#\")
- (read-char)
- (while (not (or (eq? (peek-char) #\") (eof-object? (peek-char))))
- (write-char (read-char)))
- (clear-buffer))
-
- ;; strings
- (else
- (cond ((eof-object? c) c)
- ;; identifier or keyword
- ((is-name-first? c)
- (write-char (read-char))
- (save-source-info)
- (while (is-name? (peek-char))
- (write-char (read-char)))
- (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
-
-;; This module is actually the default global environment of Lua.
-(define-module (language lua global-environment))
-
-(define (print . arguments)
- (for-each
- (lambda (x)
- (cond ((eq? x #f) (display "false"))
- ((eq? x #t) (display "true"))
- ((eq? x #nil) (display "nil"))
- (else (write x)))
- (write-char #\tab))
- arguments)
- (newline)
- #nil)
-
-(define* (assert v #:optional (message "assertion failed!") #:rest rest)
- (if ((@ (language lua runtime) false?) v)
- (runtime-error message)
- (apply values (cons v (cons message rest)))))
-
-(define-module (language lua runtime)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-69)
-
- #:export (
- ;; semantics
- false? true?
- ;; operators
- unm eq lt le gt ge add sub mul div pow
- neq
- ;; tables
- make-table
- table-get
- table-set!
- dispatch-metatable-event
- ))
-
-;;;;; 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)))
-
-;;;;; OPERATORS
-
-(define (unm a)
- "A function backing the unary - (negation) operator"
- (- a))
-
-(define (eq a b)
- "A function backing the == operator"
- (equal? a b))
-
-(define (neq a b)
- "An inversion of eq"
- (not (eq a b)))
-
-(define (lt a b)
- "A function backing the < (less-than) operator"
- (< a b))
-
-(define (le a b)
- "A function backing the <= (less-than-or-equal-to) operator"
- (or (lt a b) (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)))
-
-(define (add a b)
- "A function backing the + operator"
- (+ a b))
-
-(define (sub a b)
- "A function backing the binary - (subtraction) operator"
- (- a b))
-
-(define (mul a b)
- "A function backing the * operator"
- (* a b))
-
-(define (div a b)
- "A function backing the / operator"
- (/ a b))
-
-(define (pow a b)
- "A function backing the ^ operator"
- (expt a b))
-
-;;;;; TABLES
-
-(define-record-type table
- (%make-table metatable slots)
- table?
- (metatable table/metatable table/metatable!)
- (slots table/slots table/slots!))
-
-(define (make-table)
- (%make-table #f (make-hash-table equal?)))
-
-(define (dispatch-metatable-event key default table . arguments)
- (apply
- (if (table/metatable table)
- (hash-table-ref (table/metatable table) key)
- default)
- arguments))
-
-(define (table-get table key)
- (hash-table-ref/default (table/slots table) key #nil))
-
-(define (table-set! table key value)
- (hash-table-set! (table/slots table) key value))
-
-(define-module (language lua parser)
-
- #:use-module (language tree-il)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-8)
- #:use-module (srfi srfi-9)
-
- #:use-module (language lua common)
- #:use-module (language lua lexer)
-
- #:export (make-parser))
-
-;; This parser is based heavily on Lua's parser. Lua's grammar is a little
-;; plucky for lalr-scm or another parser generator option
-
-;; Unlike Lua's parser, it:
-;; - does not track syntax nesting levels
-;; - returns tree-il instead of incrementally compiling the code
-
-(define-record-type environment
- (make-environment parent names)
- environment?
- (parent environment/parent)
- (names environment/names environment/names!))
-
-(define (end-of-block? k)
- (case k
- ((#:else #:elseif #:end #:until) #t)
- (else (eof-object? k))))
-
-;; TODO: this is here mainly to ensure that no unwanted values are propagated
-;; through the parser -- it will be removed and replaced with the informal
-;; equivalents later
-(define (token/type t)
- (cond ((number? t) 'NUMBER)
- ((eof-object? t) 'EOS)
- ((symbol? t) 'NAME)
- ((string? t) 'STRING)
- (else
- (case t
- ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #:function #:end
#:if #:elseif #:then #:else #:true #:false #:nil #:== #:~= #:= #:local) t)
- (else (error #:TOKEN/TYPE t))))))
-
-;; name of global environment module
-(define *global-env-name* '(language lua global-environment))
-(define *global-env* (resolve-module *global-env-name*))
-
-(define *runtime-name* '(language lua runtime))
-
-(define (ref-runtime src name) (make-module-ref src *runtime-name* name #t))
-
-;; infix operator parsing
-(define (binary-operator? t)
- (case t
- ((#\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or) #t)
- (else #f)))
-
-(define (unary-operator? t)
- (case t
- ((#\- #:not) #t)
- (else #f)))
-
-;; parsing priority
-(define *unary-priority* 80)
-
-(define (priority o)
- (case o
- ((#:or) 10)
- ((#:and) 20)
- ((#:== #:~= <= >= #\< #\>) 30)
- ((#\+ #\-) 60)
- ((#\* #\/ #\%) 70)
- ((#\^ #:concat) 99)))
-
-(define (operator->tree-il src operator . arguments)
- (make-runtime-application src operator arguments))
-
-;;;;; TREE-IL UTILITIES
-
-(define (make-unary-operation src operator a)
- "Convert parsed unary operation to tree-il"
- (operator->tree-il src
- (case operator
- ((#\-) 'unm)
- (else (error #:MAKE-UNARY-OPERATION "should not happen" a)))
- a))
-
-(define (make-binary-operation src operator a b)
- "Convert parsed infix operation to tree-il"
- (case operator
- ((#\+ #\- #\* #\/ #\^ #\< #:== #:~=)
- (operator->tree-il
- src
- (case operator
- ((#\+) 'add)
- ((#\-) 'sub)
- ((#\*) 'mul)
- ((#\/) 'div)
- ((#\^) 'pow)
- ((#\<) 'lt)
- ((#:==) 'eq)
- ((#:~=) 'neq)
- (else (error #:MAKE-BINARY-OPERATION "should not happen" operator a
b)))
- a b))
- ((#:or)
- (make-lua-conditional
- src
- a
- a
- b))
- ((#:and)
- (make-lua-conditional
- src
- a
- b
- a))))
-
-(define (make-lua-assignment left right)
- "Generate an assignment from a variable and an expression"
- (cond ((module-ref? left)
- (make-module-set (module-ref-src left) (module-ref-mod left)
(module-ref-name left) (module-ref-public? left) right))
- ((lexical-ref? left)
- (make-lexical-set (lexical-ref-src left) (lexical-ref-name left)
(lexical-ref-gensym left) right))))
-
-(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 'table-get (list table index)))
-
-(define (wrap-expression-in-environment src e x)
- "Wrap an expression in an enclosing lexical environment if necessary"
- (define names (environment/names e))
- (if (not (null? names))
- (make-let src (map car names) (map cdr names) (map (lambda (x)
(make-const src #nil)) names) x)
- x))
-
-(define (make-parser port)
- ;; functions that will be retrieved from make-lexer
- (define get-source-info)
- (define lexer)
-
- ;;;;; PARSER STATE
- (define token2 #f)
-
- (define (lookahead!)
- (set! token2 (lexer)))
-
- ;; current token
- (define token)
- ;; lexical environment
- (define environment #f)
-
- ;;;;; ENVIRONMENTS
- (define (enter-environment!)
- (set! environment
- (make-environment environment '())))
-
- (define (leave-environment!)
- (if (not environment)
- (error #:LEAVE-ENVIRONMENT! "should not happen"))
- (set! environment
- (environment/parent environment)))
-
- (define (environment-define! name )
- (if (not (member name (environment/names environment)))
- (environment/names! environment (alist-cons name (gensym
(string-append " " (symbol->string name))) (environment/names environment)))))
-
- (define (environment-lookup name . e)
- (set! e (if (null? e) environment (car e )))
- (if e
- (let ((binding (assq-ref (environment/names e) name)))
- (if binding
- binding
- (environment-lookup name (environment/parent e))))
- #f))
-
- (define (resolve-ref src name)
- (let* ((binding (environment-lookup name)))
- (if binding
- (make-lexical-ref src name binding)
- ;; TODO: Consider _G
- (begin
- (if (not (module-defined? *global-env* name))
- (module-define! *global-env* name #nil))
- (make-module-ref src *global-env-name* name #f)))))
-
- ;;;;; TREE-IL UTILITIES
- ;; tree-il utilities that need access to this closure
- (define (make-lua-function src parameters body-promise)
- "Generate a function"
-
- ;; create a new environment and populate it with the function's parameters
-
- ;; functions have two environments: one for the function's parameters and
- ;; another for the function's locals (this is inefficient and is simply to
- ;; compensate for the simplistic implementation of locals (in CHUNK),
- ;; perhaps the environment should be extended to track the type of a
- ;; variable as well)
- (enter-environment!)
-
- (for-each environment-define! parameters)
- (enter-environment!)
-
- (let* ((body (force body-promise))
- (parameter-gensyms (map environment-lookup parameters)))
- (leave-environment!)
- (leave-environment!)
- (make-lambda
- src '()
- (make-lambda-case src parameters #f #f #f '() parameter-gensyms (if
(null? body) (make-void src) body) #f))))
-
- (define (apply-named-lua-function src get-body)
- (let* ((name (gensym " named"))
- (parameters (list name)))
- (make-let
- src
- parameters parameters
- (list (make-lambda src '() (get-body name)))
- (make-application src (make-lexical-ref src name name) '()))))
-
- ;;;;; LEXER INTERACTION
-
- (define (advance!)
- "Read a new token and store it in TOKEN"
- (if token2
- (begin
- (set! token token2)
- (set! token2 #f))
- (set! token (lexer))))
-
- (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)
- (begin (advance!) #t)
- #f))
-
- (define (enforce-next! expect)
- "Throw an error if the current token is not the expected token"
- (if (not (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 ] ')'
- (define (application-arguments)
- (case token
- ;; '('
- ((#\()
- (advance!)
- (if (eq? token #\))
- ;; ')'
- (begin (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))
-
- ;; 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* ((result
- (case (token/type token)
- ;; field-selector
- ((#\.)
- (enforce-next! #\.)
- (make-table-ref src prefix (make-const src (symbol->string
(single-name))))
- )
- ;; index
- ((#\[)
- (let* ((indice (index)))
- (make-table-ref src prefix indice)))
- ;; application-arguments
- ((#\()
- (make-application src prefix (application-arguments)))
- (else prefix))))
- ;; finished
- result))
-
- ;; expression-statement -> function | assignment
- (define (expression-statement)
- (define primary (primary-expression))
- (if (application? primary)
- primary
- (assignment primary)))
-
-
- ;; record-field -> (NAME | index) '=' expression
- (define (record-field)
- (let* ((indice
- (cond
- ;; NAME
- ((eq? (token/type token) 'NAME)
- (let ((tmp (make-const #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 table-var-name)
- (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)
- (append!
- (list (make-runtime-application src 'table-set!
- (list (make-lexical-ref src table-var-name
table-var-name) (or indice (make-const 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* ((temp-name (gensym " table"))
- (names (list temp-name))
- (result
- (make-let
- src
- names names
- (list (make-runtime-application src 'make-table '()))
- ;; table-fields
- (make-sequence src (reverse! (append! (list (make-lexical-ref src
temp-name temp-name)) (table-fields src temp-name)))))))
- (enforce-next! #\})
- result))
-
- ;; parameter-list -> [ parameter { ',' parameter } ]
- (define (parameter-list function-name)
- (if (eq? token #\))
- '()
- (let loop ((parameters '()))
- ;; the parameters can either be a name or a ...
- (let* ((parameters
- (case (token/type token)
- ((NAME) (append parameters (list token)))
- (else (syntax-error (get-source-info) "expected either a
name or a ... in the parameter list of ~a, but got ~a" function-name token)))))
- (advance!)
- (if (eq? token #\,)
- (begin (advance!) (loop parameters))
- parameters)))))
-
- ;; function-body -> '(' parameter-list ')' chunk END
- (define* (function-body #:optional (src (get-source-info)))
- ;; '('
- (enforce-next! #\()
- ;; parameter-list
- (let* ((parameters (parameter-list "anonymous function")))
- ;; ')'
- (enforce-next! #\))
- (let* ((result
- (make-lua-function
- src
- parameters
- (delay (chunk)))))
- (enforce-next! #:end)
- result)))
-
- ;; expression-list -> expression { ',' expression }
- (define (expression-list)
- (let loop ((tree (list (expression))))
- ;; { ',' expression }
- (if (maybe-skip-next! #\,)
- (loop (append! (list (expression)) tree))
- ;; finished
- (reverse! tree))))
-
- ;; simple-expression -> (nil | true | false | NUMBER | STRING) |
table-literal | FUNCTION function-body
- (define (simple-expression)
- (define src src)
- (receive
- (advance? result)
- (case (token/type token)
- ;; (nil | true | false | NUMBER | STRING)
- ((#:true #:false #:nil NUMBER STRING)
- (values
- #t
- (make-const
- src
- (cond ((eq? token #:true) #t)
- ((eq? token #:false) #f)
- ((eq? token #:nil) #nil)
- (else token)))))
- ;; table-literal
- ((#\{) (values #f (table-literal)))
- ;; 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-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-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
- (define result (apply-named-lua-function
- src
- (lambda (loop)
- (make-lua-conditional
- src
- condition
- (make-sequence
- src
- (list body (make-application src (make-lexical-ref src loop loop)
'())))
- (make-void src)))))
- (enforce-next! #:end)
- result)))
-
- ;; return-statement -> RETURN expression-list
- (define (return-statement)
- (define src (get-source-info))
-
- ;; RETURN
- (advance!)
-
- (make-application src (make-primitive-ref src 'return)
- ;; if followed by END or ';', the return has no
arguments, otherwise
- (if (or (end-of-block? token) (eq? token #\;))
- (list (make-void src))
- ;; expression-list
- (expression-list))))
-
- ;; 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))))
-
- (define (parse-assignment src left right)
- ;; and then parses it, branching to handle overflows on either side if
necessary
- (make-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)
- (append! (list (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) (make-const #f #nil)))
- (rest (cdr rest)))
- (if (null? rest)
- (reverse! (append! (list il) tree))
- (loop (append! (list 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 (append! (list x) tree))
- (if (eq? token #\,)
- (begin (advance!) (loop (primary-expression) tree))
- (reverse! tree))))
-
- (right (begin
- (enforce-next! #:=)
- (expression-list))))
- (parse-assignment src left right)
-
- ) ; let*
- ) ; assignment
-
-
- ;; 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-lua-conditional
- if-src
- test
- then
- (let loop ()
- (define src (get-source-info))
- (if (eq? token #:elseif)
- (receive (test then)
- (then-chunk)
- (make-lua-conditional src test then (loop)))
- (if (eq? token #:else)
- (begin (advance!) (chunk))
- (make-void #f)))))))
- (enforce-next! #:end)
- x)
-
- ;; function-statement -> FUNCTION NAME function-body
- (define (function-statement)
- (define src (get-source-info))
- ;; skip FUNCTION
- (advance!)
- ;; TODO: table functions e.g. function table:name()
- (let* ((name (single-name)))
- (module-define! (resolve-module '(language lua global-environment)) name
*unspecified*)
- (make-module-set src '(language lua global-environment) name #f
(function-body))))
-
- ;; 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 (append! (list token) names))
- (advance!)
- (if (maybe-skip-next! #\,)
- ;; { ',' NAME }
- (lp names)
- (begin
- (for-each environment-define! names)
- (if (maybe-skip-next! #:=)
- ;; [ '=' expression-list ]
- (let* ((left (map (lambda (x) (resolve-ref src x)) names))
- (right (expression-list)))
- ;(format #t "~A ~A\n" left right)
- (parse-assignment src left (reverse! right)))
- ;; otherwise, it's not a declaration, not an assignment, and
evaluates to nothing
- (make-void #f))))))
-
- (define (local-function-statement)
- (assert-token-type 'NAME)
- (let* ((name token))
- (environment-define! name)
- (advance!)
- (make-lexical-set (get-source-info) name (environment-lookup name)
(function-body))))
-
- ;; statement
- (define (statement)
- (case token
- ((#\;) (advance!) (statement))
- ;; statement -> return
- ((#:return) (values #t (return-statement)))
- ((#:if #:function #:do #:while #:local)
- (values
- #f
- (case token
- ((#:while) (while-statement))
- ((#:if) (if-statement))
- ((#:function) (function-statement))
- ((#:local)
- (advance!)
- (if (maybe-skip-next! #:function)
- (local-function-statement)
- (local-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-block? token))
- (tree '()))
- (if is-last
- (begin (maybe-skip-next! #\;)
- (wrap-expression-in-environment
- src
- environment
- (make-sequence src (reverse! tree))))
- (receive
- (is-last node)
- (statement)
- (loop (or (end-of-block? token) is-last) (append! (list node)
tree))))))
-
- (receive (get-source-info% lexer%)
- (make-lexer port)
- (set! get-source-info get-source-info%)
- (set! lexer lexer%))
- ;; toplevel local environment
- (enter-environment!)
- ;; read first token
- (advance!)
- ;; return parser
- chunk)
-
-(define-module (language lua spec)
- #:use-module (system base language)
-
- #:use-module (language lua lexer)
- #:use-module (language lua parser))
-
-(define-language lua
- #:title "Lua"
- #:reader (lambda (port _) #f)
- #:compilers `((tree-il . ,(lambda (x e o) (values x e e))))
- #:printer write)
-
-(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 lexer)
- #:use-module (language lua parser))
-
-(with-test-prefix "lua-lexer"
- (define (from-string string)
- (receive (_ lex)
- (make-lexer (open-input-string string))
- (lex)))
- (let-syntax
- ((test
- (syntax-rules (eof predicate)
- ((_ string expect)
- (pass-if (format "~S => ~A" string expect) (equal? (from-string
string) expect)))
- ((_ (eof string))
- (pass-if (format "~a => #<eof>" string) (eof-object? (from-string
string)))))))
-
- (test (eof " "))
- (test (eof "-- comment"))
-
- (test "12345" 12345)
- (test "name" 'name)
- (test "return" #:return)
- (test ";" #\;)
- (test "-" #\-)
- (test "+" #\+)
- (test "/" #\/)
- (test "*" #\*)
-
-))
-
-(define (tree-il? x) (or (application? x) (module-ref? x) (primitive-ref? x)
-(lexical-ref? x) (sequence? x) (void? x) (const? x) (lambda? x) (module-set? x)
-(toplevel-ref? x) (toplevel-set? x) (toplevel-define? x) (conditional? x)
-(lambda-case? x) (letrec? x) (let? x) (lexical-set? x)))
-
-(define (strip-tree-il! x)
- (cond ((list? x) (map! strip-tree-il! x))
- ((tree-il? x) (unparse-tree-il x))
- (else x)))
-
-(with-test-prefix "lua-parser"
- (let-syntax
- ;; Note on parser tests:
- ;; Lua does not allow standalone expressions, only statements.
- ;; It does allow returns from the toplevel. This is how expressions are
evaluated at the Lua REPL.
- ;; So, the inputs and outputs of these tests are automatically prefixed
with a return
- ((test-return
- (syntax-rules ()
- ((_ string . expect)
- (let* ((real-string (string-append "return " string))
- (real-expect `(begin (apply (primitive return) ,@`expect)))
- (result (from-string real-string)))
- (pass-if (format "~S => ~A" real-string real-expect) (equal? result
real-expect)))))))
-
- ;; shortcuts
- (define (from-string string) (strip-tree-il! ((make-parser
(open-input-string string)))))
- (define (op x) `(@ (language lua runtime) ,x))
- (define (global x) `(@@ (language lua global-environment) ,x))
-
- (test-return "" (void))
- (test-return ";" (void))
-
- (test-return "2" (const 2))
- (test-return "1 + 2" (apply ,(op 'add) (const 1) (const 2)))
- (test-return "1 + 2 * 3" (apply ,(op 'add) (const 1) (apply ,(op 'mul)
(const 2) (const 3)) ))
- (test-return "1 * 2 + 3" (apply ,(op 'add) (apply ,(op 'mul) (const 1)
(const 2)) (const 3)))
- (test-return "1 * 2 + 3 - 4" (apply ,(op 'sub) (apply ,(op 'add) (apply
,(op 'mul) (const 1) (const 2)) (const 3)) (const 4)))
- (test-return "-1" (apply ,(op 'unm) (const 1)))
- (test-return "- 2" (apply ,(op 'unm) (const 2)))
-
- (test-return "var" ,(global 'var))
- (test-return "print()" (apply ,(global 'print)))
- (test-return "print(1)" (apply ,(global 'print) (const 1)))
- (test-return "print(1,2)" (apply ,(global 'print) (const 1) (const 2)))
- (test-return "print(1+2,3*4)" (apply ,(global 'print) (apply ,(op 'add)
(const 1) (const 2)) (apply ,(op 'mul) (const 3) (const 4))))
-
-))
-
-(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 => ~A" 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)")
-
- ;; 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;" *unspecified*)
- (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)")
-
- ;; function statements
- (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 "\n-- fibonacci numbers\nfunction fib(n)\n if n < 2 then\n
return n\n else\n return fib(n-1) + fib(n-2)\n end\nend\nreturn fib(20)"
6765)
-
- ;; built-in functions
- (test "assert(true)")
- (test "print(T)" #nil)
- (test "print(false or true)" #nil)
-
- ;; 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")
-
- ;; undefined variables are implicitly defined to 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)
-
- ;; 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)
-
- ;; 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)")
-
- ;; - compiler
- ;; method invocations
- ;; for loops
- ;; repeat loops
- ;; variable arguments
- ;; multiple returns
- ;; - runtime
- ;; metatables
- ;; metatable events
-))
-
-#;(begin
- (define var
- "local function identity(x) return x end; return identity(true)"
- ) (display (compile ((make-parser (open-input-string var)))
- #:from 'lua #:to 'tree-il))
- (newline))
diff --git a/module/language/lua/common.scm b/module/language/lua/common.scm
new file mode 100644
index 0000000..5fe8cc2
--- /dev/null
+++ b/module/language/lua/common.scm
@@ -0,0 +1,20 @@
+;; common.scm --- common lua functions
+(define-module (language lua common)
+
+ #:use-module (ice-9 format)
+
+ #:export (syntax-error runtime-error))
+
+(define (syntax-error src string . arguments)
+ (throw
+ 'lua-syntax
+ (apply format (string-append "~A: " string)
+ (cons (format "address@hidden"
+ (cdr (assq 'filename src))
+ (cdr (assq 'line src))
+ (cdr (or (assq 'column src) '(#f . #f))))
+ arguments))))
+
+(define (runtime-error message)
+ (throw 'lua-runtime message))
+
diff --git a/module/language/lua/global-environment.scm
b/module/language/lua/global-environment.scm
new file mode 100644
index 0000000..61c4117
--- /dev/null
+++ b/module/language/lua/global-environment.scm
@@ -0,0 +1,48 @@
+;; global-environment.scm --- a module representing the global environment of
lua
+;; (thus, no values are exported and this module may contain more than is
defined in this file)
+
+(define-module (language lua global-environment))
+
+;; shorthand for accessing modules without polluting the namespace
+(define-syntax $
+ (syntax-rules (srfi-69 lua error)
+ ((_ (srfi-69) name . rest) ((@ (srfi srfi-69) name) . rest))
+ ((_ (error) . rest) ((@ (language lua common) runtime-error) . rest))
+ ((_ (lua) name . rest) ((@ (language lua runtime) name) . rest))
+ ))
+
+(define (rawget table key)
+ ($ (lua) assert-table 1 "rawget" table)
+ ($ (srfi-69) hash-table-ref ($ (lua) table/slots table) key))
+
+(define (rawset table key value)
+ ($ (lua) assert-table 1 "rawset" table)
+ ($ (srfi-69) hash-table-set! ($ (lua) table/slots table) key value)
+ table)
+
+(define (setmetatable table metatable)
+ ($ (lua) assert-table 1 "setmetatable" table)
+ ($ (lua) assert-type 2 "setmetatable" "nil or table" metatable (lambda (x)
(or ($ (lua) table? x) (eq? x #nil))))
+ ($ (lua) table/metatable! table metatable)
+ table)
+
+(define (getmetatable table)
+ ($ (lua) assert-table 1 "getmetatable" table)
+ ($ (lua) table/metatable table))
+
+(define (print . arguments)
+ (for-each
+ (lambda (x)
+ (cond ((eq? x #f) (display "false"))
+ ((eq? x #t) (display "true"))
+ ((eq? x #nil) (display "nil"))
+ (else (write x)))
+ (write-char #\tab))
+ arguments)
+ (newline)
+ #nil)
+
+(define* (assert v #:optional (message "assertion failed!") #:rest rest)
+ (if ($ (lua) false? v)
+ ($ (error) message)
+ (apply values (cons v (cons message rest)))))
diff --git a/module/language/lua/lexer.scm b/module/language/lua/lexer.scm
new file mode 100644
index 0000000..ea01b27
--- /dev/null
+++ b/module/language/lua/lexer.scm
@@ -0,0 +1,113 @@
+;; lexer.scm --- lua tokenizer
+(define-module (language lua lexer)
+ #:use-module (srfi srfi-14)
+ #:use-module (srfi srfi-39)
+
+ #:use-module (language lua common)
+
+ #:export (make-lexer))
+
+(define (source-info port)
+ `((backtrace . #f) (filename . ,(port-filename port))
+ (line . ,(port-line port)) (column . ,(port-column port))))
+
+(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 (possible-keyword k)
+ "Convert a symbol to a keyword if it is a reserved word in Lua"
+ (case k
+ ((return function end if then elseif else true false nil or and do while
local) (symbol->keyword k))
+ (else k)))
+
+(define (make-lexer port)
+ (define buffer (open-output-string))
+ (define (clear-buffer)
+ "Reset the buffer and return a string of the contents"
+ (define string (get-output-string buffer))
+ (truncate-file buffer 0)
+ string)
+ (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)
+ (if saved-source-info
+ saved-source-info
+ (source-info port)))
+ (define (lex)
+ (parameterize ((current-input-port port)
+ (current-output-port buffer))
+ (set! saved-source-info #f)
+ (let loop ()
+ (define c (peek-char))
+ (case c
+ ;; spaces
+ ((#\newline #\return #\space #\page #\tab #\vtab) (read-char) (loop))
+ ;; comments and -
+ ((#\-)
+ (read-char)
+ (if (eq? (peek-char) #\-)
+ ;; it is a comment
+ (let consume ((c (read-char)))
+ (cond ((eof-object? c) (loop))
+ ((eq? c #\newline) (loop))
+ (else (consume (read-char)))))
+ ;; it is a -
+ #\-))
+
+ ;; ~=
+ ((#\~)
+ (read-char)
+ (if (eq? (peek-char) #\=)
+ (begin (read-char) #:~=)
+ (syntax-error (get-source-info) "expected = after ~ but got ~c"
c)))
+ ;; = and ==
+ ((#\=)
+ (read-char)
+ (if (eq? (peek-char) #\=)
+ (begin (read-char) #:==)
+ #:=))
+ ;; TODO: ...
+ ;; floating point number or table indice
+ ((#\.) (read-char))
+ ;; characters that are allowed directly through
+ ((#\; #\( #\) #\,
+ #\+ #\/ #\*
+ #\< #\^ #\{ #\} #\[ #\] #\:) (read-char))
+ ;; numbers
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (write-char (read-char))
+ (save-source-info)
+ (while (is-digit? (peek-char))
+ (write-char (read-char)))
+ (string->number (clear-buffer)))
+ ((#\")
+ (read-char)
+ (while (not (or (eq? (peek-char) #\") (eof-object? (peek-char))))
+ (write-char (read-char)))
+ (clear-buffer))
+
+ ;; strings
+ (else
+ (cond ((eof-object? c) c)
+ ;; identifier or keyword
+ ((is-name-first? c)
+ (write-char (read-char))
+ (save-source-info)
+ (while (is-name? (peek-char))
+ (write-char (read-char)))
+ (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
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
new file mode 100644
index 0000000..1c9a6c2
--- /dev/null
+++ b/module/language/lua/parser.scm
@@ -0,0 +1,756 @@
+;; parser.scm --- lua parser which produces tree-il
+(define-module (language lua parser)
+
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+
+ #:use-module (language lua common)
+ #:use-module (language lua lexer)
+
+ #:export (make-parser))
+
+;; This parser is based heavily on Lua's parser. Lua's grammar is a little
+;; plucky for lalr-scm or another parser generator option
+
+;; Unlike Lua's parser, it:
+;; - does not track syntax nesting levels
+;; - returns tree-il instead of incrementally compiling the code
+
+(define-record-type environment
+ (make-environment parent names)
+ environment?
+ (parent environment/parent)
+ (names environment/names environment/names!))
+
+(define (end-of-block? k)
+ (case k
+ ((#:else #:elseif #:end #:until) #t)
+ (else (eof-object? k))))
+
+;; TODO: this is here mainly to ensure that no unwanted values are propagated
+;; through the parser -- it will be removed and replaced with the informal
+;; equivalents later
+(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) t)
+ (else (error #:TOKEN/TYPE t))))))
+
+;; name of global environment module
+(define *global-env-name* '(language lua global-environment))
+(define *global-env* (resolve-module *global-env-name*))
+
+(define *runtime-name* '(language lua runtime))
+
+(define (ref-runtime src name) (make-module-ref src *runtime-name* name #t))
+
+;; infix operator parsing
+(define (binary-operator? t)
+ (case t
+ ((#\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or) #t)
+ (else #f)))
+
+(define (unary-operator? t)
+ (case t
+ ((#\- #:not) #t)
+ (else #f)))
+
+;; parsing priority
+(define *unary-priority* 80)
+
+(define (priority o)
+ (case o
+ ((#:or) 10)
+ ((#:and) 20)
+ ((#:== #:~= <= >= #\< #\>) 30)
+ ((#\+ #\-) 60)
+ ((#\* #\/ #\%) 70)
+ ((#\^ #:concat) 99)))
+
+(define (operator->tree-il src operator . arguments)
+ (make-runtime-application src operator arguments))
+
+;;;;; TREE-IL UTILITIES
+
+(define (make-unary-operation src operator a)
+ "Convert parsed unary operation to tree-il"
+ (operator->tree-il src
+ (case operator
+ ((#\-) 'unm)
+ (else (error #:MAKE-UNARY-OPERATION "should not happen" a)))
+ a))
+
+(define (make-binary-operation src operator a b)
+ "Convert parsed infix operation to tree-il"
+ (case operator
+ ((#\+ #\- #\* #\/ #\^ #\< #:== #:~=)
+ (operator->tree-il
+ src
+ (case operator
+ ((#\+) 'add)
+ ((#\-) 'sub)
+ ((#\*) 'mul)
+ ((#\/) 'div)
+ ((#\^) 'pow)
+ ((#\<) 'lt)
+ ((#:==) 'eq)
+ ((#:~=) 'neq)
+ (else (error #:MAKE-BINARY-OPERATION "should not happen" operator a
b)))
+ a b))
+ ((#:or)
+ (make-lua-conditional
+ src
+ a
+ a
+ b))
+ ((#:and)
+ (make-lua-conditional
+ src
+ a
+ b
+ a))))
+
+(define (reference? x)
+ (or (module-ref? x) (lexical-ref? x)))
+
+(define (make-lua-assignment left right)
+ "Generate an assignment from a variable and an expression"
+ (cond ((module-ref? left)
+ (make-module-set (module-ref-src left) (module-ref-mod left)
(module-ref-name left) (module-ref-public? left) right))
+ ((lexical-ref? left)
+ (make-lexical-set (lexical-ref-src left) (lexical-ref-name left)
(lexical-ref-gensym left) right))))
+
+(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 (wrap-expression-in-environment src e x)
+ "Wrap an expression in an enclosing lexical environment if necessary"
+ (define names (environment/names e))
+ (if (not (null? names))
+ (make-let src (map car names) (map cdr names) (map (lambda (x)
(make-const src #nil)) names) x)
+ x))
+
+(define (make-parser port)
+ ;; functions that will be retrieved from make-lexer
+ (define get-source-info)
+ (define lexer)
+
+ ;;;;; PARSER STATE
+ (define token2 #f)
+
+ (define (lookahead!)
+ (set! token2 (lexer)))
+
+ ;; current token
+ (define token)
+ ;; lexical environment
+ (define environment #f)
+
+ ;;;;; ENVIRONMENTS
+ (define (enter-environment!)
+ (set! environment
+ (make-environment environment '())))
+
+ (define (leave-environment!)
+ (if (not environment)
+ (error #:LEAVE-ENVIRONMENT! "should not happen"))
+ (set! environment
+ (environment/parent environment)))
+
+ (define (environment-define! name )
+ (if (not (member name (environment/names environment)))
+ (environment/names! environment (alist-cons name (gensym
(string-append " " (symbol->string name))) (environment/names environment)))))
+
+ (define (environment-lookup name . e)
+ (set! e (if (null? e) environment (car e )))
+ (if e
+ (let ((binding (assq-ref (environment/names e) name)))
+ (if binding
+ binding
+ (environment-lookup name (environment/parent e))))
+ #f))
+
+ (define (resolve-ref src name)
+ (let* ((binding (environment-lookup name)))
+ (if binding
+ (make-lexical-ref src name binding)
+ ;; TODO: Consider _G
+ (begin
+ (if (not (module-defined? *global-env* name))
+ (module-define! *global-env* name #nil))
+ (make-module-ref src *global-env-name* name #f)))))
+
+ ;;;;; TREE-IL UTILITIES
+ ;; tree-il utilities that need access to this closure
+ (define (make-lua-function src parameters body-promise)
+ "Generate a function"
+
+ ;; create a new environment and populate it with the function's parameters
+
+ ;; functions have two environments: one for the function's parameters and
+ ;; another for the function's locals (this is inefficient and is simply to
+ ;; compensate for the simplistic implementation of locals (in CHUNK),
+ ;; perhaps the environment should be extended to track the type of a
+ ;; variable as well)
+ (enter-environment!)
+
+ (for-each environment-define! parameters)
+ (enter-environment!)
+
+ (let* ((body (force body-promise))
+ (parameter-gensyms (map environment-lookup parameters)))
+ (leave-environment!)
+ (leave-environment!)
+ (make-lambda
+ src '()
+ (make-lambda-case src parameters #f #f #f '() parameter-gensyms (if
(null? body) (make-void src) body) #f))))
+
+ (define (apply-named-lua-function src get-body)
+ (let* ((name (gensym " named"))
+ (parameters (list name)))
+ (make-let
+ src
+ parameters parameters
+ (list (make-lambda src '() (get-body name)))
+ (make-application src (make-lexical-ref src name 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"
+ (if (not (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 ] ')'
+ (define (application-arguments)
+ (case 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-table-ref src prefix (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-table-ref src expr indice))))
+ ;; application-arguments
+ ((#\()
+ (lp (make-application src expr (application-arguments))))
+ (else expr))))
+
+ ;; expression-statement -> function | assignment
+ (define (expression-statement)
+ (define primary (primary-expression))
+ (if (application? primary)
+ primary
+ (assignment primary)))
+
+
+ ;; record-field -> (NAME | index) '=' expression
+ (define (record-field)
+ (let* ((indice
+ (cond
+ ;; NAME
+ ((eq? (token/type token) 'NAME)
+ (let ((tmp (make-const #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 table-var-name)
+ (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)
+ (append!
+
+ (list (make-runtime-application src 'new-index!
+ (list (make-lexical-ref src table-var-name
table-var-name) (or indice (make-const 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* ((temp-name (gensym " table"))
+ (names (list temp-name))
+ (result
+ (make-let
+ src
+ names names
+ (list (make-runtime-application src 'make-table '()))
+ ;; table-fields
+ (make-sequence src (reverse! (append! (list (make-lexical-ref src
temp-name temp-name)) (table-fields src temp-name)))))))
+ (enforce-next! #\})
+ result))
+
+ ;; parameter-list -> [ parameter { ',' parameter } ]
+ (define (parameter-list function-name)
+ (if (eq? token #\))
+ '()
+ (let loop ((parameters '()))
+ ;; the parameters can either be a name or a ...
+ (let* ((parameters
+ (case (token/type token)
+ ((NAME) (append parameters (list token)))
+ (else (syntax-error (get-source-info) "expected either a
name or a ... in the parameter list of ~a, but got ~a" function-name token)))))
+ (advance!)
+ (if (eq? token #\,)
+ (advance! (loop parameters))
+ parameters)))))
+
+ ;; function-body -> '(' parameter-list ')' chunk END
+ (define* (function-body #:optional (src (get-source-info)) (need-self? #f))
+ ;; '('
+ (enforce-next! #\()
+ ;; parameter-list
+ (let* ((parameters (parameter-list "anonymous function")))
+ ;; ')'
+ (enforce-next! #\))
+ (let* ((result
+ (make-lua-function
+ src
+ parameters
+ (delay (chunk)))))
+ (enforce-next! #:end)
+ result)))
+
+ ;; expression-list -> expression { ',' expression }
+ (define (expression-list)
+ (let loop ((tree (list (expression))))
+ ;; { ',' expression }
+ (if (maybe-skip-next! #\,)
+ (loop (append! (list (expression)) tree))
+ ;; finished
+ (reverse! tree))))
+
+ ;; simple-expression -> (nil | true | false | NUMBER | STRING) |
table-literal | FUNCTION function-body
+ (define (simple-expression)
+ (define src src)
+ (receive
+ (advance? result)
+ (case (token/type token)
+ ;; (nil | true | false | NUMBER | STRING)
+ ((#:true #:false #:nil NUMBER STRING)
+ (values
+ #t
+ (make-const
+ src
+ (cond ((eq? token #:true) #t)
+ ((eq? token #:false) #f)
+ ((eq? token #:nil) #nil)
+ (else token)))))
+ ;; table-literal
+ ((#\{) (values #f (table-literal)))
+ ;; 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-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-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
+ (define result (apply-named-lua-function
+ src
+ (lambda (loop)
+ (make-lua-conditional
+ src
+ condition
+ (make-sequence
+ src
+ (list body (make-application src (make-lexical-ref src loop loop)
'())))
+ (make-void src)))))
+ (enforce-next! #:end)
+ result)))
+
+ ;; return-statement -> RETURN expression-list
+ (define (return-statement)
+ (define src (get-source-info))
+
+ ;; RETURN
+ (advance!)
+
+ (make-application src (make-primitive-ref src 'return)
+ ;; if followed by END or ';', the return has no
arguments, otherwise
+ (if (or (end-of-block? token) (eq? token #\;))
+ (list (make-void src))
+ ;; expression-list
+ (expression-list))))
+
+ ;; 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))))
+
+ (define (parse-assignment src left right)
+ ;; and then parses it, branching to handle overflows on either side if
necessary
+ (make-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)
+ (append! (list (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) (make-const #f #nil)))
+ (rest (cdr rest)))
+ (if (null? rest)
+ (reverse! (append! (list il) tree))
+ (loop (append! (list 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 (append! (list 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
+
+
+ ;; 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-lua-conditional
+ if-src
+ test
+ then
+ (let loop ()
+ (define src (get-source-info))
+ (if (eq? token #:elseif)
+ (receive (test then)
+ (then-chunk)
+ (make-lua-conditional src test then (loop)))
+ (if (eq? token #:else)
+ (advance! (chunk))
+ (make-void #f)))))))
+ (enforce-next! #:end)
+ x)
+
+ ;; 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-table-ref src last-expr name))))
+ ;; [ ':' NAME ]
+ (if (eq? token #\:)
+ (values (make-table-ref src last-expr (advance!
(single-name))) 'table-method)
+ (values last-expr 'function))))
+ (define body (function-body src (eq? type 'table-method)))
+ (case type
+ ((table-function) (make-runtime-application src 'new-index!
+ (list (cdr prefix) (make-const src
(symbol->string (car prefix))) body)))
+ ((function) (make-lua-assignment prefix body)))))
+
+ ;; 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 (append! (list token) names))
+ (advance!)
+ (if (maybe-skip-next! #\,)
+ ;; { ',' NAME }
+ (lp names)
+ (begin
+ (for-each environment-define! 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
+ (make-void #f))))))
+
+ (define (local-function-statement)
+ (assert-token-type 'NAME)
+ (let* ((name token))
+ (environment-define! name)
+ (advance!)
+ (make-lexical-set (get-source-info) name (environment-lookup name)
(function-body))))
+
+ ;; statement
+ (define (statement)
+ (case token
+ ((#\;) (advance!) (statement))
+ ;; statement -> return
+ ((#:return) (values #t (return-statement)))
+ ((#:if #:function #:do #:while #:local)
+ (values
+ #f
+ (case token
+ ((#:while) (while-statement))
+ ((#:if) (if-statement))
+ ((#:function) (function-statement))
+ ((#:local)
+ (advance!)
+ (if (maybe-skip-next! #:function)
+ (local-function-statement)
+ (local-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-block? token))
+ (tree '()))
+ (if is-last
+ (begin (maybe-skip-next! #\;)
+ (wrap-expression-in-environment
+ src
+ environment
+ (make-sequence src (reverse! tree))))
+ (receive
+ (is-last node)
+ (statement)
+ (loop (or (end-of-block? token) is-last) (append! (list node)
tree))))))
+
+ (receive (get-source-info% lexer%)
+ (make-lexer port)
+ (set! get-source-info get-source-info%)
+ (set! lexer lexer%))
+ ;; toplevel local environment
+ (enter-environment!)
+ ;; read first token
+ (advance!)
+ ;; return parser
+ chunk)
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
new file mode 100644
index 0000000..fb53478
--- /dev/null
+++ b/module/language/lua/runtime.scm
@@ -0,0 +1,134 @@
+;; runtime.scm --- lua runtime functionality
+
+(define-module (language lua runtime)
+ #:use-module (language lua common)
+
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-69)
+
+ #:duplicates (replace last)
+
+ #:export (
+ ;; semantics
+ false? true?
+
+ ;; misc
+ assert-type
+ assert-table
+
+ ;; tables
+ make-table
+ table?
+ table/slots
+ table/metatable
+ table/metatable!
+
+ dispatch-metatable-event
+
+ ;; metatable events
+ index
+ new-index!
+ ;; operators
+ unm eq lt le gt ge add sub mul div pow
+ neq
+ ))
+
+;;;;; 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")
+ (else (error))))
+
+(define (assert-type argument caller expected value predicate)
+ (if (not (predicate value))
+ (runtime-error (format "bad argument ~a to '~a' (~a expected, got ~a)"
argument caller expected (value-type->string value)))))
+
+(define (assert-table argument caller value)
+ (assert-type argument caller "table" value table?))
+
+;;;;; TABLES
+
+(define-record-type table
+ (%make-table metatable slots)
+ %table?
+ (metatable %table/metatable %table/metatable!)
+ (slots %table/slots))
+
+(define (make-table)
+ (%make-table #nil (make-hash-table)))
+
+;; table accessors for export
+(define (table? x) (%table? x))
+(define (table/slots x) (%table/slots x))
+(define (table/metatable x) (%table/metatable x))
+(define (table/metatable! x y) (%table/metatable! x y))
+
+(define (dispatch-metatable-event key default table . arguments)
+ (apply (if (true? (table/metatable table)) (hash-table-ref/default
(table/slots (table/metatable table)) key default) default) arguments))
+
+(define (index table key)
+ (hash-table-ref/default (%table/slots table) key #nil))
+
+(define (new-index! table key value)
+ (hash-table-set! (%table/slots table) key value))
+
+;;;;; OPERATORS
+
+;; 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 ((table? a)
+ (dispatch-metatable-event slot-name default a a b))
+ ((table? 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" <)))
+
+(define (unm a)
+ "A function backing the unary - (negation) operator"
+ (- a))
+
+(define (eq a b)
+ "A function backing the == operator"
+ (equal? 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)))
diff --git a/module/language/lua/spec.scm b/module/language/lua/spec.scm
new file mode 100644
index 0000000..b5abefd
--- /dev/null
+++ b/module/language/lua/spec.scm
@@ -0,0 +1,12 @@
+;; spec.scm --- lua specification
+(define-module (language lua spec)
+ #:use-module (system base language)
+
+ #:use-module (language lua lexer)
+ #:use-module (language lua parser))
+
+(define-language lua
+ #:title "Lua"
+ #:reader (lambda (port _) #f)
+ #:compilers `((tree-il . ,(lambda (x e o) (values x e e))))
+ #:printer write)
diff --git a/test-suite/tests/lua.test b/test-suite/tests/lua.test
new file mode 100644
index 0000000..0688da9
--- /dev/null
+++ b/test-suite/tests/lua.test
@@ -0,0 +1,223 @@
+;; lua.test --- lua test suite -*- mode: scheme -*-
+(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 lexer)
+ #:use-module (language lua parser))
+
+(with-test-prefix "lua-lexer"
+ (define (from-string string)
+ (receive (_ lex)
+ (make-lexer (open-input-string string))
+ (lex)))
+ (let-syntax
+ ((test
+ (syntax-rules (eof predicate)
+ ((_ string expect)
+ (pass-if (format "~S => ~A" string expect) (equal? (from-string
string) expect)))
+ ((_ (eof string))
+ (pass-if (format "~a => #<eof>" string) (eof-object? (from-string
string)))))))
+
+ (test (eof " "))
+ (test (eof "-- comment"))
+
+ (test "12345" 12345)
+ (test "name" 'name)
+ (test "return" #:return)
+ (test ";" #\;)
+ (test "-" #\-)
+ (test "+" #\+)
+ (test "/" #\/)
+ (test "*" #\*)
+
+))
+
+(define (tree-il? x) (or (application? x) (module-ref? x) (primitive-ref? x)
+ (lexical-ref? x) (sequence? x) (void? x) (const? x)
(lambda? x) (module-set? x)
+ (toplevel-ref? x) (toplevel-set? x) (toplevel-define?
x) (conditional? x)
+ (lambda-case? x) (letrec? x) (let? x) (lexical-set?
x)))
+
+(define (strip-tree-il! x)
+ (cond ((list? x) (map! strip-tree-il! x))
+ ((tree-il? x) (unparse-tree-il x))
+ (else x)))
+
+(with-test-prefix "lua-parser"
+ (let-syntax
+ ;; Note on parser tests:
+ ;; Lua does not allow standalone expressions, only statements.
+ ;; It does allow returns from the toplevel. This is how expressions are
evaluated at the Lua REPL.
+ ;; So, the inputs and outputs of these tests are automatically prefixed
with a return
+ ((test-return
+ (syntax-rules ()
+ ((_ string . expect)
+ (let* ((real-string (string-append "return " string))
+ (real-expect `(begin (apply (primitive return) ,@`expect)))
+ (result (from-string real-string)))
+ (pass-if (format "~S => ~A" real-string real-expect) (equal? result
real-expect)))))))
+
+ ;; shortcuts
+ (define (from-string string) (strip-tree-il! ((make-parser
(open-input-string string)))))
+ (define (op x) `(@ (language lua runtime) ,x))
+ (define (global x) `(@@ (language lua global-environment) ,x))
+
+ (test-return "" (void))
+ (test-return ";" (void))
+
+ (test-return "2" (const 2))
+ (test-return "1 + 2" (apply ,(op 'add) (const 1) (const 2)))
+ (test-return "1 + 2 * 3" (apply ,(op 'add) (const 1) (apply ,(op 'mul)
(const 2) (const 3)) ))
+ (test-return "1 * 2 + 3" (apply ,(op 'add) (apply ,(op 'mul) (const 1)
(const 2)) (const 3)))
+ (test-return "1 * 2 + 3 - 4" (apply ,(op 'sub) (apply ,(op 'add) (apply
,(op 'mul) (const 1) (const 2)) (const 3)) (const 4)))
+ (test-return "-1" (apply ,(op 'unm) (const 1)))
+ (test-return "- 2" (apply ,(op 'unm) (const 2)))
+
+ (test-return "var" ,(global 'var))
+ (test-return "print()" (apply ,(global 'print)))
+ (test-return "print(1)" (apply ,(global 'print) (const 1)))
+ (test-return "print(1,2)" (apply ,(global 'print) (const 1) (const 2)))
+ (test-return "print(1+2,3*4)" (apply ,(global 'print) (apply ,(op 'add)
(const 1) (const 2)) (apply ,(op 'mul) (const 3) (const 4))))
+
+))
+
+(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 => ~A" 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)")
+
+ ;; 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;" *unspecified*)
+ (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)")
+
+ ;; function statements
+ (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 "-- fibonacci numbers\nfunction fib(n)\n if n < 2 then\n return
n\n else\n return fib(n-1) + fib(n-2)\n end\nend\nreturn 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")
+
+ ;; undefined variables are implicitly defined to 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)
+
+ ;; 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)
+
+ ;; 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)")
+
+ ;; built-in functions
+ (test "assert(true)")
+ (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)")
+
+ ;; 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)
+ (test "return true")
+
+ ;; table methods/functions
+ (test "table = {}
+function table.identity(x) return x end
+return table.identity(true)")
+
+ ;; - compiler
+ ;; method invocations
+ ;; for loops
+ ;; repeat loops
+ ;; variable arguments
+ ;; multiple returns
+ ;; - runtime
+ ;; __pairs, __ipairs, __len
+))
+
+#;(begin
+ (define var
+ "return table.identity(true)"
+ ) (display (compile ((make-parser (open-input-string var)))
+ #:from 'lua #:to 'tree-il))
+ (newline))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-44-g7494cc5,
No Itisnt <=