...
 
Commits (3)
# SCaml, Smart Contract Abstract Machine Language.
> A scam never calls itself a scam.
> Scam never calls itself scam.
Small and Simple Strict Subset of OCaml for Smart contracts.
......@@ -25,7 +25,7 @@ The following OCaml features are **not** supported:
* Product types other than a pair: `t1 * t2`.
* Modules.
* Labeled functions.
* Nested patterns. Constants in patterns. "Or" pattern. Pattern guards. Exception patterns.
* Exception patterns.
* Multi case in `function`
* Partial applicaiton of primitives defined in `SCaml`.
* Reference or mutable record fields.
......@@ -46,16 +46,9 @@ type ('a, 'b) sum =
| Right of 'b
```
### No real pattern matching (yet)
### Experimental: Pattern match
For simplicity, the pattern match `match .. with ..` of OCaml
is hugely restricted in SCaml.
* Constructors in patterns are restricted to `Left`, `Right`, `::`, `[]`, `Some` and `None.
* Constructors in patterns can take only variables as their arguments. No nested pattern is allowed.
This means that for now SCaml's `match .. with ..` is just a syntactic sugar of
Michelson conditional opcodes `IF_LEFT`, `IF_CONS` and `IF_NONE`.
Full pattern matching for `match` is recently added as an experimental feature. It is not yet fully tested.
## Design
......
......@@ -166,7 +166,7 @@ let pp ppf =
f "@[<2>(fun (%a) ->@ %a@ : %a)@]"
pp_patvar pat pp body M.Type.pp t.typ
| IfThenElse (t1, t2, t3) ->
f "(if %a @[then %a@ else %a@])"
f "(@[if %a@ then %a@ else %a@])"
pp t1 pp t2 pp t3
| App (t1, ts) ->
f "(%a %a)" pp t1 Format.(list " " (fun ppf t -> fprintf ppf "(%a)" pp t)) ts
......@@ -200,10 +200,10 @@ let pp ppf =
(Format.list "@ | "
(fun ppf (p, guard, e) ->
match guard with
| None -> Format.fprintf ppf "%a -> %a"
| None -> Format.fprintf ppf "@[<2>%a ->@ %a@]"
pp_pat p
pp e
| Some g -> Format.fprintf ppf "%a when %a -> %a"
| Some g -> Format.fprintf ppf "@[<2>%a when %a ->@ %a@]"
pp_pat p
pp g
pp e
......
......@@ -4,7 +4,7 @@ open Tools
module Type = Michelson.Type
module C =Michelson.Constant
let create_var =
let create_ident =
let cntr = ref 0 in
fun n -> incr cntr; Ident.create & n ^ string_of_int !cntr
......@@ -21,22 +21,22 @@ let transpose : 'p list list -> 'p list list = fun rows ->
assert (List.length row = ncolumns);
List.nth row i) rows)
type var_ty = Ident.t * Type.t
type id_ty = Ident.t * Type.t
type case =
{ pats : pat list
; guard : int option
; action : int
; bindings : (IML.var * var_ty) list
; bindings : (IML.var * id_ty) list
}
type matrix = case list
type t =
| Fail
| Leaf of (Ident.t * var_ty) list * int
| Switch of var_ty * (IML.constr * var_ty list * t) list * t option (* default *)
| Guard of (Ident.t * var_ty) list (* binder *)
| Leaf of (Ident.t * id_ty) list * int
| Switch of id_ty * (IML.constr * id_ty list * t) list * t option (* default *)
| Guard of (Ident.t * id_ty) list (* binder *)
* int (* guard *)
* int (* case *)
* t (* otherwise *)
......@@ -91,60 +91,101 @@ let rec specialize o c (matrix : matrix) : matrix =
match pats with
| [] -> assert false
| pat::pats ->
match c, pat.desc with
| _, PAlias _ -> assert false
| c, POr (p1, p2) ->
specialize o c [{ case with pats= p1::pats }]
@ specialize o c [{ case with pats= p2::pats }]
@ st
| c, PConstr (c', ps) ->
if c = c' then { case with pats= ps @ pats } :: st else st
(* For wild, we need to build another wild with arg type.
XXX Currently we must code for each. Ugh.
*)
| CPair, PWild ->
let ty1, ty2 = match pat.typ.desc with
| TyPair (ty1, ty2) -> ty1, ty2
| _ -> assert false
in
{ case with pats= mkp ty1 PWild :: mkp ty2 PWild :: pats } :: st
| CLeft, PWild ->
let typl = match pat.typ.desc with
| TyOr (typl, _typr) -> typl
| _ -> assert false
in
{ case with pats= mkp typl PWild :: pats } :: st
| CRight, PWild ->
let typr = match pat.typ.desc with
| TyOr (_typl, typr) -> typr
| _ -> assert false
in
{ case with pats= mkp typr PWild :: pats } :: st
| CSome, PWild ->
let typ = match pat.typ.desc with
| TyOption typ -> typ
| _ -> assert false
in
{ case with pats= mkp typ PWild :: pats } :: st
| CCons, PWild ->
let typ = match pat.typ.desc with
| TyList typ -> typ
| _ -> assert false
in
{ case with pats= mkp typ PWild :: mkp pat.typ PWild :: pats } :: st
| (CNone | CNil | CUnit | CBool _ | CConstant _), PWild ->
{ case with pats } :: st
| (_ , PVar v) -> { case with pats; bindings= (v, o) :: bindings } :: st
let rec f pat = match c, pat.desc with
| _, PAlias (pat, i, _loc) ->
let cases = f pat in
List.map (fun case -> { case with bindings = (i,o) :: case.bindings }) cases
| c, POr (p1, p2) ->
specialize o c [{ case with pats= p1::pats }]
@ specialize o c [{ case with pats= p2::pats }]
| c, PConstr (c', ps) ->
if c = c' then [{ case with pats= ps @ pats }] else []
(* For wild, we need to build another wild with arg type.
XXX Currently we must code for each. Ugh.
*)
| CPair, PWild ->
let ty1, ty2 = match pat.typ.desc with
| TyPair (ty1, ty2) -> ty1, ty2
| _ -> assert false
in
[{ case with pats= mkp ty1 PWild :: mkp ty2 PWild :: pats }]
| CLeft, PWild ->
let typl = match pat.typ.desc with
| TyOr (typl, _typr) -> typl
| _ -> assert false
in
[{ case with pats= mkp typl PWild :: pats }]
| CRight, PWild ->
let typr = match pat.typ.desc with
| TyOr (_typl, typr) -> typr
| _ -> assert false
in
[{ case with pats= mkp typr PWild :: pats }]
| CSome, PWild ->
let typ = match pat.typ.desc with
| TyOption typ -> typ
| _ -> assert false
in
[{ case with pats= mkp typ PWild :: pats }]
| CCons, PWild ->
let typ = match pat.typ.desc with
| TyList typ -> typ
| _ -> assert false
in
[{ case with pats= mkp typ PWild :: mkp pat.typ PWild :: pats }]
| (CNone | CNil | CUnit | CBool _ | CConstant _), PWild ->
[{ case with pats }]
| (_ , PVar v) -> [{ case with pats; bindings= (v, o) :: bindings }]
in
let cases = f pat in
cases @ st
) matrix []
let pp_matrix ppf matrix =
let open Format in
fprintf ppf "matrix:@.";
List.iter (function
| { pats; guard= None; action= i } ->
eprintf "| %a -> %d@."
(list ", " pp_pat) pats
i
| { pats; guard= Some g; action= i } ->
eprintf "| %a when %d -> %d@."
(list ", " pp_pat) pats
g
i
) matrix
let pp_osmatrix ppf (os, matrix) =
let open Format in
fprintf ppf "match %a with@." (list ", " (fun ppf (id,_) ->
fprintf ppf "%s" & Ident.name id)) os;
List.iter (function
| { pats; guard= None; action= i } ->
eprintf "| %a -> %d@."
(list ", " pp_pat) pats
i
| { pats; guard= Some g; action= i } ->
eprintf "| %a when %d -> %d@."
(list ", " pp_pat) pats
g
i
) matrix
let specialize o c matrix =
Format.eprintf "specializing... %a@." pp_matrix matrix;
let matrix = specialize o c matrix in
Format.eprintf "specialized... %a@." pp_matrix matrix;
matrix
let rec default o (matrix : matrix) : matrix =
List.fold_right (fun ({ pats } as case) st ->
match pats with
......@@ -163,55 +204,6 @@ let rec default o (matrix : matrix) : matrix =
f pat
) matrix []
(* Extract x's of (p as x) in the column, and make columns for them. *)
let unalias_column column : pat list * pat list list =
let column0 = column in
(* extract aliases *)
let xs, column =
List.fold_right (fun pat (st, pats) ->
let rec f pat = match pat.desc with
| PAlias (pat, x, _) ->
let xs, pat = f pat in x::xs, pat
| PWild | PVar _ | PConstr _ | POr _ -> [], pat
in
let xs, pat = f pat in
xs @ st, pat::pats) column ([], [])
in
(* create new columns for xs *)
column,
List.map (fun x ->
let rec has_x pat = match pat.desc with
| PAlias (_, y, _) when x = y -> true
| PAlias (pat, _, _) -> has_x pat
| PWild | PVar _ | PConstr _ | POr _ -> false
in
List.map (fun pat0 ->
{ pat0 with desc= if has_x pat0 then PVar x else PWild }
) column0
) xs
(* Extract x's of (p as x) in the column, and make columns for them *)
let unalias_matrix o (matrix : matrix) : _ list * matrix =
match matrix with
| [] -> o, [] (* invalid I guess *)
| { pats= [] }::_ ->
(* Special case. If matrix has 0 width, we cannot use transpose since
it loses the number of rows. *)
o, matrix
| _ ->
let columns = transpose & List.map (fun c -> c.pats) matrix in
let ocolumns =
List.concat
& List.map2 (fun ov column ->
let column', new_columns = unalias_column column in
(ov, column') :: List.map (fun c -> ov, c) new_columns) o columns
in
let o = List.map fst ocolumns in
let columns = List.map snd ocolumns in
let rows = transpose columns in
o,
List.map2 (fun pats case -> { case with pats }) rows matrix
let swap i os (matrix : matrix) : _ * matrix =
let rec f rev_st i xs = match i, xs with
| 0, x::xs -> x::List.rev rev_st@xs
......@@ -221,38 +213,19 @@ let swap i os (matrix : matrix) : _ * matrix =
f [] i os,
List.map (fun ({ pats } as case) -> { case with pats= f [] i pats }) matrix
let pp_osmatrix ppf (os, matrix) =
let open Format in
fprintf ppf "match %a with@." (list ", " (fun ppf (id,_) ->
fprintf ppf "%s" & Ident.name id)) os;
List.iter (function
| { pats; guard= None; action= i } ->
eprintf "| %a -> %d@."
(list ", " pp_pat) pats
i
| { pats; guard= Some g; action= i } ->
eprintf "| %a when %d -> %d@."
(list ", " pp_pat) pats
g
i
) matrix
let rec cc os matrix =
Format.eprintf "compile: %a" pp_osmatrix (os, matrix);
let os', matrix' = unalias_matrix os matrix in
if (os, matrix) <> (os', matrix') then
Format.eprintf "simplify: %a" pp_osmatrix (os, matrix);
let os, matrix = os', matrix' in
match matrix with
| [] -> Fail
| { pats=ps; guard= g; action= a; bindings }::_ ->
if List.for_all (fun p -> match p.desc with
| PAlias _ -> assert false
| PWild | PVar _ -> true
| PConstr _ -> false
| POr _ -> false
) ps
if List.for_all (fun p ->
let rec f p = match p.desc with
| PAlias (p, _, _) -> f p
| PWild | PVar _ -> true
| PConstr _ -> false
| POr _ -> false
in
f p ) ps
then
let bindings = List.fold_right2 (fun v p st ->
match p.desc with
......@@ -274,7 +247,7 @@ let rec cc os matrix =
List.find_all (fun (_i,c) ->
List.exists (fun p ->
let rec f p = match p.desc with
| PAlias _ -> assert false
| PAlias (p, _, _) -> f p
| PWild | PVar _ -> false
| PConstr _ -> true
| POr (p1, p2) -> f p1 || f p2
......@@ -292,7 +265,7 @@ let rec cc os matrix =
List.sort_uniq compare
& List.fold_left (fun st p ->
let rec f p = match p.desc with
| PAlias _ -> assert false
| PAlias (p, _, _) -> f p
| PConstr (c, _) -> [c]
| PWild | PVar _ -> []
| POr (p1, p2) -> f p1 @ f p2
......@@ -334,34 +307,34 @@ let rec cc os matrix =
| TyOr (ty, _) -> ty
| _ -> assert false
in
[ create_var "l", ty ]
[ create_ident "l", ty ]
| CRight ->
let ty = match vty.desc with
| TyOr (_, ty) -> ty
| _ -> assert false
in
[ create_var "r", ty ]
[ create_ident "r", ty ]
| CPair ->
let ty1,ty2 = match vty.desc with
| TyPair (ty1, ty2) -> ty1, ty2
| _ -> assert false
in
[ create_var "l", ty1 ;
create_var "r", ty2 ]
[ create_ident "l", ty1 ;
create_ident "r", ty2 ]
| CCons ->
let ty = match vty.desc with
| TyList ty -> ty
| _ -> assert false
in
[ create_var "hd", ty
; create_var "tl", vty
[ create_ident "hd", ty
; create_ident "tl", vty
]
| CSome ->
let ty = match vty.desc with
| TyOption ty -> ty
| _ -> assert false
in
[ create_var "x", ty ]
[ create_ident "x", ty ]
| CNil | CNone | CBool _ | CConstant _ (* int/nat/tz *)
| CUnit -> []
......@@ -494,14 +467,14 @@ let compile_match e (cases : (pat * IML.t option * IML.t) list) =
(* actions as functions *)
let acts =
List.mapi (fun i (pat, _g, action) ->
let v = create_var (Printf.sprintf "case%d" i) in
let v = create_ident (Printf.sprintf "case%d" i) in
let patvars = IdTys.elements & patvars pat in
match patvars with
| [] ->
(* if [patvars = []], we need a [fun () ->].
Think about the case of [| _ -> assert false].
*)
let pvar = mkp Type.tyUnit & create_var "unit" in
let pvar = mkp Type.tyUnit & create_ident "unit" in
let f =
mke (Type.tyLambda (Type.tyUnit, action.typ))
(Fun (Type.tyUnit, action.typ, pvar, action))
......@@ -533,7 +506,7 @@ let compile_match e (cases : (pat * IML.t option * IML.t) list) =
List.rev cases, List.rev guards
in
let v = create_var "v" in
let v = create_ident "v" in
let typ = (match List.hd cases with (e,_,_) -> e).typ in
......