summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-12-10 19:05:01 +0100
committerIan Price <ianprice90@googlemail.com>2013-09-09 17:01:24 +0100
commit3043dc0ef734bc62aa8e226417a98f44637b641f (patch)
treeb275394c8970f8b6b983dd1c1fb8555bd1669786
parent04175c7ddaec2694c43525fd41748760bafebbbc (diff)
downloadguile-3043dc0ef734bc62aa8e226417a98f44637b641f.tar.gz
lua/runtime tweaks
* module/language/lua/runtime.scm: Various indentation and idiom tweaks.
-rw-r--r--module/language/lua/runtime.scm253
1 files changed, 140 insertions, 113 deletions
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
index c9fcf5895..6a0541273 100644
--- a/module/language/lua/runtime.scm
+++ b/module/language/lua/runtime.scm
@@ -22,11 +22,12 @@
#:use-module (language lua common)
#:use-module (rnrs control)
- #:use-module ((srfi srfi-1) #:select (filter!))
+ #:use-module ((srfi srfi-1) #:select (filter! list-index))
#: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))
+ #:use-module ((system vm program) #:select (make-program))
#:export (runtime-error
@@ -70,12 +71,8 @@
;; global environment
*global-env-table*
save-fenv
- check-global-function
- )
+ check-global-function))
- #:export-syntax (table-slots table? table-metatable table-metatable!)
-
- ) ; define-module
;; Local Variables:
;; eval: (put 'define-global 'scheme-indent-function 1)
@@ -83,10 +80,13 @@
(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))))
+ (throw 'lua-runtime
+ (apply format #f (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))))
+ (apply format #t (string-append "LUA: RUNTIME WARNING: " string "\n")
+ arguments))
;;;;; MISCELLANEOUS
@@ -102,12 +102,14 @@
(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)))))
+ (runtime-error "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 (name argument caller value)
+ (assert-type argument caller string value predicate)))))
(define-assert assert-table "table" table?)
(define-assert assert-string "string" string?)
@@ -117,16 +119,20 @@
(define-record-type table
(%make-table metatable slots)
- table?
- (metatable table-metatable table-metatable!)
- (slots table-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))
+(define (table? t)
+ (%table? t))
+(define (table-metatable t)
+ (%table-metatable t))
+(define (table-metatable! t meta)
+ (%table-metatable! t meta))
+(define (table-slots t)
+ (%table-slots t))
;;;;; USERDATA
@@ -139,8 +145,8 @@
(define (userdata-metatable x)
(and (table? (userdata-property x)) (userdata-property x)))
-(define* (register-userdata! x #:optional metatable)
- (set! (userdata? x) (or metatable #t)))
+(define* (register-userdata! x #:optional (metatable #t))
+ (set! (userdata? x) metatable))
;;;;; METATABLES
@@ -155,7 +161,7 @@
;;;;; TABLE INTERACTION
(define (dispatch-metatable-event key default x . arguments)
- (let* ((metatable (get-metatable x)))
+ (let ((metatable (get-metatable x)))
(apply
(if metatable
(hash-table-ref/default (table-slots metatable) key default)
@@ -164,17 +170,18 @@
;; 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)))
+ (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
@@ -191,17 +198,19 @@
table key value))
(define* (get-field table key #:optional (default #nil))
- (define result (index table key))
- (if (eq? result #nil)
- default
- result))
+ (let ((result (index table key)))
+ (if (eqv? 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)))))
+ (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"
@@ -270,14 +279,14 @@
(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))))))
+ (let ((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))
@@ -298,7 +307,7 @@
(set! *global-env-table* save))))
(define (check-global-function name value)
- (when (eq? value #nil)
+ (when (eqv? value #nil)
(runtime-error "attempt to call global '~a' (a nil value)" name)))
;;;;; BUILT-INS
@@ -318,10 +327,9 @@
(new-index! *global-env-table* (symbol->string 'name) name)))))
(define-global (assert v . opts)
- (define message (if (null? opts) "assertion failed" (car opts)))
- (if (not v)
- (runtime-error message)
- (apply values (cons v opts))))
+ (if v
+ (apply values v opts)
+ (runtime-error "~a" (if (null? opts) "assertion failed" (car opts)))))
;; NOTE: collectgarbage cannot be fully implemented because it expects
;; an incremental garbage collector that matches lua's interface; libgc
@@ -341,13 +349,15 @@
((string=? opt "setstepmul") (ignore))
(else (runtime-error "bad argument #1 to 'collectgarbage' (invalid option ~a)" opt)))))
+(define (run-lua lua-text)
+ ((make-program (compile lua-text #:from 'lua #:to 'objcode))))
+
(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)
+ (run-lua
+ (call-with-input-file filename
+ (lambda (file)
+ ((@ (language lua parser) read-lua) file)))))
(define-global (do-not-export error)
(lambda* (message #:optional level)
@@ -372,49 +382,44 @@
(let* ((value (index table indice)))
(if (eq? value #nil)
(values #nil #nil)
- (values indice value)))
- )
+ (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
+ (run-lua
((@ (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))))
+ (lp (cons func tree) (func))))))))))
(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)))))
+ (run-lua
+ (if filename
+ (call-with-input-file filename
+ (lambda (file)
+ ((@ (language lua parser) read-lua) file)))
+ ((@ (language lua parser) read-lua) (current-input-port)))))))
(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))))
+ (run-lua (call-with-input-string
+ string
+ (@ (language lua parser) read-lua))))))
;; TODO: module
@@ -427,9 +432,10 @@
#nil
(begin
(if (eq? index #nil)
- (let* ((next-index (list-ref keys 0)))
+ (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)))
+ (let ((key-ref
+ (1+ (list-index (lambda (x) (equal? x index)) keys))))
(if (>= key-ref (length keys))
(values #nil #nil)
(let* ((next-index (list-ref keys key-ref)))
@@ -441,8 +447,8 @@
(define-global (pcall function . arguments)
(catch #t
- (lambda () (apply function arguments))
- (lambda args (apply values (cons #f args)))))
+ (lambda () (apply function arguments))
+ (lambda args (apply values (cons #f args)))))
(define-global (print . arguments)
(for-each
@@ -466,17 +472,19 @@
(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)))
+ (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))))
+ (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)
@@ -484,26 +492,29 @@
;; 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 (memv base '(2 8 10 16))
- (runtime-warning "tonumber cannot respect bases other than 2, 8, 10, and 16"))
- (string->number e base))
- (else #nil))))
+ (cond
+ ((number? e) e)
+ ((string? e)
+ (unless (memv 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))))
+ (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))
@@ -527,17 +538,23 @@
(define-global (xpcall f err)
(catch #t
- (lambda () (values #t (f)))
- (lambda args (values #f (err args)))))
+ (lambda () (values #t (f)))
+ (lambda args (values #f (err args)))))
;;; MODULE SYSTEM
;; package
(define-global package (make-table))
+;; FIXME: this has no meaning if Guile does not support the Lua C
+;; API. Also, we would need some other way to specify the path.
+;;
;; 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"))
+#;
+(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)
@@ -547,17 +564,25 @@
(new-index! package "loaders" loaders)
;; package.loadlib
-(new-index! package "loadlib" (lambda (lib func . _) (runtime-error "loadlib not implemented")))
+(new-index! package "loadlib"
+ (lambda (lib func . _) (runtime-error "loadlib not implemented")))
+;; FIXME: Like cpath, this has no meaning if Guile does not support the
+;; Lua C API, and we would need some other way to specify the path.
+;;
;; 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"))
+#;
+(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")))
+(new-index! package "seeall"
+ (lambda (module . _) (runtime-error "seeall unimplemented")))
;; arg
;; command line argument table
@@ -582,11 +607,13 @@
(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))))
+ (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)))))
+ (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))
-