- Initial Common Lisp back-end implementation.

1 files changed, 365 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/host/common-lisp.lux b/new-luxc/source/luxc/lang/host/common-lisp.lux
new file mode 100644
index 000000000..3ab94b1a1
--- /dev/null
+++ b/new-luxc/source/luxc/lang/host/common-lisp.lux
@@ -0,0 +1,365 @@
+(.module:
+  [lux #- not or and list if function cond when let type-of]
+  (lux (control pipe)
+       (data [maybe "maybe/" Functor<Maybe>]
+             [text]
+             text/format
+             [number]
+             (coll [list "list/" Functor<List> Fold<List>]))
+       (type abstract)))
+
+(abstract: #export Single {} Unit)
+(abstract: #export Poly {} Unit)
+
+(abstract: #export (Var kind)
+  {}
+
+  Text
+
+  (def: name (All [k] (-> (Var k) Text)) (|>> @representation))
+
+  (def: #export var (-> Text (Var Single)) (|>> @abstraction))
+
+  (def: #export (poly vars)
+    (-> (List (Var Single)) (Var Poly))
+    (@abstraction
+     (format "(" (|> vars (list/map ..name) (text.join-with " ")) ")")))
+
+  (def: #export (poly+ vars rest)
+    (-> (List (Var Single)) (Var Single) (Var Poly))
+    (@abstraction
+     (format "(" (|> vars (list/map ..name) (text.join-with " "))
+             " &rest " (..name rest)
+             ")")))
+  )
+
+(type: #export SVar (Var Single))
+(type: #export PVar (Var Poly))
+(type: #export *Var (Ex [k] (Var k)))
+
+(abstract: #export Expression
+  {}
+  
+  Text
+
+  (def: #export expression (-> Expression Text) (|>> @representation))
+
+  (def: #export code (-> Text Expression) (|>> @abstraction))
+
+  (type: #export Lambda [PVar Expression])
+
+  (def: #export nil
+    Expression
+    (@abstraction "()"))
+
+  (def: #export bool
+    (-> Bool Expression)
+    (|>> (case> true (@abstraction "t")
+                false ..nil)))
+
+  (def: #export int
+    (-> Int Expression)
+    (|>> %i @abstraction))
+
+  (def: #export float
+    (-> Frac Expression)
+    (|>> (cond> [(f/= number.positive-infinity)]
+                [(new> "(/ 1.0 0.0)")]
+                
+                [(f/= number.negative-infinity)]
+                [(new> "(/ -1.0 0.0)")]
+                
+                [number.not-a-number?]
+                [(new> "(/ 0.0 0.0)")]
+                
+                ## else
+                [%f])
+         @abstraction))
+
+  (def: #export (double value)
+    (-> Frac Expression)
+    (@abstraction
+     (.cond (f/= number.positive-infinity value)
+            "(/ 1.0d0 0.0d0)"
+            
+            (f/= number.negative-infinity value)
+            "(/ -1.0d0 0.0d0)"
+            
+            (number.not-a-number? value)
+            "(/ 0.0d0 0.0d0)"
+            
+            ## else
+            (.let [raw (%f value)]
+              (.if (text.contains? "E" raw)
+                (text.replace-once "E" "d" raw)
+                (format raw "d0"))))))
+
+  (def: #export positive-infinity Expression (..float number.positive-infinity))
+  (def: #export negative-infinity Expression (..float number.negative-infinity))
+  (def: #export not-a-number Expression (..float number.not-a-number))
+
+  (def: #export string
+    (-> Text Expression)
+    (|>> %t @abstraction))
+
+  (do-template [<name> <prefix>]
+    [(def: #export <name>
+       (-> Text Expression)
+       (|>> (format <prefix>) @abstraction))]
+
+    [symbol "'"]
+    [keyword ":"])
+
+  (def: #export (form elements)
+    (-> (List Expression) Expression)
+    (@abstraction
+     (format "(" (|> elements (list/map expression) (text.join-with " ")) ")")))
+
+  (def: #export @@
+    (All [k] (-> (Var k) Expression))
+    (|>> ..name @abstraction))
+
+  (def: #export global
+    (-> Text Expression)
+    (|>> var @@))
+  
+  (def: #export ($apply func args)
+    (-> Expression (List Expression) Expression)
+    (form (#.Cons func args)))
+  
+  (do-template [<name> <function>]
+    [(def: #export <name>
+       (-> (List Expression) Expression)
+       ($apply (..global <function>)))]
+
+    [vector "vector"]
+    [list   "list"]
+    )
+
+  (def: #export (labels definitions body)
+    (-> (List [SVar Lambda]) Expression Expression)
+    (..form (.list (..global "labels")
+                   (..form (list/map (.function (_ [def-name [def-args def-body]])
+                                       (..form (.list (@@ def-name)
+                                                      (@@ def-args)
+                                                      def-body)))
+                                     definitions))
+                   body)))
+
+  (def: #export (destructuring-bind [bindings expression] body)
+    (-> [PVar Expression] Expression Expression)
+    (..form (.list (..global "destructuring-bind")
+                   (@@ bindings) expression
+                   body)))
+
+  (def: #export ($apply1 func)
+    (-> Expression (-> Expression Expression))
+    (|>> (.list) (..$apply func)))
+
+  (do-template [<lux-name> <scheme-name>]
+    [(def: #export <lux-name> (..$apply1 (..global <scheme-name>)))]
+
+    [length "length"]
+    [function "function"]
+    [copy-seq "copy-seq"]
+    [null "null"]
+    [car "car"]
+    [cdr "cdr"]
+    [error "error"]
+    [not "not"]
+    [floor/1 "floor"]
+    [type-of "type-of"]
+    [write-to-string "write-to-string"]
+    [read-from-string "read-from-string"]
+    [print "print"]
+    [reverse "reverse"]
+    [sxhash/1 "sxhash"]
+    [string-upcase/1 "string-upcase"]
+    [string-downcase/1 "string-downcase"]
+    [char-int/1 "char-int"]
+    [text/1 "text"]
+    )
+
+  (def: #export (make-array/init size init)
+    (-> Expression Expression Expression)
+    (..$apply (..global "make-array")
+              (.list (..list (.list size))
+                     (..keyword "initial-element")
+                     init)))
+
+  (def: #export get-universal-time
+    Expression
+    (..$apply (..global "get-universal-time") (.list)))
+
+  (def: #export (funcall args func)
+    (-> (List Expression) Expression Expression)
+    (..$apply (..global "funcall") (list& func args)))
+
+  (def: #export (apply args func)
+    (-> Expression Expression Expression)
+    (..$apply (..global "apply") (.list func args)))
+  
+  (def: #export ($apply2 func)
+    (-> Expression (-> Expression Expression Expression))
+    (.function (_ _0 _1)
+      (..$apply func (.list _0 _1))))
+
+  (do-template [<lux-name> <scheme-name>]
+    [(def: #export <lux-name> (..$apply2 (..global <scheme-name>)))]
+
+    [append "append"]
+    [cons "cons"]
+    [svref "svref"]
+    [char/2 "char"]
+    )
+
+  (def: #export (search/start2 reference space start)
+    (-> Expression Expression Expression Expression)
+    (..$apply (..global "search")
+              (.list reference space
+                     (..keyword "start2") start)))
+
+  (def: #export ($apply3 func)
+    (-> Expression (-> Expression Expression Expression Expression))
+    (.function (_ _0 _1 _2)
+      (..$apply func (.list _0 _1 _2))))
+
+  (do-template [<lux-name> <scheme-name>]
+    [(def: #export <lux-name> ($apply3 (..global <scheme-name>)))]
+
+    [subseq/3 "subseq"]
+    [map/3 "map"]
+    [concatenate/3 "concatenate"]
+    [format/3 "format"]
+    )
+
+  (def: #export concatenate/string
+    (-> Expression Expression Expression)
+    (concatenate/3 (..symbol "string")))
+
+  (do-template [<lux-name> <scheme-name>]
+    [(def: #export <lux-name>
+       (-> (List Expression) Expression)
+       (|>> (.list& (..global <scheme-name>)) ..form))]
+
+    [or "or"]
+    [and "and"]
+    )
+
+  (do-template [<lux-name> <scheme-name>]
+    [(def: #export (<lux-name> param subject)
+       (-> Expression Expression Expression)
+       (..form (.list (..global <scheme-name>) subject param)))]
+
+    [=   "="]
+    [eq "eq"]
+    [equal "equal"]
+    [<   "<"]
+    [<=  "<="]
+    [>   ">"]
+    [>=  ">="]
+    [string= "string="]
+    [string< "string<"]
+    [+   "+"]
+    [-   "-"]
+    [/   "/"]
+    [*   "*"]
+    [rem "rem"]
+    [floor "floor"]
+    [mod "mod"]
+    [ash "ash"]
+    [logand "logand"]
+    [logior "logior"]
+    [logxor "logxor"]
+    )
+
+  (do-template [<lux-name> <scheme-name>]
+    [(def: #export (<lux-name> bindings body)
+       (-> (List [SVar Expression]) Expression Expression)
+       (..form (.list (..global <scheme-name>)
+                      (|> bindings
+                          (list/map (.function (_ [fname fvalue])
+                                      (..form (.list (@@ fname) fvalue))))
+                          ..form)
+                      body)))]
+
+    [let  "let"]
+    [let* "let*"]
+    )
+
+  (def: #export (if test then else)
+    (-> Expression Expression Expression Expression)
+    (..form (.list (..global "if") test then else)))
+
+  (def: #export (when test then)
+    (-> Expression Expression Expression)
+    (..form (.list (..global "when") test then)))
+
+  (def: #export (cond clauses else)
+    (-> (List [Expression Expression]) Expression Expression)
+    (list/fold (.function (_ [test then] next)
+                 (if test then next))
+               else
+               (list.reverse clauses)))
+
+  (def: #export (lambda input body)
+    (-> PVar Expression Expression)
+    (..form (.list (..global "lambda")
+                   (@@ input)
+                   body)))
+
+  (def: #export (defparameter name body)
+    (-> SVar Expression Expression)
+    (..form (.list (..global "defparameter") (@@ name) body)))
+
+  (def: #export (defun name inputs body)
+    (-> SVar (List SVar) Expression Expression)
+    (..form (.list (..global "defun") (@@ name) (@@ (..poly inputs)) body)))
+
+  (def: #export progn
+    (-> (List Expression) Expression)
+    (|>> (#.Cons (..global "progn")) ..form))
+
+  (def: #export (setq! name value)
+    (-> SVar Expression Expression)
+    (..form (.list (..global "setq") (@@ name) value)))
+
+  (def: #export (setf! access value)
+    (-> Expression Expression Expression)
+    (..form (.list (..global "setf") access value)))
+
+  (type: #export Handler
+    {#condition-type Expression
+     #condition SVar
+     #body Expression})
+  
+  (def: #export (handler-case handlers body)
+    (-> (List Handler) Expression Expression)
+    (..form (.list& (..global "handler-case")
+                    body
+                    (list/map (.function (_ [type condition handler])
+                                (..form (.list type (@@ (..poly (.list condition)))
+                                               handler)))
+                              handlers))))
+
+  (do-template [<name> <prefix>]
+    [(def: #export (<name> conditions expression)
+       (-> (List Text) Expression Expression)
+       (case conditions
+         #.Nil
+         expression
+         
+         (#.Cons single #.Nil)
+         (@abstraction
+          (format <prefix> single " " (@representation expression)))
+         
+         _
+         (@abstraction
+          (format <prefix> (|> conditions (list/map ..symbol)
+                               (.list& (..symbol "or")) ..form
+                               @representation)
+                  " " (@representation expression)))))]
+
+    [conditional+ "#+"]
+    [conditional- "#-"])
+  )