Ed binop

lib/std.nh

@@ -8,15 +8,58 @@ extern "support.hpp" "std" "to_string" fun StringOfInt int -> string
 
 extern "support.hpp" "std" "pow" fun Pow float float -> float
 
+
+type key_signature = {
+	scale = { 261.63, 293.66, 329.63, 349.23, 392.00, 440.00, 493.88 }
+}
+
+type time_signature = {
+	upper = 4
+	lower = 4
+}
+
+type pitch = {
+	rank = 1
+	octave = 0
+	offset = 0
+}
+
+type chord = {
+	pitches = pitch[]
+}
+
+type track = {
+	key_signature = init key_signature
+	time_signature = init time_signature
+	chords = chord[]
+	durations = float[]
+}
+
+fun ChordOfPitch pitch = init chord { pitches = [pitch] }
+fun PitchOfInt i = init pitch { rank = i }
+fun AddPitchOctave pitch octaves = ( pitch$octave = pitch$octave + octaves; pitch )
+fun FlatPitch pitch = ( pitch$offset = pitch$offset - 1; pitch )
+fun SharpPitch pitch = ( pitch$offset = pitch$offset + 1; pitch )
+fun Rest = init chord
+
+fun ConcatTracks t1 t2 = {
+	if t1$key_signature == t2$key_signature &&
+			t1$time_signature == t2$time_signature
+	then (
+		t1$chords = t1$chords . t2$chords
+		t1$durations = t1$durations . t2$durations
+		t1
+	)
+	else throw "Cannot concat tracks with different key or time signature"
+}
+
 fun PrintEndline str = (
   Print str
   Print "\n"
 )
 
 /*
 
-include std_basic
-
 key_signature = init key_signature
 time_signature = init time_signature
 tempo = 120

src/ast.ml

@@ -37,7 +37,7 @@ type expr =
   | Block of expr list
   | Conditional of expr * expr * expr
   | For of string * expr * expr
-  | Throw of expr * expr
+  | Throw of expr
   | Assign of var_reference * expr
   | StructInit of string * expr list
 
@@ -102,7 +102,7 @@ let rec string_of_expr e =
   | ArrIdx (x, y) -> String.concat " " [ x; ".("; string_of_expr y; ")" ]
   | Arr(x) -> String.concat " " [ "["; string_of_exp_list x; "]" ]
   | ArrMusic(x) -> String.concat " " [ "{"; string_of_exp_list x; "}" ]
-  | Throw(x, y) -> String.concat " " ["Throw"; string_of_expr x; string_of_expr y]
+  | Throw(x) -> String.concat " " ["Throw"; string_of_expr x]
 and string_of_exp_list l =
   match l with
   | [] -> ""

src/cast.ml

@@ -2,7 +2,7 @@ open Core.Std
 
 open Ast
 
-type binary_operator = Add | Sub | Mult | Div | Equal | Neq | Less | Leq | Greater | Geq
+type binary_operator = Add | Sub | Mult | Div | Mod | Equal | Neq | Less | Leq | And | Or
 type unary_operator = Not | Neg
 
 type decl = Ast.t * string
@@ -91,7 +91,7 @@ let rec string_of_expr = function
       (match o with
       | Add -> "+" | Sub -> "-" | Mult -> "*" | Div -> "/"
       | Equal -> "==" | Neq -> "!="
-      | Less -> "<" | Leq -> "<=" | Greater -> ">" | Geq -> ">=") ^ " " ^
+      | Less -> "<" | Leq -> "<=" | Mod -> "%" | And -> "&&" | Or -> "||") ^ " " ^
       string_of_expr e2
   | Uniop(o, e) -> (match o with Not -> "!" | Neg -> "-") ^ string_of_expr e
   | Assign(v, e) -> string_of_expr (VarRef(v)) ^ " = " ^ string_of_expr e

src/cpp_sast.ml

@@ -14,11 +14,37 @@ let rec castx_of_sastx texpr =
     | Sast.LitStr(x) -> Cast.LitStr(x)
     | Sast.LitUnit -> Cast.LitUnit
 
-    | Sast.Binop(lexpr, op, rexpr)
-        -> ignore lexpr; ignore op; ignore rexpr; failwith "Binop cast_sast not implemented"
+    | Sast.Binop(lexpr, op, rexpr) ->
+        begin match op with
+          | Ast.Zip -> failwith "Internal error: binop zip should have been converted to Call NhFunction in ast2sast"
+          | Ast.Concat ->
+              Cast.Call(Cast.Function("nh_support","concat"),[castx_of_sastx lexpr; castx_of_sastx rexpr])
+          | Ast.Chord -> failwith "Internal error: binop chord should have been converted to Call NhFunction in ast2sast"
+          | Ast.Octave -> failwith "Internal error: binop octave should have been converted to Call NhFunction in ast2sast"
+          | _ as cop -> let op = begin match cop with
+            | Ast.Add -> Cast.Add
+            | Ast.Sub -> Cast.Sub
+            | Ast.Mul -> Cast.Mult
+            | Ast.Div -> Cast.Div
+            | Ast.Mod -> Cast.Mod
+            | Ast.Eq -> Cast.Equal
+            | Ast.Neq -> Cast.Neq
+            | Ast.Lt -> Cast.Less
+            | Ast.Lte -> Cast.Leq
+            | Ast.And -> Cast.And
+            | Ast.Or -> Cast.Or
+            | _ -> failwith "Internal error: failed to match all possible binops in sast2cast"
+          end in Cast.Binop(castx_of_sastx lexpr, op, castx_of_sastx rexpr)
+        end
+
 
-    | Sast.Uniop(op, expr)
-        -> ignore op; ignore expr; failwith "Uniop cast_sast not implemented"
+    | Sast.Uniop(op, expr) ->
+        begin match op with
+          | Ast.Not -> Cast.Uniop(Cast.Not, castx_of_sastx expr)
+          | Ast.Neg -> Cast.Uniop(Cast.Neg, castx_of_sastx expr)
+          | _ -> failwith
+              "Internal error: uniop flat and sharp should have been converted to Call NhFunction in ast2sast"
+        end
 
     | Sast.VarRef(names) -> Cast.VarRef(names)
 

src/parser.mly

@@ -143,7 +143,7 @@ expr:
 | expr CONCAT expr { Binop($1, Concat, $3) }
 | ID_VAR DOT_LPAREN expr RPAREN { ArrIdx($1, $3) }
 | control { $1 }
-| THROW non_apply non_apply { Throw($2, $3) }
+| THROW non_apply { Throw($2) }
 
 control:
 | IF sep_expr_sep THEN sep_expr_sep ELSE sep_star expr { Conditional($2,$4,$7) }

src/sast.ml

@@ -23,7 +23,7 @@ type expr_detail =
   | Block of expr_typed list
   | Conditional of expr_typed * expr_typed * expr_typed
   | For of new_variable_name * expr_typed * expr_typed
-  | Throw of expr_typed * expr_typed
+  | Throw of expr_typed
   | Init of new_variable_name * expr_typed
   | Assign of variable_name * expr_typed
   | Struct of type_name * ((string * expr_typed) list)

src/typed_ast.ml

@@ -106,6 +106,17 @@ let check_unique_functions fundefs externs =
       else nfundef :: defs
   )
 
+let chord_of sexpr =
+  begin match sexpr with
+    (* use function in standard library on chordable (chord, pitch, int) exprs *)
+    | (_, Ast.Int) -> Sast.FunApply(Sast.NhFunction("ChordOfPitch"),
+        [ Sast.FunApply(Sast.NhFunction("PitchOfInt"), [(Sast.LitInt(0),Ast.Int)]),
+          Ast.Type("pitch") ])
+    | (_, Ast.Type("pitch")) -> Sast.FunApply(Sast.NhFunction("ChordOfPitch"), [sexpr])
+    | (expr, Ast.Type("chord")) -> expr
+    | _ -> failwith "This expression is not chordable"
+  end, Ast.Type("chord")
+
 let rec sast_expr env tfuns_ref = function
   | Ast.LitBool(x) -> Sast.LitBool(x), Ast.Bool
   | Ast.LitInt(x) -> Sast.LitInt(x), Ast.Int
@@ -133,43 +144,32 @@ let rec sast_expr env tfuns_ref = function
       | Ast.And | Ast.Or -> failwith "This operation is only defined for bool"
 
       | Ast.Concat -> begin match lt, rt with
-        (* disallow chords to be concatted *)
-        | Ast.Array(l), Ast.Array(r)
-          when l = r && l <> Ast.Type("pitch") ->
-          Sast.Binop(lexprt,op,rexprt), lt
-        (* note that track is a type, not array *)
-        | Ast.Type("track"), Ast.Type("track")
-          -> Sast.Binop(lexprt,op,rexprt), lt
-        | _ -> failwith "This operation is only defined for same nonprimitive types" end
-      | Ast.Chord -> begin match lt, rt with
-        (* chordOp can be with pitch or chord or int *)
-        | Ast.Array(Ast.Type("pitch")), Ast.Array(Ast.Type("pitch"))
-        | Ast.Type("pitch"), Ast.Array(Ast.Type("pitch"))
-        | Ast.Array(Ast.Type("pitch")), Ast.Type("pitch")
-        | Ast.Type("pitch"), Ast.Type("pitch")
-        | Ast.Int, Ast.Array(Ast.Type("pitch"))
-        | Ast.Array(Ast.Type("pitch")), Ast.Int
-        | Ast.Int, Ast.Type("pitch")
-        | Ast.Type("pitch"), Ast.Int
-        | Ast.Int, Ast.Int
-          -> Sast.Binop(lexprt,op,rexprt), Ast.Array(Ast.Type("pitch"))
-        | _ -> failwith "This operation is only defined for pitch, chord, or int" end
-      | Ast.Octave -> begin match lt, rt with
-        | Ast.Type("pitch"), Ast.Int
-        | Ast.Int, Ast.Int -> Sast.Binop(lexprt,op,rexprt), Ast.Type("pitch")
-        | _ -> failwith "This operation is only defined for [pitch int] and int" end
-      | Ast.Zip -> begin match lt, rt with
-        (* zip works with music arr, chord, pitch, or int/float *)
-        | Ast.Float, Ast.Int
-        | Ast.Float, Ast.Type("pitch")
-        | Ast.Float, Ast.Array(Ast.Type("pitch"))
-        | Ast.Float, Ast.Array(Ast.Array(Ast.Type("pitch")))
-        | Ast.Array(Ast.Float), Ast.Int
-        | Ast.Array(Ast.Float), Ast.Type("pitch")
-        | Ast.Array(Ast.Float), Ast.Array(Ast.Type("pitch"))
-        | Ast.Array(Ast.Float), Ast.Array(Ast.Array(Ast.Type("pitch")))
-          -> Sast.Binop(lexprt,op,rexprt), Ast.Type("track")
-        | _ -> failwith "Incorrect types for zip" end
+        (* also allow tracks to be concatted *)
+        | Ast.Type("track"), Ast.Type("track") -> Sast.FunApply(NhFunction("ConcatTracks"),[lexprt;rexprt]), lt
+        | Ast.Array(l), Ast.Array(r) when l = r -> Sast.Binop(lexprt,op,rexprt), lt
+        | _ -> failwith "Concat is only for defined for same typed arrays and tracks" end
+
+      | Ast.Chord ->
+          (* guarantee that chord binop is between two chords *)
+          Sast.Binop(chord_of lexprt, op, chord_of rexprt), Ast.Type("chord")
+
+      | Ast.Octave ->
+          let lexprt = match lt with
+            | Ast.Type("pitch") -> lexprt
+            | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [lexprt]), Ast.Type("pitch")
+            | _ -> failwith "octave only defined for pitch or int on left side"
+          in if rt = Ast.Int
+            then Sast.FunApply(NhFunction("AddPitchOctave"), [lexprt;rexprt]), Ast.Type("pitch")
+            else failwith "octave only defined for int on right side"
+
+      | Ast.Zip ->
+          if (lt = Ast.Float || lt = Ast.Array(Ast.Float))
+            then let rexprt = match rt with
+                (* either chord or array of chord is valid for zip *)
+                | Ast.Array(Ast.Type("chord")) -> rexprt
+                | _ -> chord_of rexprt
+              in Sast.Binop(lexprt,op,rexprt), Ast.Type("track")
+            else failwith "left side expression of zip must of float or array of float"
     end
   | Ast.Uniop(op, expr) ->
     let exprt = sast_expr env tfuns_ref expr in
@@ -183,7 +183,19 @@ let rec sast_expr env tfuns_ref = function
 
       | Ast.Sharp | Ast.Flat when t = Ast.Int || t = Ast.Type("pitch")
         -> Sast.Uniop(op, exprt), Ast.Type("pitch")
-      |Ast.Sharp | Ast.Flat -> failwith "This operator is only defined for int or pitch"
+
+      | Ast.Sharp -> let tpitch = Ast.Type("pitch") in
+          let exprt = match t with
+            | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [exprt]), tpitch
+            | Ast.Type("pitch") -> exprt
+            | _ -> failwith "sharp is only defined for int or pitch"
+          in Sast.FunApply(NhFunction("SharpPitch"), [exprt]), tpitch
+      | Ast.Flat -> let tpitch = Ast.Type("pitch") in
+          let exprt = match t with
+            | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [exprt]), tpitch
+            | Ast.Type("pitch") -> exprt
+            | _ -> failwith "flat is only defined for int or pitch"
+          in Sast.FunApply(NhFunction("FlatPitch"), [exprt]), tpitch
     end
 
   | Ast.FunApply(name, arg_exprs) ->
@@ -229,7 +241,7 @@ let rec sast_expr env tfuns_ref = function
       else failwith ("There is no function named " ^ name)
 
   | Ast.Block(exprs) ->
-    let (texprs,_) = List.rev (List.fold_left exprs ~init:([],env)
+    let (texprs,_) = List.fold_left exprs ~init:([],env)
       ~f:(fun (texprs, env) expr ->
         (* propagate any env changes within block (due to new var initialization) *)
         let env =
@@ -245,8 +257,9 @@ let rec sast_expr env tfuns_ref = function
               end
         in let texpr = sast_expr env tfuns_ref expr in
         (texpr :: texprs, env)
-      ))
+      )
     in
+    let texprs = List.rev texprs in
     begin match List.last texprs with
       | Some(_, t) -> Block(texprs), t
       | None -> LitUnit, Ast.Unit
@@ -279,8 +292,8 @@ let rec sast_expr env tfuns_ref = function
   | For(loop_var_name, items, body) ->
     ignore (loop_var_name, items, body); failwith "Type checking not implemented for For"
 
-  | Throw(retval, msg) ->
-    ignore (retval, msg); failwith "Type checking not implemented for Throw"
+  | Throw(msg) ->
+    ignore msg; failwith "Type checking not implemented for Throw"
 
   | Assign(names, expr) ->
       let (value, tvalue) = sast_expr env tfuns_ref expr in