Desugaring control flow to letCC

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))]