- Implemented "atom" and "process" procedures for JS.

1 files changed, 74 insertions, 13 deletions

diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj
index 284139248..1522cf4ca 100644
--- a/luxc/src/lux/compiler/js/proc/common.clj
+++ b/luxc/src/lux/compiler/js/proc/common.clj
@@ -412,19 +412,66 @@
         =message (compile ?message)]
     (return (str "LuxRT.error(" =message ")"))))
 
-(defn compile-proc [compile proc-category proc-name ?values special-args]
-  (case proc-category
+(defn ^:private compile-atom-new [compile ?values special-args]
+  (|do [:let [(&/$Cons ?init (&/$Nil)) ?values]
+        =init (compile ?init)]
+    (return (str "{V: " =init "}"))))
+
+(defn ^:private compile-atom-get [compile ?values special-args]
+  (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values]
+        =atom (compile ?atom)]
+    (return (str =atom ".V"))))
+
+(defn ^:private compile-atom-compare-and-swap [compile ?values special-args]
+  (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values]
+        =atom (compile ?atom)
+        =old (compile ?old)
+        =new (compile ?new)]
+    (return (str "(function() {"
+                 (str "var atom = " =atom ";")
+                 (str "if(" (str "(atom.V === " =old ")") ") {"
+                      (str "atom.V = " =new ";")
+                      "return true;"
+                      "}"
+                      "else {"
+                      "return false;"
+                      "}")
+                 "})()"))))
+
+(defn ^:private compile-process-concurrency-level [compile ?values special-args]
+  (|do [:let [(&/$Nil) ?values]]
+    (return (str "LuxRT.fromNumberI64(1)"))))
+
+(defn ^:private compile-process-future [compile ?values special-args]
+  (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values]
+        =procedure (compile ?procedure)]
+    (return (str "setTimeout("
+                 (str "function() {" =procedure "(null)" "}")
+                 ",0)"))))
+
+(defn ^:private compile-process-schedule [compile ?values special-args]
+  (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values]
+        =milliseconds (compile ?milliseconds)
+        =procedure (compile ?procedure)]
+    (return (str "setTimeout("
+                 (str "function() {" =procedure "(null)" "}")
+                 ","
+                 (str "LuxRT.toNumberI64(" =milliseconds ")")
+                 ")"))))
+
+(defn compile-proc [compile category proc ?values special-args]
+  (case category
     "lux"
-    (case proc-name
+    (case proc
       "is"                   (compile-lux-is compile ?values special-args))
 
     "io"
-    (case proc-name
+    (case proc
       "log"                  (compile-io-log compile ?values special-args)
       "error"                (compile-io-error compile ?values special-args))
 
     "text"
-    (case proc-name
+    (case proc
       "="                    (compile-text-eq compile ?values special-args)
       "<"                    (compile-text-lt compile ?values special-args)
       "append"               (compile-text-append compile ?values special-args)
@@ -442,7 +489,7 @@
       )
     
     ;; "bit"
-    ;; (case proc-name
+    ;; (case proc
     ;;   "count"                (compile-bit-count compile ?values special-args)
     ;;   "and"                  (compile-bit-and compile ?values special-args)
     ;;   "or"                   (compile-bit-or compile ?values special-args)
@@ -452,7 +499,7 @@
     ;;   "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args))
     
     "array"
-    (case proc-name
+    (case proc
       "new" (compile-array-new compile ?values special-args)
       "get" (compile-array-get compile ?values special-args)
       "put" (compile-array-put compile ?values special-args)
@@ -460,7 +507,7 @@
       "size" (compile-array-size compile ?values special-args))
 
     "nat"
-    (case proc-name
+    (case proc
       "+"         (compile-nat-add compile ?values special-args)
       "-"         (compile-nat-sub compile ?values special-args)
       "*"         (compile-nat-mul compile ?values special-args)
@@ -477,7 +524,7 @@
       )
 
     "int"
-    (case proc-name
+    (case proc
       "+"         (compile-int-add compile ?values special-args)
       "-"         (compile-int-sub compile ?values special-args)
       "*"         (compile-int-mul compile ?values special-args)
@@ -494,7 +541,7 @@
       )
     
     "deg"
-    (case proc-name
+    (case proc
       "+"         (compile-deg-add compile ?values special-args)
       "-"         (compile-deg-sub compile ?values special-args)
       "*"         (compile-deg-mul compile ?values special-args)
@@ -511,7 +558,7 @@
       )
 
     "real"
-    (case proc-name
+    (case proc
       "+"         (compile-real-add compile ?values special-args)
       "-"         (compile-real-sub compile ?values special-args)
       "*"         (compile-real-mul compile ?values special-args)
@@ -532,12 +579,26 @@
       )
 
     "char"
-    (case proc-name
+    (case proc
       "="         (compile-char-eq compile ?values special-args)
       "<"         (compile-char-lt compile ?values special-args)
       "to-text"   (compile-char-to-text compile ?values special-args)
       "to-nat"    (compile-char-to-nat compile ?values special-args)
       )
+
+    "atom"
+    (case proc
+      "new" (compile-atom-new compile ?values special-args)
+      "get" (compile-atom-get compile ?values special-args)
+      "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args)
+      )
+
+    "process"
+    (case proc
+      "concurrency-level" (compile-process-concurrency-level compile ?values special-args)
+      "future" (compile-process-future compile ?values special-args)
+      "schedule" (compile-process-schedule compile ?values special-args)
+      )
     
     ;; else
-    (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))))
+    (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [category proc]))))