aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/host
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/host/common-lisp.lux365
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- "#-"])
+ )
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 13:33:31 +0000