[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-247-ga429
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-247-ga429266 |
|
Date: |
Sun, 01 Aug 2010 07:00:28 +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=a4292669aa26760ed267bca222b7f749be418f46
The branch, lua has been updated
via a4292669aa26760ed267bca222b7f749be418f46 (commit)
from b9fa70d4a187d6780b2b3c515cbf958329d6d2b7 (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 a4292669aa26760ed267bca222b7f749be418f46
Author: No Itisnt <address@hidden>
Date: Sun Aug 1 01:58:48 2010 -0500
lua: Add support for methods; work on os and table libraries
-----------------------------------------------------------------------
Summary of changes:
module/language/lua/common.scm | 37 ++++---
module/language/lua/lexer.scm | 172 ++++++++++++++++++----------
module/language/lua/parser.scm | 116 ++++++++++++-------
module/language/lua/runtime.scm | 120 +++++++++++++-------
module/language/lua/standard/io.scm | 9 ++
module/language/lua/standard/math.scm | 4 +-
module/language/lua/standard/os.scm | 38 ++++++-
module/language/lua/standard/table.scm | 33 +++++-
test-suite/tests/lua-eval.test | 13 ++-
test-suite/tests/lua-lexer.test | 14 ++-
test-suite/tests/lua-math.test | 47 --------
test-suite/tests/lua-parser.test | 57 ---------
test-suite/tests/lua-scratch.test | 125 ++++++++++++++++++++
test-suite/tests/lua-standard-library.test | 50 ++++++++
14 files changed, 562 insertions(+), 273 deletions(-)
delete mode 100644 test-suite/tests/lua-math.test
delete mode 100644 test-suite/tests/lua-parser.test
create mode 100644 test-suite/tests/lua-scratch.test
create mode 100644 test-suite/tests/lua-standard-library.test
diff --git a/module/language/lua/common.scm b/module/language/lua/common.scm
index fcc0467..5b83a7e 100644
--- a/module/language/lua/common.scm
+++ b/module/language/lua/common.scm
@@ -1,21 +1,30 @@
-;; common.scm --- common lua functions
+;; common.scm --- common lua functionality
(define-module (language lua common)
#:use-module (ice-9 format)
- #:export (syntax-error runtime-error))
+ #:export (syntax-error or-eqv?))
(define (syntax-error src string . arguments)
- (throw
- 'lua-syntax
- (apply format (string-append "~A: " string)
- (cons
- (and src (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))
+ "Throw an error tagged with 'lua-syntax, and print detailed source
+code information when available. STRING and ARGUMENTS are given to FORMAT."
+ (string-append
+ (if src
+ (format "address@hidden"
+ (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/lexer.scm b/module/language/lua/lexer.scm
index f5479dd..4109d31 100644
--- a/module/language/lua/lexer.scm
+++ b/module/language/lua/lexer.scm
@@ -1,16 +1,31 @@
;; lexer.scm --- lua tokenizer
+
+;; This is a simple lexer with two tokens of lookahead. 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 read-lua))
+ #:export (make-lexer)
+ #:export-syntax (define-lua-lexer initialize-lua-lexer!))
(define (source-info port)
- `((backtrace . #f) (filename . ,(port-filename port))
- (line . ,(port-line port)) (column . ,(port-column 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)
@@ -21,24 +36,27 @@
(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 k)
+(define (possible-keyword token)
"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
repeat until local) (symbol->keyword k))
- (else k)))
+ (if (or-eqv? token '(return function end if then elseif else true false nil
or and do while repeat until local))
+ (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)
- "Reset the buffer and return a string of the contents"
+ "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)
@@ -47,18 +65,24 @@ 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))))))
- ;; read a long form string enclosed by brackets
(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))
@@ -69,37 +93,42 @@ of an identifier"
count))))
(if (eq? (peek-char) delimiter) count -1)))
- ;; read a long string or comment
(define (read-long-string string? nest)
- ;; skip second '['
+ "Read a long string or comment"
+ ;; Skip second bracket
(read-char)
- ;; discard initial newlines
+ ;; Discard initial newlines, which is what Lua does
(while (is-newline? (peek-char))
(read-char))
+ ;; Read string contents
(let loop ((c (peek-char)))
- (cond ((eof-object? c)
- (syntax-error (get-source-info) (string-append "unfinished long "
(if string? "string" "comment"))))
- ((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
- (write-char (read-char))
- (let lp ((n nest2))
- (if (= n 0)
- #f
- (begin
- (write-char #\=)
- (lp (- n 1)))))
- (write-char #\])
- (loop (peek-char))))))
- (else (write-char (read-char))
- (loop (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)
@@ -130,7 +159,7 @@ of an identifier"
(if (eq? c delimiter)
(read-char) ;; terminate loop and discard delimiter
(begin
- (write-char (read-char))
+ (save-and-next!)
(loop (peek-char)))))))
(clear-buffer))
@@ -138,7 +167,7 @@ of an identifier"
(save-source-info)
(let* ((main (string-append (or string "") (begin
(while (or (is-digit?
(peek-char)) (eq? (peek-char) #\.))
- (write-char
(read-char)))
+ (save-and-next!))
(clear-buffer))))
(exponent
(if (or (eq? (peek-char) #\e) (eq? (peek-char) #\E))
@@ -147,11 +176,11 @@ of an identifier"
(if (eq? (peek-char) #\+)
(read-char)
(if (eq? (peek-char) #\-)
- (write-char (read-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))
- (write-char (read-char)))
+ (save-and-next!))
(clear-buffer))
#f))
(final (string->number main)))
@@ -166,28 +195,29 @@ of an identifier"
(let loop ()
(define c (peek-char))
(case c
- ;; spaces
+ ;; Skip spaces
((#\newline #\return #\space #\page #\tab #\vtab) (read-char) (loop))
- ;; comments and -
+
+ ;; Either a minus (-), or a long comment, which is a - followed by a
bracketed string
((#\-)
(read-char)
(if (eq? (peek-char) #\-)
- ;; it is a comment
+ ;; It's a comment
(begin
(read-char)
- ;; long comment
+ ;; Long comment
(if (eq? (peek-char) #\[)
(let* ((nest (get-long-string-nesting-level)))
(drop-buffer)
- (if (> nest -1)
+ (if (not (negative? nest))
(begin
(read-long-string #f nest)
(drop-buffer)
(loop))
- ;; not actually a long comment, drop it
+ ;; If it's not actually a long comment, drop it
(begin (drop-buffer) (eat-comment) (loop))))
(begin (eat-comment) (loop))))
- ;; it is a -
+ ;; It's a regular minus
#\-))
;; ~=
@@ -196,18 +226,24 @@ of an identifier"
(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) #:>=) #\>))
- ;; = and ==
+
+ ;; = 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
(...)
((#\.)
@@ -222,41 +258,59 @@ of an identifier"
#:concat))
#\.)))
- ;; strings
- ;; double-quoted
+ ;; Double-quoted string
((#\") (read-string #\"))
- ;; single-quoted
+
+ ;; Single-quoted string
((#\') (read-string #\'))
- ;; long-form with nestable brackets
+
+ ;; 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 directly through
+
+ ;; Characters that are allowed to fall through directly to the parser
((#\; #\( #\) #\,
#\+ #\/ #\*
#\^ #\{ #\} #\] #\: #\#) (read-char))
- ;; numbers
+
+ ;; Numbers
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(save-source-info)
- (write-char (read-char))
+ (save-and-next!)
(read-number #f))
- ;; strings
(else
(cond ((eof-object? c) c)
- ;; identifier or keyword
+ ;; Identifier or keyword
((is-name-first? c)
- (write-char (read-char))
+ (save-and-next!)
(save-source-info)
(while (is-name? (peek-char))
- (write-char (read-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
+ (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)))))
+
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 81e7a37..13ecfa7 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -1,9 +1,21 @@
;; parser.scm --- lua parser
+
+;; rewrite
+;; - use WHEN, UNLESS where appropriate
+;; - try to put less in MAKE-PARSER, maybe even make a state record
+;; - move lexer stuff to lexer (token buffer, advance!, token assertions etc)
& export
+
+;; 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) #:version (6))
#:use-module (language lua common)
#:use-module (language lua lexer)
@@ -11,15 +23,7 @@
#:export (make-parser read-lua))
-;; 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 an abstract syntax tree instead of incrementally compiling the
code
-
-;;;;; RECORDS
-
+;; Implicitly named records
(letrec-syntax
((define-record
(lambda (stx)
@@ -63,9 +67,12 @@
(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)
@@ -86,20 +93,15 @@
(function-call operator operands)
(binary-operation operator left right))
- )
+ ) ; letrec-syntax
+;; Constants
(define *nil-literal* (make-ast-literal #f #nil))
(define *void-literal* (make-ast-literal #f *unspecified*))
-;; parsing priority
-(define *unary-priority* 80)
-
-;;;;;
-
-(define (end-of-chunk? k)
- (case k
- ((#:else #:elseif #:end #:until) #t)
- (else (eof-object? k))))
+(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)
@@ -113,21 +115,20 @@
#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots) t)
(else (error #:TOKEN/TYPE t))))))
-;;;;; OPERATOR PRECEDENCE PARSING
-
;; infix operator parsing
(define (binary-operator? t)
- (case t
- ((#\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or) #t)
- (else #f)))
+ "Return #t if the token may be a binary operator"
+ (or-eqv? t #\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or))
(define (unary-operator? t)
- (case t
- ((#\- #:not #\#) #t)
- (else #f)))
+ "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)
@@ -158,33 +159,36 @@
;;;;; PARSER
(define (make-parser port)
- ;; functions that will be retrieved from make-lexer
- (define get-source-info)
- (define lexer)
+ ;; Variables that will be set to the results of MAKE-LEXER.
+ (define-lua-lexer get-source-info lexer)
- ;;;;; PARSER STATE
+ ;; We need two tokens of lookahead
(define token2 #f)
(define (lookahead!)
(set! token2 (lexer)))
- ;; current token
+ ;; Current token
(define token)
- ;; lexical environment
+
+ ;; Lexical environment
(define environment #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)))
(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
@@ -193,7 +197,12 @@
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)))
@@ -203,18 +212,21 @@
#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)
@@ -332,6 +344,15 @@
((#\[)
(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))))
@@ -424,26 +445,33 @@
(advance!)
(if (eq? token #\,)
(if (eq? last-token #:dots)
- (syntax-error (get-source-info) "expected ')' after ... in
the parameter list of '~a' function-name")
+ (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)) (need-self? #f)
(name "anonymous"))
+ (define* (function-body #:optional (src (get-source-info)) (implicit-self?
#f) (name "anonymous"))
;; '('
(enforce-next! #\()
;; parameter-list
(receive (parameters variable-arguments?)
- (parameter-list name)
+ (if (eq? token #\))
+ (values '() #f)
+ (parameter-list name))
(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 parameters parameter-gensyms
variable-arguments? (if (null? body) *void-literal* body))))
+ (make-ast-function src
+ (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)
@@ -659,12 +687,15 @@
(lp (make-ast-table-ref src last-expr name))))
;; [ ':' NAME ]
(if (eq? token #\:)
- (values (make-ast-table-ref src last-expr (advance!
(single-name))) 'table-method)
+ (let* ((name (advance! (single-name))))
+ (advance!)
+ (values (cons name last-expr) 'table-method))
(values last-expr 'function))))
(define body (function-body src (eq? type 'table-method)
(symbol->string name)))
(case type
- ((table-function) (make-ast-table-set src (cdr prefix)
(make-ast-literal src (symbol->string (car prefix))) body))
- ((function) (make-lua-assignment prefix body)))))
+ ((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)
@@ -741,10 +772,7 @@
(statement)
(loop (or (end-of-chunk? 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%))
+ (initialize-lua-lexer! port get-source-info lexer)
;; toplevel local environment
(enter-environment!)
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
index 2daeb08..f5dc01d 100644
--- a/module/language/lua/runtime.scm
+++ b/module/language/lua/runtime.scm
@@ -1,4 +1,4 @@
-;; runtime.scm --- lua runtime functionality
+; runtime.scm --- lua runtime functionality
(define-module (language lua runtime)
#:use-module (language lua common)
@@ -8,6 +8,8 @@
#:use-module ((srfi srfi-98) #:select (get-environment-variable))
#:export (
+ runtime-error
+
;; semantics
false? true?
@@ -15,6 +17,7 @@
value-type->string
assert-type
assert-table
+ assert-string
;; tables
make-table
@@ -46,9 +49,16 @@
) ; define-module
-;;; Local Variables:
-;;; eval: (put 'define-global 'scheme-indent-function 1)
-;;; End:
+;; Local Variables:
+;; eval: (put 'define-global 'scheme-indent-function 1)
+;; End:
+
+(define (runtime-error message)
+ "Throw an error tagged with 'lua-runtime"
+ (throw 'lua-runtime message))
+
+(define (runtime-warning string . arguments)
+ (format #t (string-append "GUILE-LUA: RUNTIME WARNING: " string) arguments))
;;;;; SEMANTICS
@@ -67,14 +77,21 @@
((string? x) "string")
((number? x) "number")
((boolean? x) "boolean")
- (else (error))))
+ ((eq? x #nil) "nil")
+ ((procedure? x) "function")
+ (else "userdata")))
(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?))
+(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?)
;;;;; TABLES
@@ -183,7 +200,7 @@
(module (hash-table-ref slots 'module)))
(if (not (module-defined? module key))
#nil
- (module-ref module key))))))
+ (module-ref module key #f))))))
(define (make-module-table name)
(define table (make-table))
@@ -202,35 +219,20 @@
;;;;; BUILT-INS
(define-syntax define-global
- (syntax-rules ()
+ (syntax-rules (*)
+ ((_ (* name . rest) body ...)
+ (define-global name (lambda* rest body ...)))
+ ((_ (name . rest) body ...)
+ (define-global name (lambda rest body ...)))
((_ name value)
(begin
(define name value)
- (new-index! *global-env-table* (symbol->string 'name) name)))
- ((_ (name args ...) body ...)
- (begin
- (define name (lambda (args ... . ignore) body ...))
- (new-index! *global-env-table* (symbol->string 'name) name)))
- ((_ (name . rest) body ...)
- (new-index! *global-env-table* (symbol->string 'name) (lambda rest body
...)))))
-
-(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 (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 metatable)
- table)
+ (export name)
+ (new-index! *global-env-table* (symbol->string 'name) name)))))
-(define-global (getmetatable table)
- (assert-table 1 "getmetatable" table)
- (table/metatable table))
+;; _G
+;; global variable table
+(define-global _G *global-env-table*)
(define-global (assert v . opts)
(define message (if (null? opts) "assertion failed" (car opts)))
@@ -238,6 +240,28 @@
(runtime-error message)
(apply values (cons v opts))))
+(define-global (* collectgarbage 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") (ignore))
+ ((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")
+ (runtime-warning "UNIMPLEMENTED")
+ #nil)
+
+(define-global (getmetatable table)
+ (assert-table 1 "getmetatable" table)
+ (table/metatable table))
+
(define-global (print . arguments)
(for-each
(lambda (x)
@@ -250,13 +274,32 @@
(newline)
#nil)
+(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 (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 metatable)
+ table)
+
+;; _VERSION
+;; contains a string describing the lua version
+(define-global _VERSION "Guile-Lua 5.1")
+
+;;; 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)
@@ -287,14 +330,6 @@
(if (not (null? (cdr rest)))
(lp (cdr rest))))
-;; _VERSION
-;; contains a string describing the lua version
-(define-global _VERSION "Guile-Lua 5.1")
-
-;; _G
-;; global variable table
-(define-global _G *global-env-table*)
-
;; require
(define (register-loaded-module name table)
(rawset *global-env-table* name table)
@@ -306,6 +341,7 @@
#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))))
diff --git a/module/language/lua/standard/io.scm
b/module/language/lua/standard/io.scm
index 47cfe06..44b5f19 100644
--- a/module/language/lua/standard/io.scm
+++ b/module/language/lua/standard/io.scm
@@ -2,3 +2,12 @@
#:use-module (language lua runtime))
;; close, flush, input, lines, open, output, popen, read, tmpfile, type,
write, file:close, file:flush, file:lines, file:read, file:seek, file:setvbuf,
file:write
+
+(define stdin (current-input-port))
+(define stdout (current-output-port))
+(define stderr (current-error-port))
+
+(define (close file)
+ #f)
+
+
diff --git a/module/language/lua/standard/math.scm
b/module/language/lua/standard/math.scm
index dabda0d..abb8339 100644
--- a/module/language/lua/standard/math.scm
+++ b/module/language/lua/standard/math.scm
@@ -60,6 +60,8 @@
(atan (/ x y)))
(define (randomseed seed . _)
+ ;; should have our own state in here
+ (warining "math.randomseed: (@ (guile) *random-state*) will be mutated as a
result of this call")
(set! *random-state* (seed->random-state seed))
*unspecified*)
@@ -67,7 +69,7 @@
(if (null? _)
((@ (guile) random) 1)
(begin
- (format #t "Guile-Lua runtime warning: lower bound of random will not
be respected")
+ (warning "math.random: lower bound of random will not be respected")
(if (null? (cdr _))
((@ (guile) random) 1)
((@ (guile) random) (cadr _))))))
diff --git a/module/language/lua/standard/os.scm
b/module/language/lua/standard/os.scm
index e948cf3..ca27cff 100644
--- a/module/language/lua/standard/os.scm
+++ b/module/language/lua/standard/os.scm
@@ -1,2 +1,38 @@
(define-module (language lua standard os)
- #:use-module (language lua runtime))
+ #:use-module (language lua runtime)
+
+ #:use-module (srfi srfi-98))
+
+;; clock, date, difftime, setlocale, time
+
+(define (clock)
+ ;; ??? does this work
+ (vector-ref (times) 0))
+
+(define (difftime t2 t1)
+ (- t2 t1))
+
+(define* (execute #:optional (command #f))
+ (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 oldname newname)
+ (rename-file oldname newname))
+
+(define (remove filename)
+ (if (file-is-directory? filename)
+ (rmdir filename)
+ (delete-file filename)))
+
+(define* (time #:optional (table #f))
+ #f)
+
+(define (tmpname)
+ (mkstemp!))
diff --git a/module/language/lua/standard/table.scm
b/module/language/lua/standard/table.scm
index 7f57bc5..2d15368 100644
--- a/module/language/lua/standard/table.scm
+++ b/module/language/lua/standard/table.scm
@@ -1,14 +1,41 @@
(define-module (language lua standard table)
+ #:use-module (language lua common)
#:use-module (language lua runtime)
- #:export (maxn))
+
+ #:use-module (rnrs control)
+ #:use-module ((srfi srfi-69) #:select (hash-table-size))
+)
;; TODO - concat, 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) (hash-table-size ht) %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))
+
+
(define (maxn table . _)
- (let loop ((rest (hash-table-keys table))
+ (assert-table 1 "maxn" table)
+ (let loop ((rest (hash-table-keys (table/slots table)))
(n 0))
(if (null? rest)
- n
+ (values n)
(let* ((item (car rest)))
(if (and (number? item) (> item n))
(loop (cdr rest) item)
diff --git a/test-suite/tests/lua-eval.test b/test-suite/tests/lua-eval.test
index 4bebffa..20d3d73 100644
--- a/test-suite/tests/lua-eval.test
+++ b/test-suite/tests/lua-eval.test
@@ -75,6 +75,7 @@
(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 "-- 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)
@@ -144,4 +145,14 @@ return _G._G._G.a")
(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)")
+
+ ))
+
diff --git a/test-suite/tests/lua-lexer.test b/test-suite/tests/lua-lexer.test
index a899d93..aff6ec6 100644
--- a/test-suite/tests/lua-lexer.test
+++ b/test-suite/tests/lua-lexer.test
@@ -1,4 +1,4 @@
-;; lua-lexer.test --- lua lexer test suite -*- mode: scheme -*-
+;; lua-lexer.test --- lua lexer test suite -*- mode: scheme -*-
(define-module (test-lua-lexer)
#:use-module (ice-9 format)
#:use-module (srfi srfi-8)
@@ -8,9 +8,15 @@
(with-test-prefix "lua-lexer"
(define (from-string string)
- (receive (_ lex)
- (make-lexer (open-input-string string))
- (lex)))
+ (define-lua-lexer get-source-info lex)
+ (call-with-input-string
+ string
+ (lambda (port)
+
+; (format #t "SHIT ASS ~A\n" get-source-info lex)
+ (initialize-lua-lexer! port get-source-info lex)
+ (lex))))
+
(let-syntax
((test
(syntax-rules (eof)
diff --git a/test-suite/tests/lua-math.test b/test-suite/tests/lua-math.test
deleted file mode 100644
index c24c2dd..0000000
--- a/test-suite/tests/lua-math.test
+++ /dev/null
@@ -1,47 +0,0 @@
-; -*- 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 parser)
-
- )
-
-(with-test-prefix "lua-math"
- (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 "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))
-
-
-))
-
diff --git a/test-suite/tests/lua-parser.test b/test-suite/tests/lua-parser.test
deleted file mode 100644
index 86ef23e..0000000
--- a/test-suite/tests/lua-parser.test
+++ /dev/null
@@ -1,57 +0,0 @@
-;; lua-parser.test --- lua parser 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 (test-suite lib)
-
- #:use-module (language lua parser))
-
-(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 => ~S" 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))))
-
- ) ;let-syntax
-) ;with-test-prefix
diff --git a/test-suite/tests/lua-scratch.test
b/test-suite/tests/lua-scratch.test
new file mode 100644
index 0000000..b380968
--- /dev/null
+++ b/test-suite/tests/lua-scratch.test
@@ -0,0 +1,125 @@
+; -*- mode: scheme -*-
+
+ ;;;;; TODO LIST
+ ;; - Multiple values
+ ;; - Variable arguments
+ ;; - Applications of a table literal with no parentheses
+ ;; - Concatenation
+ ;; - Method invocations
+ ;; - For loops
+ ;; - Modules: os, table, io, math
+ ;; - Metatable events: __index, __newindex, __mode, __call, __metatable,
__tostring, __gc, __concat, __eq, __unm
+ ;; require 'math' FAILS
+ ;;;;; NOT PART OF PROJECT
+ ;; - bitlib, coroutine, debug, string
+
+ ;;;;; tenative multiple values idea:
+ ;; The context of expressions is recorded by the parser when relevant When
+ ;; multiple values can occur, evaluating the expression will result in a
+ ;; <multiple-values> record. This record shall be inspected by functions in
+ ;; (language lua runtime), and used as necessary
+
+ ;; Situations where we need to consider multiple values:
+
+ ;; table literals
+ ;; return statements
+ ;; assignments
+ ;; function calls
+
+#|
+ Manual excerpt on multiple values:
+
+ ;; Before the assignment, the list of values is adjusted to the length of
+ ;; the list of variables. If there are more values than needed, the excess
+ ;; values are thrown away. If there are fewer values than needed, the list
+ ;; is extended with as many nil's as needed. If the list of expressions
ends
+ ;; with a function call, then all values returned by that call enter the
+ ;; list of values, before the adjustment (except when the call is enclosed
+ ;; in parentheses; see §2.5).
+
+ ;; 2.5 - Expressions
+
+ ;; Both function calls and vararg expressions can result in multiple
+ ;; values. If an expression is used as a statement (only possible for
+ ;; function calls (see §2.4.6)), then its return list is adjusted to zero
+ ;; elements, thus discarding all returned values. If an expression is used
+ ;; as the last (or the only) element of a list of expressions, then no
+ ;; adjustment is made (unless the call is enclosed in parentheses). In all
+ ;; other contexts, Lua adjusts the result list to one element, discarding
+ ;; all values except the first one.
+
+ End manual excerpt
+
+ Multiple values
+
+ we must know the context of all expressions -- whether they occur alone,
+ before the end of a list, or at the end of a list
+
+ f() -- adjusted to 0 results
+ g(f(), x) -- f() is adjusted to 1 result
+ g(x, f()) -- g gets x plus all results from f()
+ a,b,c = f(), x -- f() is adjusted to 1 result (c gets nil)
+ a,b = ... -- a gets the first vararg parameter, b gets
+ -- the second (both a and b can get nil if there
+ -- is no corresponding vararg parameter)
+
+ a,b,c = x, f() -- f() is adjusted to 2 results
+ a,b,c = f() -- f() is adjusted to 3 results
+ return f() -- returns all results from f()
+ return ... -- returns all received vararg parameters
+ return x,y,f() -- returns x, y, and all results from f()
+ {f()} -- creates a list with all results from f()
+ {...} -- creates a list with all vararg parameters
+ {f(), nil} -- f() is adjusted to 1 result
+
+
+
+
+ |#
+
+(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)
+
+ )
+
+;; so now we need to deal with multiple values when:
+;; function call is last in application (pass all results to function
application, append?)
+;; function call is last in assignment (assign all results to variables, nil
to overflows)
+;; function is last in table constructor (assign to indices)
+;; table constructor
+;; also variable arguments (later)
+
+(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 "function identity(x) return x end return identity(21)" 21)
+ ;(test "assert(true)" #t)
+ ;(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 identity(x) return x end return identity(2) +
identity(2)" 4)
+ #t
+))
+
+(begin
+ (define var
+"table = {}
+function table:identity() return self end return table:identity(true)"
+ ) (display (compile ((make-parser (open-input-string var)))
+ #:from 'lua #:to 'value))
+ (newline))
diff --git a/test-suite/tests/lua-standard-library.test
b/test-suite/tests/lua-standard-library.test
new file mode 100644
index 0000000..8fa6665
--- /dev/null
+++ b/test-suite/tests/lua-standard-library.test
@@ -0,0 +1,50 @@
+; -*- 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 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-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))
+ )
+
+(with-test-prefix "lua-table"
+ (test "require 'table'; return true")
+ (test "return table.concat({\"1\", \"2\", \"3\"}, \" \")" "1 2 3")
+)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-247-ga429266,
No Itisnt <=