giles
43c13c4eb1
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
403 lines
10 KiB
Plaintext
403 lines
10 KiB
Plaintext
(define lua-truthy? (fn (v) (and (not (= v nil)) (not (= v false)))))
|
|
|
|
(define
|
|
lua-to-number
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((= (type-of v) "number") v)
|
|
((= (type-of v) "string")
|
|
(let ((n (parse-number v))) (if (= n nil) nil n)))
|
|
(else nil))))
|
|
|
|
(define
|
|
lua-to-string
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((= v nil) "nil")
|
|
((= v true) "true")
|
|
((= v false) "false")
|
|
((= (type-of v) "number") (str v))
|
|
((= (type-of v) "string") v)
|
|
(else (str v)))))
|
|
|
|
(define
|
|
lua-num-op
|
|
(fn
|
|
(op a b)
|
|
(let
|
|
((na (lua-to-number a)) (nb (lua-to-number b)))
|
|
(begin
|
|
(when
|
|
(or (= na nil) (= nb nil))
|
|
(error (str "lua: arith on non-number: " a " " op " " b)))
|
|
(cond
|
|
((= op "+") (+ na nb))
|
|
((= op "-") (- na nb))
|
|
((= op "*") (* na nb))
|
|
((= op "/") (/ na nb))
|
|
((= op "%") (- na (* nb (floor (/ na nb)))))
|
|
((= op "^") (pow na nb))
|
|
(else (error (str "lua: unknown arith op " op))))))))
|
|
|
|
(define
|
|
lua-get-mm
|
|
(fn
|
|
(v name)
|
|
(cond
|
|
((not (= (type-of v) "dict")) nil)
|
|
(else
|
|
(let
|
|
((mt (get v "__meta")))
|
|
(cond
|
|
((= mt nil) nil)
|
|
((not (= (type-of mt) "dict")) nil)
|
|
((has-key? mt name) (get mt name))
|
|
(else nil)))))))
|
|
|
|
(define
|
|
lua-arith
|
|
(fn
|
|
(mm op a b)
|
|
(cond
|
|
((and (= (type-of a) "number") (= (type-of b) "number"))
|
|
(lua-num-op op a b))
|
|
((and
|
|
(or (= (type-of a) "number") (= (type-of a) "string"))
|
|
(or (= (type-of b) "number") (= (type-of b) "string"))
|
|
(not (= (lua-to-number a) nil))
|
|
(not (= (lua-to-number b) nil)))
|
|
(lua-num-op op a b))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm a mm)))
|
|
(cond
|
|
((not (= m nil)) (lua-first (m a b)))
|
|
(else
|
|
(let
|
|
((m2 (lua-get-mm b mm)))
|
|
(if
|
|
(not (= m2 nil))
|
|
(lua-first (m2 a b))
|
|
(error (str "lua: arith on " (type-of a) " " op " " (type-of b))))))))))))
|
|
|
|
(define lua-add (fn (a b) (lua-arith "__add" "+" a b)))
|
|
|
|
(define lua-sub (fn (a b) (lua-arith "__sub" "-" a b)))
|
|
|
|
(define lua-mul (fn (a b) (lua-arith "__mul" "*" a b)))
|
|
|
|
(define lua-div (fn (a b) (lua-arith "__div" "/" a b)))
|
|
|
|
(define lua-mod (fn (a b) (lua-arith "__mod" "%" a b)))
|
|
|
|
(define lua-pow (fn (a b) (lua-arith "__pow" "^" a b)))
|
|
|
|
(define
|
|
lua-neg
|
|
(fn
|
|
(a)
|
|
(cond
|
|
((= (type-of a) "number") (- 0 a))
|
|
(else
|
|
(let
|
|
((na (lua-to-number a)))
|
|
(cond
|
|
((not (= na nil)) (- 0 na))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm a "__unm")))
|
|
(if
|
|
(not (= m nil))
|
|
(lua-first (m a))
|
|
(error (str "lua: neg on non-number: " (type-of a))))))))))))
|
|
|
|
(define
|
|
lua-concat-coerce
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((= (type-of v) "string") v)
|
|
((= (type-of v) "number") (str v))
|
|
(else (error (str "lua: cannot concat " v))))))
|
|
|
|
(define
|
|
lua-concat
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and
|
|
(or (= (type-of a) "string") (= (type-of a) "number"))
|
|
(or (= (type-of b) "string") (= (type-of b) "number")))
|
|
(str (lua-concat-coerce a) (lua-concat-coerce b)))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm a "__concat")))
|
|
(cond
|
|
((not (= m nil)) (lua-first (m a b)))
|
|
(else
|
|
(let
|
|
((m2 (lua-get-mm b "__concat")))
|
|
(if
|
|
(not (= m2 nil))
|
|
(lua-first (m2 a b))
|
|
(error (str "lua: concat on " (type-of a) " and " (type-of b))))))))))))
|
|
|
|
(define
|
|
lua-eq
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (= a nil) (= b nil)) true)
|
|
((or (= a nil) (= b nil)) false)
|
|
((and (= (type-of a) (type-of b)) (= a b)) true)
|
|
((and (= (type-of a) "dict") (= (type-of b) "dict"))
|
|
(let
|
|
((m (lua-get-mm a "__eq")))
|
|
(cond
|
|
((not (= m nil))
|
|
(let ((r (lua-first (m a b)))) (and (not (= r nil)) (not (= r false)))))
|
|
(else false))))
|
|
(else false))))
|
|
|
|
(define lua-neq (fn (a b) (not (lua-eq a b))))
|
|
|
|
(define
|
|
lua-lt
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (= (type-of a) "number") (= (type-of b) "number")) (< a b))
|
|
((and (= (type-of a) "string") (= (type-of b) "string")) (< a b))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm a "__lt")))
|
|
(cond
|
|
((not (= m nil))
|
|
(let ((r (lua-first (m a b)))) (and (not (= r nil)) (not (= r false)))))
|
|
(else
|
|
(let
|
|
((m2 (lua-get-mm b "__lt")))
|
|
(cond
|
|
((not (= m2 nil))
|
|
(let ((r (lua-first (m2 a b)))) (and (not (= r nil)) (not (= r false)))))
|
|
(else (error "lua: attempt to compare incompatible types")))))))))))
|
|
|
|
(define
|
|
lua-le
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (= (type-of a) "number") (= (type-of b) "number")) (<= a b))
|
|
((and (= (type-of a) "string") (= (type-of b) "string"))
|
|
(or (< a b) (= a b)))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm a "__le")))
|
|
(cond
|
|
((not (= m nil))
|
|
(let ((r (lua-first (m a b)))) (and (not (= r nil)) (not (= r false)))))
|
|
(else
|
|
(let
|
|
((m2 (lua-get-mm b "__le")))
|
|
(cond
|
|
((not (= m2 nil))
|
|
(let ((r (lua-first (m2 a b)))) (and (not (= r nil)) (not (= r false)))))
|
|
(else (not (lua-lt b a))))))))))))
|
|
|
|
(define lua-gt (fn (a b) (lua-lt b a)))
|
|
|
|
(define lua-ge (fn (a b) (lua-le b a)))
|
|
|
|
(define
|
|
lua-len
|
|
(fn
|
|
(a)
|
|
(cond
|
|
((= (type-of a) "string") (len a))
|
|
((= (type-of a) "list") (len a))
|
|
((= (type-of a) "dict")
|
|
(let
|
|
((m (lua-get-mm a "__len")))
|
|
(cond
|
|
((not (= m nil)) (lua-first (m a)))
|
|
(else
|
|
(let
|
|
((n 0))
|
|
(begin
|
|
(define
|
|
count-loop
|
|
(fn
|
|
(i)
|
|
(if
|
|
(has-key? a (str i))
|
|
(begin (set! n i) (count-loop (+ i 1)))
|
|
n)))
|
|
(count-loop 1)))))))
|
|
(else (error (str "lua: len on non-len type: " (type-of a)))))))
|
|
|
|
(define
|
|
lua-for-continue?
|
|
(fn (i stop step) (if (> step 0) (<= i stop) (>= i stop))))
|
|
|
|
(define
|
|
lua-make-table
|
|
(fn
|
|
(&rest fields)
|
|
(let
|
|
((t {}) (array-idx 1))
|
|
(begin
|
|
(define
|
|
process
|
|
(fn
|
|
(fs)
|
|
(when
|
|
(> (len fs) 0)
|
|
(begin
|
|
(let
|
|
((f (first fs)))
|
|
(cond
|
|
((= (first f) "pos")
|
|
(begin
|
|
(set! t (assoc t (str array-idx) (nth f 1)))
|
|
(set! array-idx (+ array-idx 1))))
|
|
((= (first f) "kv")
|
|
(let
|
|
((k (nth f 1)) (v (nth f 2)))
|
|
(set! t (assoc t (str k) v))))))
|
|
(process (rest fs))))))
|
|
(process fields)
|
|
t))))
|
|
|
|
(define
|
|
lua-get
|
|
(fn
|
|
(t k)
|
|
(cond
|
|
((= t nil) nil)
|
|
((not (= (type-of t) "dict")) nil)
|
|
(else
|
|
(let
|
|
((key (str k)))
|
|
(cond
|
|
((has-key? t key) (get t key))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm t "__index")))
|
|
(cond
|
|
((= m nil) nil)
|
|
((= (type-of m) "dict") (lua-get m k))
|
|
(else (lua-first (m t k))))))))))))
|
|
|
|
(define
|
|
lua-set!
|
|
(fn
|
|
(t k v)
|
|
(let
|
|
((key (str k)))
|
|
(cond
|
|
((has-key? t key) (dict-set! t key v))
|
|
(else
|
|
(let
|
|
((m (lua-get-mm t "__newindex")))
|
|
(cond
|
|
((= m nil) (dict-set! t key v))
|
|
((= (type-of m) "dict") (lua-set! m k v))
|
|
(else (begin (m t k v) nil)))))))))
|
|
|
|
(define
|
|
lua-multi?
|
|
(fn
|
|
(v)
|
|
(and
|
|
(= (type-of v) "list")
|
|
(> (len v) 0)
|
|
(= (first v) (quote lua-multi)))))
|
|
|
|
(define
|
|
lua-first
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((lua-multi? v) (if (> (len v) 1) (nth v 1) nil))
|
|
(else v))))
|
|
|
|
(define
|
|
lua-nth-ret
|
|
(fn
|
|
(v i)
|
|
(cond
|
|
((lua-multi? v)
|
|
(let ((idx (+ i 1))) (if (< idx (len v)) (nth v idx) nil)))
|
|
(else (if (= i 0) v nil)))))
|
|
|
|
(define
|
|
lua-pack-build
|
|
(fn
|
|
(vals i)
|
|
(cond
|
|
((>= i (len vals)) (list))
|
|
((= i (- (len vals) 1))
|
|
(let
|
|
((last (nth vals i)))
|
|
(if (lua-multi? last) (rest last) (list last))))
|
|
(else (cons (nth vals i) (lua-pack-build vals (+ i 1)))))))
|
|
|
|
(define
|
|
lua-pack-return
|
|
(fn
|
|
(vals)
|
|
(cond
|
|
((= (len vals) 0) (list (quote lua-multi)))
|
|
(else (cons (quote lua-multi) (lua-pack-build vals 0))))))
|
|
|
|
(define lua-setmetatable (fn (t mt) (begin (dict-set! t "__meta" mt) t)))
|
|
|
|
(define
|
|
lua-getmetatable
|
|
(fn
|
|
(t)
|
|
(cond
|
|
((not (= (type-of t) "dict")) nil)
|
|
((has-key? t "__meta") (get t "__meta"))
|
|
(else nil))))
|
|
|
|
(define setmetatable lua-setmetatable)
|
|
(define getmetatable lua-getmetatable)
|
|
|
|
(define
|
|
lua-type
|
|
(fn
|
|
(v)
|
|
(cond
|
|
((= v nil) "nil")
|
|
((= (type-of v) "number") "number")
|
|
((= (type-of v) "string") "string")
|
|
((= v true) "boolean")
|
|
((= v false) "boolean")
|
|
((= (type-of v) "dict") "table")
|
|
((or (= (type-of v) "function") (= (type-of v) "lambda")) "function")
|
|
(else (type-of v)))))
|
|
|
|
(define type lua-type)
|
|
|
|
(define sx-apply-ref apply)
|
|
|
|
(define
|
|
lua-call
|
|
(fn
|
|
(&rest args)
|
|
(let
|
|
((f (first args)) (rargs (rest args)))
|
|
(cond
|
|
((or (= (type-of f) "function") (= (type-of f) "lambda"))
|
|
(sx-apply-ref f rargs))
|
|
((= (type-of f) "dict")
|
|
(let
|
|
((m (lua-get-mm f "__call")))
|
|
(cond
|
|
((= m nil) (error "lua: attempt to call non-function"))
|
|
(else (sx-apply-ref m (cons f rargs))))))
|
|
(else (error "lua: attempt to call non-function"))))))
|