diff --git a/assemble.ml b/assemble.ml index 992d134..3214961 100644 --- a/assemble.ml +++ b/assemble.ml @@ -1,21 +1,45 @@ include import "./compile.ml" +module Strings = import "./lib/strings.ml" open import "prelude.ml" open import "lua/io.ml" +open import "./lang.ml" let resolve_addr = function | Combinator n -> n ^ "_combinator" | Arg i -> "stack[sp - " ^ show (i + 1) ^ "][3]" + | Int i -> show i -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 rec 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(stack, sp)" + | Eval -> " stack[sp] = eval(stack[sp])" + | Add -> " stack[sp - 1] = stack[sp - 1] + stack[sp]; sp = sp - 1" + | Sub -> " stack[sp - 1] = stack[sp - 1] - stack[sp]; sp = sp - 1" + | Div -> " stack[sp - 1] = stack[sp - 1] / stack[sp]; sp = sp - 1" + | Mul -> " stack[sp - 1] = stack[sp - 1] * stack[sp]; sp = sp - 1" + | Iszero (yes, no) -> + " if stack[sp] == 0 then\n" + ^ foldl (fun x i -> x ^ " " ^ gm2lua i) "" yes ^ "\n" + ^ " else\n" + ^ foldl (fun x i -> x ^ " " ^ gm2lua i) "" no ^ "\n" + ^ " end" let compute_local_set xs = let rec go i (s : S.t string) = function - | Cons ((name, _, _), xs) -> + | Cons (Fd (Fimport {var}), xs) -> + if i >= 100 then + s + else + go (i + 2) (S.insert (var ^ "_wrapper") (S.insert (var ^ "_combinator") s)) xs + | Cons (Sc (name, _), xs) -> if i >= 100 then s else @@ -26,12 +50,52 @@ let compute_local_set xs = let sc2lua (name, arity, body) = let body = body - |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function()\n") + |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function(stack, sp)\n") |> (^ "end") let dec = name ^ "_combinator = { F, " ^ name ^ ", " ^ show arity ^ ", " ^ show name ^ " };" body ^ "\n" ^ dec +let foreign2lua (Fimport { cc, fent = fspec, var, ftype }) = + let (file, fspec) = + match Strings.split_on " " fspec with + | [file, func] -> (Some file, func) + | [func] -> (None, func) + | _ -> error @@ "Foreign spec too big: " ^ fspec + match cc with + | Prim -> error "primitive definitions are in Gmcode" + | Lua -> + let arity = arity ftype + let args = map (fun i -> ("a" ^ show i, i)) [1..arity] + let fcall = + if arity == 0 then + fspec + else + let Cons ((a, _), args) = args + fspec ^ "(" ^ foldl (fun a (i, _) -> a ^ ", " ^ i) a args ^ ")" + let wrapper = + "local function " ^ var ^ "_wrapper(stack, sp)\n" + ^ foldl (fun x (a, i) -> x ^ " local " ^ a ^ " = stack[sp - " ^ show i ^ "][3];\n") "" args + ^ " stack[sp - " ^ show arity ^ "] = " ^ fcall ^ "\n" + ^ " return unwind(stack, sp - " ^ show arity ^ ")\nend" + let dec = + var ^ "_combinator = { F, " ^ var ^ "_wrapper, " ^ show arity ^ ", '" ^ fspec ^ "' };" + let contents = + match file with + | Some path -> + let f = open_for_reading path + let x = read_all f + close_file f + match x with + | Some s -> "--- " ^ path ^ "\n" ^ s ^ "\n" + | None -> "" + | None -> "" + contents ^ wrapper ^ "\n" ^ dec + +let codegen = function + | Sc t -> sc2lua t + | Fd i -> foreign2lua i + let preamble = let f = open_for_reading "preamble.lua" let x = read_all f @@ -48,5 +112,5 @@ let assm_program decs = 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()" + let body = foldl (fun x s -> x ^ codegen s ^ "\n") "" decs + preamble ^ local_decs ^ "\n" ^ body ^ "unwind({{ A, main_combinator, 123 }}, 1)" diff --git a/compile.ml b/compile.ml index 359fcbd..20e4942 100644 --- a/compile.ml +++ b/compile.ml @@ -8,6 +8,7 @@ open import "./lib/monads.ml" type addr = | Combinator of string | Arg of int + | Int of int type gm_code = | Push of addr @@ -15,6 +16,8 @@ type gm_code = | Pop of int | Unwind | Mkap + | Add | Sub | Mul | Div | Eval + | Iszero of list gm_code * list gm_code instance show gm_code begin let show = function @@ -22,12 +25,24 @@ instance show gm_code begin | Unwind -> "Unwind" | Push (Combinator k) -> "Push " ^ k | Push (Arg i) -> "Arg " ^ show i + | Push (Int i) -> "Int " ^ show i | Update n -> "Update " ^ show n | Pop n -> "Pop " ^ show n + | Add -> "Add" + | Mul -> "Mul" + | Sub -> "Sub" + | Div -> "Div" + | Eval -> "Eval" + | Iszero p -> "Iszero " ^ show p end +type program_item = + | Sc of string * int * list gm_code + | Fd of fdecl + let rec lambda_lift = function | Ref v -> pure (Ref v) + | Lit v -> pure (Lit v) | App (f, x) -> (| app (lambda_lift f) (lambda_lift x) |) | Lam (v, x) -> let! body = lambda_lift x @@ -61,6 +76,7 @@ let rec eta_contract = function dec | _, _ -> dec | Data c -> Data c + | Foreign i -> Foreign i let rec lambda_lift_sc = function | Decl (n, a, e) -> @@ -71,9 +87,27 @@ let rec lambda_lift_sc = function let! _ = modify (fun (a, b, s) -> (a, b, S.insert n s)) pure (Decl (n, a, e)) | Data c -> Data c |> pure + | Foreign i -> Foreign i |> pure type dlist 'a <- list 'a -> list 'a +let cg_prim (Fimport { var, fent }) = + let prim_math_op x = + [ Push (Arg 0), Eval, Push (Arg 2), Eval, x, Update 2, Pop 2, Unwind ] + let prim_equality = + [ Push (Arg 0), Eval (* x, arg0, arg1, arg2, arg3 *) + , Push (Arg 2), Eval (* y, x, arg0, arg1, arg2, arg3 *) + , Sub (* y - x, arg0, arg1, arg2, arg3 *) + , Iszero ([ Push (Arg 3) ], [ Push (Arg 4) ]) + , Push (Int 0), Mkap, Update 4, Pop 4, Unwind ] + match fent with + | "add" -> Sc (var, 2, prim_math_op Add) + | "sub" -> Sc (var, 2, prim_math_op Sub) + | "mul" -> Sc (var, 2, prim_math_op Mul) + | "div" -> Sc (var, 2, prim_math_op Div) + | "equ" -> Sc (var, 4, prim_equality) + | e -> error @@ "No such primitive " ^ e + let rec compile (env : M.t string int) = function | Ref v -> match M.lookup v env with @@ -85,8 +119,11 @@ let rec compile (env : M.t string int) = function 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?" + | Lam _ -> + error "Can not compile lambda expression, did you forget to lift?" + | Case _ -> + error "Can not compile case expression, did you forget to lift?" + | Lit i -> (Push (Int i) ::) let supercomb (_, args, exp) = let env = M.from_list (zip args [0..length args]) @@ -98,8 +135,23 @@ 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" + let define nm = + let! x = get + if nm `S.member` x then + error @@ "Redefinition of value " ^ nm + else + modify (S.insert nm) + + let go = + flip traverse (lams ++ decs) @@ function + | Decl ((nm, args, _) as sc) -> + let! _ = define nm + let code = supercomb sc + Sc (nm, length args, code) |> pure + | Data _ -> error "data declaration in compiler" + | Foreign (Fimport { cc = Prim, var } as fi) -> + let! _ = define var + pure (cg_prim fi) + | Foreign f -> pure (Fd f) + let (out, _) = run_state go S.empty + out diff --git a/driver.ml b/driver.ml index 714ab42..86207bc 100644 --- a/driver.ml +++ b/driver.ml @@ -4,6 +4,10 @@ open import "./parser.ml" open import "prelude.ml" open import "lua/io.ml" +let printerror (e, { line, col }) = + put_line @@ "line " ^ show line ^ ", col " ^ show col ^ ":" + print e + let go infile outfile = let infile = open_for_reading infile let outfile = open_file outfile Write_m @@ -16,7 +20,7 @@ let go infile outfile = |> C.program |> A.assm_program |> write_bytes outfile - | Left e -> print e + | Left e -> printerror e | _ -> () close_file infile close_file outfile @@ -29,7 +33,7 @@ let test str = |> C.program |> A.assm_program |> put_line - | Left e -> print e + | Left e -> printerror e let test_file infile = let infile = open_for_reading infile diff --git a/lang.ml b/lang.ml index c9cb2b8..de1f5c6 100644 --- a/lang.ml +++ b/lang.ml @@ -3,10 +3,11 @@ 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 + | Ref of string + | App of expr * expr + | Lam of string * expr | Case of expr * list (string * expr) + | Lit of int let app = curry App let lam = curry Lam @@ -20,6 +21,7 @@ let rec free_vars = function |> map (fun (_, e) -> free_vars e) |> foldl S.union S.empty |> S.union (free_vars e) + | Lit _ -> S.empty let rec subst m = function | Ref v -> @@ -29,17 +31,35 @@ let rec subst m = function | 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) + | Lit x -> Lit x type hstype = | Tycon of string | Tyvar of string | Tyapp of hstype * hstype + | Tyarr of hstype * hstype + | Tytup of list hstype + +let rec arity = function + | Tyarr (_, i) -> 1 + arity i + | _ -> 0 type constr = Constr of string * list hstype +type call_conv = Lua | Prim + +type fdecl = + Fimport of { + cc : call_conv, + fent : string, + ftype : hstype, + var : string + } + type decl = | Decl of string * list string * expr | Data of string * list string * list constr + | Foreign of fdecl type prog <- list decl @@ -67,3 +87,4 @@ let ds_prog prog = match c with | Data c -> ds_data c | Decl (n, args, e) -> [Decl (n, args, e)] + | Foreign d -> [Foreign d] diff --git a/lexer.ml b/lexer.ml index a1a1c7c..b9a3dee 100644 --- a/lexer.ml +++ b/lexer.ml @@ -37,6 +37,7 @@ let arrow : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (sym 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 dcolon : 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" @@ -63,6 +64,7 @@ let iskw = function | "module" | "newtype" | "of" + | "foreign" | "then" | "type" | "where" @@ -127,7 +129,21 @@ let integer : forall 'm. monad 'm => parser_t 'm int = let! c = hexit let! cs = many_fold (^) "" hexit pure ("0x" ^ c ^ cs) - let! c = (try hexadecimal <|> decimal) "hex or decimal integer" + let! c = (lexeme (try hexadecimal <|> decimal)) "hex or decimal integer" match parse_int c with | None -> error "no parse" | Some x -> pure x + +let string : forall 'm. monad 'm => parser_t 'm string = + flip () "string literal" # lexeme @@ + let parse_escape = function + | "n" -> pure "\n" + | "t" -> pure "\t" + | "\"" -> pure "\"" + | a -> unexpected ("escape sequence " ^ a) + let str_ent = + satisfy (fun p -> p <> "\"" && p <> "\\") + <|> ( let! _ = try (symbol "\\") + let! e = char + parse_escape e) + symbol "\"" *> many_fold (^) "" str_ent <* symbol "\"" diff --git a/lib/parsers.ml b/lib/parsers.ml index 0fd067d..67b7eed 100644 --- a/lib/parsers.ml +++ b/lib/parsers.ml @@ -13,56 +13,59 @@ instance show error begin ^ "Expecting one of " ^ foldl (^) "" ms end +private type pos <- { line : int, col : int } + private type result 'a = - | Ok of consumed * 'a * string - | Err of consumed * error * string + | Ok of consumed * 'a * string * pos + | Err of consumed * error * string * pos 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_t 'm 'a = private P of pos -> 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 -> + let f <$> P x = P @@ fun pos i -> + flip map (x pos 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 + let pure x = P (fun p s -> pure (Ok (E, x, s, p))) + let P f <*> P x = P @@ fun p s -> + let! f = f p s match f with - | Ok (c, f, s) -> - let! x = x s + | Ok (c, f, s, p) -> + let! x = x p s match x with - | Ok (c', x, s) -> pure @@ Ok (join_consumed c c', f x, s) + | Ok (c', x, s, p) -> pure @@ Ok (join_consumed c c', f x, s, p) | 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 |) +let x <$ a = map (const x) a instance monad 'm => monad (parser_t 'm) begin - let P x >>= f = P @@ fun s -> - let! x = x s + let P x >>= f = P @@ fun p s -> + let! x = x p s match x with - | Ok (c, x, s) -> + | Ok (c, x, s, p) -> let P kont = f x - let! x = kont s + let! x = kont p 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 private fail e = P (fun p s -> pure (Err (E, e, s, p))) let empty : forall 'm 'a. monad 'm => parser_t 'm 'a = fail (Unexpected ("empty parse", [])) @@ -73,23 +76,23 @@ let 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 +let P x <|> P y = P @@ fun p s -> + let! x = x p s match x with | Ok x -> pure (Ok x) - | Err (c, m, s) -> - let! y = y s + | Err (c, m, s, p) -> + let! y = y p 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 +let P x <+> y = P @@ fun p s -> + let! x = x p s match x with | Ok x -> pure (Ok x) - | Err (c, m, s) -> + | Err (c, m, s, p) -> let P y = force y - let! y = y s + let! y = y p 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)) @@ -97,51 +100,61 @@ let P x <+> y = P @@ fun s -> private module S = import "lua/string.ml" let char : forall 'm. applicative 'm => parser_t 'm string = - P @@ fun s -> + P @@ fun p 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) + if x == "\n" then + pure @@ Ok (C, x, r, { line = p.line + 1, col = 0 }) + else + pure @@ Ok (C, x, r, { line = p.line, col = p.col + 1 }) else - pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s) + pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s, p) let eof : forall 'm. applicative 'm => parser_t 'm () = - P @@ fun s -> + P @@ fun p s -> if s == "" then - pure @@ Ok (E, (), s) + pure @@ Ok (E, (), s, p) + else + pure @@ + Err (E, Unexpected (S.substring s 1 1, ["end-of-file"]), s, p) + +let satisfy pred = + P @@ fun p s -> + let x = S.substring s 1 1 + if x <> "" && pred x then + let r = S.substring s 2 (S.length s) + if x == "\n" then + pure @@ Ok (C, x, r, { line = p.line + 1, col = 0 }) + else + pure @@ Ok (C, x, r, { line = p.line, col = p.col + 1 }) 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 + let m = + if x == "" then + "end of file" + else + x + pure @@ Err (E, Unexpected (m, ["character"]), s, p) + +let P k m = P @@ fun p s -> + let! x = k p 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 + let rec go consumed kont pos s = + let! x = x pos s match x with - | Err ((c, _, s) as p) -> + | Err ((c, _, s, pos) as p) -> match c with | C -> pure (Err p) - | E -> kont consumed z s - | Ok (c, x, s) -> + | E -> kont consumed z pos s + | Ok (c, x, s, pos) -> 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)))) + | C -> go C (fun c -> kont c # k x) pos s + P (go E (fun c z pos s -> pure (Ok (c, z, s, pos)))) let many p = many_fold (::) [] p let some p = @@ -191,11 +204,11 @@ let between o c p = let! _ = c pure x -let try (P x) = P @@ fun s -> - let! x = x s +let try (P x) = P @@ fun pos s -> + let! x = x pos s match x with | Ok c -> pure (Ok c) - | Err (_, p, _) -> pure (Err (E, p, s)) + | Err (_, p, _) -> pure (Err (E, p, s, pos)) let optionally p = map Some (try p) <|> pure None @@ -209,24 +222,35 @@ let rec sep_end_by_1 sep p = and sep_end_by sep p = sep_end_by_1 sep p <|> pure [] +let chainr1 p op = + let rec scan = + let! x = p + rest x + and rest x = + ( let! f = op + let! y = scan + pure (f x y) + ) <|> pure x + let _ = rest (* shut up, amc *) + scan let parse (P x) s = - let! x = x s + let! x = x { line = 0, col = 0 } s match x with | Ok (_, x, r) -> pure @@ Right (x, r) - | Err (_, m, _) -> pure @@ Left m + | Err (_, m, _, p) -> pure @@ Left (m, p) let run_parser p s = let Id x = parse p s x let run_parser' (P x) s = - let Id x = x s + let Id x = x { line = 0, col = 0 } s x -let lift m = P @@ fun s -> +let lift m = P @@ fun pos s -> let! x = m - pure @@ Ok (E, x, s) + pure @@ Ok (E, x, s, pos) let morph (k : forall 'a. 'm 'a -> 'n 'a) (P x) = P @@ fun s -> k (x s) let void x = map (const ()) x diff --git a/lib/strings.ml b/lib/strings.ml new file mode 100644 index 0000000..506fd9e --- /dev/null +++ b/lib/strings.ml @@ -0,0 +1,16 @@ +module S = import "lua/string.ml" +open import "prelude.ml" + +let split_on ch str = + let len = S.length str + let rec go i acc acc' = + if i > len then + reverse (acc :: acc') + else + let this = S.substring str i i + if this == ch then + go (i + 1) "" (acc :: acc') + else + go (i + 1) (acc ^ this) acc' + go 1 "" [] + diff --git a/parser.ml b/parser.ml index 3db7426..0c7b40d 100644 --- a/parser.ml +++ b/parser.ml @@ -8,7 +8,8 @@ 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) + <|> map Ref (try conid) + <|> map Lit (try integer) <+> between (try oparen) cparen expr and fexp : forall 'm. monad 'm => parser_t 'm expr = let! a = atom @@ -39,14 +40,18 @@ and expr : forall 'm. monad 'm => parser_t 'm expr = 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 = + <+> between (try oparen) cparen ty_tup +and ty_fexp : forall 'm. monad 'm => parser_t 'm hstype = let! a = ty_atom let! ats = many ty_atom pure (foldl (curry Tyapp) a ats) +and ty_exp : forall 'm. monad 'm => parser_t 'm hstype = + chainr1 ty_fexp (map (const (curry Tyarr)) arrow) +and ty_tup : forall 'm. monad 'm => parser_t 'm hstype = + Tytup <$> sep_by comma ty_exp let datadec : forall 'm. monad 'm => parser_t 'm decl = - let! _ = keyword "data" + let! _ = try (keyword "data") let datacon = let! nm = conid let! args = many ty_atom @@ -57,13 +62,29 @@ let datadec : forall 'm. monad 'm => parser_t 'm decl = let! c = sep_by_1 pipe (try datacon) pure (Data (nm, args, c)) +let fdecl : forall 'm. monad 'm => parser_t 'm fdecl = + let! _ = try (keyword "import") + let! cc = + ( (Lua <$ try (keyword "lua")) + <|> (Prim <$ try (keyword "prim")) + ) + let! fent = string + let! var = varid + let! _ = dcolon + let! ftype = ty_exp + pure (Fimport { cc, fent, var, ftype }) + +let func : forall 'm. monad 'm => parser_t 'm decl = + let! nm = varid + let! args = many (try varid) + let! _ = equals + map (fun e -> Decl (nm, args, e)) expr + 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 foreign = + let! _ = try (keyword "foreign") + map Foreign fdecl + try datadec <|> try foreign <|> func let prog : forall 'm. monad 'm => parser_t 'm prog = sep_end_by_1 semi dec <* eof diff --git a/preamble.lua b/preamble.lua index 68979c4..3b3ab11 100644 --- a/preamble.lua +++ b/preamble.lua @@ -1,49 +1,47 @@ local A, F, I = {}, {}, {} -local stack = {} -local sp = 1 - -local function repr(x) +local function unwind(stack, sp) + local x = stack[sp] 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]) .. ')' + if x[1] == A then + stack[sp + 1] = x[2] + return unwind(stack, sp + 1) elseif x[1] == I then - return '&' .. repr(x[2]) + stack[sp] = x[2] + return unwind(stack, sp) + elseif x[1] == F then + if sp - 1 >= x[3] then + return x[2](stack, sp) + else + error("insufficient arguments for supercombinator " .. x[4]) + end end else - return tostring(x) + return x, stack, sp end end -local function unwind() - local x = stack[sp] +local function repr(x) 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() + return repr(x[2]) .. '(' .. repr(x[3]) 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 + return x[4] + elseif x[1] == I then + return '&' .. repr(x[2]) end + return '' else - os.exit(x) + return tostring(x) end end -local function getchar() +local function eval(node) + local stack, sp = { node }, 1 + return (unwind(stack, sp)) +end + +local function getchar(stack, sp) local k = stack[sp - 1][3]; sp = sp - 1 local knil = stack[sp - 1][3]; sp = sp - 1 local ch = io.read(1) @@ -52,7 +50,7 @@ local function getchar() else stack[sp] = { A, knil, 0 } end - return unwind() + return unwind(stack, sp) end local getchar_combinator = { F, getchar, 2 } @@ -62,7 +60,7 @@ local function putchar() local k = stack[sp - 2][3]; sp = sp - 1 io.write(string.char(ch)) stack[sp] = { A, k, ch } - return unwind() + return unwind(stack, sp) end local putchar_combinator = { F, putchar, 2 }