- Initial Common Lisp back-end implementation.

1 files changed, 372 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux
new file mode 100644
index 000000000..eae90e771
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux
@@ -0,0 +1,372 @@
+(.module:
+  lux
+  (lux (control ["p" parser "p/" Monad<Parser>]
+                [monad #+ do])
+       (data [bit]
+             [number #+ hex]
+             text/format
+             (coll [list "list/" Monad<List>]))
+       [macro]
+       (macro [code]
+              ["s" syntax #+ syntax:])
+       [io #+ Process])
+  [//]
+  (luxc [lang]
+        (lang (host ["_" common-lisp #+ SVar Expression @@]))))
+
+(def: prefix Text "LuxRuntime")
+
+(def: #export unit Expression (_.string //.unit))
+
+(def: (flag value)
+  (-> Bool Expression)
+  (if value
+    (_.string "")
+    _.nil))
+
+(def: (variant' tag last? value)
+  (-> Expression Expression Expression Expression)
+  (<| (_.cons (_.symbol //.variant-tag))
+      (_.cons tag)
+      (_.cons last?)
+      value))
+
+(def: #export (variant tag last? value)
+  (-> Nat Bool Expression Expression)
+  (variant' (_.int (:! Int tag)) (flag last?) value))
+
+(def: #export none
+  Expression
+  (variant +0 false unit))
+
+(def: #export some
+  (-> Expression Expression)
+  (variant +1 true))
+
+(def: #export left
+  (-> Expression Expression)
+  (variant +0 false))
+
+(def: #export right
+  (-> Expression Expression)
+  (variant +1 true))
+
+(type: Runtime Expression)
+
+(def: declaration
+  (s.Syntax [Text (List Text)])
+  (p.either (p.seq s.local-symbol (p/wrap (list)))
+            (s.form (p.seq s.local-symbol (p.some s.local-symbol)))))
+
+(syntax: (runtime: [[name args] declaration]
+           definition)
+  (let [implementation (code.local-symbol (format "@@" name))
+        runtime (format prefix "__" (lang.normalize-name name))
+        $runtime (` (_.var (~ (code.text runtime))))
+        @runtime (` (@@ (~ $runtime)))
+        argsC+ (list/map code.local-symbol args)
+        argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`))
+                          args)
+        declaration (` ((~ (code.local-symbol name))
+                        (~+ argsC+)))
+        type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression)))
+                    _.Expression))]
+    (wrap (list (` (def: (~' #export) (~ declaration)
+                     (~ type)
+                     (~ (case argsC+
+                          #.Nil
+                          @runtime
+
+                          _
+                          (` (_.$apply (~ @runtime) (list (~+ argsC+))))))))
+                (` (def: (~ implementation)
+                     _.Expression
+                     (~ (case argsC+
+                          #.Nil
+                          (` (_.defparameter (~ $runtime) (~ definition)))
+
+                          _
+                          (` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
+                                           (list/map (function (_ [left right])
+                                                       (list left right)))
+                                           list/join))]
+                               (_.defun (~ $runtime) (list (~+ argsLC+))
+                                        (~ definition))))))))))))
+
+(syntax: #export (with-vars [vars (s.tuple (p.many s.local-symbol))]
+                   body)
+  (wrap (list (` (let [(~+ (|> vars
+                               (list/map (function (_ var)
+                                           (list (code.local-symbol var)
+                                                 (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var)))))))))
+                               list/join))]
+                   (~ body))))))
+
+(runtime: (lux//try op)
+  (with-vars [error]
+    (_.handler-case
+     (list [(_.bool true) error
+            (..left (_.format/3 _.nil (_.string "~A") (@@ error)))])
+     (..right (_.funcall (list ..unit) (@@ op))))))
+
+(runtime: (lux//program-args program-args)
+  (with-vars [loop input output]
+    (_.labels (list [loop [(_.poly (list input output))
+                           (_.if (_.null (@@ input))
+                             (@@ output)
+                             (_.funcall (list (_.cdr (@@ input))
+                                              (..some (_.vector (list (_.car (@@ input)) (@@ output)))))
+                                        (_.function (@@ loop))))]])
+              (_.funcall (list (_.reverse (@@ program-args))
+                               ..none)
+                         (_.function (@@ loop))))))
+
+(def: runtime//lux
+  Runtime
+  (_.progn (list @@lux//try
+                 @@lux//program-args)))
+
+(def: minimum-index-length
+  (-> Expression Expression)
+  (|>> (_.+ (_.int 1))))
+
+(def: product-element
+  (-> Expression Expression Expression)
+  _.svref)
+
+(def: (product-tail product)
+  (-> Expression Expression)
+  (_.svref product (|> (_.length product) (_.- (_.int 1)))))
+
+(def: (updated-index min-length product)
+  (-> Expression Expression Expression)
+  (|> min-length (_.- (_.length product))))
+
+(runtime: (product//left product index)
+  (with-vars [$index_min_length]
+    (_.let (list [$index_min_length (minimum-index-length (@@ index))])
+      (_.if (|> (_.length (@@ product)) (_.> (@@ $index_min_length)))
+        ## No need for recursion
+        (product-element (@@ product) (@@ index))
+        ## Needs recursion
+        (product//left (product-tail (@@ product))
+                       (updated-index (@@ $index_min_length) (@@ product)))))))
+
+(runtime: (product//right product index)
+  (with-vars [$index_min_length $product_length]
+    (_.let (list [$index_min_length (minimum-index-length (@@ index))]
+                 [$product_length (_.length (@@ product))])
+      (<| (_.if (|> (@@ $product_length) (_.= (@@ $index_min_length)))
+            ## Last element.
+            (product-element (@@ product) (@@ index)))
+          (_.if (|> (@@ $product_length) (_.< (@@ $index_min_length)))
+            ## Needs recursion
+            (product//right (product-tail (@@ product))
+                            (updated-index (@@ $index_min_length) (@@ product))))
+          ## Must slice
+          (_.subseq/3 (@@ product) (@@ index) (@@ $product_length))))))
+
+(runtime: (sum//get sum wanted_tag wants_last)
+  (with-vars [variant-tag sum-tag sum-flag sum-value]
+    (let [no-match _.nil
+          is-last? (|> (@@ sum-flag) (_.equal (_.string "")))
+          test-recursion (_.if is-last?
+                           ## Must recurse.
+                           (sum//get (@@ sum-value)
+                                     (|> (@@ wanted_tag) (_.- (@@ sum-tag)))
+                                     (@@ wants_last))
+                           no-match)]
+      (<| (_.destructuring-bind [(_.poly (list variant-tag sum-tag sum-flag sum-value))
+                                 (@@ sum)])
+          (_.if (|> (@@ wanted_tag) (_.= (@@ sum-tag)))
+            (_.if (|> (@@ sum-flag) (_.equal (@@ wants_last)))
+              (@@ sum-value)
+              test-recursion))
+          (_.if (|> (@@ wanted_tag) (_.> (@@ sum-tag)))
+            test-recursion)
+          (_.if (_.and (list (|> (@@ wants_last) (_.equal (_.string "")))
+                             (|> (@@ wanted_tag) (_.< (@@ sum-tag)))))
+            (variant' (|> (@@ sum-tag) (_.- (@@ wanted_tag))) (@@ sum-flag) (@@ sum-value)))
+          no-match))))
+
+(def: runtime//adt
+  Runtime
+  (_.progn (list @@product//left
+                 @@product//right
+                 @@sum//get)))
+
+(runtime: (bit//shift-right shift input)
+  (_.if (_.= (_.int 0) (@@ shift))
+    (@@ input)
+    (|> (@@ input)
+        (_.ash (_.* (_.int -1) (@@ shift)))
+        (_.logand (_.int (hex "7FFFFFFFFFFFFFFF"))))))
+
+(def: runtime//bit
+  Runtime
+  (_.progn (list @@bit//shift-right)))
+
+(do-template [<name> <top-cmp>]
+  [(def: (<name> top value)
+     (-> Expression Expression Expression)
+     (_.and (list (|> value (_.>= (_.int 0)))
+                  (|> value (<top-cmp> top)))))]
+
+  [within? _.<]
+  [up-to?  _.<=]
+  )
+
+(runtime: (text//char idx text)
+  (_.if (|> (@@ idx) (within? (_.length (@@ text))))
+    (..some (_.char-int/1 (_.char/2 (@@ text) (@@ idx))))
+    ..none))
+
+(runtime: (text//clip from to text)
+  (_.if (_.and (list (|> (@@ to) (within? (_.length (@@ text))))
+                     (|> (@@ from) (up-to? (@@ to)))))
+    (..some (_.subseq/3 (@@ text) (@@ from) (@@ to)))
+    ..none))
+
+(runtime: (text//index reference start space)
+  (with-vars [index]
+    (_.let (list [index (_.search/start2 (@@ reference) (@@ space) (@@ start))])
+      (_.if (@@ index)
+        (..some (@@ index))
+        ..none))))
+
+(def: runtime//text
+  Runtime
+  (_.progn (list @@text//index
+                 @@text//clip
+                 @@text//char)))
+
+(def: (check-index-out-of-bounds array idx body)
+  (-> Expression Expression Expression Expression)
+  (_.if (|> idx (_.<= (_.length array)))
+    body
+    (_.error (_.string "Array index out of bounds!"))))
+
+(runtime: (array//get array idx)
+  (with-vars [temp]
+    (<| (check-index-out-of-bounds (@@ array) (@@ idx))
+        (_.let (list [temp (_.svref (@@ array) (@@ idx))])
+          (_.if (_.null (@@ temp))
+            ..none
+            (..some (@@ temp)))))))
+
+(runtime: (array//put array idx value)
+  (<| (check-index-out-of-bounds (@@ array) (@@ idx))
+      (_.progn
+       (list (_.setf! (_.svref (@@ array) (@@ idx)) (@@ value))
+             (@@ array)))))
+
+(def: runtime//array
+  Runtime
+  (_.progn
+   (list @@array//get
+         @@array//put)))
+
+(runtime: (atom//compare-and-swap atom old new)
+  (with-vars [temp]
+    (_.let (list [temp (_.svref (@@ atom) (_.int 0))])
+      (_.if (_.eq (@@ old) (@@ temp))
+        (_.progn
+         (list (_.setf! (_.svref (@@ atom) (_.int 0)) (@@ new))
+               (_.bool true)))
+        (_.bool false)))))
+
+(def: runtime//atom
+  Runtime
+  @@atom//compare-and-swap)
+
+(runtime: (box//write value box)
+  (_.progn
+   (list
+    (_.setf! (_.svref (@@ box) (_.int 0)) (@@ value))
+    ..unit)))
+
+(def: runtime//box
+  Runtime
+  (_.progn (list @@box//write)))
+
+(runtime: (io//exit code)
+  (_.progn
+   (list (_.conditional+ (list "sbcl")
+                         (_.$apply (_.global "sb-ext:quit") (list (@@ code))))
+         (_.conditional+ (list "clisp")
+                         (_.$apply (_.global "ext:exit") (list (@@ code))))
+         (_.conditional+ (list "ccl")
+                         (_.$apply (_.global "ccl:quit") (list (@@ code))))
+         (_.conditional+ (list "allegro")
+                         (_.$apply (_.global "excl:exit") (list (@@ code))))
+         (_.$apply (_.global "cl-user::quit") (list (@@ code))))))
+
+(runtime: (io//current-time _)
+  (|> _.get-universal-time
+      (_.* (_.int 1_000))))
+
+(def: runtime//io
+  (_.progn (list @@io//exit
+                 @@io//current-time)))
+
+(def: process//incoming
+  SVar
+  (_.var (lang.normalize-name "process//incoming")))
+
+(runtime: (process//loop _)
+  (_.if (_.not (_.null (@@ process//incoming)))
+    (with-vars [queue process]
+      (_.let (list [queue (@@ process//incoming)])
+        (_.progn (list (_.setq! process//incoming (_.list (list)))
+                       (_.map/3 _.nil
+                                (_.lambda (_.poly (list process))
+                                     (_.funcall (list ..unit) (@@ process)))
+                                (@@ queue))
+                       (process//loop ..unit)))))
+    ..unit))
+
+(runtime: (process//schedule milli-seconds procedure)
+  (_.progn
+   (list
+    (_.if (_.= (_.int 0) (@@ milli-seconds))
+      (_.setq! process//incoming (_.cons (@@ procedure) (@@ process//incoming)))
+      (with-vars [start scheduled now diff _ignored]
+        (_.let (list [start (io//current-time ..unit)])
+          (_.labels (list [scheduled [(_.poly+ (list) _ignored)
+                                      (_.let (list [now (io//current-time ..unit)]
+                                                   [diff (|> (@@ now) (_.- (@@ start)))])
+                                        (_.if (|> (@@ diff) (_.>= (@@ milli-seconds)))
+                                          (_.funcall (list ..unit) (@@ procedure))
+                                          (process//schedule (|> (@@ milli-seconds) (_.- (@@ diff)))
+                                                             (_.function (@@ scheduled)))))]])
+                    (_.setq! process//incoming (_.cons (_.function (@@ scheduled))
+                                                       (@@ process//incoming)))))))
+    ..unit)))
+
+(def: runtime//process
+  Runtime
+  (_.progn (list (_.defparameter process//incoming (_.list (list)))
+                 @@process//loop
+                 @@process//schedule)))
+
+(def: runtime
+  Runtime
+  (_.progn (list runtime//lux
+                 runtime//bit
+                 runtime//adt
+                 runtime//text
+                 runtime//array
+                 runtime//atom
+                 runtime//box
+                 runtime//io
+                 runtime//process))
+  )
+
+(def: #export artifact Text (format prefix //.file-extension))
+
+(def: #export translate
+  (Meta (Process Unit))
+  (do macro.Monad<Meta>
+    [_ //.init-module-buffer
+     _ (//.save runtime)]
+    (//.save-module! artifact)))