rose-ash/lib/lua/runtime.sx

(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-apply
  (fn
    (f rargs)
    (let
      ((n (len rargs)))
      (cond
        ((= n 0) (f))
        ((= n 1) (f (nth rargs 0)))
        ((= n 2) (f (nth rargs 0) (nth rargs 1)))
        ((= n 3) (f (nth rargs 0) (nth rargs 1) (nth rargs 2)))
        ((= n 4) (f (nth rargs 0) (nth rargs 1) (nth rargs 2) (nth rargs 3)))
        ((= n 5) (f (nth rargs 0) (nth rargs 1) (nth rargs 2) (nth rargs 3) (nth rargs 4)))
        ((= n 6) (f (nth rargs 0) (nth rargs 1) (nth rargs 2) (nth rargs 3) (nth rargs 4) (nth rargs 5)))
        ((= n 7) (f (nth rargs 0) (nth rargs 1) (nth rargs 2) (nth rargs 3) (nth rargs 4) (nth rargs 5) (nth rargs 6)))
        ((= n 8) (f (nth rargs 0) (nth rargs 1) (nth rargs 2) (nth rargs 3) (nth rargs 4) (nth rargs 5) (nth rargs 6) (nth rargs 7)))
        (else (sx-apply-ref f rargs))))))

(define
  lua-call
  (fn
    (&rest args)
    (let
      ((f (first args)) (rargs (rest args)))
      (cond
        ((or (= (type-of f) "function") (= (type-of f) "lambda"))
          (lua-apply f rargs))
        ((= (type-of f) "dict")
          (let
            ((m (lua-get-mm f "__call")))
            (cond
              ((= m nil) (error "lua: attempt to call non-function"))
              (else (lua-apply m (cons f rargs))))))
        (else (error "lua: attempt to call non-function"))))))

(define lua-error (fn (&rest args) (raise (first args))))

(define error lua-error)

(define
  pcall
  (fn
    (&rest args)
    (let
      ((f (first args)) (rargs (rest args)))
      (guard
        (e (true (list (quote lua-multi) false e)))
        (let
          ((r (lua-apply f rargs)))
          (cond
            ((lua-multi? r) (cons (quote lua-multi) (cons true (rest r))))
            (else (list (quote lua-multi) true r))))))))

(define
  xpcall
  (fn
    (f msgh)
    (guard
      (e (true (list (quote lua-multi) false (lua-first (lua-apply msgh (list e))))))
      (let
        ((r (lua-apply f (list))))
        (cond
          ((lua-multi? r) (cons (quote lua-multi) (cons true (rest r))))
          (else (list (quote lua-multi) true r)))))))

(define
  lua-ipairs-iter
  (fn
    (t i)
    (let
      ((nk (+ i 1)))
      (let
        ((v (get t (str nk))))
        (if (= v nil) nil (list (quote lua-multi) nk v))))))

(define
  lua-ipairs
  (fn
    (t)
    (list (quote lua-multi) lua-ipairs-iter t 0)))

(define ipairs lua-ipairs)

(define
  lua-next-skip-meta
  (fn
    (ks)
    (cond
      ((= (len ks) 0) (list))
      ((= (first ks) "__meta") (lua-next-skip-meta (rest ks)))
      (else ks))))

(define
  lua-next-after
  (fn
    (ks prev-key)
    (cond
      ((= (len ks) 0) (list))
      ((= (first ks) (str prev-key)) (lua-next-skip-meta (rest ks)))
      (else (lua-next-after (rest ks) prev-key)))))

(define
  lua-key-to-value
  (fn
    (k)
    (cond
      ((= k "true") true)
      ((= k "false") false)
      (else
        (let
          ((n (lua-to-number k))) (if (= n nil) k n))))))

(define
  lua-next
  (fn
    (&rest args)
    (let
      ((t (first args))
        (prev (if (> (len (rest args)) 0) (first (rest args)) nil)))
      (let
        ((all-keys (keys t)))
        (let
          ((ks (if (= prev nil) (lua-next-skip-meta all-keys) (lua-next-after all-keys prev))))
          (cond
            ((= (len ks) 0) nil)
            (else
              (let
                ((k (first ks)))
                (list (quote lua-multi) (lua-key-to-value k) (get t k))))))))))

(define next lua-next)

(define
  lua-pairs
  (fn
    (t)
    (list (quote lua-multi) lua-next t nil)))

(define pairs lua-pairs)

(define
  lua-arg
  (fn
    (args i)
    (if (< i (len args)) (nth args i) nil)))

;; ── Coroutines (call/cc based) ────────────────────────────────
(define __current-co nil)

(define
  lua-coroutine-create
  (fn
    (f)
    (let ((co {}))
      (begin
        (dict-set! co "__co" true)
        (dict-set! co "status" "suspended")
        (dict-set! co "body" f)
        (dict-set! co "resume-k" nil)
        (dict-set! co "caller-k" nil)
        co))))

(define
  lua-coroutine-status
  (fn
    (co)
    (if (and (= (type-of co) "dict") (has-key? co "__co"))
        (get co "status")
        (error "lua: not a coroutine"))))

(define
  lua-co-wrap-result
  (fn (r)
    (cond
      ((lua-multi? r) (cons (quote lua-multi) (cons true (rest r))))
      (else (list (quote lua-multi) true r)))))

(define
  lua-co-first-call
  (fn (co rvals prev)
    (let ((r (lua-apply (get co "body") rvals)))
      (begin
        (dict-set! co "status" "dead")
        (set! __current-co prev)
        ((get co "caller-k") (lua-co-wrap-result r))))))

(define
  lua-co-continue-call
  (fn (co rvals)
    (let ((rk (get co "resume-k")))
      (begin
        (dict-set! co "resume-k" nil)
        (rk (if (> (len rvals) 0) (first rvals) nil))))))

(define
  lua-coroutine-resume
  (fn
    (&rest args)
    (let ((co (first args)) (rvals (rest args)))
      (cond
        ((not (and (= (type-of co) "dict") (has-key? co "__co")))
          (list (quote lua-multi) false "not a coroutine"))
        ((= (get co "status") "dead")
          (list (quote lua-multi) false "cannot resume dead coroutine"))
        ((= (get co "status") "running")
          (list (quote lua-multi) false "cannot resume running coroutine"))
        (else
          (call/cc
            (fn (k)
              (let ((prev __current-co))
                (begin
                  (dict-set! co "caller-k" k)
                  (dict-set! co "status" "running")
                  (set! __current-co co)
                  (guard
                    (e (true
                         (begin
                           (dict-set! co "status" "dead")
                           (set! __current-co prev)
                           (list (quote lua-multi) false e))))
                    (cond
                      ((= (get co "resume-k") nil) (lua-co-first-call co rvals prev))
                      (else (lua-co-continue-call co rvals)))))))))))))

(define
  lua-coroutine-yield
  (fn
    (&rest yvals)
    (cond
      ((= __current-co nil) (error "lua: attempt to yield from outside a coroutine"))
      (else
        (call/cc
          (fn (k)
            (let ((co __current-co))
              (begin
                (dict-set! co "resume-k" k)
                (dict-set! co "status" "suspended")
                (set! __current-co nil)
                ((get co "caller-k") (cons (quote lua-multi) (cons true yvals)))))))))))

(define
  lua-co-wrap-caller
  (fn (co args)
    (let ((r (sx-apply-ref lua-coroutine-resume (cons co args))))
      (cond
        ((and (lua-multi? r) (> (len r) 1) (= (nth r 1) true))
          (cond
            ((<= (len r) 2) nil)
            ((= (len r) 3) (nth r 2))
            (else (cons (quote lua-multi) (rest (rest r))))))
        ((and (lua-multi? r) (> (len r) 1))
          (error (if (> (len r) 2) (nth r 2) "coroutine error")))
        (else nil)))))

(define
  lua-coroutine-wrap
  (fn (f)
    (let ((co (lua-coroutine-create f)))
      (fn (&rest args) (lua-co-wrap-caller co args)))))

(define coroutine {})

(dict-set! coroutine "create" lua-coroutine-create)
(dict-set! coroutine "resume" lua-coroutine-resume)
(dict-set! coroutine "yield" lua-coroutine-yield)
(dict-set! coroutine "status" lua-coroutine-status)
(dict-set! coroutine "wrap" lua-coroutine-wrap)