[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-16-gdb94b4f

[No Itisnt]

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=db94b4fe2b5e85f0edee1a474f897d26d94ea937

The branch, lua has been updated
       via  db94b4fe2b5e85f0edee1a474f897d26d94ea937 (commit)
       via  568b574c3e9023320ac3431e7c1bf725340b71ab (commit)
       via  80dbc71eb516f56c7e0985f640d03ce3a9fe7f8a (commit)
       via  b9fe6d4a819a1b6f8e84a0821f07027b48eec6d8 (commit)
      from  1ccee22b16f08649527eabd353025192e12876f9 (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 db94b4fe2b5e85f0edee1a474f897d26d94ea937
Author: No Itisnt <address@hidden>
Date:   Sun Jun 6 16:22:22 2010 -0500

    Lua now has partial support for functions and full (but not extensively 
tested)
    support for if statements.

commit 568b574c3e9023320ac3431e7c1bf725340b71ab
Author: No Itisnt <address@hidden>
Date:   Fri Jun 4 11:26:52 2010 -0500

    Fix binary operator support

commit 80dbc71eb516f56c7e0985f640d03ce3a9fe7f8a
Author: No Itisnt <address@hidden>
Date:   Fri Jun 4 09:32:49 2010 -0500

    Add unary operators.
    
    * lua.scm: Add support for unary operators, currently just unm (unary -).

commit b9fe6d4a819a1b6f8e84a0821f07027b48eec6d8
Author: No Itisnt <address@hidden>
Date:   Thu Jun 3 19:14:09 2010 -0500

    Remove (rnrs control) from imports
    
    * lua.scm: Remove (rnrs control) from imports.

-----------------------------------------------------------------------

Summary of changes:
 lua.scm |  438 ++++++++++++++++++++++++++++++++++++++++++++++++++-------------
 1 files changed, 351 insertions(+), 87 deletions(-)

diff --git a/lua.scm b/lua.scm
index 4bdd1d9..fdd2058 100644
--- a/lua.scm
+++ b/lua.scm
@@ -11,8 +11,8 @@ that port."
   (define port (current-input-port))
   (throw
    'lua-syntax
-   (apply format (string-append "~S: " string)
-          (cons (format "address@hidden:"
+   (apply format (string-append "~A: " string)
+          (cons (format "address@hidden"
                         (port-filename port)
                         (port-line port)
                         (port-column port))
@@ -24,8 +24,6 @@ that port."
     (line . ,(port-line port)) ((column . ,(port-column port)))))
 
 (define-module (language lua lexer)
-
-  #:use-module ((rnrs control) #:version (6))
   #:use-module (srfi srfi-14)
   #:use-module (srfi srfi-39)
 
@@ -43,8 +41,9 @@ that port."
 (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) (symbol->keyword k))
+    ((return function end if then elseif else true false nil) (symbol->keyword 
k))
     (else k)))
 
 (define (make-lexer port)
@@ -71,17 +70,18 @@ that port."
                        ((eq? c #\newline) (loop))
                        (else (consume (read-char)))))
                ;; it is a -
-               '-))
+               #\-))
           ;; = and ==
           ((#\=)
            (read-char)
            (if (eq? (peek-char) #\=)
-               (begin (read-char) '==)
-               '=))
-          ;; semicolons
-          ((#\;) (read-char))
-          ;; operators
-          ((#\+) (string->symbol (string (read-char))))
+               (begin (read-char) #:==)
+               #:=))
+          ;; TODO: ...
+
+          ;; characters that are allowed directly through
+          ((#\; #\( #\, #\)
+            #\+ #\/ #\*) (read-char))
           ;; numbers
           ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
            (while (is-digit? (peek-char))
@@ -101,52 +101,65 @@ that port."
     ) ; lex
 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)
+     (write x)
+     (write-char #\tab)
+   arguments))
+  (newline))
+
 (define-module (language lua runtime)
 
   #:export (unm eq lt le gt ge add sub mul div pow))
 
-(define (unm a b)
-  "A function backing the unary - (negation) operator")
+(define (unm a)
+  "A function backing the unary - (negation) operator"
+  (- a))
 
-(define (== a b)
+(define (eq a b)
   "A function backing the == operator")
 
-(define (<= a b)
+(define (le a b)
   "A function backing the < and > operators")
 
-(define (>= a b)
+(define (ge a b)
   "A function translating > to <")
 
-(define (< a b)
+(define (lt a b)
   "A function backing the <= and >= operators")
 
-(define (> a b)
+(define (gt a b)
   "A function translating >= to <=")
 
-(define (+ a b) 
+(define (add a b)
   "A function backing the + operator"
   (+ a b))
 
-(define (- a b)
-  "A function backing the binary - (subtraction) operator")
+(define (sub a b)
+  "A function backing the binary - (subtraction) operator"
+  (- a b))
 
-(define (* a b)
+(define (mul a b)
   "A function backing the * operator"
   (* a b))
 
-(define (/ a b)
+(define (div a b)
   "A function backing the / operator"
-  #f)
+  (/ a b))
 
-(define (^ a b)
+(define (pow a b)
   "A function backing the ^ operator"
   #f)
 
 (define-module (language lua parser)
 
   #:use-module (language tree-il)
-  #:use-module ((rnrs control) #:version (6))
   #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-9)
 
   #:use-module (language lua common)
   #:use-module (language lua lexer)
@@ -161,6 +174,12 @@ lex) ; make-lexer
 ;; - 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)
@@ -169,121 +188,314 @@ lex) ; make-lexer
 (define (token/type t)
   (cond ((number? t) 'NUMBER)
         ((eof-object? t) 'EOS)
-        (else (error #:TOKEN/TYPE t))))
+        ((symbol? t) 'NAME)
+        ((string? t) 'STRING)
+        (else
+         (case t
+           ((#\( #\, #\- #:function #:end #:if #:elseif #:then #:else #:true 
#:false) t)
+           (else (error #:TOKEN/TYPE t))))))
 
 ;; infix operator parsing
 (define (binary-operator? t)
   (case t
-    ((+) #t)
+    ((#\+ #\* #\/ #\-) #t)
     (else #f)))
 
+;; TODO: length operator cannot be represented as a keyword
+(define (unary-operator? t)
+  (case t
+    ((#\- #:not) #t)
+    (else #f)))
+
+;; TODO: collapse priorities into one
 (define (left-priority o)
   (case o
-    ((+ -) 6)
-    ((* / %) 7)
+    ((#\+ #\-) 6)
+    ((#\* #\/ #\%) 7)
     (else (error #:LEFT-PRIORITY o))))
 
 (define (right-priority o)
   (case o
-    ((+ -) 6)
-    ((* / %) 7)
+    ((#\+ #\-) 6)
+    ((#\* #\/ #\%) 7)
     (else (error #:RIGHT-PRIORITY o))))
 
+;; priority of unary operators
+(define *unary-priority* 8)
+
+(define (operator->tree-il operator . arguments)
+  (make-application #f (make-module-ref #f '(language lua runtime) operator 
#t) arguments))
+
+(define (make-unary-operation operator a)
+  (operator->tree-il
+   (case operator
+     ((#\-) 'unm)
+     (else (error #:MAKE-UNARY-OPERATION "should not happen" a)))
+   a))
+   
 ;; convert parsed infix operation to tree-il
-(define (infix operator a b)
-  (make-application
-   #f
-   (make-module-ref #f operator '(language lua runtime) #t)
-   (list a b)))
+(define (make-binary-operation operator a b)
+  (operator->tree-il
+   (case operator
+     ((#\+) 'add)
+     ((#\-) 'sub)
+     ((#\*) 'mul)
+     ((#\/) 'div)
+     (else (error #:MAKE-BINARY-OPERATION "should not happen" a)))
+   a b))
 
 (define (make-parser port)
   ;; lexer
   (define lexer (make-lexer port))
   ;; parser state
   (define token)
-  (define (advance) (set! token (lexer)))
-
-  ;; the parser (read from the bottom up)
-  (define (prefix-expression)
-    ;; prefix-expression -> NAME | '(' expression ')'
-    #t)
+  (define environment #f)
   
+  ;; auxilliary functions
+
+  ;; 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 (append! (environment/names 
environment) (list name)))))
+
+  (define* (environment-exists? name #:optional (e environment))
+    (if e 
+        (if (member name (environment/names e))
+            #t
+            (environment-exists? name (environment/parent e)))
+        #f))
+
+  ;; tokens
+  (define (advance!) (set! token (lexer)))
+
+  (define* (assert-token-type type #:optional (token token))
+    (if (not (equal? (token/type token) type))
+        (syntax-error "expected ~a" type)))
+
+  (define (test-next! c)
+    (if (equal? token c)
+        (begin (advance!) #t)
+        #f))
+
+  (define (enforce-next! expect)
+    (if (not (test-next! expect))
+        (syntax-error "expected ~a but got ~a" expect token)))
+
+  ;; tree-il  
+  (define (make-return x)
+    "Return a tree-il expression representing an explicit return of X."
+    (make-application (source-info) (make-primitive-ref #f 'return) x))
+
+  ;; grammar  
+  (define (single-variable)
+    (define save token)
+    (assert-token-type 'NAME)
+    (advance!)
+    ;; resolve variable
+    (if (environment-exists? save)
+        (make-lexical-ref #f save save)
+        (make-module-ref #f '(language lua global-environment) save #f)))
+
+  ;; application-arguments -> '(' [ expression-list ] ')'
+  (define (application-arguments)
+    (case token
+      ((#\()
+       (advance!)
+       (if (eq? token #\))
+           '()
+           (expression-list)))
+      (else (error #:APPLICATION-ARGUMENTS "should not happen"))))
+
+  ;; prefix-expression -> NAME | '(' expression ')'
+  (define (prefix-expression)
+    (cond ((eq? (token/type token) 'NAME) (single-variable))
+          (else (syntax-error "unexpected symbol ~a" token))))
+
+  ;; primary-expression -> prefix-expression { '.' NAME | '[' expression ']' | 
':' application-arguments | application-arguments }
   (define (primary-expression)
-    ;; primary-expression -> prefix-expression { `.' NAME | `[' expression `]' 
| `:' function-arguments | function-arguments }
-    (prefix-expression))
+    (define prefix (prefix-expression))
+    (let ()
+      (define result
+        (case (token/type token)
+          ((#\()
+           (make-application #f prefix (application-arguments)))
+          ((#:end) prefix)
+          (else (error #:PRIMARY-EXPRESSION "should not happen" token))))
+      result))
 
   (define (expression-statement)
     (primary-expression))
 
+  ;; 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 "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 #:key (locals '()))
+    (enforce-next! #\()
+    (let* ((parameters (parameter-list "anonymous function")))
+      (enforce-next! #\))
+
+      ;; create a new environment and populate it with function arguments
+      (enter-environment!)
+      (if (not (null? parameters))
+          (let loop ((parameter (car parameters))
+                     (rest (cdr parameters)))
+            (environment-define! parameter)
+            (if (not (null? rest))
+                (loop (car rest) (cdr rest)))))
+
+      (let* ((body (chunk)))
+        (enforce-next! #:end)
+        (leave-environment!)
+        (make-lambda #f parameters (if (null? body) (make-void #f) body)))))
+
   (define (expression-list)
-    (list (expression)))
+    (let loop ((tree (list (expression))))
+      (if (test-next! #\,)
+          (loop (append tree (list (expression))))
+          tree)))
 
+  ;; simple-expression -> NUMBER | FUNCTION function-body
   (define (simple-expression)
-    (define r
-      (case (token/type token)
-        ((NUMBER) (make-const (source-info) token))
-        (else (error #:SIMPLE-EXPRESSION "should not happen"))))
-    (advance)
-    r)
-
+    (receive
+     (advance? result)
+     (case (token/type token)
+       ((NUMBER) (values #t (make-const (source-info) token)))
+       ((#:true) (values #t (make-const (source-info) #t)))
+       ((#:false) (values #t (make-const (source-info) #f)))
+       ((#:function) (advance!) (values #f (function-body)))
+       (else (values #f (primary-expression))))
+     (if advance?
+         (advance!))
+     result))
+
+  ;; subexpression -> (simple-expression | unary-operator subexpression) { 
binary-operator subexpression }
   (define (subexpression limit)
-    ;; gets the next expression
-    (define left (simple-expression))
-    ;; now check the following token
-    (let loop ()
+    (define left)
+      ;; test for preceding unary operator
+    (set! left
+      (if (unary-operator? token)
+          (let* ((operator token))
+            (advance!)
+            (make-unary-operation operator (subexpression *unary-priority*)))
+          ;; note that simple-expression may also call advance!
+          (simple-expression)))
+
+    (let loop ((left left))
+      ;; if this is a binary operation, read the second argument
       (if (and (binary-operator? token) (> (left-priority token) limit))
           (let* ((operator token))
-            (advance)
-            ;; read next expression with higher priority
+            (advance!)
+            ;; read next expression with higher priorities
             (let* ((right (subexpression (right-priority operator))))
-              (infix operator left right)))
+              (loop (make-binary-operation operator left right))))
+          ;; otherwise, return the first expression
           left)))
-  
+
   (define (expression)
     (subexpression 0))
 
   (define (return)
     ;; skip 'return'
-    (advance)
+    (advance!)
     ;; if followed by END or ';', the return has no arguments
-    (make-application
-     (source-info)
-     (make-primitive-ref #f 'return)
-     (if (or (end-of-block? token) (eq? token #\;))
-         '()
-         (expression-list))))
+    (make-return (if (or (end-of-block? token) (eq? token #\;)) '() 
(expression-list))))
+
+  ;; then-chunk -> [IF | ELSEIF] expression THEN chunk
+  (define (then-chunk)
+    ;; skip IF or ELSEIF
+    (advance!)
+    (let* ((condition (expression)))
+      (enforce-next! #:then)
+      (values condition (chunk))))
+
+  ;; if -> IF condition THEN chunk { ELSEIF condition THEN chunk } [ELSE 
chunk] END  
+  (define (if-statement)
+    (define x
+      (receive (test then)
+               (then-chunk)
+               (make-conditional
+                #f
+                test
+                then
+                (let loop ()
+                  (if (eq? token #:elseif)
+                      (receive (test then)
+                               (then-chunk)
+                               (make-conditional #f test then (loop)))
+                      (if (eq? token #:else)
+                          (begin (advance!) (make-conditional #f (make-const 
#f #t) (chunk) (make-void #f)))
+                          (make-void #f)))))))
+    (enforce-next! #:end)
+    x)
   
   ;; statement
   (define (statement)
     (case token
       ;; statement -> return
       ((#:return) (values #t (return)))
+      ((#:if) (values #f (if-statement)))
       
       ;; statement -> function | assignment
       (else (values #f (expression-statement)))))
   
   ;; chunk -> { statement [ ';' ] }
   (define (chunk)
-    (let loop ((is-last #f)
+    (let loop ((is-last (end-of-block? token))
                (tree '()))
       (if is-last
           tree
         (receive
          (is-last tree)
          (statement)
-         (loop is-last tree)))))
+         (loop (or (end-of-block? token) is-last) tree)))))
 
+  ;; toplevel local environment
+  (enter-environment!)
   ;; read first token
-  (advance)
+  (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 (p _) ((make-parser p)))
+  #: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 (system base syntax)
-  #:use-module (system base pmatch)
+  #:use-module (system base compile)
   #:use-module (test-suite lib)
 
   #:use-module (language lua lexer)
@@ -301,11 +513,15 @@ lex) ; make-lexer
 
     (test (eof " "))
     (test (eof "-- comment"))
-    
+
     (test "12345" 12345)
     (test "name" 'name)
     (test "return" #:return)
     (test ";" #\;)
+    (test "-" #\-)
+    (test "+" #\+)
+    (test "/" #\/)
+    (test "*" #\*)
 
 ))
 
@@ -317,21 +533,69 @@ lex) ; make-lexer
         (else x)))
 
 (with-test-prefix "lua-parser"
-  (define (from-string string) ((make-parser (open-input-string string))))
+  (define (from-string string) (strip-tree-il! ((make-parser 
(open-input-string string)))))
+  (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 `(apply (primitive return) ,@`expect))
+                (result (from-string real-string)))
+           (pass-if (format "~S => ~A" real-string real-expect) (equal? result 
real-expect))))))
+     (test
+      (syntax-rules ()
+        ((_ string . expect)
+         (pass-if (format "~S => ~A" string 'expect) (equal? (from-string 
string) 'expect)))))
+     (print-test
+      (syntax-rules ()
+        ((_ string . expect)
+         (let* ((real-string string)
+                (real-expect `(apply (primitive return) ,@`expect))
+                (result (from-string real-string)))
+           (format #t "~a\n" result)
+           (pass-if (format "~S => ~A" real-string real-expect) (equal? result 
real-expect)))))))
+
+    ;; shortcuts
+    (define (op x) `(@ (language lua runtime) ,x))
+    (define (global x) `(@@ (language lua global-environment) ,x))
+
+    (test-return "")
+    (test-return ";")
+    (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 "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))))
+    (test-return "function() end" (lambda () (void)))
+    (test-return "function(a) return a end" (lambda (a) (apply (primitive 
return) (lexical a a))))
+ ))
+
+(with-test-prefix "lua-eval"
+  (define (from-string string)
+    (compile ((make-parser (open-input-string string)))
+             #:from 'lua
+             #:to 'value))
   (let-syntax
     ((test
       (syntax-rules ()
         ((_ string expect)
-         (pass-if (format "~S => ~A" string expect) (equal? (strip-tree-il! 
(from-string string)) expect))))))
+         (pass-if (format "~S => ~A" string expect) (equal? (from-string 
string) expect))))))
 
-    (test "return" '(apply (primitive return)))
-    (test "return;" '(apply (primitive return)))
-    (test "return 2" '(apply (primitive return) (const 2)))
-    (test "return 2 + 2" '(apply (primitive return) (apply (@ + (language lua 
runtime)) (const 2) (const 2))))
+    (test "return 2" 2)
+    (test "return 2 + 2" 4)
+    (test "return 1 + 2 * 3" 7)
+    (test "return 1 * 2 + 3" 5)
+    
+    (test "if true then return true else return false end" #t)
+    (test "if false then return false elseif false then return false elseif 
true then return true else return false end" #t)
+    (test "if false then return false elseif false then return false elseif 
false then return false else return true end" #t)
 ))
-
-(with-test-prefix "lua-eval"
-  (define (from-string string)
-    #f)
-  #t
-)
\ No newline at end of file


hooks/post-receive
-- 
GNU Guile