Merge branch 'fix-polymorphism'

gen_code.rb

@@ -174,7 +174,7 @@ def gen_insttype
     puts "      [@printer (fun fmt _ -> Format.fprintf fmt \"Op#{inst["inst"]}(...)\")]" if inst["suppress-pp"]
     puts "      [@printer (#{inst["custom-pp"]})]" if inst["custom-pp"]
   end
-  puts "  [@@deriving show]"
+  puts "  [@@deriving show { with_path = false; }]"
 end
 
 def gen_attype

lib-satysfi/dist/packages/cd.satyh

@@ -1,14 +1,15 @@
 @require: gr
 @require: color
 @require: geom
+@require: option
 
 module CD : sig
   type obj
   val \diagram : [length; length; (|
       obj             : point -> math -> obj;
       draw-obj        : obj -> graphics list;
-      draw-arr        : math -> float -> length -> obj -> obj -> graphics list;
-      draw-dashed-arr : math -> float -> length -> obj -> obj -> graphics list;
+      draw-arr        : math -> float?-> length ?-> obj -> obj -> graphics list;
+      draw-dashed-arr : math -> float?-> length ?-> obj -> obj -> graphics list;
     |) -> graphics list] inline-cmd
 end = struct
 
@@ -26,10 +27,10 @@ end = struct
   let wpad = 2pt
     % -- padding width for objects
 
-  let draw-arr-scheme arrowf ctx m t-name len-name (((x1r, _), _) as obj1r) (((x2r, _), _) as obj2r) =
+  let draw-arr-scheme arrowf ctx m ?:t-name-opt ?:len-name-opt (((x1r, _), _) as obj1r) (((x2r, _), _) as obj2r) =
 
-%    let t-name = destruct-option 0.5 t-name-opt in
-%    let len-name = destruct-option (get-font-size ctx *' 0.5) len-name-opt in
+    let t-name = Option.from 0.5 t-name-opt in
+    let len-name = Option.from (get-font-size ctx *' 0.5) len-name-opt in
 %    let t-name = 0.5 in
 %    let len-name = get-font-size ctx *' 0.5 in
 

lib-satysfi/dist/packages/list.satyh

@@ -26,38 +26,38 @@ module List
       | f (x :: xs) = (f x) :: map f xs
 
 
-    let mapi =
+    let mapi f =
       let-rec aux
         | i f []        = []
         | i f (x :: xs) = (f i x) :: aux (i + 1) f xs
       in
-      aux 0
+      aux 0 f
 
 
     let-rec iter
       | f []        = ()
       | f (x :: xs) = f x before iter f xs
 
 
-    let iteri =
+    let iteri f =
       let-rec aux
         | i f []        = ()
         | i f (x :: xs) = f i x before aux (i + 1) f xs
       in
-      aux 0
+      aux 0 f
 
 
     let-rec fold-left
       | f init []        = init
       | f init (x :: xs) = fold-left f (f init x) xs
 
 
-    let fold-lefti =
+    let fold-lefti f =
       let-rec aux
         | i f init []        = init
         | i f init (x :: xs) = aux (i + 1) f (f i init x) xs
       in
-      aux 0
+      aux 0 f
 
 
     let-rec fold-right
@@ -85,10 +85,10 @@ module List
       | x :: xs -> x :: append xs lst2
 
 
-    let concat = fold-right append []
+    let concat lst = fold-right append [] lst
 
 
-    let fold-left-adjacent f init lst =
+    let fold-left-adjacent f =
       let-rec aux leftopt init lst =
         match lst with
         | [] ->
@@ -102,7 +102,7 @@ module List
             let initnew = f init head leftopt (Some(right)) in
             aux (Some(head)) initnew tail
       in
-      aux None init lst
+      aux None
 
 
     let map-adjacent f lst =
@@ -120,16 +120,16 @@ module List
         reverse acc
 
 
-    let length =
-      fold-right (fun _ i -> i + 1) 0
+    let length lst =
+      fold-right (fun _ i -> i + 1) 0 lst
 
 
-    let nth =
+    let nth lst =
       let-rec aux i n xs =
         match xs with
         | []           -> None
         | head :: tail -> if n == i then Some(head) else aux (i + 1) n tail
       in
-        aux 0
+        aux 0 lst
 
   end

satysfi.opam

@@ -1,6 +1,6 @@
 opam-version: "1.2"
 name: "satysfi"
-version: "0.0.1"
+version: "0.0.2"
 maintainer: "gfngfn"
 authors: [
   "gfngfn"

src/frontend/bytecomp/bytecomp.ml

@@ -18,15 +18,14 @@ let compile_and_exec env ast =
 
 let compile_environment env =
   let (binds, _) = env in
-    binds |> EvalVarIDMap.iter (fun evid loc -> 
+    binds |> EvalVarIDMap.iter (fun evid loc ->
         match !loc with
-        | PrimitiveWithEnvironment(parbrs, env1, arity, astf) ->
+        | PrimitiveWithEnvironment(parbr, env1, arity, astf) ->
           begin
-            match compile_and_exec env (Function(parbrs)) with
-            | CompiledFuncWithEnvironment(_, _, framesize, body, env1) ->
+            match compile_and_exec env (Function([], parbr)) with
+            | CompiledFuncWithEnvironment([], _, _, framesize, body, env1) ->
               loc := CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf)
             | _ -> ()
           end
         | _ -> ()
       )
-

src/frontend/bytecomp/compiler.ml

@@ -39,10 +39,8 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) =
       | IRInputHorzText(s) ->
           CompiledInputHorzText(s)
 
-      | IRInputHorzEmbedded(ircmd, irarglist) ->
-          let appcode = emit_appop (List.length irarglist) [] true in
-          let cmdcode = compile ircmd appcode in
-          let compiled = compile_list irarglist cmdcode in
+      | IRInputHorzEmbedded(irabs) ->
+          let compiled = compile irabs [] in
             CompiledInputHorzEmbedded(compiled)
 
       | IRInputHorzEmbeddedMath(irmath) ->
@@ -57,10 +55,8 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) =
 and compile_input_vert_content (ivlst : ir_input_vert_element list) =
   let compiled_ivlist =
     ivlst |> List.map (function
-      | IRInputVertEmbedded(ircmd, irarglist) ->
-          let appcode = emit_appop (List.length irarglist) [] true in
-          let cmdcode = compile ircmd appcode in
-          let compiled = compile_list irarglist cmdcode in
+      | IRInputVertEmbedded(irabs) ->
+          let compiled = compile irabs [] in
             CompiledInputVertEmbedded(compiled)
 
       | IRInputVertContent(ir) ->
@@ -135,21 +131,28 @@ and compile (ir : ir) (cont : instruction list) =
   | IRLetNonRecIn(ir1, irpat, ir2) ->
       compile ir1 @@ compile_patsel (Range.dummy "LetNonRecIn") [IRPatternBranch(irpat, ir2)] cont
 
-  | IRFunction(framesize, irpatlst, irbody) ->
+  | IRFunction(framesize, optvars, irpatlst, irbody) ->
       let body = compile irbody [] in
       let patlst = compile_patlist irpatlst body in
       let (optcode, n) = optimize_func_prologue patlst in
         if framesize - n = 0 then
-          OpClosure(List.length irpatlst, 0, optcode) :: cont
+          OpClosure(optvars, List.length irpatlst, 0, optcode) :: cont
         else
-          OpClosure(List.length irpatlst, framesize, optcode) :: cont
+          OpClosure(optvars, List.length irpatlst, framesize, optcode) :: cont
 
   | IRApply(arity, ircallee, irargs) ->
-      compile_list irargs @@ (compile ircallee @@ emit_appop (List.length irargs) cont false)
+      let n = List.length irargs in
+      compile ircallee @@ (compile_list irargs @@ OpForward(n) :: emit_appop n cont false)
 
   | IRApplyPrimitive(op, arity, irargs) ->
       compile_list irargs (op :: cont)
 
+  | IRApplyOptional(ircallee, iroptarg) ->
+      compile ircallee @@ (compile iroptarg @@ OpApplyOptional :: cont)
+
+  | IRApplyOmission(irabs) ->
+      compile irabs @@ OpApplyOmission :: cont
+
   | IRTuple(len, iritems) ->
       compile_list iritems (OpMakeTuple(len) :: cont)
 
@@ -207,7 +210,7 @@ and compile (ir : ir) (cont : instruction list) =
         compile irpt0 (OpPath(pathelemlst, closingopt) :: cont)
 
 
-and compile_patsel (rng : Range.t) (patbrs : ir_pattern_branch list) cont =
+and compile_patsel (rng : Range.t) (patbrs : ir_pattern_branch list) (cont : instruction list) : instruction list =
   let consif cond a b =
     if cond then a :: b else b
   in
@@ -232,7 +235,7 @@ and compile_patsel (rng : Range.t) (patbrs : ir_pattern_branch list) cont =
     iter (List.rev patbrs) [OpError("no matches (" ^ (Range.to_string rng) ^ ")")] 0
 
 
-and compile_patlist patlist cont =
+and compile_patlist (patlist : ir_pattern_tree list) (cont : instruction list) : instruction list =
   let next = [OpError("no matches")] in
   let rec iter patlist cont =
     match patlist with
@@ -243,7 +246,7 @@ and compile_patlist patlist cont =
     iter patlist cont
 
 
-and compile_patcheck (pat : ir_pattern_tree) next cont =
+and compile_patcheck (pat : ir_pattern_tree) (next : instruction list) (cont : instruction list) : instruction list =
   let return inst = inst :: cont in
     match pat with
     | IRPIntegerConstant(pnc) -> return (OpCheckStackTopInt(pnc, next))
@@ -255,14 +258,14 @@ and compile_patcheck (pat : ir_pattern_tree) next cont =
     | IRPVariable(var) ->
         begin
           match var with
-          | GlobalVar(loc, evid, refs) -> return (OpBindGlobal(loc, evid, !refs))
+          | GlobalVar(loc, evid, refs)    -> return (OpBindGlobal(loc, evid, !refs))
           | LocalVar(lv, off, evid, refs) -> return (OpBindLocal(lv, off, evid, !refs))
         end
 
     | IRPAsVariable(var, psub) ->
         let bindop =
           match var with
-          | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs)
+          | GlobalVar(loc, evid, refs)    -> OpBindGlobal(loc, evid, !refs)
           | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs)
         in
         let code = compile_patcheck psub next cont in