diff options
author | No Itisnt <theseaisinhere+git@gmail.com> | 2010-06-03 03:12:41 -0500 |
---|---|---|
committer | Ian Price <ianprice90@googlemail.com> | 2013-09-09 17:01:23 +0100 |
commit | a30c18c22a26be43f095e92c007142ae3fffc367 (patch) | |
tree | ae83f065eb36ff0355a2abca97afa363677f1345 /module/language/lua/runtime.scm | |
parent | 6871327742d3e1a0966aa8fed04c911311c12c2a (diff) | |
download | guile-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.scm | 606 |
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)) + |