Browse Source

add a FFI and primitive supercombinators

master
Amélia Liao 3 years ago
parent
commit
af4038b200
9 changed files with 339 additions and 123 deletions
  1. +74
    -10
      assemble.ml
  2. +59
    -7
      compile.ml
  3. +6
    -2
      driver.ml
  4. +24
    -3
      lang.ml
  5. +17
    -1
      lexer.ml
  6. +83
    -59
      lib/parsers.ml
  7. +16
    -0
      lib/strings.ml
  8. +31
    -10
      parser.ml
  9. +29
    -31
      preamble.lua

+ 74
- 10
assemble.ml View File

@ -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)"

+ 59
- 7
compile.ml View File

@ -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

+ 6
- 2
driver.ml View File

@ -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


+ 24
- 3
lang.ml View File

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

+ 17
- 1
lexer.ml View File

@ -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 "\""

+ 83
- 59
lib/parsers.ml View File

@ -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

+ 16
- 0
lib/strings.ml View File

@ -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 "" []

+ 31
- 10
parser.ml View File

@ -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

+ 29
- 31
preamble.lua View File

@ -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 '<bad node>'
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 }

Loading…
Cancel
Save