aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/php/case.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/php/case.jvm.lux')
-rw-r--r--new-luxc/source/luxc/lang/translation/php/case.jvm.lux255
1 files changed, 0 insertions, 255 deletions
diff --git a/new-luxc/source/luxc/lang/translation/php/case.jvm.lux b/new-luxc/source/luxc/lang/translation/php/case.jvm.lux
deleted file mode 100644
index c438425ff..000000000
--- a/new-luxc/source/luxc/lang/translation/php/case.jvm.lux
+++ /dev/null
@@ -1,255 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data [number]
- [text]
- text/format
- (coll [list "list/" Functor<List> Fold<List>]
- (set ["set" unordered #+ Set])))
- [macro #+ "meta/" Monad<Meta>]
- (macro [code]))
- (luxc [lang]
- (lang [".L" variable #+ Register Variable]
- ["ls" synthesis #+ Synthesis Path]
- (host ["_" php #+ Expression Statement Except Var])))
- [//]
- (// [".T" runtime]
- [".T" primitive]
- [".T" reference]))
-
-(def: #export (translate-let translate register valueS bodyS)
- (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis
- (Meta Expression))
- (do macro.Monad<Meta>
- [valueO (translate valueS)
- bodyO (translate bodyS)
- #let [@register (referenceT.variable register)]]
- (wrap (|> bodyO
- (list (_.set!' @register valueO))
- _.array/*
- (_.nth (_.int 1))))))
-
-(def: #export (translate-record-get translate valueS pathP)
- (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bit])
- (Meta Expression))
- (do macro.Monad<Meta>
- [valueO (translate valueS)]
- (wrap (list/fold (function (_ [idx tail?] source)
- (let [method (if tail?
- runtimeT.product//right
- runtimeT.product//left)]
- (method source (_.int (:coerce Int idx)))))
- valueO
- pathP))))
-
-(def: #export (translate-if testO thenO elseO)
- (-> Expression Expression Expression Expression)
- (_.? testO thenO elseO))
-
-(def: @savepoint (_.var "pm_cursor_savepoint"))
-(def: @cursor (_.var "pm_cursor"))
-
-(def: (push-cursor! value)
- (-> Expression Statement)
- (_.do! (_.array-push/2 @cursor value)))
-
-(def: save-cursor!
- Statement
- (_.do! (_.array-push/2 @savepoint (_.array-slice/2 @cursor (_.int 0)))))
-
-(def: restore-cursor!
- Statement
- (_.set! @cursor (_.array-pop/1 @savepoint)))
-
-(def: cursor-top
- Expression
- (_.nth (|> @cursor _.count/1 (_.- (_.int 1)))
- @cursor))
-
-(def: pop-cursor!
- Statement
- (_.do! (_.array-pop/1 @cursor)))
-
-(def: pm-error (_.string "PM-ERROR"))
-
-(def: php-exception (_.global "Exception"))
-
-(def: (new-Exception error)
- (-> Expression Expression)
- (_.new php-exception (list error)))
-
-(def: fail-pm! (_.throw! (new-Exception pm-error)))
-
-(def: @temp (_.var "temp"))
-
-(exception: #export (Unrecognized-Path {message Text})
- message)
-
-(def: @alt-error (_.var "alt_error"))
-
-(def: (pm-catch! handler!)
- (-> Statement Except)
- {#_.class php-exception
- #_.exception @alt-error
- #_.handler (_.if! (|> @alt-error (_.send "getMessage" (list)) (_.= pm-error))
- handler!
- (_.throw! @alt-error))})
-
-(def: (translate-pattern-matching' translate pathP)
- (-> (-> Synthesis (Meta Expression)) Path (Meta Statement))
- (case pathP
- (^code ("lux case exec" (~ bodyS)))
- (do macro.Monad<Meta>
- [bodyO (translate bodyS)]
- (wrap (_.return! bodyO)))
-
- (^code ("lux case pop"))
- (meta/wrap pop-cursor!)
-
- (^code ("lux case bind" (~ [_ (#.Nat register)])))
- (meta/wrap (_.set! (referenceT.variable register) cursor-top))
-
- (^template [<tag> <format>]
- [_ (<tag> value)]
- (meta/wrap (_.when! (_.not (_.= (|> value <format>) cursor-top))
- fail-pm!)))
- ([#.Int _.int]
- [#.Bit _.bool]
- [#.Frac _.float]
- [#.Text _.string])
-
- (^template [<pm> <getter>]
- (^code (<pm> (~ [_ (#.Nat idx)])))
- (meta/wrap (push-cursor! (<getter> cursor-top (_.int (:coerce Int idx))))))
- (["lux case tuple left" runtimeT.product//left]
- ["lux case tuple right" runtimeT.product//right])
-
- (^template [<pm> <flag>]
- (^code (<pm> (~ [_ (#.Nat idx)])))
- (meta/wrap (|> (_.set! @temp (runtimeT.sum//get cursor-top (_.int (:coerce Int idx)) <flag>))
- (_.then! (_.if! (_.is-null/1 @temp)
- fail-pm!
- (push-cursor! @temp))))))
- (["lux case variant left" _.null]
- ["lux case variant right" (_.string "")])
-
- (^code ("lux case seq" (~ leftP) (~ rightP)))
- (do macro.Monad<Meta>
- [leftO (translate-pattern-matching' translate leftP)
- rightO (translate-pattern-matching' translate rightP)]
- (wrap (|> leftO
- (_.then! rightO))))
-
- (^code ("lux case alt" (~ leftP) (~ rightP)))
- (do macro.Monad<Meta>
- [leftO (translate-pattern-matching' translate leftP)
- rightO (translate-pattern-matching' translate rightP)]
- (wrap (_.try! (|> save-cursor!
- (_.then! leftO))
- (list (pm-catch!
- (|> restore-cursor!
- (_.then! rightO)))))))
-
- _
- (lang.throw Unrecognized-Path (%code pathP))
- ))
-
-(def: (translate-pattern-matching translate pathP)
- (-> (-> Synthesis (Meta Expression)) Path (Meta Statement))
- (do macro.Monad<Meta>
- [pattern-matching (translate-pattern-matching' translate pathP)]
- (wrap (_.try! pattern-matching
- (list (pm-catch!
- (_.throw! (new-Exception (_.string "Invalid expression for pattern-matching.")))))))))
-
-(def: (initialize-pattern-matching! stack-init)
- (-> Expression Statement)
- (|> (_.set! @cursor (_.array/* (list stack-init)))
- (_.then! (_.set! @savepoint (_.array/* (list))))))
-
-(def: empty (Set Variable) (set.new number.Hash<Int>))
-
-(type: Storage
- {#bindings (Set Variable)
- #dependencies (Set Variable)})
-
-(def: (path-variables pathP)
- (-> Path Storage)
- (loop [pathP pathP
- outer-variables {#bindings empty
- #dependencies empty}]
- ## TODO: Remove (let [outer recur]) once loops can have names.
- (let [outer recur]
- (case pathP
- (^code ("lux case bind" (~ [_ (#.Nat register)])))
- (update@ #bindings (set.add (.int register))
- outer-variables)
-
- (^or (^code ("lux case seq" (~ leftP) (~ rightP)))
- (^code ("lux case alt" (~ leftP) (~ rightP))))
- (list/fold outer outer-variables (list leftP rightP))
-
- (^code ("lux case exec" (~ bodyS)))
- (loop [bodyS bodyS
- inner-variables outer-variables]
- ## TODO: Remove (let [inner recur]) once loops can have names.
- (let [inner recur]
- (case bodyS
- (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS)))
- (inner valueS inner-variables)
-
- (^code [(~+ members)])
- (list/fold inner inner-variables members)
-
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (if (set.member? (get@ #bindings inner-variables) var)
- inner-variables
- (update@ #dependencies (set.add var) inner-variables))
-
- (^code ("lux call" (~ functionS) (~+ argsS)))
- (list/fold inner inner-variables (#.Cons functionS argsS))
-
- (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS)))
- (|> environment
- (list/map (|>> (list) code.form))
- (list/fold inner inner-variables))
-
- (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS)))
- (list/fold inner (update@ #bindings (set.add (.int register))
- inner-variables)
- (list inputS exprS))
-
- (^code ("lux case" (~ inputS) (~ pathPS)))
- (|> inner-variables (inner inputS) (outer pathPS))
-
- (^code ((~ [_ (#.Text procedure)]) (~+ argsS)))
- (list/fold inner inner-variables argsS)
-
- _
- inner-variables)))
-
- _
- outer-variables))))
-
-(def: generated-name
- (-> Text (Meta Text))
- (|>> macro.gensym
- (:: macro.Monad<Meta> map (|>> %code lang.normalize-name))))
-
-(def: #export (translate-case translate valueS pathP)
- (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression))
- (do macro.Monad<Meta>
- [valueO (translate valueS)
- @case (:: @ map _.global (generated-name "case"))
- @value (:: @ map _.var (generated-name "value"))
- #let [@dependencies+ (|> (path-variables pathP)
- (get@ #dependencies)
- set.to-list
- (list/map referenceT.local))]
- pattern-matching! (translate-pattern-matching translate pathP)
- _ (//.save (_.function! @case (|> (list& @value @dependencies+)
- (list/map _.parameter))
- (|> (initialize-pattern-matching! @value)
- (_.then! pattern-matching!))))]
- (wrap (_.apply (list& valueO @dependencies+) @case))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 03:52:54 +0000