mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

lua/runtime tweaks

Browse source 
* module/language/lua/runtime.scm: Various indentation and idiom
  tweaks.
This commit is contained in:
Andy Wingo 2010-12-10 19:05:01 +01:00 • committed by Ian Price
parent 04175c7dda
commit 3043dc0ef7
1 changed files with 140 additions and 113 deletions
Download patch file Download diff file Expand all files Collapse all files

253
module/language/lua/runtime.scm
View file

@ -22,11 +22,12 @@
#:use-module (language lua common) #:use-module (language lua common)
#:use-module (rnrs control) #: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-9)
#:use-module (srfi srfi-69) #:use-module (srfi srfi-69)
#:use-module ((srfi srfi-98) #:select (get-environment-variable)) #:use-module ((srfi srfi-98) #:select (get-environment-variable))
#:use-module ((system base compile) #:select (compile read-and-compile)) #:use-module ((system base compile) #:select (compile read-and-compile))
#:use-module ((system vm program) #:select (make-program))
#:export (runtime-error #:export (runtime-error
@ -70,12 +71,8 @@
;; global environment ;; global environment
*global-env-table* *global-env-table*
save-fenv save-fenv
check-global-function check-global-function))
)
#:export-syntax (table-slots table? table-metatable table-metatable!)
) ; define-module
;; Local Variables: ;; Local Variables:
;; eval: (put 'define-global 'scheme-indent-function 1) ;; eval: (put 'define-global 'scheme-indent-function 1)
@ -83,10 +80,13 @@
(define (runtime-error string . arguments) (define (runtime-error string . arguments)
"Throw an error tagged with 'lua-runtime" "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) (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 ;;;;; MISCELLANEOUS
@ -102,12 +102,14 @@
(define (assert-type argument caller expected value predicate) (define (assert-type argument caller expected value predicate)
(if (not (predicate value)) (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 (define-syntax define-assert
(syntax-rules () (syntax-rules ()
((_ name string predicate) ((_ 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-table "table" table?)
(define-assert assert-string "string" string?) (define-assert assert-string "string" string?)
@ -117,16 +119,20 @@
(define-record-type table (define-record-type table
(%make-table metatable slots) (%make-table metatable slots)
table? %table?
(metatable table-metatable table-metatable!) (metatable %table-metatable %table-metatable!)
(slots table-slots)) (slots %table-slots))
(define (make-table) (define (make-table)
(%make-table #f (make-hash-table))) (%make-table #f (make-hash-table)))
(define (table? t)
(define (table? x) (table? x)) (%table? t))
(define (table-metatable x) (table-metatable x)) (define (table-metatable t)
(define (table-metatable! x y) (table-metatable! x y)) (%table-metatable t))
(define (table-metatable! t meta)
(%table-metatable! t meta))
(define (table-slots t)
(%table-slots t))
;;;;; USERDATA ;;;;; USERDATA
@ -139,8 +145,8 @@
(define (userdata-metatable x) (define (userdata-metatable x)
(and (table? (userdata-property x)) (userdata-property x))) (and (table? (userdata-property x)) (userdata-property x)))
(define* (register-userdata! x #:optional metatable) (define* (register-userdata! x #:optional (metatable #t))
(set! (userdata? x) (or metatable #t))) (set! (userdata? x) metatable))
;;;;; METATABLES ;;;;; METATABLES
@ -155,7 +161,7 @@
;;;;; TABLE INTERACTION ;;;;; TABLE INTERACTION
(define (dispatch-metatable-event key default x . arguments) (define (dispatch-metatable-event key default x . arguments)
(let* ((metatable (get-metatable x))) (let ((metatable (get-metatable x)))
(apply (apply
(if metatable (if metatable
(hash-table-ref/default (table-slots metatable) key default) (hash-table-ref/default (table-slots metatable) key default)
@ -164,17 +170,18 @@
;; see manual section 2.5.5 ;; see manual section 2.5.5
(define (table-length table) (define (table-length table)
(let* ((numeric-keys (sort! (filter! number? (hash-table-keys (table-slots table))) <))) (let ((numeric-keys
(if (eq? (car numeric-keys) 1) (sort! (filter! number? (hash-table-keys (table-slots table))) <)))
(let lp ((cell (car numeric-keys)) (if (eq? (car numeric-keys) 1)
(rest (cdr numeric-keys)) (let lp ((cell (car numeric-keys))
(length 0)) (rest (cdr numeric-keys))
;; length does not count "holes" (length 0))
;; so if a table has the keys 1,2,3 and 5, the length of the table is 3 ;; length does not count "holes"
(if (or (> cell (+ length 1)) (null? rest)) ;; so if a table has the keys 1,2,3 and 5, the length of the table is 3
(+ length 1) ;; add one to length as though we had started from one (if (or (> cell (+ length 1)) (null? rest))
(lp (car rest) (cdr rest) cell))) (+ length 1) ;; add one to length as though we had started from one
0))) (lp (car rest) (cdr rest) cell)))
0)))
(define (index table key) (define (index table key)
(dispatch-metatable-event (dispatch-metatable-event
@ -191,17 +198,19 @@
table key value)) table key value))
(define* (get-field table key #:optional (default #nil)) (define* (get-field table key #:optional (default #nil))
(define result (index table key)) (let ((result (index table key)))
(if (eq? result #nil) (if (eqv? result #nil)
default default
result)) result)))
;;;;; OPERATORS ;;;;; OPERATORS
(define (len a) (define (len a)
"A function backing the unary # (length) operator" "A function backing the unary # (length) operator"
(cond ((string? a) (string-length a)) (cond
((table? a) (table-length a)) ((string? a) (string-length a))
(else (runtime-error "attempt to get length of a ~A value" (value-type->string a))))) ((table? a) (table-length a))
(else (runtime-error "attempt to get length of a ~A value"
(value-type->string a)))))
(define (unm a) (define (unm a)
"A function backing the unary - (negation) operator" "A function backing the unary - (negation) operator"
@ -270,14 +279,14 @@
(hash-table-set! (hash-table-set!
(table-slots module-metatable) "__index" (table-slots module-metatable) "__index"
(lambda (table key) (lambda (table key)
(define slots (table-slots table)) (let ((slots (table-slots table)))
(if (hash-table-exists? slots key) (if (hash-table-exists? slots key)
(hash-table-ref slots key) (hash-table-ref slots key)
(let ((key (string->symbol key)) (let ((key (string->symbol key))
(module (hash-table-ref slots 'module))) (module (hash-table-ref slots 'module)))
(if (not (module-defined? module key)) (if (not (module-defined? module key))
#nil #nil
(module-ref module key #f)))))) (module-ref module key #f)))))))
(define (make-module-table name) (define (make-module-table name)
(define table (make-table)) (define table (make-table))
@ -298,7 +307,7 @@
(set! *global-env-table* save)))) (set! *global-env-table* save))))
(define (check-global-function name value) (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))) (runtime-error "attempt to call global '~a' (a nil value)" name)))
;;;;; BUILT-INS ;;;;; BUILT-INS
@ -318,10 +327,9 @@
(new-index! *global-env-table* (symbol->string 'name) name))))) (new-index! *global-env-table* (symbol->string 'name) name)))))
(define-global (assert v . opts) (define-global (assert v . opts)
(define message (if (null? opts) "assertion failed" (car opts))) (if v
(if (not v) (apply values v opts)
(runtime-error message) (runtime-error "~a" (if (null? opts) "assertion failed" (car opts)))))
(apply values (cons v opts))))
;; NOTE: collectgarbage cannot be fully implemented because it expects ;; NOTE: collectgarbage cannot be fully implemented because it expects
;; an incremental garbage collector that matches lua's interface; libgc ;; an incremental garbage collector that matches lua's interface; libgc
@ -341,13 +349,15 @@
((string=? opt "setstepmul") (ignore)) ((string=? opt "setstepmul") (ignore))
(else (runtime-error "bad argument #1 to 'collectgarbage' (invalid option ~a)" opt))))) (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) (define-global (dofile filename)
(assert-string 1 "dofile" filename) (assert-string 1 "dofile" filename)
(runtime-warning "dofile cannot return the values of the chunk and instead will return #nil") (run-lua
(call-with-input-file filename (call-with-input-file filename
(lambda (file) (lambda (file)
(compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value))) ((@ (language lua parser) read-lua) file)))))
#nil)
(define-global (do-not-export error) (define-global (do-not-export error)
(lambda* (message #:optional level) (lambda* (message #:optional level)
@ -372,49 +382,44 @@
(let* ((value (index table indice))) (let* ((value (index table indice)))
(if (eq? value #nil) (if (eq? value #nil)
(values #nil #nil) (values #nil #nil)
(values indice value))) (values indice value))))
)
table table
0)) 0))
(define (load-warning)
(runtime-warning "load, loadfile, and loadstring cannot return the results of evaluating a file"))
(define (load-chunkname-warning chunkname) (define (load-chunkname-warning chunkname)
(when chunkname (when chunkname
(runtime-warning "load and loadstring ignore chunkname"))) (runtime-warning "load and loadstring ignore chunkname")))
(define-global load (define-global load
(lambda* (func #:optional chunkname) (lambda* (func #:optional chunkname)
(load-warning)
(load-chunkname-warning chunkname) (load-chunkname-warning chunkname)
(lambda () (lambda ()
(compile (run-lua
((@ (language lua parser) read-lua) ((@ (language lua parser) read-lua)
(open-input-string (open-input-string
(let lp ((tree '()) (let lp ((tree '())
(result (func))) (result (func)))
(if (or (equal? func "") (eq? func #nil) (eq? func *unspecified*)) (if (or (equal? func "") (eq? func #nil) (eq? func *unspecified*))
(string-concatenate-reverse tree) (string-concatenate-reverse tree)
(lp (cons func tree) (func)))))) (lp (cons func tree) (func))))))))))
#:from 'lua #:to 'value))))
(define-global loadfile (define-global loadfile
(lambda* (#:optional filename) (lambda* (#:optional filename)
(load-warning)
(lambda () (lambda ()
(if filename (run-lua
(call-with-input-file filename (if filename
(lambda (file) (call-with-input-file filename
(compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to 'value))) (lambda (file)
(read-and-compile (current-input-port) #:from 'lua))))) ((@ (language lua parser) read-lua) file)))
((@ (language lua parser) read-lua) (current-input-port)))))))
(define-global loadstring (define-global loadstring
(lambda* (string #:optional chunkname) (lambda* (string #:optional chunkname)
(load-warning)
(load-chunkname-warning chunkname) (load-chunkname-warning chunkname)
(lambda () (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 ;; TODO: module
@ -427,9 +432,10 @@
#nil #nil
(begin (begin
(if (eq? index #nil) (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))) (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)) (if (>= key-ref (length keys))
(values #nil #nil) (values #nil #nil)
(let* ((next-index (list-ref keys key-ref))) (let* ((next-index (list-ref keys key-ref)))
@ -441,8 +447,8 @@
(define-global (pcall function . arguments) (define-global (pcall function . arguments)
(catch #t (catch #t
(lambda () (apply function arguments)) (lambda () (apply function arguments))
(lambda args (apply values (cons #f args))))) (lambda args (apply values (cons #f args)))))
(define-global (print . arguments) (define-global (print . arguments)
(for-each (for-each
@ -466,17 +472,19 @@
(define-global (select index . rest) (define-global (select index . rest)
(define rest-length (length rest)) (define rest-length (length rest))
(cond ((number? index) (cond
(let lp ((vals '()) ((number? index)
(i index)) (let lp ((vals '())
(if (> i rest-length) (i index))
(apply values (reverse! vals)) (if (> i rest-length)
(lp (cons (list-ref rest (- i 1)) vals) (+ i 1))))) (apply values (reverse! vals))
(else rest-length))) (lp (cons (list-ref rest (- i 1)) vals) (+ i 1)))))
(else rest-length)))
(define-global (setmetatable table metatable) (define-global (setmetatable table metatable)
(assert-table 1 "setmetatable" table) (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-metatable! table (if (eq? metatable #nil) #f metatable))
table) table)
@ -484,26 +492,29 @@
;; not have the same semantics as lua's tonumber; it should be based on the lexer ;; not have the same semantics as lua's tonumber; it should be based on the lexer
(define-global tonumber (define-global tonumber
(lambda* (e #:optional (base 10)) (lambda* (e #:optional (base 10))
(cond ((number? e) e) (cond
((string? e) ((number? e) e)
(unless (memv base '(2 8 10 16)) ((string? e)
(runtime-warning "tonumber cannot respect bases other than 2, 8, 10, and 16")) (unless (memv base '(2 8 10 16))
(string->number e base)) (runtime-warning
(else #nil)))) "tonumber cannot respect bases other than 2, 8, 10, and 16"))
(string->number e base))
(else #nil))))
(define-global (tostring e) (define-global (tostring e)
(cond ((string? e) e) (cond
((eqv? e #t) "true") ((string? e) e)
((eqv? e #f) "false") ((eqv? e #t) "true")
((eqv? e #nil) "nil") ((eqv? e #f) "false")
((number? e) (number->string e)) ((eqv? e #nil) "nil")
((might-have-metatable? e) ((number? e) (number->string e))
(dispatch-metatable-event ((might-have-metatable? e)
"__tostring" (dispatch-metatable-event
(lambda (table) (format #f "~A" e)) "__tostring"
e (lambda (table) (format #f "~A" e))
e)) e
(else (runtime-error "tostring cannot convert value ~A" e)))) e))
(else (runtime-error "tostring cannot convert value ~A" e))))
(define-global (type v) (define-global (type v)
(value-type->string v)) (value-type->string v))
@ -527,17 +538,23 @@
(define-global (xpcall f err) (define-global (xpcall f err)
(catch #t (catch #t
(lambda () (values #t (f))) (lambda () (values #t (f)))
(lambda args (values #f (err args))))) (lambda args (values #f (err args)))))
;;; MODULE SYSTEM ;;; MODULE SYSTEM
;; package ;; package
(define-global package (make-table)) (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 ;; 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 ;; package.loaded
(define loaded (make-table)) (define loaded (make-table))
(new-index! package "loaded" loaded) (new-index! package "loaded" loaded)
@ -547,17 +564,25 @@
(new-index! package "loaders" loaders) (new-index! package "loaders" loaders)
;; package.loadlib ;; 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 ;; 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 ;; package.preload
(define preload (make-table)) (define preload (make-table))
(new-index! package "preload" preload) (new-index! package "preload" preload)
;; package.seeall ;; package.seeall
(new-index! package "seeall" (lambda (module . _) (runtime-error "seeall unimplemented"))) (new-index! package "seeall"
(lambda (module . _) (runtime-error "seeall unimplemented")))
;; arg ;; arg
;; command line argument table ;; command line argument table
@ -582,11 +607,13 @@
(assert-type 1 "require" "string" module-name string?) (assert-type 1 "require" "string" module-name string?)
;; try to load module, if it's not already loaded ;; try to load module, if it's not already loaded
(if (not (hash-table-exists? (table-slots loaded) module-name)) (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) (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)) (if (not (hash-table-exists? (table-slots loaded) module-name))
(runtime-error "require failed")) (runtime-error "require failed"))
(rawget loaded module-name)) (rawget loaded module-name))