aboutsummaryrefslogtreecommitdiff
path: root/lux-scheme/source
diff options
context:
space:
mode:
Diffstat (limited to 'lux-scheme/source')
-rw-r--r--lux-scheme/source/program.lux355
1 files changed, 355 insertions, 0 deletions
diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux
new file mode 100644
index 000000000..b4adddec9
--- /dev/null
+++ b/lux-scheme/source/program.lux
@@ -0,0 +1,355 @@
+(.module:
+ [lux #*
+ ["." debug]
+ ["." host (#+ import: interface: do-to object)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ [parser
+ [cli (#+ program:)]]]
+ [data
+ ["." maybe]
+ ["." error (#+ Error)]
+ [number
+ ["." i64]]
+ ["." text ("#@." hash)
+ format]
+ [collection
+ ["." array (#+ Array)]]]
+ [macro
+ ["." template]]
+ [world
+ ["." file]]
+ [target
+ ["_" scheme]]
+ [tool
+ [compiler
+ ["." name]
+ ["." synthesis]
+ [phase
+ [macro (#+ Expander)]
+ ["." generation
+ ["." scheme
+ ["." runtime]
+ ["." extension]]]]
+ [default
+ ["." platform (#+ Platform)]]]]]
+ [program
+ ["/" compositor
+ ["/." cli]]])
+
+(import: #long java/lang/Boolean)
+(import: #long java/lang/String)
+
+(import: #long (java/lang/Class a))
+
+(import: #long java/lang/Object
+ (toString [] java/lang/String)
+ (getClass [] (java/lang/Class java/lang/Object)))
+
+(import: #long java/lang/Long
+ (intValue [] java/lang/Integer))
+
+(import: #long java/lang/Integer
+ (longValue [] java/lang/Long))
+
+(import: #long gnu/math/IntNum
+ (new #manual [int])
+ (longValue [] long))
+
+(import: #long gnu/math/DFloNum
+ (doubleValue [] double))
+
+(import: #long gnu/lists/FString
+ (toString [] String))
+
+(import: #long gnu/lists/Pair
+ (getCar [] java/lang/Object)
+ (getCdr [] java/lang/Object))
+
+(import: #long (gnu/lists/FVector E)
+ (getBufferLength [] int)
+ (getRaw [int] E))
+
+(import: #long gnu/expr/ModuleMethod
+ (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object))
+
+(import: #long gnu/mapping/Environment)
+
+(import: #long gnu/expr/Language
+ (eval [java/lang/String] #try java/lang/Object))
+
+(import: #long kawa/standard/Scheme
+ (#static getR7rsInstance [] kawa/standard/Scheme))
+
+(def: (variant? value)
+ (-> Any Bit)
+ (case (host.check (Array java/lang/Object) (:coerce java/lang/Object value))
+ (#.Some array)
+ ## TODO: Get rid of this coercion ASAP.
+ (let [array (:coerce (Array java/lang/Object) array)]
+ (and (n/= 3 (array.size array))
+ (case (array.read 0 array)
+ (#.Some tag)
+ (case (host.check java/lang/Integer tag)
+ (#.Some _)
+ true
+
+ #.None
+ false)
+
+ #.None
+ false)))
+
+ #.None
+ false))
+
+(template [<name>]
+ [(interface: <name>
+ (getValue [] java/lang/Object))
+
+ (`` (import: #long (~~ (template.identifier ["program/" <name>]))
+ (getValue [] java/lang/Object)))]
+
+ [VariantValue]
+ [TupleValue]
+ )
+
+(def: (variant-value lux-value cdr? value)
+ (-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair)
+ (object [] gnu/lists/Pair [program/VariantValue]
+ []
+ ## Methods
+ (program/VariantValue
+ (getValue self) java/lang/Object
+ (:coerce java/lang/Object value))
+ (gnu/lists/Pair
+ (getCar self) java/lang/Object
+ (if cdr?
+ (case (array.read 1 value)
+ (#.Some flag-is-set)
+ (:coerce java/lang/Object "")
+
+ #.None
+ (host.null))
+ (|> value
+ (array.read 0)
+ maybe.assume
+ (:coerce java/lang/Integer)
+ gnu/math/IntNum::new)))
+ (gnu/lists/Pair
+ (getCdr self) java/lang/Object
+ (if cdr?
+ (|> value
+ (array.read 2)
+ maybe.assume
+ lux-value)
+ (variant-value lux-value true value)))))
+
+(def: (tuple-value lux-value value)
+ (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector)
+ (object [] gnu/lists/SimpleVector [program/TupleValue]
+ []
+ ## Methods
+ (program/TupleValue
+ (getValue self) java/lang/Object
+ (:coerce java/lang/Object value))
+ (gnu/lists/SimpleVector
+ (getBufferLength self) int
+ (host.long-to-int (array.size value)))
+ (gnu/lists/SimpleVector
+ (getRaw self {idx int}) java/lang/Object
+ (|> value
+ (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)))
+ maybe.assume
+ lux-value))
+ (gnu/lists/SimpleVector
+ (getBuffer self) java/lang/Object
+ (error! "tuple-value getBuffer"))
+ (gnu/lists/SimpleVector
+ (setBuffer self {_ java/lang/Object}) void
+ (error! "tuple-value setBuffer"))
+ (gnu/lists/SimpleVector
+ (clearBuffer self {_ int} {_ int}) void
+ (error! "tuple-value clearBuffer"))
+ (gnu/lists/SimpleVector
+ (copyBuffer self {_ int}) void
+ (error! "tuple-value copyBuffer"))
+ (gnu/lists/SimpleVector
+ (newInstance self {_ int}) gnu/lists/SimpleVector
+ (error! "tuple-value newInstance"))
+ ))
+
+(exception: (unknown-kind-of-host-object {object java/lang/Object})
+ (exception.report
+ ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
+ ["Object" (java/lang/Object::toString object)]))
+
+(exception: (cannot-apply-a-non-function {object java/lang/Object})
+ (exception.report
+ ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
+ ["Object" (java/lang/Object::toString object)]))
+
+(def: (lux-value value)
+ (-> java/lang/Object java/lang/Object)
+ (<| (case (host.check (Array java/lang/Object) value)
+ (#.Some value)
+ ## TODO: Get rid of the coercions below.
+ (if (variant? value)
+ (variant-value lux-value false (:coerce (Array java/lang/Object) value))
+ (tuple-value lux-value (:coerce (Array java/lang/Object) value)))
+ #.None)
+ value))
+
+(type: (Reader a)
+ (-> a (Error Any)))
+
+(def: (variant tag flag value)
+ (-> Nat Bit Any Any)
+ [(java/lang/Long::intValue (:coerce java/lang/Long tag))
+ (: Any
+ (if flag
+ synthesis.unit
+ (host.null)))
+ value])
+
+(def: (read-variant read host-object)
+ (-> (Reader java/lang/Object) (Reader gnu/lists/Pair))
+ (do error.monad
+ [tag (read (gnu/lists/Pair::getCar host-object))
+ #let [host-object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host-object))
+ flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host-object))
+ (#.Some _)
+ true
+
+ #.None
+ false)]
+ value (read (gnu/lists/Pair::getCdr host-object))]
+ (wrap (..variant (:coerce Nat tag) flag value))))
+
+(def: (read-tuple read host-object)
+ (-> (Reader java/lang/Object) (Reader (gnu/lists/FVector java/lang/Object)))
+ (let [size (.nat (gnu/lists/FVector::getBufferLength host-object))]
+ (loop [idx 0
+ output (: (Array Any)
+ (array.new size))]
+ (if (n/< size idx)
+ (case (read (gnu/lists/FVector::getRaw (.int idx) host-object))
+ (#error.Failure error)
+ (#error.Failure error)
+
+ (#error.Success lux-value)
+ (recur (inc idx) (array.write idx (: Any lux-value) output)))
+ (#error.Success output)))))
+
+(def: (read host-object)
+ (Reader java/lang/Object)
+ (`` (<| (~~ (template [<class>]
+ [(case (host.check <class> host-object)
+ (#.Some host-object)
+ (#error.Success host-object)
+ #.None)]
+
+ [java/lang/Boolean] [java/lang/String] [gnu/expr/ModuleMethod]
+ ))
+ (~~ (template [<class> <method>]
+ [(case (host.check <class> host-object)
+ (#.Some host-object)
+ (#error.Success (<method> host-object))
+ #.None)]
+
+ [gnu/math/IntNum gnu/math/IntNum::longValue]
+ [gnu/math/DFloNum gnu/math/DFloNum::doubleValue]
+ [gnu/lists/FString gnu/lists/FString::toString]
+ [program/VariantValue program/VariantValue::getValue]
+ [program/TupleValue program/TupleValue::getValue]
+ ))
+ (case (host.check gnu/lists/Pair host-object)
+ (#.Some host-object)
+ (read-variant read host-object)
+ #.None)
+ (case (host.check gnu/lists/FVector host-object)
+ (#.Some host-object)
+ (read-tuple read (:coerce (gnu/lists/FVector java/lang/Object) host-object))
+ #.None)
+ ## else
+ (exception.throw ..unknown-kind-of-host-object host-object))))
+
+(def: ensure-macro
+ (-> Macro (Maybe gnu/expr/ModuleMethod))
+ (|>> (:coerce java/lang/Object) (host.check gnu/expr/ModuleMethod)))
+
+(def: (expander macro inputs lux)
+ Expander
+ (case (ensure-macro macro)
+ (#.Some macro)
+ (case (gnu/expr/ModuleMethod::apply2 (lux-value (:coerce java/lang/Object inputs))
+ (lux-value (:coerce java/lang/Object lux))
+ macro)
+ (#error.Success output)
+ (|> output
+ ..read
+ (:coerce (Error (Error [Lux (List Code)]))))
+
+ (#error.Failure error)
+ (#error.Failure error))
+
+ #.None
+ (exception.throw ..cannot-apply-a-non-function (:coerce java/lang/Object macro)))
+ )
+
+(def: separator "$")
+
+(type: Host
+ (generation.Host _.Expression _.Expression))
+
+(def: host
+ (IO Host)
+ (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance)
+ evaluate! (function (evaluate! alias input)
+ (do error.monad
+ [output (gnu/expr/Language::eval (_.code input) interpreter)]
+ (read output)))]
+ (: Host
+ (structure
+ (def: evaluate! evaluate!)
+ (def: (execute! alias input)
+ (gnu/expr/Language::eval (_.code input) interpreter))
+ (def: (define! [module name] input)
+ (let [global (format (text.replace-all .module-separator ..separator module)
+ ..separator (name.normalize name)
+ "___" (%n (text@hash name)))
+ @global (_.var global)]
+ (do error.monad
+ [#let [definition (_.define-constant @global input)]
+ _ (gnu/expr/Language::eval (_.code definition) interpreter)
+ value (evaluate! global @global)]
+ (wrap [global value definition])))))))))
+
+(def: platform
+ (IO (Platform IO _.Var _.Expression _.Expression))
+ (do io.monad
+ [host ..host]
+ (wrap {#platform.&monad io.monad
+ #platform.&file-system file.system
+ #platform.host host
+ #platform.phase scheme.generate
+ #platform.runtime runtime.generate})))
+
+(def: (program program)
+ (-> _.Expression _.Expression)
+ (_.apply/2 program
+ ## TODO: Figure out how to always get the command-line
+ ## arguments.
+ ## It appears that it differs between Scheme implementations.
+ (runtime.lux//program-args _.nil)
+ _.nil))
+
+(program: [{service /cli.service}]
+ (/.compiler ..expander
+ ..platform
+ extension.bundle
+ ..program
+ service))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 08:48:55 +0000