tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

project.tri (5095B)

      1 !import prelude *
      2 !import consumers_structural as S
      3 !import consumers_lowerings_specialize as P
      4 !export *
      5 -- Experimental capture-free rule lowering. The static environment contains
      6 -- accessors; runtime context is (input,state), extended only by Call results.
      7 
      8 checkStem inner value = triage false (child : inner child) (_ _ : false) value
      9 checkFork left right value = triage false (_ : false) (a b : lazyBool (_ : right b) (_ : false) (left a)) value
     10 checkPattern_ self pattern = matchPair (tag payload :
     11   lazyBool (_ : value : true)
     12     (_ : lazyBool (_ : value : triage true (_ : false) (_ _ : false) value)
     13       (_ : lazyBool (_ : checkStem (self payload))
     14         (_ : lazyBool (_ : matchPair (left right : checkFork (self left) (self right)) payload)
     15           (_ : lazyBool (_ : value : true)
     16             (_ : lazyBool (_ : value : equal? payload value)
     17               (_ : lazyBool (_ : self (snd payload))
     18                 (_ : value : false) (equal? tag 6)) (equal? tag 5)) (equal? tag 4)) (equal? tag 3)) (equal? tag 2)) (equal? tag 1)) (equal? tag 0)) pattern
     19 checkPattern pattern = y checkPattern_ pattern
     20 
     21 -- These projections are executed only after both patterns have matched.
     22 projectStem get context = triage t (child : child) (_ _ : t) (get context)
     23 projectLeft get context = fst (get context)
     24 projectRight get context = snd (get context)
     25 accessors_ self pattern get env = matchPair (tag payload :
     26   lazyBool (_ : self payload (projectStem get) env)
     27     (_ : lazyBool (_ : matchPair (left right : self right (projectRight get) (self left (projectLeft get) env)) payload)
     28       (_ : lazyBool (_ : pair (pair payload get) env)
     29         (_ : lazyBool (_ : matchPair (slot child : self child get (pair (pair slot get) env)) payload)
     30           (_ : env) (equal? tag 6)) (equal? tag 4)) (equal? tag 3)) (equal? tag 2)) pattern
     31 accessors pattern get env = y accessors_ pattern get env
     32 getCapture_ self env slot = lazyList (_ : context : err "unknown capture" t) (entry rest : lazyBool (_ : context : ok ((snd entry) context) t) (_ : self rest slot) (equal? (fst entry) slot)) env
     33 getCapture env slot = y getCapture_ env slot
     34 liftAccessor entry = pair (fst entry) (context : (snd entry) (snd context))
     35 returnEnv slot env = pair (pair slot fst) (map liftAccessor env)
     36 
     37 callOutput worker input receiver context recur invoke = bindResult (worker context recur invoke) (target _ : bindResult (input context recur invoke) (argument _ : bindResult (invoke target argument (fst target)) (returned _ : receiver (pair returned context) recur invoke)))
     38 linkedCall worker input receiver context recur invoke = bindResult (input context recur invoke) (argument _ : bindResult (P.runDirect worker argument) (returned _ : receiver (pair returned context) recur invoke))
     39 output_ self output env = matchPair (tag payload :
     40   lazyBool (_ : context recur invoke : ok payload t)
     41     (_ : lazyBool (_ : context recur invoke : getCapture env payload context)
     42       (_ : lazyBool (_ : matchPair (left right : P.compiledForkOutput (self left env) (self right env)) payload)
     43         (_ : lazyBool (_ : matchPair (input state : P.compiledRecurOutput (self input env) (self state env)) payload)
     44           (_ : lazyBool (_ : matchPair (worker more : matchPair (input continuation : matchPair (slot receiver :
     45             lazyBool (_ : linkedCall (snd worker) (self input env) (self receiver (returnEnv slot env)))
     46               (_ : callOutput (self worker env) (self input env) (self receiver (returnEnv slot env))) (equal? (fst worker) 0)) continuation) more) payload)
     47             (_ : lazyBool (_ : P.compiledStemOutput (self payload env))
     48               (_ : lazyBool (_ : matchPair (worker more : matchPair (input state :
     49                 lazyBool (_ : P.linkedBecome (snd worker) (self input env) (self state env))
     50                   (_ : P.compiledBecomeOutput (self worker env) (self input env) (self state env)) (equal? (fst worker) 0)) more) payload)
     51                 (_ : lazyBool (_ : matchPair (left right : P.compiledEqualOutput (self left env) (self right env)) payload)
     52                   (_ : context recur invoke : err "unknown output form" t) (equal? tag 8)) (equal? tag 6)) (equal? tag 5)) (equal? tag 4)) (equal? tag 3)) (equal? tag 2)) (equal? tag 1)) (equal? tag 0)) output
     53 output template env = y output_ template env
     54 branch inputCheck stateCheck emit fallback input state recur invoke = lazyBool (_ : lazyBool (_ : emit (pair input state) recur invoke) (_ : fallback input state recur invoke) (stateCheck state)) (_ : fallback input state recur invoke) (inputCheck input)
     55 rules_ self rules = lazyList (_ : input state recur invoke : err "no matching consumer rule" t) (rule rest : matchPair (inputPattern more : matchPair (statePattern template : branch (checkPattern inputPattern) (checkPattern statePattern) (output template (accessors statePattern snd (accessors inputPattern fst t))) (self rest)) more) rule) rules
     56 compile program = S.makeConsumer (fst program) (y rules_ (snd program))
     57 compileBound program state = bindResult (P.bindState program state) (bound _ : ok (compile bound) t)