1 files changed, 154 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux
new file mode 100644
index 000000000..a72239982
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux
@@ -0,0 +1,154 @@
+(.module:
+  [lux #*
+   [host (#+ import:)]
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." function]]
+   [data
+    ["." product]
+    [collection
+     ["." dictionary]]]
+   [target
+    ["_" common-lisp (#+ Expression)]]]
+  ["." /// #_
+   ["#." runtime (#+ Operation Phase Handler Bundle)]
+   ["#." primitive]
+   [//
+    [extension (#+ Nullary Unary Binary Trinary
+                   nullary unary binary trinary)]
+    [//
+     [extension
+      ["." bundle]]]]])
+
+(def: lux-procs
+  Bundle
+  (|> bundle.empty
+      (bundle.install "is" (binary (product.uncurry _.eq)))
+      (bundle.install "try" (unary ///runtime.lux//try))))
+
+(def: (i64//left-shift [paramG subjectG])
+  (Binary (Expression Any))
+  (_.ash (_.rem (_.int +64) paramG) subjectG))
+
+(def: (i64//arithmetic-right-shift [paramG subjectG])
+  (Binary (Expression Any))
+  (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1)))
+         subjectG))
+
+(def: (i64//logic-right-shift [paramG subjectG])
+  (Binary (Expression Any))
+  (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG))
+
+(def: i64-procs
+  Bundle
+  (<| (bundle.prefix "i64")
+      (|> bundle.empty
+          (bundle.install "and" (binary (product.uncurry _.logand)))
+          (bundle.install "or" (binary (product.uncurry _.logior)))
+          (bundle.install "xor" (binary (product.uncurry _.logxor)))
+          (bundle.install "left-shift" (binary i64//left-shift))
+          (bundle.install "logical-right-shift" (binary i64//logic-right-shift))
+          (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift))
+          (bundle.install "=" (binary (product.uncurry _.=)))
+          (bundle.install "<" (binary (product.uncurry _.<)))
+          (bundle.install "+" (binary (product.uncurry _.+)))
+          (bundle.install "-" (binary (product.uncurry _.-)))
+          (bundle.install "*" (binary (product.uncurry _.*)))
+          (bundle.install "/" (binary (product.uncurry _.floor)))
+          (bundle.install "%" (binary (product.uncurry _.rem)))
+          (bundle.install "f64" (unary (function (_ value)
+                                         (_.coerce/2 [value (_.symbol "double-float")]))))
+          (bundle.install "char" (unary (|>> _.code-char/1 _.string/1)))
+          )))
+
+(import: #long java/lang/Double
+  (#static MIN_VALUE Double)
+  (#static MAX_VALUE Double))
+
+(template [<name> <const>]
+  [(def: (<name> _)
+     (Nullary (Expression Any))
+     (_.double <const>))]
+
+  [f64//smallest (java/lang/Double::MIN_VALUE)]
+  [f64//min      (f/* -1.0 (java/lang/Double::MAX_VALUE))]
+  [f64//max      (java/lang/Double::MAX_VALUE)]
+  )
+
+(def: f64-procs
+  Bundle
+  (<| (bundle.prefix "f64")
+      (|> bundle.empty
+          (bundle.install "+" (binary (product.uncurry _.+)))
+          (bundle.install "-" (binary (product.uncurry _.-)))
+          (bundle.install "*" (binary (product.uncurry _.*)))
+          (bundle.install "/" (binary (product.uncurry _./)))
+          (bundle.install "%" (binary (product.uncurry _.mod)))
+          (bundle.install "=" (binary (product.uncurry _.=)))
+          (bundle.install "<" (binary (product.uncurry _.<)))
+          (bundle.install "smallest" (nullary f64//smallest))
+          (bundle.install "min" (nullary f64//min))
+          (bundle.install "max" (nullary f64//max))
+          (bundle.install "i64" (unary _.floor/1))
+          (bundle.install "encode" (unary _.write-to-string/1))
+          (bundle.install "decode" (unary (let [@temp (_.var "temp")]
+                                            (function (_ input)
+                                              (_.let (list [@temp (_.read-from-string/1 input)])
+                                                (_.if (_.equal (_.symbol "DOUBLE-FLOAT")
+                                                               (_.type-of/1 @temp))
+                                                  (///runtime.some @temp)
+                                                  ///runtime.none)))))))))
+
+(def: (text//< [paramG subjectG])
+  (Binary (Expression Any))
+  (|> (_.string< paramG subjectG)
+      _.null/1
+      _.not/1))
+
+(def: (text//clip [paramO extraO subjectO])
+  (Trinary (Expression Any))
+  (///runtime.text//clip subjectO paramO extraO))
+
+(def: (text//index [startO partO textO])
+  (Trinary (Expression Any))
+  (///runtime.text//index textO partO startO))
+
+(def: text-procs
+  Bundle
+  (<| (bundle.prefix "text")
+      (|> bundle.empty
+          (bundle.install "=" (binary (product.uncurry _.string=)))
+          (bundle.install "<" (binary text//<))
+          (bundle.install "concat" (binary _.concatenate/2|string))
+          (bundle.install "index" (trinary text//index))
+          (bundle.install "size" (unary _.length/1))
+          (bundle.install "char" (binary (|>> _.char/2 _.char-int/1)))
+          (bundle.install "clip" (trinary text//clip))
+          )))
+
+(def: (void code)
+  (-> (Expression Any) (Expression Any))
+  ($_ _.progn
+      code
+      ///runtime.unit))
+
+(def: io-procs
+  Bundle
+  (<| (bundle.prefix "io")
+      (|> bundle.empty
+          (bundle.install "log" (unary (|>> _.print/1 ..void)))
+          (bundle.install "error" (unary _.error/1))
+          (bundle.install "exit" (unary ///runtime.io//exit))
+          (bundle.install "current-time" (nullary (function (_ _)
+                                                    (///runtime.io//current-time ///runtime.unit)))))))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "lux")
+      (|> lux-procs
+          (dictionary.merge i64-procs)
+          (dictionary.merge f64-procs)
+          (dictionary.merge text-procs)
+          (dictionary.merge io-procs)
+          )))