A09 Anton Surkis

.github/workflows/check.yml

@@ -41,15 +41,15 @@ jobs:
           else
             echo ${branch:1:2} > assignment_number.txt
           fi
-       - name: Check Deadline
-         run: |
-           deadline=2023-12-30T23:59
-           if [[ $(date +'%Y-%m-%dT%H:%M') > $deadline ]];
-           then
-               echo "FIASCO: The deadline has expired"
-               echo $(date +'%Y-%m-%dT%H:%M')
-               exit 1
-           fi
+      - name: Check Deadline
+        run: |
+          deadline=2023-12-30T23:59
+          if [[ $(date +'%Y-%m-%dT%H:%M') > $deadline ]];
+          then
+              echo "FIASCO: The deadline has expired"
+              echo $(date +'%Y-%m-%dT%H:%M')
+              exit 1
+          fi
       - uses: actions/upload-artifact@v2
         with:
           name: share_info

src/Builtins.lama

@@ -1,14 +1,27 @@
 -- Builtins
 import World;
+import Array;
+
+-- ONLY FOR THIS HOMEWORK
+-- The only function that operates on S-Expressions
+-- is the `length` function
+fun sexpToArray (x) {
+  case x of
+    S (tag, arr) -> mapArray (sexpToArray, arr)
+  | #array -> mapArray (sexpToArray, x)
+  | x : xs -> sexpToArray (x) : sexpToArray (xs)
+  | x -> x
+  esac
+}
 
 public fun evalBuiltin (name, args, w) {
-  case [name, args] of
-    ["stringval", {a}]            -> [a.string, w]
-  | ["length"   , {a@#array}]     -> [a.length, w]
-  | ["length"   , {a@#str}]       -> [a.length, w]
-  | ["length"   , {Sexp (_, vs)}] -> [vs.length, w]
-  | ["read"     , {}]             -> readWorld (w) 
-  | ["write"    , {x@#val}]       -> [0, writeWorld (x, w)]
+  case [name, sexpToArray (args)] of
+    ["stringval", {a}]              -> [a.string, w]
+  | ["length"   , {a@#array}]       -> [a.length, w]
+  | ["length"   , {a@#str}]         -> [a.length, w]
+  | ["length"   , {Sexp (_, vals)}] -> [vals.length, w]
+  | ["read"     , {}]               -> readWorld (w) 
+  | ["write"    , {x@#val}]         -> [0, writeWorld (x, w)]
   | _ ->
      failure ("no builtin ""%s"" or it can not be applied to %s\n", name, args.string)
   esac

src/Expr.lama

@@ -55,6 +55,7 @@ public fun evalOp (op, l, r) {
 --        Ignore  (expr)               |
 --        String  (string)             |
 --        Array   (expr list)          |
+--        Sexp    (string, expr list)  |
 --        Elem    (expr, expr)         |
 --        ElemRef (expr, expr)         |
 --        Builtin (string, expr list)
@@ -101,8 +102,183 @@ fun evalList (c, exprs) {
   esac
 }
 
+fun unwrapVal (x) {
+  case x of Val (x) -> x esac
+}
+
+fun lookupUnwrapVal (state, name) {
+  unwrapVal (lookupVal (state, name))
+}
+
+fun matchesPattern (tmpVal, pat) {
+  var result = case pat of
+    Wildcard -> true
+  | Named (name, pat) -> matchesPattern (tmpVal, pat)
+  | Number (num) ->
+      case tmpVal of
+        #val -> tmpVal == num
+      | _ -> false
+      esac
+  | String (s) ->
+      case tmpVal of
+        #str -> compare (tmpVal, s) == 0
+      | _ -> false
+      esac
+  | Array (patArgs) ->
+      case tmpVal of
+        #array ->
+          var sizeEq = size (patArgs) == length (tmpVal);
+          if sizeEq
+          then
+            var valArgs = arrayList (tmpVal);
+            foldl (
+                fun (acc, [patArg, valArg]) {
+                  acc && matchesPattern (valArg, patArg)
+                }
+              , true, zip (patArgs, valArgs))
+          else false
+          fi
+      | _ -> false
+      esac
+  | Sexp (patTag, patArgs) ->
+      case tmpVal of
+        S (valTag, valArgsArr) ->
+          var tagEq = compare (patTag, valTag) == 0;
+          var sizeEq = size (patArgs) == length (valArgsArr);
+          if tagEq && sizeEq
+          then
+            var valArgs = arrayList (valArgsArr);
+            foldl (
+                fun (acc, [patArg, valArg]) {
+                  acc && matchesPattern (valArg, patArg)
+                }
+              , true, zip (patArgs, valArgs))
+          else false
+          fi
+      | _ -> false
+      esac
+  | _ -> false
+  esac;
+  -- printf("%s matches? %s => %d\n", tmpVal.string, pat.string, result);
+  result
+}
+
 fun eval (c@[s, w], expr) {
-  failure ("evalExpr not implemented\n")
+  -- printf ("Eval %s\n", string (expr));
+  case expr of
+    Skip -> [c, V]
+  | Scope (defs, expr) ->
+      var s1 = foldl (fun (s, def) {
+        case def of
+          Var (names) -> addNames (s, names)
+        | Val (names) -> addNames (s, names)
+        | Fun (name, args, body) -> addFunction (s, name, args, body)
+        | _ -> failure (sprintf ("%s unimplemented", def.string))
+        esac
+      }, enterScope (s), defs);
+      case eval ([s1, w], expr) of
+        [[s, w], x] -> [[leaveScope (s), w], x]
+      esac
+  | Ignore (expr) ->
+      case eval (c, expr) of
+        [c, _] -> [c, V]
+      esac
+  | Seq (lhs, rhs) ->
+      case evalList (c, {lhs, rhs}) of
+        [c, {lhs, rhs}] -> [c, rhs]
+      esac
+  | Assn (lhs, rhs) ->
+      case evalList (c, {lhs, rhs}) of
+        [[s, w], {R (name), rhs}] ->
+          -- printf ("%s := %s\n", name, string (rhs));
+          [ [s <- [name, Val (rhs)], w], rhs ]
+      | [[s, w], {ER (arr, idx), rhs}] ->
+          arr[idx] := rhs;
+          [[s, w], rhs]
+      esac
+  | Set (name, expr) ->
+      case eval (c, expr) of
+        [[s, w], x] -> [ [s <- [name, Val (x)], w], x ]
+      esac
+  | Var (name) -> [c, lookupUnwrapVal (s, name)]
+  | Ref (name) -> [c, R (name)]
+  | Const (x) -> [c, x]
+  | String (string) ->
+      -- printf ("Evaluated into %s\n", string);
+      [c, string]
+  | Array (exprs) ->
+      case evalList (c, exprs) of
+        [c, elems] -> [c, listArray (elems)]
+      esac
+  | Sexp (tag, exprs) ->
+      case evalList (c, exprs) of
+        [c, elems] -> [c, S (tag, listArray (elems))]
+      esac
+  | Elem (arr, idx) ->
+      case evalList (c, {arr, idx}) of [c, {arr, idx}] ->
+      case arr of
+        S (tag, arr) -> [c, arr[idx]]
+      |         arr  -> [c, arr[idx]]
+      esac esac
+  | ElemRef (arr, idx) ->
+      case evalList (c, {arr, idx}) of
+        [c, {arr, idx}] -> [c, ER (arr, idx)]
+      esac
+  | Binop (op, lhs, rhs) ->
+      case evalList (c, {lhs, rhs}) of
+        [c, {lhs, rhs}] -> [c, evalOp (op, lhs, rhs)]
+      esac
+  | If (cond, bodyThen, bodyElse) ->
+      case eval (c, cond) of [c, condVal] ->
+        if condVal
+        then eval (c, bodyThen)
+        else eval (c, bodyElse)
+        fi
+      esac
+  | lp@While (cond, body) ->
+      case eval (c, cond) of [c, condVal] ->
+        if condVal
+        then eval (c, Seq (body, lp))
+        else [c, V]
+        fi
+      esac
+  | DoWhile (cond, body) -> eval (c, Seq (body, While (cond, body)))
+  | Call (name, argExprs) ->
+      case evalList (c, argExprs) of [c@[s, w], argVals] ->
+        case lookupFun (s, name) of
+          Fun (argNames, External) ->
+            case evalBuiltin (name, argVals, w) of
+              [x, w] -> [[s, w], x]
+            esac
+        | Fun (argNames, body) ->
+            var s1 = foldl (
+              fun (s, [name, x]) { s <- [name, Val (x)] }
+            , addNames (enterFunction (s), argNames)
+            , zip (argNames, argVals)
+            );
+            case eval ([s1, w], body) of [[s1, w], x] ->
+              [[leaveFunction (s, getGlobal (s1)), w], x]
+            esac
+        esac
+      esac
+  | Case (tmpName, branches, [line, col]) ->
+      var tmpVal = lookupUnwrapVal (s, tmpName);
+      var retFun = foldr (fun (other, [pat, br]) {
+        if matchesPattern (tmpVal, pat)
+        then fun () { eval (c, br) }
+        else other
+        fi
+      }, fun () {
+        failure (
+          "Value %s matched no pattern among %s at %d:%d\n"
+        , string (tmpVal)
+        , string (map (fst, branches))
+        , line
+        , col
+        )
+      }, branches);
+      retFun ()
+  esac
 }
 
 

src/Parser.lama

@@ -226,7 +226,91 @@ var
                         esac, loc)}
     } |
 
-    $(failure ("the rest of primary parsing in not implemented\n"))),
+    loc=pos kSkip { fun (a) { assertVoid (a, returnST (Skip), loc) } }
+  | inbr[s("("), scopeExpr, s(")")]
+  -- | kRead s["("] x=lident s[")"] { fun (a) { Read (x) } }
+  -- | loc=pos kWrite s["("] x=exp s[")"]
+  --   { fun (a) { assertVoid (a, Write (x (Val)), loc) } }
+  | loc=pos kIf cond=exp kThen bodyThen=scopeExpr bodyElse=endIf {
+      fun (a) {
+        cond (Val) =>> fun (cond) {
+        bodyThen (a) =>> fun (bodyThen) {
+        bodyElse (a) => fun (bodyElse) {
+          If (cond, bodyThen, bodyElse)
+        } } }
+      }
+    }
+  | loc=pos kWhile cond=exp kDo body=scopeExpr kOd {
+      fun (a) {
+        assertVoid (a
+        , cond (Val) =>> fun (cond) {
+          body (Void) => fun (body) {
+            While (cond, body)
+          } }
+        , loc
+        )
+      }
+    }
+  | loc=pos kDo body=scopeExpr kWhile cond=exp kOd {
+      fun (a) {
+        assertVoid (a
+          , cond (Val) =>> fun (cond) {
+            body (Void) => fun (body) {
+              distributeScope (body, fun (body) {
+                DoWhile (cond, body)
+              })
+            } }
+          , loc
+          )
+      }
+    }
+  | loc=pos kFor init=scopeExpr s[","] cond=exp s[","] iter=exp kDo body=scopeExpr kOd {
+      fun (a) {
+        assertVoid (a
+          , init (Void) =>> fun (init) {
+            cond (Val) =>> fun (cond) {
+            body (Void) =>> fun (body) {
+            iter (Void) => fun (iter) {
+              distributeScope (init, fun (init) {
+                  Seq (init, While (cond, Seq (body, iter)))
+              })
+            } } } }
+          , loc
+          )
+      }
+    }
+  | loc=pos
+    kCase scrutinee=exp kOf
+      cases=listBy[
+        syntax (
+          pat=pattern s["->"] branch=scopeExpr { [pat, branch] }
+        )
+      , s("|")
+      ]
+    kEsac {
+      fun (a) {
+        scrutinee (Val) =>> fun (scrutinee) {
+          var patBranches = foldr (fun (acc, [pat, branch]) {
+            acc =>> fun (acc) {
+            branch (a) => fun (branch) {
+              [pat, branch] : acc
+            } }
+          }, returnST ({}), cases);
+
+          freshName =>> fun (tmpName) {
+          patBranches => fun (patBranches) {
+            var reified = reifyPatternBindings (tmpName, patBranches);
+            expandScope (
+              { Val ({ [tmpName, scrutinee] }) }
+            , Case (tmpName, reified, loc)
+            )
+          } }
+        }
+      }
+    }
+    -- |
+    -- $(failure ("the rest of primary parsing in not implemented\n"))
+    ),
 
 
   basic = memo $ eta (
@@ -317,5 +401,34 @@ var
    }
   );
 
+var endIf = memo $ eta syntax (
+  loc=pos kFi { fun (a) { assertVoid (a, returnST (Skip), loc) } }
+| kElse body=scopeExpr kFi { body }
+| kElif cond=scopeExpr kThen bodyThen=scopeExpr bodyElse=endIf {
+    fun (a) {
+      cond (Val) =>> fun (cond) {
+      bodyThen (a) =>> fun (bodyThen) {
+      bodyElse (a) => fun (bodyElse) {
+        If (cond, bodyThen, bodyElse)
+      } } }
+    }
+  }
+);
+
+var pattern = memo $ eta syntax (
+  s["_"] { Wildcard }
+| name=lident s["@"] pat=pattern { Named (name, pat) }
+| name=lident { Named (name, Wildcard) }
+| s["["] items=list0[pattern] s["]"] { Array (items) }
+| tag=uident args=inbr[s("("), list0(pattern), s(")")]? {
+    case args of
+      None -> Sexp (tag, {})
+    | Some (args) -> Sexp (tag, args)
+    esac
+  }
+| x=decimal { Number (stringInt(x)) }
+| x=strlit { String (x) }
+);
+
 -- Public top-level parser
 public parse = syntax (s=scopeExpr {s (Void) (emptyEnv ()) [1]});