lua: metatable dispatch (__index/__newindex/arith/cmp/__call/__len) +23 tests

lib/lua/runtime.sx

@@ -41,27 +41,77 @@
           ((= op "^") (pow na nb))
           (else (error (str "lua: unknown arith op " op))))))))
 
-(define lua-add (fn (a b) (lua-num-op "+" a b)))
+(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-sub (fn (a b) (lua-num-op "-" a b)))
+(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-mul (fn (a b) (lua-num-op "*" a b)))
+(define lua-add (fn (a b) (lua-arith "__add" "+" a b)))
 
-(define lua-div (fn (a b) (lua-num-op "/" a b)))
+(define lua-sub (fn (a b) (lua-arith "__sub" "-" a b)))
 
-(define lua-mod (fn (a b) (lua-num-op "%" a b)))
+(define lua-mul (fn (a b) (lua-arith "__mul" "*" a b)))
 
-(define lua-pow (fn (a b) (lua-num-op "^" 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)
-    (let
-      ((na (lua-to-number a)))
-      (begin
-        (when (= na nil) (error (str "lua: neg on non-number: " a)))
-        (- 0 na)))))
+    (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
@@ -76,9 +126,23 @@
   lua-concat
   (fn
     (a b)
-    (let
-      ((sa (lua-concat-coerce a)) (sb (lua-concat-coerce b)))
-      (str sa sb))))
+    (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
@@ -88,6 +152,13 @@
       ((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))))
@@ -99,9 +170,41 @@
     (cond
       ((and (= (type-of a) "number") (= (type-of b) "number")) (< a b))
       ((and (= (type-of a) "string") (= (type-of b) "string")) (< a b))
-      (else (error "lua: attempt to compare incompatible types")))))
+      (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) (or (lua-lt a b) (lua-eq a b))))
+(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)))
 
@@ -116,17 +219,22 @@
       ((= (type-of a) "list") (len a))
       ((= (type-of a) "dict")
         (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))))
+          ((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
@@ -166,9 +274,37 @@
   lua-get
   (fn
     (t k)
-    (if (= t nil) nil (let ((v (get t (str k)))) (if (= v nil) nil v)))))
+    (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) (dict-set! t (str k) v)))
+(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?
@@ -215,3 +351,52 @@
     (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"))))))