path: root/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux

(.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)
  (-> Bit 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 Bit Expression Expression)
  (variant' (_.int (:coerce Int tag)) (flag last?) value))

(def: #export none
  Expression
  (variant +0 #0 unit))

(def: #export some
  (-> Expression Expression)
  (variant +1 #1))

(def: #export left
  (-> Expression Expression)
  (variant +0 #0))

(def: #export right
  (-> Expression Expression)
  (variant +1 #1))

(type: Runtime Expression)

(def: declaration
  (s.Syntax [Text (List Text)])
  (p.either (p.seq s.local-identifier (p/wrap (list)))
            (s.form (p.seq s.local-identifier (p.some s.local-identifier)))))

(syntax: (runtime: {[name args] declaration}
           definition)
  (let [implementation (code.local-identifier (format "@@" name))
        runtime (format prefix "__" (lang.normalize-name name))
        $runtime (` (_.var (~ (code.text runtime))))
        @runtime (` (@@ (~ $runtime)))
        argsC+ (list/map code.local-identifier args)
        argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`))
                          args)
        declaration (` ((~ (code.local-identifier 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-identifier))}
                   body)
  (wrap (list (` (let [(~+ (|> vars
                               (list/map (function (_ var)
                                           (list (code.local-identifier var)
                                                 (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var)))))))))
                               list/join))]
                   (~ body))))))

(runtime: (lux//try op)
  (with-vars [error]
    (_.handler-case
     (list [(_.bool #1) 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//logical-right-shift shift input)
  (_.if (_.= (_.int 0) (@@ shift))
    (@@ input)
    (|> (@@ input)
        (_.ash (_.* (_.int -1) (@@ shift)))
        (_.logand (_.int (hex "7FFFFFFFFFFFFFFF"))))))

(def: runtime//bit
  Runtime
  (_.progn (list @@bit//logical-right-shift)))

(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 #1)))
        (_.bool #0)))))

(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 Any))
  (do macro.Monad<Meta>
    [_ //.init-module-buffer
     _ (//.save runtime)]
    (//.save-module! artifact)))