summaryrefslogtreecommitdiff
path: root/module/language/lua/runtime.scm
diff options
context:
space:
mode:
authorNo Itisnt <theseaisinhere+git@gmail.com>2010-06-03 03:12:41 -0500
committerIan Price <ianprice90@googlemail.com>2013-09-09 17:01:23 +0100
commita30c18c22a26be43f095e92c007142ae3fffc367 (patch)
treeae83f065eb36ff0355a2abca97afa363677f1345 /module/language/lua/runtime.scm
parent6871327742d3e1a0966aa8fed04c911311c12c2a (diff)
downloadguile-a30c18c22a26be43f095e92c007142ae3fffc367.tar.gz
add lua language implementation
What is missing: + Functions: module, getfenv, setfenv, math.modf, table.sort + Parser: needs to be more flexible + Compiler: needs more extensive work to properly handle all possible cases of variable arguments, multiple returns, and loops + Language: Variable arguments and unpacking of multiple returns. (For example we need to be able to handle something as complex as print(unpack({...})), which is easy with Lua's explicit stack but will require lots of tree-il gymnastics, or perhaps modifications to better allow different calling conventions. (For instance -- how would we support Python or Ruby, where keyword arguments are gathered into a hashtable and passed as a single argument?) What is there: A fair shot at supporting Lua 5.1, not quite a drop-in replacement, but not far from that goal either.
Diffstat (limited to 'module/language/lua/runtime.scm')
-rw-r--r--module/language/lua/runtime.scm606
1 files changed, 606 insertions, 0 deletions
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
new file mode 100644
index 000000000..6cf30d335
--- /dev/null
+++ b/module/language/lua/runtime.scm
@@ -0,0 +1,606 @@
+;;; Guile Lua --- runtime functionality
+
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language lua runtime)
+ #:use-module (language lua common)
+
+ #:use-module (rnrs control)
+ #:use-module ((srfi srfi-1) #:select (filter!))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-69)
+ #:use-module ((srfi srfi-98) #:select (get-environment-variable))
+ #:use-module ((system base compile) #:select (compile read-and-compile))
+
+ #:export (
+ runtime-error
+
+ ;; semantics
+ false? true?
+
+ ;; misc
+ value-type->string
+ assert-type
+ assert-table
+ assert-string
+ assert-number
+
+ ;; tables
+ make-table
+ table?
+ table-slots
+ table-metatable
+ table-metatable!
+ table-length
+
+ ;; userdata
+ userdata
+ userdata-metatable
+ register-userdata!
+
+ ;; metatable
+ might-have-metatable?
+ get-metatable
+ dispatch-metatable-event
+
+ ;; table interaction
+ index
+ new-index!
+ get-field
+
+ ;; operators
+ len unm eq lt le gt ge add sub mul div pow
+ neq concat
+
+ ;; modules
+ make-module-table
+
+ ;; global environment
+ *global-env-table*
+ save-fenv
+ check-global-function
+ )
+
+ #:export-syntax (table-slots table? table-metatable table-metatable!)
+
+ ) ; define-module
+
+;; Local Variables:
+;; eval: (put 'define-global 'scheme-indent-function 1)
+;; End:
+
+(define (runtime-error string . arguments)
+ "Throw an error tagged with 'lua-runtime"
+ (throw 'lua-runtime (apply format (cons (string-append "LUA: ERROR: " string "\n") arguments))))
+
+(define (runtime-warning string . arguments)
+ (apply format (cons #t (cons (string-append "LUA: RUNTIME WARNING: " string "\n") arguments))))
+
+;;;;; SEMANTICS
+
+(define (false? x)
+ "Wrapper for Scheme's false semantics that considers #nil to be false"
+ (or (eq? x #f) (eq? x #nil)))
+
+(define (true? x)
+ "Inversion of false?"
+ (not (false? x)))
+
+;;;;; MISCELLANEOUS
+
+(define (value-type->string x)
+ (cond ((table? x) "table")
+ ((string? x) "string")
+ ((number? x) "number")
+ ((boolean? x) "boolean")
+ ((eq? x #nil) "nil")
+ ((procedure? x) "function")
+ ;; TODO: value-type->string must recognize threads
+ (else "userdata")))
+
+(define (assert-type argument caller expected value predicate)
+ (if (not (predicate value))
+ (runtime-error (format #f "bad argument ~a to '~a' (~a expected, got ~a)" argument caller expected (value-type->string value)))))
+
+(define-syntax define-assert
+ (syntax-rules ()
+ ((_ name string predicate)
+ (define (name argument caller value) (assert-type argument caller string value predicate)))))
+
+(define-assert assert-table "table" table?)
+(define-assert assert-string "string" string?)
+(define-assert assert-number "number" number?)
+
+;;;;; TABLES
+
+(define-record-type table
+ (%make-table metatable slots)
+ table?
+ (metatable table-metatable table-metatable!)
+ (slots table-slots))
+
+(define (make-table)
+ (%make-table #f (make-hash-table)))
+
+(define (table? x) (table? x))
+(define (table-metatable x) (table-metatable x))
+(define (table-metatable! x y) (table-metatable! x y))
+
+;;;;; USERDATA
+
+;; Userdata is tracked by this property. It can be #f, indicating the
+;; object is not userdata, #t, indicating the object is userdata but has
+;; no metatable, or an actual table, which counts as the metatable.
+(define userdata-property (make-object-property))
+
+(define userdata? userdata-property)
+(define (userdata-metatable x)
+ (and (table? (userdata-property x)) (userdata-property x)))
+
+(define* (register-userdata! x #:optional metatable)
+ (set! (userdata? x) (or metatable #t)))
+
+;;;;; METATABLES
+
+(define (might-have-metatable? x)
+ (or (table? x) (userdata? x)))
+
+(define (get-metatable x)
+ (cond ((table? x) (table-metatable x))
+ ((userdata? x) (userdata-metatable x))
+ (else #f)))
+
+;;;;; TABLE INTERACTION
+
+(define (dispatch-metatable-event key default x . arguments)
+ (let* ((metatable (get-metatable x)))
+ (apply
+ (if metatable
+ (hash-table-ref/default (table-slots metatable) key default)
+ default)
+ arguments)))
+
+;; see manual section 2.5.5
+(define (table-length table)
+ (let* ((numeric-keys (sort! (filter! number? (hash-table-keys (table-slots table))) <)))
+ (if (eq? (car numeric-keys) 1)
+ (let lp ((cell (car numeric-keys))
+ (rest (cdr numeric-keys))
+ (length 0))
+ ;; length does not count "holes"
+ ;; so if a table has the keys 1,2,3 and 5, the length of the table is 3
+ (if (or (> cell (+ length 1)) (null? rest))
+ (+ length 1) ;; add one to length as though we had started from one
+ (lp (car rest) (cdr rest) cell)))
+ 0)))
+
+(define (index table key)
+ (dispatch-metatable-event
+ "__index"
+ (lambda (table key) (hash-table-ref/default (table-slots table) key #nil))
+ table
+ table key))
+
+(define (new-index! table key value)
+ (dispatch-metatable-event
+ "__newindex"
+ (lambda (table key value) (hash-table-set! (table-slots table) key value))
+ table
+ table key value))
+
+(define* (get-field table key #:optional (default #nil))
+ (define result (index table key))
+ (if (eq? result #nil)
+ default
+ result))
+
+;;;;; OPERATORS
+(define (len a)
+ "A function backing the unary # (length) operator"
+ (cond ((string? a) (string-length a))
+ ((table? a) (table-length a))
+ (else (runtime-error "attempt to get length of a ~A value" (value-type->string a)))))
+
+(define (unm a)
+ "A function backing the unary - (negation) operator"
+ (if (might-have-metatable? a)
+ (dispatch-metatable-event "__unm" - a a)
+ (- a)))
+
+(define (builtin-eq a b)
+ "A function backing the == operator"
+ (equal? a b))
+
+(define (builtin-concat a b)
+ (when (or (table? a) (table? b))
+ (runtime-error "attempt to concatenate a table value"))
+ (when (or (eq? a #nil) (eq? b #nil))
+ (runtime-error "attempt to concatenate a nil value"))
+ (when (or (boolean? a) (boolean? b))
+ (runtime-error "attempt to concatenate a boolean value"))
+ (format #f "~a~a" a b))
+
+(define (neq a b)
+ "An inversion of eq"
+ (not (eq a b)))
+
+(define (ge a b)
+ "A function backing the >= (greater-than-or-equal-to) operator"
+ (not (lt a b)))
+
+(define (gt a b)
+ "A function backing the > (greater-than) operator"
+ (not (le a b)))
+
+;; This macro could be even cooler and generate the slot names as well as the
+;; parsers name/function mappings at expand-time
+(letrec-syntax
+ ((define-binary-operators
+ (syntax-rules ()
+ ((_ (name slot-name default) ...)
+ (begin
+ (define-binary-operators () name slot-name default)
+ ...))
+ ((_ () name slot-name default)
+ (begin
+ (define (name a b)
+ (cond ((might-have-metatable? a)
+ (dispatch-metatable-event slot-name default a a b))
+ ((might-have-metatable? b)
+ (dispatch-metatable-event slot-name default b a b))
+ (else (default a b)))))))))
+ (define-binary-operators
+ (add "__add" +)
+ (sub "__sub" -)
+ (mul "__mul" *)
+ (div "__div" /)
+ (pow "__pow" expt)
+ (le "__le" <=)
+ (lt "__lt" <)
+ (eq "__eq" builtin-eq)
+ (concat "__concat" builtin-concat)))
+
+;;;;; MODULES
+
+;; A metatable for tables backed by modules
+(define module-metatable (make-table))
+
+(hash-table-set!
+ (table-slots module-metatable) "__index"
+ (lambda (table key)
+ (define slots (table-slots table))
+ (if (hash-table-exists? slots key)
+ (hash-table-ref slots key)
+ (let ((key (string->symbol key))
+ (module (hash-table-ref slots 'module)))
+ (if (not (module-defined? module key))
+ #nil
+ (module-ref module key #f))))))
+
+(define (make-module-table name)
+ (define table (make-table))
+ (table-metatable! table module-metatable)
+ (hash-table-set! (table-slots table) 'module (resolve-module name))
+ table)
+
+;;;;; GLOBAL ENVIRONMENT
+
+(define *global-env-table* (make-table))
+
+;; Saves _G and returns a function that will restore it
+(define (save-fenv table)
+ "Saves *global-env-table* and returns a function to restore it"
+ (let* ((save *global-env-table*))
+ (set! *global-env-table* table)
+ (lambda ()
+ (set! *global-env-table* save))))
+
+(define (check-global-function name value)
+ (when (eq? value #nil)
+ (runtime-error "attempt to call global '~a' (a nil value)" name)))
+
+;;;;; BUILT-INS
+
+(define-syntax define-global
+ (syntax-rules (do-not-export)
+ ((_ (do-not-export name) value)
+ (begin
+ (define name value)
+ (new-index! *global-env-table* (symbol->string 'name) name)))
+ ((_ (name . rest) body ...)
+ (define-global name (lambda rest body ...)))
+ ((_ name value)
+ (begin
+ (define name value)
+ (export name)
+ (new-index! *global-env-table* (symbol->string 'name) name)))))
+
+(define-global (assert v . opts)
+ (define message (if (null? opts) "assertion failed" (car opts)))
+ (if (false? v)
+ (runtime-error message)
+ (apply values (cons v opts))))
+
+;; NOTE: collectgarbage cannot be fully implemented because it expects
+;; an incremental garbage collector that matches lua's interface; libgc
+;; can be incremental but i don't think we can turn that on from guile
+;; currently, and even if we could i'm not sure that libgc exposes what
+;; lua wants
+(define-global collectgarbage
+ (lambda* (opt #:optional (arg #nil))
+ (define (ignore) (runtime-warning "collectgarbage cannot respect command ~a" opt))
+ (assert-type 1 "collectgarbage" "string" opt string?)
+ (cond ((string=? opt "stop") (ignore))
+ ((string=? opt "restart") (ignore))
+ ((string=? opt "collect") (gc))
+ ((string=? opt "count") (ignore))
+ ((string=? opt "step") (ignore))
+ ((string=? opt "setpause") (ignore))
+ ((string=? opt "setstepmul") (ignore))
+ (else (runtime-error "bad argument #1 to 'collectgarbage' (invalid option ~a)" opt)))))
+
+(define-global (dofile filename)
+ (assert-string 1 "dofile" filename)
+ (runtime-warning "dofile cannot return the values of the chunk and instead will return #nil")
+ (call-with-input-file filename
+ (lambda (file)
+ (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value)))
+ #nil)
+
+(define-global (do-not-export error)
+ (lambda* (message #:optional level)
+ (runtime-warning "level argument to error is not respected")
+ (throw 'lua-error message)))
+
+;; global variable table
+(define-global _G *global-env-table*)
+
+(define-global (getmetatable table)
+ (assert-table 1 "getmetatable" table)
+ (let* ((mt (table-metatable table)))
+ (if (eq? mt #f)
+ #nil
+ mt)))
+
+(define-global (ipairs table)
+ (assert-table 1 "ipairs" table)
+ (values
+ (lambda (table indice)
+ (set! indice (+ indice 1))
+ (let* ((value (index table indice)))
+ (if (eq? value #nil)
+ (values #nil #nil)
+ (values indice value)))
+ )
+ table
+ 0))
+
+(define (load-warning)
+ (runtime-warning "load, loadfile, and loadstring cannot return the results of evaluating a file"))
+
+(define (load-chunkname-warning chunkname)
+ (when chunkname
+ (runtime-warning "load and loadstring ignore chunkname")))
+
+(define-global load
+ (lambda* (func #:optional chunkname)
+ (load-warning)
+ (load-chunkname-warning chunkname)
+ (lambda ()
+ (compile
+ ((@ (language lua parser) read-lua)
+ (open-input-string
+ (let lp ((tree '())
+ (result (func)))
+ (if (or (equal? func "") (eq? func #nil) (eq? func *unspecified*))
+ (string-concatenate-reverse tree)
+ (lp (cons func tree) (func))))))
+ #:from 'lua #:to 'value))))
+
+(define-global loadfile
+ (lambda* (#:optional filename)
+ (load-warning)
+ (lambda ()
+ (if filename
+ (call-with-input-file filename
+ (lambda (file)
+ (compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value)))
+ (read-and-compile (current-input-port) #:from 'lua)))))
+
+(define-global loadstring
+ (lambda* (string #:optional chunkname)
+ (load-warning)
+ (load-chunkname-warning chunkname)
+ (lambda ()
+ (compile ((@ (language lua parser) read-lua) (open-input-string string)) #:from 'lua #:to 'value))))
+
+;; TODO: module
+
+(define-global next
+ (lambda* (table #:optional (index #nil))
+ (assert-table 1 "next" table)
+ (let* ((keys (hash-table-keys (table-slots table))))
+ ;; empty table = nil
+ (if (null? keys)
+ #nil
+ (begin
+ (if (eq? index #nil)
+ (let* ((next-index (list-ref keys 0)))
+ (values next-index (rawget table next-index)))
+ (let* ((key-ref (+ ((@ (srfi srfi-1) list-index) (lambda (x) (equal? x index)) keys) 1)))
+ (if (>= key-ref (length keys))
+ (values #nil #nil)
+ (let* ((next-index (list-ref keys key-ref)))
+ (values next-index (rawget table next-index)))))))))))
+
+(define-global pairs
+ (lambda* (table)
+ (values next table #nil)))
+
+(define-global (pcall function . arguments)
+ (catch #t
+ (lambda () (apply function arguments))
+ (lambda args (apply values (cons #f args)))))
+
+(define-global (print . arguments)
+ (for-each
+ (lambda (x)
+ (display (tostring x))
+ (write-char #\tab))
+ arguments)
+ (newline)
+ #nil)
+
+(define-global (rawequal v1 v2)
+ (equal? v1 v2))
+
+(define-global (rawget table key)
+ (assert-table 1 "rawget" table)
+ (hash-table-ref (table-slots table) key))
+
+(define-global (rawset table key value)
+ (assert-table 1 "rawset" table)
+ (hash-table-set! (table-slots table) key value))
+
+(define-global (select index . rest)
+ (define rest-length (length rest))
+ (cond ((number? index)
+ (let lp ((vals '())
+ (i index))
+ (if (> i rest-length)
+ (apply values (reverse! vals))
+ (lp (cons (list-ref rest (- i 1)) vals) (+ i 1)))))
+ (else rest-length)))
+
+(define-global (setmetatable table metatable)
+ (assert-table 1 "setmetatable" table)
+ (assert-type 2 "setmetatable" "nil or table" metatable (lambda (x) (or (table? x) (eq? x #nil))))
+ (table-metatable! table (if (eq? metatable #nil) #f metatable))
+ table)
+
+;; NOTE: built-in 'tonumber' is implemented on string->number and may
+;; not have the same semantics as lua's tonumber; it should be based on the lexer
+(define-global tonumber
+ (lambda* (e #:optional (base 10))
+ (cond ((number? e) e)
+ ((string? e)
+ (unless (or-eqv? base 2 8 10 16)
+ (runtime-warning "tonumber cannot respect bases other than 2, 8, 10, and 16"))
+ (string->number e base))
+ (else #nil))))
+
+(define-global (tostring e)
+ (cond ((string? e) e)
+ ((eqv? e #t) "true")
+ ((eqv? e #f) "false")
+ ((eqv? e #nil) "nil")
+ ((number? e) (number->string e))
+ ((might-have-metatable? e)
+ (dispatch-metatable-event
+ "__tostring"
+ (lambda (table) (format #f "~A" e))
+ e
+ e))
+ (else (runtime-error "tostring cannot convert value ~A" e))))
+
+(define-global (type v)
+ (value-type->string v))
+
+(define-global unpack
+ (lambda* (array #:optional (i 1) j)
+ (assert-table 1 "unpack" array)
+ (unless j (set! j (table-length array)))
+ (apply values (reverse!
+ (let lp ((ls '())
+ (i i))
+ (if (> i j)
+ ls
+ (if (eq? #nil (index array i))
+ ls
+ (lp (cons (index array i) ls) (+ i 1)))))))))
+
+;; _VERSION
+;; contains a string describing the lua version
+(define-global _VERSION "Guile/Lua 5.1")
+
+(define-global (xpcall f err)
+ (catch #t
+ (lambda () (values #t (f)))
+ (lambda args (values #f (err args)))))
+
+;;; MODULE SYSTEM
+
+;; package
+(define-global package (make-table))
+
+;; package.cpath
+(new-index! package "cpath" (or (get-environment-variable "LUA_CPATH")
+ "./?.so;/usr/lib/lua/5.1/?.so;/usr/lib/lua/5.1/loadall.so"))
+;; package.loaded
+(define loaded (make-table))
+(new-index! package "loaded" loaded)
+
+;; package.loaders
+(define loaders (make-table))
+(new-index! package "loaders" loaders)
+
+;; package.loadlib
+(new-index! package "loadlib" (lambda (lib func . _) (runtime-error "loadlib not implemented")))
+
+;; package.path
+(new-index! package "path" (or (get-environment-variable "LUA_PATH") "./?.lua;/usr/share/lua/5.1/?.lua;/usr/share/lua/5.1/?/init.lua;/usr/lib/lua/5.1/?.lua;/usr/lib/lua/5.1/?/init.lua"))
+
+;; package.preload
+(define preload (make-table))
+(new-index! package "preload" preload)
+
+;; package.seeall
+(new-index! package "seeall" (lambda (module . _) (runtime-error "seeall unimplemented")))
+
+;; arg
+;; command line argument table
+(define arg (make-table))
+(let lp ((rest (command-line))
+ (i 0))
+ (new-index! arg i (car rest))
+ (if (not (null? (cdr rest)))
+ (lp (cdr rest) (1+ i))))
+
+;; require
+(define (register-loaded-module name table)
+ (rawset *global-env-table* name table)
+ (rawset loaded name table))
+
+(define (module-exists? name)
+ (if (module-public-interface (resolve-module name))
+ #t
+ #f))
+
+(define-global (require module-name . _)
+ (assert-type 1 "require" "string" module-name string?)
+ ;; try to load module, if it's not already loaded
+ (if (not (hash-table-exists? (table-slots loaded) module-name))
+ (let* ((std-module-name `(language lua standard ,(string->symbol module-name))))
+ (if (module-exists? std-module-name)
+ (register-loaded-module module-name (make-module-table std-module-name)))))
+
+ (if (not (hash-table-exists? (table-slots loaded) module-name))
+ (runtime-error "require failed"))
+ (rawget loaded module-name))
+