Skip to content

Instantly share code, notes, and snippets.

@dbp

dbp/desugar-control.rkt

Created January 3, 2013 18:29
Show Gist options
  • Save dbp/4445687 to your computer and use it in GitHub Desktop.
Save dbp/4445687 to your computer and use it in GitHub Desktop.
Download ZIP
Desugaring control flow to letCC
Raw
desugar-control.rkt
;; Control flow
;; basically, we provide a shadowed '^throw continuation, and then see what
;; we are handed. if it is an error (ie, an exception), we see if it matches
;; what we are catching, and if it doesn't, we re-throw. Since we are out of
;; scope of the current try/catch, we will now pick up whatever exception
;; continuation is outside. note that this obviously requires the entire program
;; to be wrapped in a try/catch that matches on everything (which it is).
[CTry
(bdy mat cat els)
;(ULet '^escape (UId '^throw) ;; debugging infinite throw loop
(ULet '^rv
(ULetCC '^throw
(desugar-core-inner bdy))
(UIf (UPrim2 'equal (UPrim1 'ty (UId '^rv)) (UStr "error"))
(UIf (UApp (UApp (desugar-core-inner mat) (UId '^throw)) (UPrim1 'err-v (UId '^rv)))
(ULet '^exn (UPrim1 'err-v (UId '^rv))
(desugar-core-inner cat))
(UApp (UId '^throw) (UId '^rv)))
;; this is done in racket intentionally. we don't want something that
;; eventually evaluates to pass (ie none), but it to be syntactically CPass
(type-case CExp els
[CPass () (UId '^rv)]
[else (desugar-core-inner els)])))]
[CRaise (e) (UApp (UId '^throw) (UError (desugar-core-inner e)))]
;; while loops desugar into recursion, with the added break and continue continuations
[CWhile (cnd bdy)
(ULetCC '^break
(ULet '^loop (UNone)
(USeq (USet '^loop
(UFn '_
(UIf (desugar-core-inner cnd)
(USeq (ULetCC '^continue
(desugar-core-inner bdy))
(UApp (UId '^loop) (UNone)))
(UNone))))
(UApp (UId '^loop) (UNone)))))]
[CBreak () (UApp (UId '^break) (UNone))]
[CContinue () (UApp (UId '^continue) (UNone))]
;; early return is handled by binding a return continuation inside functions
[CFn (args body)
(foldr (lambda (arg exp) (UFn arg exp))
(ULetCC '^ret (desugar-core-inner body))
(cons '^throw args))]
[CRet (v) (UApp (UId '^ret) (desugar-core-inner v))]
[CGen
(args body)
(foldr
;; we create a function that returns a generator with the arguments in scope
(lambda (arg exp) (UFn arg exp))
(UMap
(make-hash
(list
(pair (UStr "next")
(ULet '^where-to-go (UUnbound)
(ULet '^resumer (UUnbound)
(ULet 'throwk (UUnbound)
(ULet 'yield (UUnbound)
(USeq
(USet 'yield
(UFn '^throw
(UFn '^v
(ULetCC
'^gen-k
(USeq (USet '^resumer #|(UFn '^throw|# (UId '^gen-k))
(USeq
(UPrim1 'print (UStr ""))
(UApp #|(UApp|# (UId '^where-to-go) #|(UId '^throw))|# (UId '^v))))))))
(USeq
(USet '^resumer
#|(UFn
'^throw|#
(UFn
'^v ;; value is ignored
(ULet
'^throw (UId 'throwk)
(USeq
(USeq (UPrim1 'print (UStr ""))
(desugar-core-inner body))
(USeq (UPrim1 'print (UStr ""))
(desugar-core-inner (CRaise (CId 'StopIteration))))))))
(UFn
'^throw
(UFn 'self
(ULetCC
'^dyn-k
(USeq
(USeq (UPrim1 'print (UStr ""))
(USeq (USet 'throwk (UId '^throw))
(USet '^where-to-go #|(UFn '^throw|# (UId '^dyn-k))))
(UApp #|(UApp|# (UId '^resumer) #|(UId '^throw))|# (UNone)))))))))))))
(pair (UStr "^type")
(UStr "generator"))
(pair (UStr "__iter__")
(UFn '^throw (UFn 'self (UId 'self)))))))
(cons '^throw args))]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment