goto.ml

open Printf

exception Goto of string

let label (name: string) = ()
let goto (name: string) = raise (Goto name)

let goto_block (blocks: (string * (unit -> unit)) list): unit =
  let rec goto_block_impl (name: string option): unit =
    try
      let exec (blocks: (string * (unit -> unit)) list): unit =
        blocks |> List.iter (fun (_, block) -> block ())
      in
      let rec skip (blocks: (string * (unit -> unit)) list) (entry: string) =
        match blocks with
        | [] -> ()
        | (name, _) :: rest ->
           if String.equal name entry
           then exec blocks
           else skip rest entry
      in
      match name with
      | None -> exec blocks
      | (Some entry) -> skip blocks entry
    with
      Goto name -> goto_block_impl (Some name)
  in goto_block_impl None

let () =
  let i = ref 0 in
  goto_block
    [("loop", (fun () ->
        if !i >= 10 then goto "out" else ();
        printf "%d: Hello, World\n" !i;
        i := !i + 1;
        goto "loop"));
     ("out", (fun () ->
        printf "Done!\n"))]

Hello, I was thinking of defining labels as mutually recursive functions. The downside is that goto calls have to be tail calls, hence the begin/end block for the else.

let goto f = f ()

let () =

    let rec entry_point () =
        goto loop

    and i = ref 0

    and loop () =
        if !i >= 10 then
            goto out
        else begin
            Printf.printf "%d: Hello, World\n" !i;
            i := !i + 1;
            goto loop;
        end

    and out () =
        print_endline "Done!"

    in goto entry_point

My other idea was to define a binding operator to do the try/with but jumping forward doesn't work :

exception Goto of string

let rec (let*) label body =
    try body ()
    with
    | Goto l when l = label -> let* _ = label in body ()
    | Goto l -> () (* What to do here ? *) 


let goto label : unit =
    raise (Goto label)

let () =
    let i = ref 0 in

    let* _ = "loop" in


    if !i >= 10 then 
        (* Doesn't work since Goto "out" isn't caught correctly,
            the main function returns here *)
        goto "out";

    Printf.printf "%d: Hello, World\n" !i;
    i := !i + 1;
    goto "loop";

    let* _ = "out" in
    print_endline "stop";

Something

@scouarn 🥇 (I don't know why GitHub doesn't allow reactions on Gist comments 🦜)

I tried porting this to haskell and, as you would expect, it worked just fine.

{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Control.Exception (Exception, throw, try)
import Control.Monad (when)
import Data.Foldable (find, for_)
import Data.IORef (newIORef, readIORef, modifyIORef)

main :: IO ()
main = do
  iRef <- newIORef 0
  runGoTo 
    [ ("loop", do
        i <- readIORef iRef
        when (i >= 10) $ goto "done"
        print i
        modifyIORef iRef (+ 1)
        goto "loop")
    , ("done", putStrLn "DONE")]

newtype GoTo = GoTo String deriving (Show)
instance Exception GoTo

goto :: String -> IO ()
goto label = throw (GoTo label)

runGoTo :: [(String, IO ())] -> IO ()
runGoTo blocks = do
  result :: Either GoTo () <- try $ for_ blocks snd
  case result of
    Left (GoTo label) -> case find ((== label) . fst) blocks of
      Just (_, block) -> runGoTo (dropWhile ((/= label) . fst) blocks)
      Nothing -> error $ "Label not found: " <> label
    Right () -> return ()

Guys, I tested a for loop of an object inside a block, and a normal function with a for loop. Any idea why the loop inside the goto_block mechanism always much faster?

Hi there ! I don't understand why do you iterate for each function of blocks , you can simply just run the first one ?

let exec (blocks: (string * (unit -> unit)) list): unit =
        match blocks with
        | [] -> ()
        | (_,foo) :: _ -> foo ()