erlang: ETS-lite (+13 tests)

lib/erlang/runtime.sx

@@ -150,6 +150,7 @@
         :current nil
         :processes {}
         :registered {}
+        :ets {}
         :runnable (er-q-new)})))
 
 (define er-sched (fn () (nth er-scheduler 0)))
@@ -1025,3 +1026,179 @@
 (define
   er-load-supervisor!
   (fn () (erlang-load-module er-supervisor-source)))
+
+;; ── ETS-lite ────────────────────────────────────────────────────
+;; Each table is a mutable list of tuples; key is the tuple's first
+;; element (keypos=1, the default). Tables live on the scheduler
+;; under `:ets` keyed by the registering atom name. Set semantics:
+;; `insert/2` replaces an existing entry with the same key.
+(define er-ets-tables (fn () (get (er-sched) :ets)))
+
+(define
+  er-bif-ets-new
+  (fn
+    (vs)
+    (cond
+      (not (= (len vs) 2)) (error "Erlang: ets:new/2: arity")
+      :else (let
+        ((name (nth vs 0)))
+        (cond
+          (not (er-atom? name))
+          (raise (er-mk-error-marker (er-mk-atom "badarg")))
+          (dict-has? (er-ets-tables) (get name :name))
+          (raise
+            (er-mk-error-marker
+              (er-mk-tuple (list (er-mk-atom "badarg") name))))
+          :else (do
+            (dict-set! (er-ets-tables) (get name :name) (list))
+            name))))))
+
+(define
+  er-ets-resolve
+  (fn
+    (id)
+    (cond
+      (not (er-atom? id))
+      (raise (er-mk-error-marker (er-mk-atom "badarg")))
+      (not (dict-has? (er-ets-tables) (get id :name)))
+      (raise (er-mk-error-marker (er-mk-atom "badarg")))
+      :else (get (er-ets-tables) (get id :name)))))
+
+(define
+  er-bif-ets-insert
+  (fn
+    (vs)
+    (cond
+      (not (= (len vs) 2)) (error "Erlang: ets:insert/2: arity")
+      :else (let
+        ((tab (er-ets-resolve (nth vs 0)))
+          (entry (nth vs 1)))
+        (cond
+          (not (er-tuple? entry))
+          (raise (er-mk-error-marker (er-mk-atom "badarg")))
+          (= (len (get entry :elements)) 0)
+          (raise (er-mk-error-marker (er-mk-atom "badarg")))
+          :else (do
+            (er-ets-replace-or-append! tab entry)
+            (er-mk-atom "true")))))))
+
+(define
+  er-ets-replace-or-append!
+  (fn
+    (tab entry)
+    (let
+      ((key (nth (get entry :elements) 0))
+        (replaced (list false)))
+      (for-each
+        (fn
+          (i)
+          (when
+            (er-equal? (nth (get (nth tab i) :elements) 0) key)
+            (set-nth! tab i entry)
+            (set-nth! replaced 0 true)))
+        (range 0 (len tab)))
+      (when (not (nth replaced 0)) (append! tab entry)))))
+
+(define
+  er-bif-ets-lookup
+  (fn
+    (vs)
+    (cond
+      (not (= (len vs) 2)) (error "Erlang: ets:lookup/2: arity")
+      :else (let
+        ((tab (er-ets-resolve (nth vs 0)))
+          (key (nth vs 1))
+          (out (er-mk-nil)))
+        (for-each
+          (fn
+            (i)
+            (let
+              ((j (- (- (len tab) 1) i))
+                (entry (nth tab (- (- (len tab) 1) i))))
+              (when
+                (er-equal? (nth (get entry :elements) 0) key)
+                (set! out (er-mk-cons entry out)))))
+          (range 0 (len tab)))
+        out))))
+
+(define
+  er-bif-ets-delete
+  (fn
+    (vs)
+    (cond
+      (= (len vs) 1) (er-ets-delete-table! (nth vs 0))
+      (= (len vs) 2) (er-ets-delete-key! (nth vs 0) (nth vs 1))
+      :else (error "Erlang: ets:delete: arity"))))
+
+(define
+  er-ets-delete-table!
+  (fn
+    (id)
+    (cond
+      (not (er-atom? id))
+      (raise (er-mk-error-marker (er-mk-atom "badarg")))
+      (not (dict-has? (er-ets-tables) (get id :name)))
+      (raise (er-mk-error-marker (er-mk-atom "badarg")))
+      :else (do
+        (dict-delete! (er-ets-tables) (get id :name))
+        (er-mk-atom "true")))))
+
+(define
+  er-ets-delete-key!
+  (fn
+    (id key)
+    (let
+      ((tab (er-ets-resolve id)) (out (list)))
+      (for-each
+        (fn
+          (i)
+          (let
+            ((entry (nth tab i)))
+            (when
+              (not (er-equal? (nth (get entry :elements) 0) key))
+              (append! out entry))))
+        (range 0 (len tab)))
+      (dict-set! (er-ets-tables) (get id :name) out)
+      (er-mk-atom "true"))))
+
+(define
+  er-bif-ets-tab2list
+  (fn
+    (vs)
+    (let
+      ((tab (er-ets-resolve (er-bif-arg1 vs "ets:tab2list"))) (out (er-mk-nil)))
+      (for-each
+        (fn
+          (i)
+          (let
+            ((j (- (- (len tab) 1) i)))
+            (set! out (er-mk-cons (nth tab j) out))))
+        (range 0 (len tab)))
+      out)))
+
+(define
+  er-bif-ets-info
+  (fn
+    (vs)
+    (cond
+      (= (len vs) 2)
+      (let
+        ((tab (er-ets-resolve (nth vs 0))) (key (nth vs 1)))
+        (cond
+          (and (er-atom? key) (= (get key :name) "size")) (len tab)
+          :else (er-mk-atom "undefined")))
+      :else (error "Erlang: ets:info: arity"))))
+
+(define
+  er-apply-ets-bif
+  (fn
+    (name vs)
+    (cond
+      (= name "new") (er-bif-ets-new vs)
+      (= name "insert") (er-bif-ets-insert vs)
+      (= name "lookup") (er-bif-ets-lookup vs)
+      (= name "delete") (er-bif-ets-delete vs)
+      (= name "tab2list") (er-bif-ets-tab2list vs)
+      (= name "info") (er-bif-ets-info vs)
+      :else (error
+        (str "Erlang: undefined 'ets:" name "/" (len vs) "'")))))