Initial commit

4 years ago · 6639992685
--- a/assemble.ml
+++ b/assemble.ml
@ -0,0 +1,52 @@
 include import "./compile.ml"
 open import "prelude.ml"
 open import "lua/io.ml"

 let resolve_addr = function
 | Combinator n -> n ^ "_combinator"
 | Arg i -> "stack[sp - " ^ show (i + 1) ^ "][3]"

 let gm2lua = function
 | Push addr -> " stack[sp + 1] = " ^ resolve_addr addr ^ "; sp = sp + 1"
 | Pop n -> " sp = sp - " ^ show n
 | Update n -> " stack[sp - " ^ show (n + 1) ^ "] = { I, stack[sp] }; sp = sp - 1"
 | Mkap -> " stack[sp - 1] = { A, stack[sp - 1], stack[sp] }; sp = sp - 1"
 | Unwind -> " return unwind()"

 let compute_local_set xs =
 let rec go i (s : S.t string) = function
 | Cons ((name, _, _), xs) ->
 if i >= 100 then
 s
 else
 go (i + 2) (S.insert name (S.insert (name ^ "_combinator") s)) xs
 | Nil -> s
 go 1 S.empty xs

 let sc2lua (name, arity, body) =
 let body =
 body
 |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function()\n")
 |> (^ "end")
 let dec =
 name ^ "_combinator = { F, " ^ name ^ ", " ^ show arity ^ ", " ^ show name ^ " };"
 body ^ "\n" ^ dec

 let preamble =
 let f = open_for_reading "preamble.lua"
 let x = read_all f
 close_file f
 match x with
 | Some s -> s
 | None -> error "no preamble.lua"

 let assm_program decs =
 match decs with
 | [] -> error "empty program"
 | _ ->
 let Cons (local1, locals) =
 compute_local_set decs |> S.members
 let local_decs =
 foldl (fun x v -> x ^ ", " ^ v) ("local " ^ local1) locals
 let body = foldl (fun x s -> x ^ sc2lua s ^ "\n") "" decs
 preamble ^ local_decs ^ "\n" ^ body ^ "stack[sp] = { A, main_combinator, 0 }; unwind()"
--- a/compile.ml
+++ b/compile.ml
@ -0,0 +1,105 @@
 module M = import "data/map.ml"
 module S = import "data/set.ml"

 open import "prelude.ml"
 open import "./lang.ml"
 open import "./lib/monads.ml"

 type addr =
 | Combinator of string
 | Arg of int

 type gm_code =
 | Push of addr
 | Update of int
 | Pop of int
 | Unwind
 | Mkap

 instance show gm_code begin
 let show = function
 | Mkap -> "Mkap"
 | Unwind -> "Unwind"
 | Push (Combinator k) -> "Push " ^ k
 | Push (Arg i) -> "Arg " ^ show i
 | Update n -> "Update " ^ show n
 | Pop n -> "Pop " ^ show n
 end

 let rec lambda_lift = function
 | Ref v -> pure (Ref v)
 | App (f, x) -> (| app (lambda_lift f) (lambda_lift x) |)
 | Lam (v, x) ->
 let! body = lambda_lift x
 let! (i, defs, known_sc) = get

 let vars =
 x |> free_vars
 |> S.delete v
 |> flip S.difference known_sc
 |> S.members

 let def = ("Lam" ^ show i, vars ++ [v], body)
 let app = foldl (fun f -> app f # Ref) (Ref ("Lam" ^ show i)) vars

 put (i + 1, Decl def :: defs, known_sc)
 |> map (const app)
 | Case (sc, alts) ->
 alts
 |> map (fun (_, x) -> x)
 |> foldl app sc
 |> lambda_lift

 let rec eta_contract = function
 | Decl (n, a, e) as dec ->
 match a, e with
 | [], _ -> dec
 | xs, App (f, Ref v) ->
 if v == last xs && not (S.member v (free_vars f)) then
 eta_contract (Decl (n, init a, f))
 else
 dec
 | _, _ -> dec
 | Data c -> Data c

 let rec lambda_lift_sc = function
 | Decl (n, a, e) ->
 match e with
 | Lam (v, e) -> lambda_lift_sc (Decl (n, a ++ [v], e))
 | _ ->
 let! e = lambda_lift e
 let! _ = modify (fun (a, b, s) -> (a, b, S.insert n s))
 pure (Decl (n, a, e))
 | Data c -> Data c |> pure

 type dlist 'a <- list 'a -> list 'a

 let rec compile (env : M.t string int) = function
 | Ref v ->
 match M.lookup v env with
 | Some i -> (Push (Arg i) ::)
 | None -> (Push (Combinator v) ::)

 | App (f, x) ->
 let f = compile env f
 let x = compile (map (1 +) env) x
 f # x # (Mkap ::)

 | Lam _ -> error "Can not compile lambda expression, did you forget to lift?"
 | Case _ -> error "Can not compile case expression, did you forget to lift?"

 let supercomb (_, args, exp) =
 let env = M.from_list (zip args [0..length args])
 let k = compile (M.from_list (zip args [0..length args])) exp
 k [Update (length env), Pop (length env), Unwind]

 let known_scs = S.from_list [ "getchar", "putchar" ]

 let program decs =
 let (decs, (_, lams, _)) =
 run_state (traverse (lambda_lift_sc # eta_contract) decs) (0, [], known_scs)
 flip map (lams ++ decs) @@ function
 | Decl ((nm, args, _) as sc) ->
 let code = supercomb sc
 (nm, length args, code)
 | Data _ -> error "data declaration in compiler"
--- a/driver.ml
+++ b/driver.ml
@ -0,0 +1,50 @@
 module C = import "./compile.ml"
 module A = import "./assemble.ml"
 open import "./parser.ml"
 open import "prelude.ml"
 open import "lua/io.ml"

 let go infile outfile =
 let infile = open_for_reading infile
 let outfile = open_file outfile Write_m
 match read_all infile with
 | Some str ->
 match lex prog str with
 | Right (ds, _) ->
 ds
 |> ds_prog
 |> C.program
 |> A.assm_program
 |> write_bytes outfile
 | Left e -> print e
 | _ -> ()
 close_file infile
 close_file outfile

 let test str =
 match lex prog str with
 | Right (ds, _) ->
 ds
 |> ds_prog
 |> C.program
 |> A.assm_program
 |> put_line
 | Left e -> print e

 let test_file infile =
 let infile = open_for_reading infile
 match read_all infile with
 | Some str -> test str
 | None -> ()
 close_file infile


 external val args : string * string =
 "{ _1 = select(1, ...), _2 = select(2, ...) }"
 external val has_args : bool = "select('#', ...) ~= 0"

 let () =
 if has_args then
 let (from, into) = args
 go from into
 else ()
--- a/lang.ml
+++ b/lang.ml
@ -0,0 +1,69 @@
 open import "prelude.ml"
 module S = import "data/set.ml"
 module M = import "data/map.ml"

 type expr =
 | Ref of string
 | App of expr * expr
 | Lam of string * expr
 | Case of expr * list (string * expr)

 let app = curry App
 let lam = curry Lam

 let rec free_vars = function
 | Ref v -> S.singleton v
 | App (f, x) -> S.union (free_vars f) (free_vars x)
 | Lam (v, x) -> v `S.delete` free_vars x
 | Case (e, bs) ->
 bs
 |> map (fun (_, e) -> free_vars e)
 |> foldl S.union S.empty
 |> S.union (free_vars e)

 let rec subst m = function
 | Ref v ->
 match M.lookup v m with
 | Some s -> s
 | None -> Ref v
 | App (f, x) -> App (subst m f, subst m x)
 | Lam (v, x) -> Lam (v, subst (M.delete v m) x)
 | Case (e, xs) -> Case (subst m e, map (second (subst m)) xs)

 type hstype =
 | Tycon of string
 | Tyvar of string
 | Tyapp of hstype * hstype

 type constr = Constr of string * list hstype

 type decl =
 | Decl of string * list string * expr
 | Data of string * list string * list constr

 type prog <- list decl

 let rec xs !! i =
 match xs, i with
 | Cons (x, _), 0 -> x
 | Cons (_, xs), i when i > 0 -> xs !! (i - 1)
 | _, _ -> error "empty list and/or negative index"

 let ds_data (_, _, cs) =
 let ncons = length cs
 let alts = map (("c" ^) # show) [1..ncons]
 let ds_con i (Constr (n, args)) =
 let arity = length args
 let alt = alts !! i
 let args = map (("x" ^) # show) [1..arity]
 Decl (n, args, foldr lam (foldl app (Ref alt) (map Ref args)) alts)
 let rec go i = function
 | [] -> []
 | Cons (x, xs) -> ds_con i x :: go (i + 1) xs
 go 0 cs

 let ds_prog prog =
 let! c = prog
 match c with
 | Data c -> ds_data c
 | Decl (n, args, e) -> [Decl (n, args, e)]
--- a/lexer.ml
+++ b/lexer.ml
@ -0,0 +1,133 @@
 include import "./lib/parsers.ml"
 open import "prelude.ml"

 let lex = run_parser

 let line_comment () =
 let! _ = symbol "--"
 let rec go =
 let! x = map (const "\n") eof <|> char
 if x == "\n" then
 pure ()
 else
 go
 go

 let whitepiece : forall 'm. monad 'm => parser_t 'm () =
 (try (void @@ one_of " \n\v\t\r") <|> try (line_comment ()))
 <?> "white space"

 let whitespace : forall 'm. monad 'm => parser_t 'm () =
 void (many whitepiece)

 let lexeme p =
 let! _ = whitespace
 p

 let oparen : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "(")
 let cparen : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ")")
 let comma : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ",")
 let semi : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ";")
 let osquare : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "[")
 let csquare : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "]")
 let obrace : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "{")
 let cbrace : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "}")
 let back : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "\\")
 let arrow : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "->")
 let darrow : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "=>")
 let equals : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "=")
 let pipe : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "|")

 let small : forall 'm. monad 'm => parser_t 'm string =
 try (satisfy (fun c -> "a" <= c && c <= "z") <|> symbol "_") <?> "small letter"

 let big : forall 'm. monad 'm => parser_t 'm string =
 try (satisfy (fun c -> "A" <= c && c <= "Z")) <?> "big letter"

 let iskw = function
 | "case"
 | "class"
 | "data"
 | "default"
 | "deriving"
 | "do"
 | "else"
 | "if"
 | "import"
 | "in"
 | "infix"
 | "infixl"
 | "infixr"
 | "instance"
 | "let"
 | "module"
 | "newtype"
 | "of"
 | "then"
 | "type"
 | "where"
 | "_" -> true
 | _ -> false

 let isreserved = function
 | "=" | "=>" | "->" | "|" -> true
 | _ -> false

 let varid : forall 'm. monad 'm => parser_t 'm string =
 flip (<?>) "variable name" # lexeme @@
 let! c = small
 let! cs =
 many_fold (^) "" (small <|> big <|> try (symbol "'"))
 <|> pure ""
 let id = c ^ cs
 if iskw id then
 unexpected id
 else
 pure id

 let conid : forall 'm. monad 'm => parser_t 'm string =
 flip (<?>) "constructor name" # lexeme @@
 let! c = big
 let! cs =
 many_fold (^) "" (small <|> big <|> try (symbol "'"))
 <|> pure ""
 pure (c ^ cs)

 let tyvar = varid
 let tycon = conid
 let tycls = conid

 let keyword c = lexeme (symbol c) <?> "``" ^ c ^ "''"

 let operator : forall 'm. monad 'm => parser_t 'm string =
 flip (<?>) "operator" # lexeme @@
 let! c = one_of "!#$%&*+./<=>?@\\^|-~"
 let! cs = many_fold (^) "" (one_of ":!#$%&*+./<=>?@\\^|-~")
 let op = c ^ cs
 if isreserved op then
 unexpected op
 else
 pure op

 let digit : forall 'm. monad 'm => parser_t 'm string =
 satisfy (fun c -> "0" <= c && c <= "9") <?> "digit"

 let hexit : forall 'm. monad 'm => parser_t 'm string =
 digit
 <|> satisfy (fun c -> "a" <= c && c <= "f")
 <|> satisfy (fun c -> "A" <= c && c <= "F")

 let integer : forall 'm. monad 'm => parser_t 'm int =
 let decimal =
 let! c = digit
 let! cs = many_fold (^) "" digit
 pure (c ^ cs)
 let hexadecimal =
 let! _ = symbol "0x"
 let! c = hexit
 let! cs = many_fold (^) "" hexit
 pure ("0x" ^ c ^ cs)
 let! c = (try hexadecimal <|> decimal) <?> "hex or decimal integer"
 match parse_int c with
 | None -> error "no parse"
 | Some x -> pure x
--- a/lib/monads.ml
+++ b/lib/monads.ml
@ -0,0 +1,42 @@
 open import "prelude.ml"

 type identity 'a = Id of 'a

 instance functor identity begin
 let f <$> Id x = Id (f x)
 end

 instance applicative identity begin
 let pure = Id
 let Id f <*> Id x = Id (f x)
 end

 instance monad identity begin
 let Id x >>= f = f x
 end

 type state 's 'a = State of 's -> 'a * 's

 let run_state (State k) = k

 instance functor (state 's) begin
 let f <$> State x = State (first f # x)
 end

 instance applicative (state 's) begin
 let pure x = State (x,)
 let State f <*> State x = State @@ fun s ->
 let (f, s) = f s
 let (x, s) = x s
 (f x, s)
 end

 instance monad (state 's) begin
 let State x >>= f = State @@ fun s ->
 let (x, s) = x s
 run_state (f x) s
 end

 let get = State (fun s -> (s, s))
 let put x = State (fun _ -> ((), x))
 let modify f = State (fun s -> ((), f s))
--- a/lib/parsers.ml
+++ b/lib/parsers.ml
@ -0,0 +1,232 @@
 open import "prelude.ml"
 open import "./monads.ml"

 private type consumed = C | E

 private type error = Unexpected of string * list string

 instance show error begin
 let show = function
 | Unexpected (s, []) -> s
 | Unexpected (s, ms) ->
 "Unexpected " ^ s ^ "\n"
 ^ "Expecting one of " ^ foldl (^) "" ms
 end

 private type result 'a =
 | Ok of consumed * 'a * string
 | Err of consumed * error * string

 let join_consumed x y =
 match x with
 | C -> C
 | E -> y

 type parser_t 'm 'a = private P of string -> 'm (result 'a)
 type parser <- parser_t identity

 instance functor 'm => functor (parser_t 'm) begin
 let f <$> P x = P @@ fun i ->
 flip map (x i) @@ fun p ->
 match p with
 | Ok (c, x, i) -> Ok (c, f x, i)
 | Err e -> Err e
 end

 instance monad 'm => applicative (parser_t 'm) begin
 let pure x = P (fun s -> pure (Ok (E, x, s)))
 let P f <*> P x = P @@ fun s ->
 let! f = f s
 match f with
 | Ok (c, f, s) ->
 let! x = x s
 match x with
 | Ok (c', x, s) -> pure @@ Ok (join_consumed c c', f x, s)
 | Err (c', p) -> pure @@ Err (join_consumed c c', p)
 | Err e -> pure @@ Err e
 end

 let x *> y = (fun _ x -> x) <$> x <*> y
 let x <* y = (| const x y |)

 instance monad 'm => monad (parser_t 'm) begin
 let P x >>= f = P @@ fun s ->
 let! x = x s
 match x with
 | Ok (c, x, s) ->
 let P kont = f x
 let! x = kont s
 match x with
 | Ok (c', x, s) -> pure @@ Ok (join_consumed c c', x, s)
 | Err (c', p) -> pure @@ Err (join_consumed c c', p)
 | Err e -> pure @@ Err e
 end

 let private fail e = P (fun s -> pure (Err (E, e, s)))

 let empty : forall 'm 'a. monad 'm => parser_t 'm 'a =
 fail (Unexpected ("empty parse", []))

 let unexpected e =
 fail (Unexpected (e, []))

 let alt_err (Unexpected (u, xs)) (Unexpected (_, ys)) =
 Unexpected (u, xs ++ ys)

 let P x <|> P y = P @@ fun s ->
 let! x = x s
 match x with
 | Ok x -> pure (Ok x)
 | Err (c, m, s) ->
 let! y = y s
 match y with
 | Ok (c', x, s) -> pure (Ok (join_consumed c c', x, s))
 | Err (c', m', s) -> pure (Err (join_consumed c c', alt_err m m', s))

 let P x <+> y = P @@ fun s ->
 let! x = x s
 match x with
 | Ok x -> pure (Ok x)
 | Err (c, m, s) ->
 let P y = force y
 let! y = y s
 match y with
 | Ok (c', x, s) -> pure (Ok (join_consumed c c', x, s))
 | Err (c', m', s) -> pure (Err (join_consumed c c', alt_err m m', s))

 private module S = import "lua/string.ml"

 let char : forall 'm. applicative 'm => parser_t 'm string =
 P @@ fun s ->
 let x = S.substring s 1 1
 if x <> "" then
 let r = S.substring s 2 (S.length s)
 pure @@ Ok (C, x, r)
 else
 pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s)

 let eof : forall 'm. applicative 'm => parser_t 'm () =
 P @@ fun s ->
 if s == "" then
 pure @@ Ok (E, (), s)
 else
 pure @@ Err (E, Unexpected (S.substring s 1 1, ["end-of-file"]), s)

 let satisfy p = P @@ fun s ->
 let x = S.substring s 1 1
 if x <> "" && p x then
 pure @@ Ok (C, x, S.substring s 2 (S.length s))
 else
 let m =
 if x == "" then
 "end of file"
 else x
 pure @@ Err (E, Unexpected (m, ["character"]), s)

 let P k <?> m = P @@ fun s ->
 let! x = k s
 match x with
 | Ok e -> pure (Ok e)
 | Err (c, Unexpected (u, _), s) -> pure (Err (c, Unexpected (u, [m]), s))

 let many_fold k z (P x) =
 let rec go consumed kont s =
 let! x = x s
 match x with
 | Err ((c, _, s) as p) ->
 match c with
 | C -> pure (Err p)
 | E -> kont consumed z s
 | Ok (c, x, s) ->
 match c with
 | E -> error @@ "many: got parser that accepts the empty string"
 | C -> go C (fun c -> kont c # k x) s
 P (go E (fun c z s -> pure (Ok (c, z, s))))

 let many p = many_fold (::) [] p
 let some p =
 let! x = p
 (x ::) <$> many p

 let sep_by_1 sep p =
 let! x = p
 let! xs = many (sep *> p)
 pure (x :: xs)

 let sep_by sep p = sep_by_1 sep p <|> pure []
 external private val is_infix_of : string -> string -> bool =
 "function(s, s2) return s2:find(s) ~= nil end"

 external private val is_prefix_of : string -> string -> bool =
 "function(s, s2) return (s2:find(s)) == 1 end"

 let one_of chs =
 let len = S.length chs
 let rec loop ch i =
 if i > len then
 fail @@ Unexpected (ch, ["one of \"" ^ chs ^ "\""])
 else if ch == S.substring chs i i then
 pure ch
 else
 loop ch (i + 1)
 let! ch = char
 loop ch 1

 let symbol str =
 let len = S.length str
 let rec loop acc i =
 if i > len then
 pure acc
 else
 let! c = char <?> S.substring str i i
 if c == S.substring str i i then
 loop (acc ^ c) (i + 1)
 else
 fail @@ Unexpected (acc ^ c, [S.substring str 1 i])
 loop "" 1

 let between o c p =
 let! _ = o
 let! x = p
 let! _ = c
 pure x

 let try (P x) = P @@ fun s ->
 let! x = x s
 match x with
 | Ok c -> pure (Ok c)
 | Err (_, p, _) -> pure (Err (E, p, s))

 let optionally p = map Some (try p) <|> pure None


 let rec sep_end_by_1 sep p =
 let! x = p
 ( let! _ = sep
 let! xs = sep_end_by sep p
 pure (x :: xs)
 ) <|> pure [x]
 and sep_end_by sep p =
 sep_end_by_1 sep p <|> pure []


 let parse (P x) s =
 let! x = x s
 match x with
 | Ok (_, x, r) -> pure @@ Right (x, r)
 | Err (_, m, _) -> pure @@ Left m

 let run_parser p s =
 let Id x = parse p s
 x

 let run_parser' (P x) s =
 let Id x = x s
 x

 let lift m = P @@ fun s ->
 let! x = m
 pure @@ Ok (E, x, s)

 let morph (k : forall 'a. 'm 'a -> 'n 'a) (P x) = P @@ fun s -> k (x s)
 let void x = map (const ()) x
--- a/parser.ml
+++ b/parser.ml
@ -0,0 +1,69 @@
 include import "./lang.ml"
 include import "./lexer.ml"
 open import "prelude.ml"

 let parse = lex

 let laid_out_block p = between obrace cbrace (sep_end_by_1 semi p)

 let rec atom : forall 'm. monad 'm => parser_t 'm expr =
 map Ref (try varid)
 <+> map Ref (try conid)
 <+> between (try oparen) cparen expr
 and fexp : forall 'm. monad 'm => parser_t 'm expr =
 let! a = atom
 let! ats = many atom
 pure (foldl (curry App) a ats)
 and expr : forall 'm. monad 'm => parser_t 'm expr =
 let lam =
 let! _ = back
 let! vs = many (try varid)
 let! _ = arrow
 let! b = expr
 pure (foldr ((Lam #) # curry id) b vs)
 let case =
 let! _ = keyword "case"
 let! e = fexp
 let! _ = keyword "of"
 let! arms =
 laid_out_block (
 let! c = conid
 let! vs = many (try varid)
 let! _ = arrow
 let! e = expr
 pure (c, foldr ((Lam #) # curry id) e vs)
 )
 pure (Case (e, arms))
 try lam <|> try case <+> fexp

 let rec ty_atom : forall 'm. monad 'm => parser_t 'm hstype =
 map Tyvar (try varid)
 <|> map Tycon (try conid)
 <+> between (try oparen) cparen ty_exp
 and ty_exp : forall 'm. monad 'm => parser_t 'm hstype =
 let! a = ty_atom
 let! ats = many ty_atom
 pure (foldl (curry Tyapp) a ats)

 let datadec : forall 'm. monad 'm => parser_t 'm decl =
 let! _ = keyword "data"
 let datacon =
 let! nm = conid
 let! args = many ty_atom
 pure (Constr (nm, args))
 let! nm = conid
 let! args = many (try varid)
 let! _ = equals
 let! c = sep_by_1 pipe (try datacon)
 pure (Data (nm, args, c))

 let dec : forall 'm. monad 'm => parser_t 'm decl =
 let func =
 let! nm = varid
 let! args = many (try varid)
 let! _ = equals
 map (fun e -> Decl (nm, args, e)) expr
 try datadec <|> func

 let prog : forall 'm. monad 'm => parser_t 'm prog =
 sep_end_by_1 semi dec <* eof
--- a/preamble.lua
+++ b/preamble.lua
@ -0,0 +1,68 @@
 local A, F, I = {}, {}, {}

 local stack = {}
 local sp = 1

 local function repr(x)
 if type(x) == 'table' then
 if x[1] == F then
 return x[4]
 elseif x[1] == A then
 return repr(x[2]) .. '(' .. repr(x[3]) .. ')'
 elseif x[1] == I then
 return '&' .. repr(x[2])
 end
 else
 return tostring(x)
 end
 end

 local function unwind()
 local x = stack[sp]
 if type(x) == 'table' then
 if x[1] == A then
 stack[sp + 1] = x[2]; sp = sp + 1
 return unwind()
 elseif x[1] == I then
 stack[sp] = x[2]
 return unwind()
 elseif x[1] == F then
 if sp - 1 >= x[3] then
 return x[2]()
 else
 print("insufficient arguments for supercombinator " .. x[4])
 print 'stack dump:'
 for k, v in pairs(stack) do
 print(sp - k, repr(v))
 end
 error()
 end
 end
 else
 os.exit(x)
 end
 end

 local function getchar()
 local k = stack[sp - 1][3]; sp = sp - 1
 local knil = stack[sp - 1][3]; sp = sp - 1
 local ch = io.read(1)
 if ch then
 stack[sp] = { A, k, ch:byte() }
 else
 stack[sp] = { A, knil, 0 }
 end
 return unwind()
 end

 local getchar_combinator = { F, getchar, 2 }

 local function putchar()
 local ch = stack[sp - 1][3];
 local k = stack[sp - 2][3]; sp = sp - 1
 io.write(string.char(ch))
 stack[sp] = { A, k, ch }
 return unwind()
 end

 local putchar_combinator = { F, putchar, 2 }
--- a/test.hs
+++ b/test.hs
@ -0,0 +1,6 @@
 data List a = Nil | Cons a (List a);
 map f xs = case xs of { Nil -> Nil; Cons x xs -> Cons (f x) (map f xs) };
 readall k = getchar (\ch -> readall (\xs -> k (Cons ch xs))) (\ch -> k Nil);
 putall x xs = case xs of { Nil -> x; Cons x xs -> putchar x (\ch -> putall x xs) };
 id x = x;
 main x = readall (putall x);