From 20347cc51bce75f4c4949fb046c958e8512c6c96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Thu, 25 Sep 2025 14:01:24 +0200 Subject: [PATCH 01/25] Rename 'Call' to 'StackExpand` in IR, Raw, and Stack This brings the name closer to the actual meaning of this construction. --- compiler/src/ClosureConv.hs | 2 +- compiler/src/IR.hs | 13 +++++++------ compiler/src/IR2Raw.hs | 4 ++-- compiler/src/IROpt.hs | 6 +++--- compiler/src/Raw.hs | 4 ++-- compiler/src/Raw2Stack.hs | 4 ++-- compiler/src/RawDefUse.hs | 2 +- compiler/src/RawOpt.hs | 23 ++++++++++++----------- compiler/src/Stack.hs | 4 ++-- compiler/src/Stack2JS.hs | 2 +- compiler/test/ir2raw-test/testcases/TR.hs | 4 ++-- 11 files changed, 35 insertions(+), 33 deletions(-) diff --git a/compiler/src/ClosureConv.hs b/compiler/src/ClosureConv.hs index d92d4024..4b212f1c 100644 --- a/compiler/src/ClosureConv.hs +++ b/compiler/src/ClosureConv.hs @@ -201,7 +201,7 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do cpsToIR (CPS.LetRet (CPS.Cont arg kt') kt) = do t <- cpsToIR kt t' <- local (insVar arg) (cpsToIR kt') - return $ CCIR.BB [] $ Call arg t t' + return $ CCIR.BB [] $ StackExpand arg t t' cpsToIR (CPS.LetFun fdefs kt) = do let vnames_orig = map (\(CPS.Fun fname _) -> fname) fdefs let localExt = local (insVars vnames_orig) diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index 8621c088..c4836153 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -91,7 +91,7 @@ data IRTerminator -- and then execute the second BB, which can refer to this variable and -- where PC is reset to the level before entering the first BB. -- Represents a "let x = ... in ..." format. - | Call VarName IRBBTree IRBBTree + | StackExpand VarName IRBBTree IRBBTree deriving (Eq,Show,Generic) @@ -147,7 +147,7 @@ instance ComputesDependencies IRBBTree where instance ComputesDependencies IRTerminator where dependencies (If _ bb1 bb2) = mapM_ dependencies [bb1, bb2] dependencies (AssertElseError _ bb1 _ _) = dependencies bb1 - dependencies (Call _ t1 t2) = dependencies t1 >> dependencies t2 + dependencies (StackExpand _ t1 t2) = dependencies t1 >> dependencies t2 dependencies _ = return () instance ComputesDependencies FunDef where @@ -231,15 +231,15 @@ instance WellFormedIRCheck IRInst where wfir (Assign (VN x) e) = do checkId x wfir e wfir (MkFunClosures _ fdefs) = mapM_ (\((VN x), _) -> checkId x) fdefs - + instance WellFormedIRCheck IRTerminator where wfir (If _ bb1 bb2) = do wfir bb1 wfir bb2 wfir (AssertElseError _ bb _ _) = wfir bb - wfir (Call (VN x) bb1 bb2 ) = do - checkId x + wfir (StackExpand (VN x) bb1 bb2 ) = do + checkId x wfir bb1 wfir bb2 @@ -442,7 +442,8 @@ ppIR (MkFunClosures varmap fdefs) = -ppTr (Call vn bb1 bb2) = (ppId vn <+> text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) + +ppTr (StackExpand vn bb1 bb2) = (ppId vn <+> text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) ppTr (AssertElseError va ir va2 _) diff --git a/compiler/src/IR2Raw.hs b/compiler/src/IR2Raw.hs index 7f663c17..6bc633c9 100644 --- a/compiler/src/IR2Raw.hs +++ b/compiler/src/IR2Raw.hs @@ -699,7 +699,7 @@ tr2raw = \case return $ If r bb1' bb2' -- Revision 2023-08: Equivalent, only way of modifying bb2 changed. - IR.Call v irBB1 irBB2 -> do + IR.StackExpand v irBB1 irBB2 -> do bb1 <- tree2raw irBB1 BB insts2 tr2 <- tree2raw irBB2 -- Prepend before insts2 instructions to store in variable v the result @@ -711,7 +711,7 @@ tr2raw = \case -- generally using Sequence (faster concatenation) for instructions -- might improve performance let bb2 = BB insts2' tr2 - return $ Call bb1 bb2 + return $ StackExpand bb1 bb2 -- Note: This is translated into branching and Error for throwing RT exception -- Revision 2023-08: More fine-grained raising of blocking label, see below. diff --git a/compiler/src/IROpt.hs b/compiler/src/IROpt.hs index 610c1f24..f0676ef2 100644 --- a/compiler/src/IROpt.hs +++ b/compiler/src/IROpt.hs @@ -67,7 +67,7 @@ instance Substitutable IRTerminator where AssertElseError (apply subst x) (apply subst bb) (apply subst y) pos LibExport x -> LibExport (apply subst x) Error x pos -> Error (apply subst x) pos - Call decVar bb1 bb2 -> Call decVar (apply subst bb1) (apply subst bb2) + StackExpand decVar bb1 bb2 -> StackExpand decVar (apply subst bb1) (apply subst bb2) instance Substitutable IRBBTree where apply subst (BB insts tr) = @@ -462,7 +462,7 @@ trPeval (AssertElseError x bb y_err pos) = do return $ BB [] (AssertElseError x bb' y_err pos) -trPeval (Call x bb1 bb2) = do +trPeval (StackExpand x bb1 bb2) = do bb1' <- peval bb1 bb2' <- peval bb2 @@ -473,7 +473,7 @@ trPeval (Call x bb1 bb2) = do setChangeFlag return $ BB (insts1 ++ insts2) tr2 _ -> - return $ BB [] (Call x bb1' bb2') + return $ BB [] (StackExpand x bb1' bb2') trPeval tr@(Ret x) = do markUsed' x diff --git a/compiler/src/Raw.hs b/compiler/src/Raw.hs index a9a17046..2f7a5ff9 100644 --- a/compiler/src/Raw.hs +++ b/compiler/src/Raw.hs @@ -158,7 +158,7 @@ data RawTerminator | Error RawVar PosInf -- | Execute the first BB and then execute the second BB where -- PC is reset to the level before entering the first BB. - | Call RawBBTree RawBBTree + | StackExpand RawBBTree RawBBTree deriving (Eq, Show) @@ -341,7 +341,7 @@ ppIR (MkFunClosures varmap fdefs) = -- ppIR (LevelOperations _ insts) = -- text "level operation" $$ nest 2 (vcat (map ppIR insts)) -ppTr (Call bb1 bb2) = (text "call" $$ nest 4 (ppBB bb1)) $$ (ppBB bb2) +ppTr (StackExpand bb1 bb2) = (text "call" $$ nest 4 (ppBB bb1)) $$ (ppBB bb2) -- ppTr (AssertElseError va ir va2 _) diff --git a/compiler/src/Raw2Stack.hs b/compiler/src/Raw2Stack.hs index caf87c3b..b4e892a7 100644 --- a/compiler/src/Raw2Stack.hs +++ b/compiler/src/Raw2Stack.hs @@ -188,7 +188,7 @@ trTr (Raw.LibExport v) = do return $ Stack.LibExport v trTr (Raw.Error r1 p) = do return $ Stack.Error r1 p -trTr (Raw.Call bb1 bb2) = do +trTr (Raw.StackExpand bb1 bb2) = do __callDepth <- localCallDepth <$> ask bb1' <- local (\tenv -> tenv { localCallDepth = __callDepth + 1 } ) $ trBB bb1 n <- getBlockNumber @@ -205,7 +205,7 @@ trTr (Raw.Call bb1 bb2) = do | x <- filter filterConsts (Set.elems varsToLoad) ] bb2'@(Stack.BB inst_2 tr_2) <- trBB bb2 - return $ Stack.Call bb1' (Stack.BB (loads ++ inst_2) tr_2) + return $ Stack.StackExpand bb1' (Stack.BB (loads ++ inst_2) tr_2) trBB :: Raw.RawBBTree -> Tr Stack.StackBBTree diff --git a/compiler/src/RawDefUse.hs b/compiler/src/RawDefUse.hs index c6b7314f..e987b917 100644 --- a/compiler/src/RawDefUse.hs +++ b/compiler/src/RawDefUse.hs @@ -233,7 +233,7 @@ instance Trav RawTerminator where trav bb2 LibExport v -> use v Error r _ -> use r - Call bb1 bb2 -> do + StackExpand bb1 bb2 -> do trav bb1 modify (\s -> let (c, _) = locInfo s diff --git a/compiler/src/RawOpt.hs b/compiler/src/RawOpt.hs index 937dc8be..e7253b77 100644 --- a/compiler/src/RawOpt.hs +++ b/compiler/src/RawOpt.hs @@ -78,7 +78,7 @@ instance Substitutable RawTerminator where If r bb1 bb2 -> If (apply subst r) (apply subst bb1) (apply subst bb2) Error r p -> Error (apply subst r) p - Call bb1 bb2 -> Call (apply subst bb1) (apply subst bb2) + StackExpand bb1 bb2 -> StackExpand (apply subst bb1) (apply subst bb2) _ -> tr instance Substitutable RawBBTree where @@ -420,7 +420,7 @@ instance PEval RawTerminator where } bb2' <- peval bb2 return $ If x bb1' bb2' - Call bb1 bb2 -> do + StackExpand bb1 bb2 -> do s <- get bb1' <- peval bb1 put $ s { stateMon = Map.empty @@ -428,7 +428,7 @@ instance PEval RawTerminator where , stateJoins = stateJoins s } -- reset the monitor state bb2' <- peval bb2 - return $ Call bb1' bb2' + return $ StackExpand bb1' bb2' Ret -> do return tr' TailCall x -> do @@ -470,14 +470,15 @@ filterInstBwd ls = f (Nothing, Nothing) (reverse ls) [] --- | This optimization for 'Call' moves instructions from the continuation to before the 'Call'. --- This can result in a 'Call' which just contains a 'Ret', which is then optimized away. --- The optimization compensates for redundant assignments introduced by the translation. -hoistCalls :: RawBBTree -> RawBBTree -hoistCalls bb@(BB insts tr) = +-- | This optimization for 'StackExpand' moves instructions from the continuation to before the +-- 'StackExpand'. This can result in a 'StackExpand' which just contains a 'Ret', which is then +-- optimized away. The optimization compensates for redundant assignments introduced by the +-- translation. +hoistStackExpand :: RawBBTree -> RawBBTree +hoistStackExpand bb@(BB insts tr) = case tr of -- Here we check which instructions from ii_1 can be moved to before the call - Call (BB ii_1 tr_1) bb2 -> + StackExpand (BB ii_1 tr_1) bb2 -> let isFrameSpecific i = case i of SetBranchFlag -> True @@ -487,7 +488,7 @@ hoistCalls bb@(BB insts tr) = -- jx_1: non-frame-specific instructions, are moved to before the call -- jx_2: frame-specific instructions, stay under the call's instructions (jx_1, jx_2) = Data.List.break isFrameSpecific ii_1 - in BB (insts ++ jx_1) (Call (BB jx_2 tr_1) bb2) + in BB (insts ++ jx_1) (StackExpand (BB jx_2 tr_1) bb2) -- If returning, the current frame will be removed, and thus all PC set instructions -- are redundant and can be removed. Ret -> @@ -537,7 +538,7 @@ instance PEval RawBBTree where If x (BB (set_pc_bl ++ i_then) tr_then) (BB (set_pc_bl ++ i_else) tr_else) - _ -> hoistCalls $ BB (insts_no_ret ++ set_pc_bl) tr'' + _ -> hoistStackExpand $ BB (insts_no_ret ++ set_pc_bl) tr'' let insts_sorted = instOrder insts_ return $ BB insts_sorted bb_ diff --git a/compiler/src/Stack.hs b/compiler/src/Stack.hs index 6427a452..91f3e4f9 100644 --- a/compiler/src/Stack.hs +++ b/compiler/src/Stack.hs @@ -47,7 +47,7 @@ data StackTerminator | If RawVar StackBBTree StackBBTree | LibExport VarAccess | Error RawVar PosInf - | Call StackBBTree StackBBTree + | StackExpand StackBBTree StackBBTree deriving (Eq, Show) @@ -150,7 +150,7 @@ ppIR (MkFunClosures varmap fdefs) = ppIR (LabelGroup insts) = text "group" $$ nest 2 (vcat (map ppIR insts)) -ppTr (Call bb1 bb2) = (text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) +ppTr (StackExpand bb1 bb2) = (text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2) -- ppTr (AssertElseError va ir va2 _) diff --git a/compiler/src/Stack2JS.hs b/compiler/src/Stack2JS.hs index 5717b99f..0a11bedd 100644 --- a/compiler/src/Stack2JS.hs +++ b/compiler/src/Stack2JS.hs @@ -452,7 +452,7 @@ ir2js InvalidateSparseBit = return $ {-- TERMINATORS --} -tr2js (Call bb bb2) = do +tr2js (StackExpand bb bb2) = do _frameSize <- gets frameSize _sparseSlot <- gets sparseSlot _consts <- gets consts diff --git a/compiler/test/ir2raw-test/testcases/TR.hs b/compiler/test/ir2raw-test/testcases/TR.hs index 4800b478..f330a8e0 100644 --- a/compiler/test/ir2raw-test/testcases/TR.hs +++ b/compiler/test/ir2raw-test/testcases/TR.hs @@ -30,8 +30,8 @@ tcs = map (second mkP) (BB [Assign (VN "b1") (Base "v1") ] (LibExport (mkV "b1"))) (BB [Assign (VN "b2") (Base "v2") ] (LibExport (mkV "b2"))) ), - ( "Call" - , Call (VN "x") + ( "StackExpand" + , StackExpand (VN "x") (BB [Assign (VN "b1") (Base "v1") ] (LibExport (mkV "b1"))) (BB [Assign (VN "b2") (Base "v2") ] (LibExport (mkV "b2"))) ), From dfdb947f726e997b690ff3b46449805a4a34c260 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Thu, 25 Sep 2025 16:33:27 +0200 Subject: [PATCH 02/25] Improve lib record export syntax This way, is is less likely one by accident exports the wrong function under a different name --- lib/Hash.trp | 16 +++++++-------- lib/HashMap.trp | 32 +++++++++++++---------------- lib/HashSet.trp | 26 ++++++++++-------------- lib/List.trp | 47 ++++++++++++++++++------------------------- lib/ListPair.trp | 31 +++++++++++++--------------- lib/Number.trp | 39 ++++++++++++++++++----------------- lib/StencilVector.trp | 38 +++++++++++++++++----------------- lib/String.trp | 23 +++++++++++---------- lib/Unit.trp | 14 ++++++------- 9 files changed, 123 insertions(+), 143 deletions(-) diff --git a/lib/Hash.trp b/lib/Hash.trp index 5a4b0d90..f10ec7b0 100644 --- a/lib/Hash.trp +++ b/lib/Hash.trp @@ -68,15 +68,13 @@ let (*--- Module ---*) val Hash = { - hashString = hashString, - hashMultiplyShift = hashMultiplyShift, - hashInt = hashInt, - hashNumber = hashNumber, - hashList = hashList, - hash = hash + hashString, + hashMultiplyShift, + hashInt, + hashNumber, + hashList, + hash } -in [ ("Hash", Hash) - , ("hash", hash) - ] +in [ ("Hash", Hash), ("hash", hash) ] end diff --git a/lib/HashMap.trp b/lib/HashMap.trp index 43358544..a8e25072 100644 --- a/lib/HashMap.trp +++ b/lib/HashMap.trp @@ -202,24 +202,20 @@ let (* NOTE: The map is implemented as a Hash Array Mapped Trie (HAMT), i.e. a p (*--- Module ---*) val HashMap = { - (* Construction *) - empty = empty, - singleton = singleton, - insert = insert, - remove = remove, - (* Queries *) - null = null, - size = size, - findOpt = findOpt, - find = find, - mem = mem, - (* Manipulation *) - fold = fold, - (* List Conversion*) - keys = keys, - values = values, - toList = toList, - fromList = fromList + empty, + singleton, + insert, + remove, + null, + size, + findOpt, + find, + mem, + fold, + keys, + values, + toList, + fromList } in [ ("HashMap", HashMap) ] diff --git a/lib/HashSet.trp b/lib/HashSet.trp index 0ffccbc5..ccad42d0 100644 --- a/lib/HashSet.trp +++ b/lib/HashSet.trp @@ -47,21 +47,17 @@ let (* NOTE: The set is implemented as a HashMap with dummy values, `()`. This i (*--- Module ---*) val HashSet = { - (* Construction *) - empty = empty, - singleton = singleton, - insert = insert, - remove = remove, - (* Queries *) - null = null, - size = size, - mem = mem, - (* Manipulation *) - fold = fold, - (* List Conversion*) - elems = elems, - toList = toList, - fromList = fromList + empty, + singleton, + insert, + remove, + null, + size, + mem, + fold, + elems, + toList, + fromList } in [ ("HashSet", HashSet) ] diff --git a/lib/List.trp b/lib/List.trp index 872936e9..775007e3 100644 --- a/lib/List.trp +++ b/lib/List.trp @@ -169,33 +169,26 @@ let (* -- List Access -- *) (*--- Module ---*) val List = { - head = head, - tail = tail, - nth = nth, - - null = null, - elem = elem, - length = length, - - reverse = reverse, - append = append, - revAppend = revAppend, - appendAt = appendAt, - sublist = sublist, - - map = map, - mapi = mapi, - foldl = foldl, - filter = filter, - filteri = filteri, - partition = partition, - - range = range, - - sort = sort + head, + tail, + nth, + null, + elem, + length, + reverse, + append, + revAppend, + appendAt, + sublist, + map, + mapi, + foldl, + filter, + filteri, + partition, + range, + sort } -in [ ("List", List), - ("length", length) - ] +in [ ("List", List), ("length", length) ] end diff --git a/lib/ListPair.trp b/lib/ListPair.trp index 20d03ca6..94b54eed 100644 --- a/lib/ListPair.trp +++ b/lib/ListPair.trp @@ -64,22 +64,19 @@ let (* -- ListPair Generation -- *) (*--- Module ---*) val ListPair = { - zip = zip, - unzip = unzip, - - null = null, - length = length, - - reverse = reverse, - append = append, - revAppend = revAppend, - - findOpt = findOpt, - find = find, - mem = mem, - - map = map, - foldl = foldl + zip, + unzip, + null, + length, + reverse, + append, + revAppend, + findOpt, + find, + mem, + map, + foldl } -in [ ("ListPair", ListPair) ] end +in [ ("ListPair", ListPair) ] +end diff --git a/lib/Number.trp b/lib/Number.trp index ad9b7527..a8867220 100644 --- a/lib/Number.trp +++ b/lib/Number.trp @@ -93,25 +93,26 @@ let (** Largest (safe) possible integral value. Anything larger than this cannot (*--- Module ---*) val Number = { - maxInt = maxInt, - minInt = minInt, - precision = precision, - maxInt32 = maxInt32, - minInt32 = minInt32, - maxNum = maxNum, - minNum = minNum, - abs = abs, - min = min, - max = max, - ceil = ceil, - floor = floor, - round = round, - sqrt = sqrt, - isInt = isInt, - toInt = toInt, - toInt32 = toInt32, - toString = toString, - fromString = fromString + maxInt, + minInt, + precision, + maxInt32, + minInt32, + maxNum, + minNum, + abs, + min, + max, + ceil, + floor, + round, + sqrt, + isInt, + toInt, + toInt32, + toString, + fromString } + in [("Number", Number)] end diff --git a/lib/StencilVector.trp b/lib/StencilVector.trp index a272bc91..f73701cc 100644 --- a/lib/StencilVector.trp +++ b/lib/StencilVector.trp @@ -146,26 +146,24 @@ let (*--- Constants ---*) (* TODO: Lift list functions `mapi`, `find` and `filter`? *) + (*--- Module ---*) val StencilVector = { - (* Constants *) - maskBits = maskBits, - maskMax = maskMax, - (* Functions *) - empty = empty, - singleton = singleton, - get = get, - getOrDefault = getOrDefault, - set = set, - unset = unset, - mem = mem, - valid = valid, - null = null, - mask = mask, - length = length, - map = map, - fold = fold + maskBits, + maskMax, + empty, + singleton, + get, + getOrDefault, + set, + unset, + mem, + valid, + null, + mask, + length, + map, + fold } -in (* Export public functions *) - [ ("StencilVector", StencilVector) - ] + +in [ ("StencilVector", StencilVector) ] end diff --git a/lib/String.trp b/lib/String.trp index b275f776..2dfe068e 100644 --- a/lib/String.trp +++ b/lib/String.trp @@ -70,17 +70,18 @@ let (** The maximum length of a string. (*--- Module ---*) val String = { - maxSize = maxSize, - size = size, - sub = sub, - subCode = subCode, - substring = substring, - concat = concat, - concatWith = concatWith, - implode = implode, - explode = explode, - map = map, - translate = translate + maxSize, + size, + sub, + subCode, + substring, + concat, + concatWith, + implode, + explode, + map, + translate } + in [("String", String)] end diff --git a/lib/Unit.trp b/lib/Unit.trp index 483d32ac..f4b49eba 100644 --- a/lib/Unit.trp +++ b/lib/Unit.trp @@ -112,13 +112,13 @@ let (*--- Module ---*) val Unit = { - group = group, - it = it, - isEq = isEq, - isTrue = isTrue, - isFalse = isFalse, - isNeq = isNeq, - run = run + group, + it, + isEq, + isTrue, + isFalse, + isNeq, + run } in [ ("Unit", Unit) ] From 7afbef12d79981f12efac648a70eef83fb439bc6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Fri, 26 Sep 2025 10:30:43 +0200 Subject: [PATCH 03/25] Manifest design of the Standard Library in its README --- lib/README.md | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/lib/README.md b/lib/README.md index ea43f188..44119947 100644 --- a/lib/README.md +++ b/lib/README.md @@ -21,13 +21,19 @@ reviewed rigorously rather than depend on the monitor. To compile a module as part of the standard library, add it to the list of files in the `lib` target of the *makefile*. +## Design Principles + +- File names are written in `CamelCase`. This makes them conform to the Standard ML Basis Library. +- It is more important to match the function names and signatures in the Standard ML library than to + improve on them. For example, `String.sub` would make more sense with the type `[Char] -> Int -> + Char` but to match the SML library, we will stick with `[Char] * Int -> Char`. +- Each module exports a single *record* with the same name as the file. This (1) makes it closer to + the SML module system and (2) allows for name resolution, e.g. `HashMap.findOpt` and + `ListPair.findOpt` can be used in the same file. +- Each function that is exported has to be documented (`(** *)`). In the long run, we will + auto-generate documentation for the Standard Library. + ## TODO -- To conform with the Standard ML Basis Library, we should have the files conform to a `CamelCase` - style. -- To fake namespaced import, e.g. `List.length`, the library should export a struct instead. Only - certain functions should "pollute" the global namespace. -- Quite a lot of the standard library is not documented in any way. What is the purpose of each - function and each module? The [modules](#modules) above are the ones that have been updated and - documented. -- There are a lot of things in here - some of it dead. Can we merge/remove some things? +The [modules](#modules) mentioned above already follow the [design principles](#design-principles). +The remaining files either need to be updated or to be removed. From c1d59a5a2c9762e70c1e240d318e452faa197df3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Mon, 29 Sep 2025 16:36:16 +0200 Subject: [PATCH 04/25] Set up Dependabot to keep an eye on Action dependencies --- .github/dependabot.yml | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 .github/dependabot.yml diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 00000000..5ace4600 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: + - package-ecosystem: "github-actions" + directory: "/" + schedule: + interval: "weekly" From 4342c8d606e5d62344d5ee48d41e5ed94beab950 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Mon, 29 Sep 2025 16:45:46 +0200 Subject: [PATCH 05/25] Fix 'Data.ByteString.getLine' is deprecated --- compiler/app/Main.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index fd007e2b..400fa6f5 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -21,9 +21,8 @@ import qualified Raw2Stack import qualified Stack2JS import qualified RawOpt -- import System.IO (isEOF) -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS import Data.ByteString.Base64 (decode) -import qualified Data.ByteString.Char8 as BSChar8 import qualified Data.ByteString.Lazy.Char8 as BSLazyChar8 import System.IO import System.Exit @@ -220,7 +219,7 @@ fromStdinIR = do input <- BS.getLine if BS.isPrefixOf "!ECHO " input then let response = BS.drop 6 input - in do BSChar8.putStrLn response + in do BS.putStrLn response -- debugOut "echo" else case decode input of @@ -244,7 +243,7 @@ fromStdinIRJson = do input <- BS.getLine if BS.isPrefixOf "!ECHO " input then let response = BS.drop 6 input - in BSChar8.putStrLn response + in BS.putStrLn response else case decode input of Right bs -> From 1eb31dd1bed737b79c60f91b6f132c2b8508d427 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Mon, 29 Sep 2025 16:54:32 +0200 Subject: [PATCH 06/25] Rename 'make all' to 'make build' to match conventions --- Makefile | 2 +- compiler/Makefile | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 0012dafc..ebcdc384 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ rt: COMPILER=./bin/troupec compiler: - cd compiler; $(MAKE) all + cd compiler; $(MAKE) build p2p-tools: cd p2p-tools; tsc diff --git a/compiler/Makefile b/compiler/Makefile index 216554ec..4bacb78d 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -1,6 +1,6 @@ .PHONY: test -all: +build: stack -v build $(STACK_OPTS) mkdir -p ./../bin stack -v install $(STACK_OPTS) --local-bin-path ./../bin/ From 086aeeb454c94d1bbdd3ad7955b173c76c8d9829 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Mon, 29 Sep 2025 16:55:42 +0200 Subject: [PATCH 07/25] Remove verbosity if not otherwise requested --- compiler/Makefile | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/compiler/Makefile b/compiler/Makefile index 4bacb78d..2ef4c261 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -1,9 +1,12 @@ .PHONY: test +build: VERBOSITY_FLAG = build: - stack -v build $(STACK_OPTS) + stack $(VERBOSITY_FLAG) build $(STACK_OPTS) mkdir -p ./../bin - stack -v install $(STACK_OPTS) --local-bin-path ./../bin/ + stack $(VERBOSITY_FLAG) install $(STACK_OPTS) --local-bin-path ./../bin/ +build/verbose: + $(MAKE) $(MAKE_FLAGS) build VERBOSITY_FLAG="-v" clean: rm *.cabal From d9e06f51d4e1530080425862ebbe12749e8be5a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Mon, 29 Sep 2025 17:04:19 +0200 Subject: [PATCH 08/25] Separate build step from installation (readding 'all' target) --- Makefile | 2 +- compiler/Makefile | 12 ++++++++++-- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index ebcdc384..0012dafc 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ rt: COMPILER=./bin/troupec compiler: - cd compiler; $(MAKE) build + cd compiler; $(MAKE) all p2p-tools: cd p2p-tools; tsc diff --git a/compiler/Makefile b/compiler/Makefile index 2ef4c261..be9ca64e 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -1,13 +1,21 @@ .PHONY: test +all: build install + build: VERBOSITY_FLAG = build: stack $(VERBOSITY_FLAG) build $(STACK_OPTS) - mkdir -p ./../bin - stack $(VERBOSITY_FLAG) install $(STACK_OPTS) --local-bin-path ./../bin/ build/verbose: $(MAKE) $(MAKE_FLAGS) build VERBOSITY_FLAG="-v" +install: VERBOSITY_FLAG = +install: + $(MAKE) $(MAKE_FLAGS) build + mkdir -p ./../bin + stack $(VERBOSITY_FLAG) install $(STACK_OPTS) --local-bin-path ./../bin/ +install/verbose: + $(MAKE) $(MAKE_FLAGS) install VERBOSITY_FLAG="-v" + clean: rm *.cabal stack clean --full From 5691f184f0314ce1f18192160d9f4de0569c9269 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 30 Sep 2025 11:00:45 +0200 Subject: [PATCH 09/25] Move 'ghci' targets to the end and differentiate with '/' rather than '-' --- compiler/Makefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/compiler/Makefile b/compiler/Makefile index be9ca64e..47df99ca 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -22,14 +22,14 @@ clean: rm -rf ../bin # If problems still persist after this, remove all GHC compilers in ~/.stack/programs/**/ -ghci-irtester: - stack ghci --main-is Troupe-compiler:exe:irtester --no-load - -ghci-troupec: - stack ghci --main-is Troupe-compiler:exe:troupec --no-load - test: stack test $(STACK_OPTS) parser-info: stack exec happy -- -i src/Parser.y + +ghci/irtester: + stack ghci --main-is Troupe-compiler:exe:irtester --no-load + +ghci/troupec: + stack ghci --main-is Troupe-compiler:exe:troupec --no-load From 4c802122ced0f175b2fcb3e5da1c6eabea5f010e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 09:34:19 +0200 Subject: [PATCH 10/25] Remove 'raft' library It is old, unused, unmaintained, and superseeded by a recent BSc project --- lib/Makefile | 2 - lib/raft.trp | 321 --------------------------------------------- lib/raft_debug.trp | 319 -------------------------------------------- 3 files changed, 642 deletions(-) delete mode 100644 lib/raft.trp delete mode 100644 lib/raft_debug.trp diff --git a/lib/Makefile b/lib/Makefile index e8942aca..cd4e129f 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -19,8 +19,6 @@ build: $(COMPILER) ./NetHealth.trp -l $(COMPILER) ./declassifyutil.trp -l $(COMPILER) ./stdio.trp -l - $(COMPILER) ./raft.trp -l - $(COMPILER) ./raft_debug.trp -l $(COMPILER) ./bst.trp -l $(COMPILER) ./localregistry.trp -l diff --git a/lib/raft.trp b/lib/raft.trp deleted file mode 100644 index 4e584824..00000000 --- a/lib/raft.trp +++ /dev/null @@ -1,321 +0,0 @@ -import timeout -import List - -datatype Atoms = APPEND_ENTRIES - | REQUEST_VOTE - | APPEND_ENTRIES_RESPONSE - | REQUEST_VOTE_RESPONSE - | CLIENT_COMMAND - | CLIENT_COMMAND_RESPONSE - | NOT_LEADER - | START - | TIMEOUT - | ERROR - -let val DURATION = 500 - - fun broadcast [] msg = () - | broadcast ((_, pid)::l) msg = - let val _ = send (pid, msg) - in broadcast l msg - end - - fun index_of [] pid = -1 - | index_of ((n, pid')::l) pid = if pid' = pid then n else index_of l pid - - val empty_log = (0, [(0, 0)]) - - fun log_get (sz, xs) n = if n > sz then ERROR else List.nth xs (sz - n + 1) - - fun log_push (sz, xs) x = (sz + 1, x::xs) - - fun last_log_index (sz, xs) = sz - - (* discard everything in the log after index n *) - fun log_discard (sz, xs) n = - if sz > n - then case xs of - y::ys => log_discard (sz - 1, ys) n - | [] => ERROR - else (sz, xs) - - fun log_add_new_entries (sz, xs) ys = - (sz + length ys, List.append ys xs) - - (* Get all the entries after index n *) - fun log_take_entries (sz, xs) n = - if sz = n - then [] - else case xs of - y::ys => y::(log_take_entries (sz - 1, ys) n) - | [] => ERROR - - fun fst (a, b) = a - - fun snd (a, b) = b - - (* Check entry at prevLogIndex matches prevLogTerm, - return true if it doesn't - false otherwise *) - fun check_log (sz, log) prevLogIndex prevLogTerm = - if prevLogIndex > sz - then true - else let val (prevLogTerm', _) = log_get (sz, log) prevLogIndex - in prevLogTerm <> prevLogTerm' - end - - (* If leaderCommit > commitIndex, return min(leaderCommit, index of last new entry) *) - fun new_commit_index commitIndex lastEntryIndex leaderCommit = - if leaderCommit > commitIndex - then if leaderCommit < lastEntryIndex then leaderCommit else lastEntryIndex - else commitIndex - - (* Returns prevLogIndex, prevLogTerm, entries *) - (* such that prevLogIndex = nextIndex - 1 *) - (* and prevLogTerm = term at prevLogIndex *) - (* entries = the entries starting at nextIndex *) - fun get_log_entries log nextIndex = - let val prevLogIndex = nextIndex - 1 - val (prevLogTerm, _) = if prevLogIndex = 0 then (0, ()) else log_get log prevLogIndex - val entries = log_take_entries log prevLogIndex - in (prevLogIndex, prevLogTerm, entries) - end - - (* Send append entries response and return new log state and new commitIndex*) - (* log is a list of pairs (term * cmd) *) - (* entries is a list of triples (num * term * cmd) *) - fun append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit = - if (term < currentTerm) then - let val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, false)) - in (log, commitIndex) - end - else if check_log log prevLogIndex prevLogTerm then - let val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, false)) - in (log, commitIndex) - end - else let val log1 = log_discard log prevLogIndex - val newLog = log_add_new_entries log1 entries - val newCommitIndex = new_commit_index commitIndex (prevLogIndex + length entries) leaderCommit - val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, true)) - in (newLog, newCommitIndex) - end - - (* If last log index >= nextIndex for a follower: send - AppendEntries RPC with log entries starting at nextIndex *) - fun update_followers currentTerm commitIndex cluster log nextIndex print = - let fun f (n, pid) = - (* if nextIndex = last log index, this should behave as a heartbeat *) - if arrayGet (nextIndex, n - 1) <= last_log_index log + 1 - then let val (prevLogIndex, prevLogTerm, entries) = get_log_entries log (arrayGet (nextIndex, n - 1)) - in send (pid, (APPEND_ENTRIES, currentTerm, self (), prevLogIndex, prevLogTerm, entries, commitIndex)) - end - else print "THIS SHOULD NEVER HAPPEN" - in List.map f cluster - end - - (* If there exists an N such that N > commitIndex, a majority - of matchIndex[i] >= N, and log[N].term == currentTerm: - set commitIndex = N *) - fun check_commitIndex cluster threshold log commitIndex matchIndex = - let val lastLogIndex = last_log_index log - val majority = List.foldl (fn ((n, _), k) => if arrayGet (matchIndex, n - 1) >= lastLogIndex then k + 1 else k) 1 cluster - in if (lastLogIndex > commitIndex andalso majority > threshold) - then lastLogIndex - else commitIndex - end - - (* Takes the list of all machines present in the cluster represented by a list of pairs (number * process id) *) - fun machine index machines apply_entry init_state print = - let val threshold = ((length machines) + 1) / 2 - val cluster = machines - val print = fn term => fn string => print ("TERM " ^ (toString term) ^ ": " ^ string) - - fun leader m (currentTerm, votedFor, log, commitIndex, lastApplied, nextIndex, matchIndex) state = - let val nonce = mkuuid () - val _ = timeout (self ()) (TIMEOUT, nonce) DURATION - val commitIndex = check_commitIndex cluster threshold log commitIndex matchIndex - (* If last log index >= nextIndex for a follower: send - AppendEntries RPC with log entries starting at nextIndex *) - val _ = update_followers currentTerm commitIndex cluster log nextIndex print - val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry true state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - fun loop commitIndex lastApplied state n = - receive - [ hn (TIMEOUT, k) => - if k <> n - then (* print currentTerm "leader: old timeout, ignoring"; *) loop commitIndex lastApplied state n - else - (* print currentTerm "I am leader, do heartbeat"; *) - leader (m + 1) (currentTerm, votedFor, log, commitIndex, lastApplied, nextIndex, matchIndex) state - , hn (REQUEST_VOTE, term, candidateId, lastLogIndex, lastLogTerm) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if (term > currentTerm) - then follower (term, -1, log, commitIndex, lastApplied) state - else loop commitIndex lastApplied state n - , hn (REQUEST_VOTE_RESPONSE, term, vote) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm - then follower (term, -1, log, commitIndex, lastApplied) state - else loop commitIndex lastApplied state n - , hn (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm then - let val (newLog, newCommitIndex) = append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit - in follower (term, -1, newLog, newCommitIndex, lastApplied) state - end - else loop commitIndex lastApplied state n - , hn (APPEND_ENTRIES_RESPONSE, from, prevLogIndex, entries, term, result) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if (term > currentTerm) - then follower (term, -1, log, commitIndex, lastApplied) state - else - (* If successful: update nextIndex and matchIndex for follower - If AppendEntries fails because of log inconsistency: - decrement nextIndex and retry *) - let val follower_index = index_of cluster from - val _ = if result then - arraySet (matchIndex, follower_index - 1, prevLogIndex + (length entries)) - else () - val _ = if result then - arraySet (nextIndex, follower_index - 1, prevLogIndex + (length entries) + 1) - else arraySet (nextIndex, follower_index - 1, (arrayGet (nextIndex, follower_index - 1)) - 1) - val commitIndex = if result then check_commitIndex cluster threshold log commitIndex matchIndex else commitIndex - val (lastApplied, state) = if result andalso commitIndex > lastApplied then (lastApplied + 1, apply_entry true state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - in loop commitIndex lastApplied state n - end - , hn (CLIENT_COMMAND, pid, cmd, _) => - let val newLog = log_push log (currentTerm, (pid, cmd)) - in leader (m + 1) (currentTerm, votedFor, newLog, commitIndex, lastApplied, nextIndex, matchIndex) state - end - , hn (CLIENT_COMMAND_RESPONSE, _) => - (* This should never happen, just ignore *) - loop commitIndex lastApplied state n - ] - in loop commitIndex lastApplied state nonce - end - - and follower (currentTerm, votedFor, log, commitIndex, lastApplied) state = - let val election_timeout = (1 + random ()) * DURATION - val nonce = mkuuid () - val _ = timeout (self ()) (TIMEOUT, nonce) election_timeout - val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry false state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - fun loop votedFor n = - receive - [ hn (TIMEOUT, k) when k <> n => - (* print currentTerm "timeout, old nonce, ignoring"; *) - loop votedFor n - , hn (TIMEOUT, k) when k = n => - print currentTerm "timeout, same nonce so no heartbeat from leader, do election"; - candidate (currentTerm + 1, self (), log, commitIndex, lastApplied) state - , hn (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit) => - let val (newLog, newCommitIndex) = append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit - in follower (if term >= currentTerm then term else currentTerm, if term > currentTerm then -1 else votedFor, newLog, newCommitIndex, lastApplied) state - end - , hn (APPEND_ENTRIES_RESPONSE, from, prevLogIndex, entries, term, result) => - if term > currentTerm then follower (term, -1, log, commitIndex, lastApplied) - else loop votedFor n - , hn (REQUEST_VOTE, term, candidateId, lastLogIndex, lastLogTerm) => - let val vote = ((term = currentTerm) andalso ((votedFor = -1) orelse (votedFor = candidateId)) orelse (term > currentTerm)) andalso (lastLogIndex >= last_log_index log) - val _ = send (candidateId, (REQUEST_VOTE_RESPONSE, term, vote)) - in if vote - then follower (term, candidateId, log, commitIndex, lastApplied) state - else follower (currentTerm, votedFor, log, commitIndex, lastApplied) state - end - , hn (REQUEST_VOTE_RESPONSE, term, vote) => - if term >= currentTerm - then follower (term, votedFor, log, commitIndex, lastApplied) state - else loop votedFor n - , hn (CLIENT_COMMAND, pid, cmd, nonce) => - send (pid, (NOT_LEADER, nonce)); - loop votedFor n - , hn (CLIENT_COMMAND_RESPONSE, _) => - (* This should never happen, just ignore *) - loop votedFor n - ] - in loop votedFor nonce - end - - and candidate (currentTerm, votedFor, log, commitIndex, lastApplied) state = - let val election_timeout = (1 + random ()) * DURATION - val nonce = mkuuid () - val _ = timeout (self ()) (TIMEOUT, nonce) election_timeout - val _ = broadcast cluster (REQUEST_VOTE, currentTerm, self (), commitIndex, currentTerm - 1) - val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry false state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - fun loop votes n = - (* print "wait for vote"; *) - if votes > threshold then - print currentTerm "*** elected as leader ***"; - leader 0 (currentTerm, self (), log, commitIndex, lastApplied, arrayCreate (`{}`, length cluster + 1, last_log_index log + 1), arrayCreate (`{}`, length cluster + 1, 0)) state - else - receive - [ hn (TIMEOUT, k) when k <> n => loop votes n - , hn (TIMEOUT, k) when k = n => - (* Start new election term *) - print currentTerm "repeat election"; - candidate (currentTerm + 1, self (), log, commitIndex, lastApplied) state - , hn (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit) => - (* print "be follower 1"; *) - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term >= currentTerm then - let val (newLog, newCommitIndex) = append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit - in follower (term, votedFor, newLog, newCommitIndex, lastApplied) state - end - else loop votes n - , hn (APPEND_ENTRIES_RESPONSE, from, prevLogIndex, entries, term, result) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm then print term "leader elected 1, become follower"; follower (term, votedFor, log, commitIndex, lastApplied) state - else loop votes n - , hn (REQUEST_VOTE, term, candidateId, lastLogIndex, lastLogTerm) => - let val vote = (term > currentTerm) - in if vote - then print term "leader elected 2, become follower"; follower (term, candidateId, log, commitIndex, lastApplied) state - else loop votes n - end - , hn (REQUEST_VOTE_RESPONSE, term, vote) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm then print term "leader elected 3, become follower"; follower (term, -1, log, commitIndex, lastApplied) state - else if term = currentTerm andalso vote then loop (votes + 1) n else loop votes n - , hn (CLIENT_COMMAND, pid, cmd, nonce) => - send (pid, (NOT_LEADER, nonce)); - loop votes n - , hn (CLIENT_COMMAND_RESPONSE, _) => - (* This should never happen, just ignore *) - loop votes n - ] - in loop 1 nonce - end - - in follower (0, -1, empty_log, 0, 0) init_state - end - - fun apply_entry apply_command isLeader state (pid, cmd) = - let - val (v, s) = apply_command state cmd - val _ = if isLeader then send (pid, (CLIENT_COMMAND_RESPONSE, v)) else () - in s end - - fun pre_machine () = - receive [ hn (START, (n, l, apply_command, init_state, print)) => - print "*************************************************************"; - print "pre_machine: received START"; - machine n l (apply_entry apply_command) init_state print ] - - fun spawn_machine () = - spawn pre_machine - -in - [ - ("START", START) - , ("pre_machine", pre_machine) - , ("spawn_machine", spawn_machine) - , ("CLIENT_COMMAND", CLIENT_COMMAND) - , ("CLIENT_COMMAND_RESPONSE", CLIENT_COMMAND_RESPONSE) - , ("NOT_LEADER", NOT_LEADER) - ] -end diff --git a/lib/raft_debug.trp b/lib/raft_debug.trp deleted file mode 100644 index 03504ade..00000000 --- a/lib/raft_debug.trp +++ /dev/null @@ -1,319 +0,0 @@ -import List -import timeout - -datatype Atoms = APPEND_ENTRIES - | REQUEST_VOTE - | APPEND_ENTRIES_RESPONSE - | REQUEST_VOTE_RESPONSE - | CLIENT_COMMAND - | CLIENT_COMMAND_RESPONSE - | NOT_LEADER - | START - | TIMEOUT - | ERROR - -let val DURATION = 150 - - fun broadcast [] msg = () - | broadcast ((_, pid)::l) msg = - let val _ = send (pid, msg) - in broadcast l msg - end - - fun index_of [] pid = -1 - | index_of ((n, pid')::l) pid = if pid' = pid then n else index_of l pid - - val empty_log = (0, [(0, 0)]) - - fun log_get (sz, xs) n = if n > sz then ERROR else List.nth xs (sz - n + 1) - - fun log_push (sz, xs) x = (sz + 1, x::xs) - - fun last_log_index (sz, xs) = sz - - (* discard everything in the log after index n *) - fun log_discard (sz, xs) n = - if sz > n - then case xs of - y::ys => log_discard (sz - 1, ys) n - | [] => ERROR - else (sz, xs) - - fun log_add_new_entries (sz, xs) ys = - (sz + length ys, List.append ys xs) - - (* Get all the entries after index n *) - fun log_take_entries (sz, xs) n = - if sz = n - then [] - else case xs of - y::ys => y::(log_take_entries (sz - 1, ys) n) - | [] => ERROR - - fun fst (a, b) = a - - fun snd (a, b) = b - - (* Check entry at prevLogIndex matches prevLogTerm, - return true if it doesn't - false otherwise *) - fun check_log log prevLogIndex prevLogTerm print = - let val (prevLogTerm', _) = case log_get log prevLogIndex of (a, b) => (a, b) | x => print x - val (prevLogTerm', _) = log_get log prevLogIndex - in prevLogTerm <> prevLogTerm' - end - - (* If leaderCommit > commitIndex, return min(leaderCommit, index of last new entry) *) - fun new_commit_index commitIndex lastEntryIndex leaderCommit = - if leaderCommit > commitIndex - then if leaderCommit < lastEntryIndex then leaderCommit else lastEntryIndex - else commitIndex - - (* Returns prevLogIndex, prevLogTerm, entries *) - (* such that prevLogIndex = nextIndex - 1 *) - (* and prevLogTerm = term at prevLogIndex *) - (* entries = the entries starting at nextIndex *) - fun get_log_entries log nextIndex = - let val prevLogIndex = nextIndex - 1 - val (prevLogTerm, _) = if prevLogIndex = 0 then (0, ()) else log_get log prevLogIndex - val entries = log_take_entries log prevLogIndex - in (prevLogIndex, prevLogTerm, entries) - end - - (* Send List.append entries response and return new log state and new commitIndex*) - (* log is a list of pairs (term * cmd) *) - (* entries is a list of triples (num * term * cmd) *) - fun append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit print = - if (term < currentTerm) then - let val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, false)) - in (log, commitIndex) - end - else if check_log log prevLogIndex prevLogTerm print then - let val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, false)) - in (log, commitIndex) - end - else let val log1 = log_discard log prevLogIndex - val newLog = log_add_new_entries log1 entries - val newCommitIndex = new_commit_index commitIndex (prevLogIndex + length entries) leaderCommit - val _ = send (leaderId, (APPEND_ENTRIES_RESPONSE, self(), prevLogIndex, entries, currentTerm, true)) - in (newLog, newCommitIndex) - end - - (* If last log index >= nextIndex for a follower: send - List.AppendEntries RPC with log entries starting at nextIndex *) - fun update_followers currentTerm commitIndex cluster log nextIndex = - let fun f (n, pid) = - (* if nextIndex = last log index, this should behave as a heartbeat *) - if arrayGet (nextIndex, n - 1) <= last_log_index log + 1 - then let val (prevLogIndex, prevLogTerm, entries) = get_log_entries log (arrayGet (nextIndex, n - 1)) - in send (pid, (APPEND_ENTRIES, currentTerm, self (), prevLogIndex, prevLogTerm, entries, commitIndex)) - end - else () - in List.map f cluster - end - - (* If there exists an N such that N > commitIndex, a majority - of matchIndex[i] >= N, and log[N].term == currentTerm: - set commitIndex = N *) - fun check_commitIndex cluster threshold log commitIndex matchIndex = - let val lastLogIndex = last_log_index log - val majority = List.foldl (fn ((n, _), k) => if arrayGet (matchIndex, n - 1) >= lastLogIndex then k + 1 else k) 1 cluster - in if (lastLogIndex > commitIndex andalso majority) - then lastLogIndex - else commitIndex - end - - (* Takes the list of all machines present in the cluster represented by a list of pairs (number * process id) *) - fun machine index machines apply_entry init_state print = - let val threshold = ((length machines) + 1) / 2 - val cluster = machines - - fun leader m (currentTerm, votedFor, log, commitIndex, lastApplied, nextIndex, matchIndex) state = - let - (* val _ = print ("Machine " ^ (toString index) ^ " is leader during term " ^ (toString currentTerm)) *) - (* val _ = print ("Machine " ^ (toString index) ^ " has pid", self ()) *) - (* val _ = print ("Log is", log) *) - val nonce = mkuuid () - val _ = timeout (self ()) (TIMEOUT, nonce) DURATION - val commitIndex = check_commitIndex cluster threshold log commitIndex matchIndex - (* If last log index >= nextIndex for a follower: send - List.AppendEntries RPC with log entries starting at nextIndex *) - val _ = update_followers currentTerm commitIndex cluster log nextIndex - val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry true state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - fun loop n lastApplied state = - receive - [ hn (TIMEOUT, k) => - if k <> n then loop n lastApplied state else - leader (m + 1) (currentTerm, votedFor, log, commitIndex, lastApplied, nextIndex, matchIndex) state - , hn (REQUEST_VOTE, term, candidateId, lastLogIndex, lastLogTerm) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if (term > currentTerm) - then follower (term, -1, log, commitIndex, lastApplied) state - else loop n lastApplied state - , hn (REQUEST_VOTE_RESPONSE, term, vote) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm - then follower (term, -1, log, commitIndex, lastApplied) state - else loop n lastApplied state - , hn (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm then - let val (newLog, newCommitIndex) = append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit print - in follower (term, -1, newLog, newCommitIndex, lastApplied) state - end - else loop n lastApplied state - , hn (APPEND_ENTRIES_RESPONSE, from, prevLogIndex, entries, term, result) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if (term > currentTerm) - then follower (term, -1, log, commitIndex, lastApplied) state - else - (* If successful: update nextIndex and matchIndex for follower - If List.AppendEntries fails because of log inconsistency: - decrement nextIndex and retry *) - let val follower_index = index_of cluster from - val _ = if result then - arraySet (matchIndex, follower_index - 1, prevLogIndex + (length entries)) - else () - val _ = if result then - arraySet (nextIndex, follower_index - 1, prevLogIndex + (length entries) + 1) - else arraySet (nextIndex, follower_index - 1, (arrayGet (nextIndex, follower_index - 1)) - 1) - val (lastApplied, state) = if result andalso commitIndex > lastApplied then (lastApplied + 1, apply_entry true state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - in loop n lastApplied state - end - , hn (CLIENT_COMMAND, pid, cmd) => - let val newLog = log_push log (currentTerm, (pid, cmd)) - in leader (m + 1) (currentTerm, votedFor, newLog, commitIndex, lastApplied, nextIndex, matchIndex) state - end - , hn (CLIENT_COMMAND_RESPONSE, _) => - (* This should never happen, just ignore *) - loop n lastApplied state - ] - in loop nonce lastApplied state - end - - and follower (currentTerm, votedFor, log, commitIndex, lastApplied) state = - let - (* val _ = print ("Machine " ^ (toString index) ^ " is follower during term " ^ (toString currentTerm)) *) - (* val _ = print ("Machine " ^ (toString index) ^ " has pid", self ()) *) - (* val _ = print ("Log is", log) *) - val election_timeout = (1 + random ()) * DURATION - val nonce = mkuuid () - val _ = timeout (self ()) (TIMEOUT, nonce) election_timeout - val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry false state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - fun loop votedFor n = - receive - [ hn (TIMEOUT, k) when k <> n => loop votedFor n - , hn (TIMEOUT, k) when k = n => - candidate (currentTerm + 1, self (), log, commitIndex, lastApplied) state - , hn (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit) => - let - (* val _ = print ("Follower " ^ (toString index) ^ " has received", (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit)) *) - val (newLog, newCommitIndex) = append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit print - in follower (if term >= currentTerm then term else currentTerm, if term > currentTerm then -1 else votedFor, newLog, newCommitIndex, lastApplied) state - end - , hn (APPEND_ENTRIES_RESPONSE, from, prevLogIndex, entries, term, result) => - if term > currentTerm then follower (term, -1, log, commitIndex, lastApplied) - else loop votedFor n - , hn (REQUEST_VOTE, term, candidateId, lastLogIndex, lastLogTerm) => - let val vote = ((term = currentTerm) andalso ((votedFor = -1) orelse (votedFor = candidateId)) orelse (term > currentTerm)) andalso (lastLogIndex >= last_log_index log) - val _ = send (candidateId, (REQUEST_VOTE_RESPONSE, term, vote)) - in if vote - then follower (term, candidateId, log, commitIndex, lastApplied) state - else follower (currentTerm, votedFor, log, commitIndex, lastApplied) state - end - , hn (REQUEST_VOTE_RESPONSE, term, vote) => - if term >= currentTerm - then follower (term, votedFor, log, commitIndex, lastApplied) state - else loop votedFor n - , hn (CLIENT_COMMAND, pid, cmd) => - send (pid, NOT_LEADER); - loop votedFor n - , hn (CLIENT_COMMAND_RESPONSE, _) => - (* This should never happen, just ignore *) - loop votedFor n - ] - in loop votedFor nonce - end - - and candidate (currentTerm, votedFor, log, commitIndex, lastApplied) state = - let - (* val _ = print ("Machine " ^ (toString index) ^ " is candidate during term " ^ (toString currentTerm)) *) - (* val _ = print ("Machine " ^ (toString index) ^ " has pid", self ()) *) - (* val _ = print ("Log is", log) *) - val election_timeout = (1 + random ()) * DURATION - val nonce = mkuuid () - val _ = timeout (self ()) (TIMEOUT, nonce) election_timeout - val _ = broadcast cluster (REQUEST_VOTE, currentTerm, self (), commitIndex, currentTerm - 1) - val (lastApplied, state) = if commitIndex > lastApplied then (lastApplied + 1, apply_entry false state (snd (log_get log (lastApplied + 1)))) else (lastApplied, state) - fun loop votes n = - if votes >= threshold then - leader 0 (currentTerm, self (), log, commitIndex, lastApplied, arrayCreate (`{}`, length cluster + 1, last_log_index log + 1), arrayCreate (`{}`, length cluster + 1, 0)) state - else - receive - [ hn (TIMEOUT, k) when k <> n => loop votes n - , hn (TIMEOUT, k) when k = n => - (* Start new election term *) - candidate (currentTerm + 1, self (), log, commitIndex, lastApplied) state - , hn (APPEND_ENTRIES, term, leaderId, prevLogIndex, prevLogTerm, entries, leaderCommit) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term >= currentTerm then - let val (newLog, newCommitIndex) = append_entries currentTerm log commitIndex term leaderId prevLogIndex prevLogTerm entries leaderCommit print - in follower (term, votedFor, newLog, newCommitIndex, lastApplied) state - end - else loop votes n - , hn (APPEND_ENTRIES_RESPONSE, from, prevLogIndex, entries, term, result) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm then follower (term, votedFor, log, commitIndex, lastApplied) state - else loop votes n - , hn (REQUEST_VOTE, term, candidateId, lastLogIndex, lastLogTerm) => - let val vote = (term > currentTerm) - in if vote - then follower (term, candidateId, log, commitIndex, lastApplied) state - else loop votes n - end - , hn (REQUEST_VOTE_RESPONSE, term, vote) => - (* If RPC request or response contains term T > currentTerm: - set currentTerm = T, convert to follower *) - if term > currentTerm then follower (term, -1, log, commitIndex, lastApplied) state - else if term = currentTerm andalso vote then loop (votes + 1) n else loop votes n - , hn (CLIENT_COMMAND, pid, cmd) => - send (pid, NOT_LEADER); - loop votes n - , hn (CLIENT_COMMAND_RESPONSE, _) => - (* This should never happen, just ignore *) - loop votes n - ] - in loop 1 nonce - end - - in follower (0, -1, empty_log, 0, 0) init_state - end - - fun apply_entry apply_command isLeader state (pid, cmd) = - let val (v, s) = apply_command state cmd - val _ = if isLeader then send (pid, (CLIENT_COMMAND_RESPONSE, v)) else () - in s end - - fun pre_machine () = - receive [ hn (START, (n, l, apply_command, init_state, print)) => - machine n l (apply_entry apply_command) init_state print ] - - fun spawn_machine () = - spawn pre_machine - -in - [ - ("START", START) - , ("pre_machine", pre_machine) - , ("spawn_machine", spawn_machine) - , ("CLIENT_COMMAND", CLIENT_COMMAND) - , ("CLIENT_COMMAND_RESPONSE", CLIENT_COMMAND_RESPONSE) - , ("NOT_LEADER", NOT_LEADER) - ] -end From 81a7d0c7c5401a62c47d859d9070d267f703036a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 09:36:28 +0200 Subject: [PATCH 11/25] Remove 'localregistry' library If we truly need it later, then we can easily reimplement this library. At that point we might have a context (worker stealing?) that can inform the API design --- lib/Makefile | 1 - lib/localregistry.trp | 35 ----------------------------------- 2 files changed, 36 deletions(-) delete mode 100644 lib/localregistry.trp diff --git a/lib/Makefile b/lib/Makefile index cd4e129f..c54ee07d 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -20,7 +20,6 @@ build: $(COMPILER) ./declassifyutil.trp -l $(COMPILER) ./stdio.trp -l $(COMPILER) ./bst.trp -l - $(COMPILER) ./localregistry.trp -l clean: rm -rf out diff --git a/lib/localregistry.trp b/lib/localregistry.trp deleted file mode 100644 index 0a510a7e..00000000 --- a/lib/localregistry.trp +++ /dev/null @@ -1,35 +0,0 @@ -import List - -datatype Atoms = REGISTER | LOOKUP | FOUND | NOT_FOUND | SHUTDOWN - -let fun local_registry () = - let fun registry_worker (active , pending) = - receive [ - hn (REGISTER, name_registered, pid_registered) => - let val new_active = (name_registered, pid_registered)::active - val (to_notify, new_pending) = List.partition ( fn (x, _) => x = name_registered) pending - val _ = List.map (fn (_, pid) => send (pid, (FOUND, pid_registered))) to_notify - in registry_worker ( new_active, new_pending) - - end - , hn (LOOKUP, name, pid_requester ) => - registry_worker - (active, - case List.lookup active name NOT_FOUND of - NOT_FOUND => (name,pid_requester)::pending - | pid_found => send (pid_requester, (FOUND, pid_found)); pending - ) - , hn (SHUTDOWN) => () - ] - in registry_worker ([],[]) - end - - fun local_register reg name = send (reg, (REGISTER, name, self())) - fun local_whois reg name = - send (reg, (LOOKUP, name, self())); - receive [ hn (FOUND, pid) => pid] -in [("local_register", local_register) - ,("local_whois", local_whois) - ,("local_registry", local_registry) - ] -end From 803aef36b3659d0673bbe7b862dd00a64ee90bde Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 09:40:04 +0200 Subject: [PATCH 12/25] Remove 'NetHealth' library This was only a temporary LLM-generated library never meant to be kept --- lib/Makefile | 1 - lib/NetHealth.trp | 197 ------------------ tests/rt/libp2p-migration-tests/README.md | 155 -------------- .../additional-simplifications.md | 116 ----------- .../direct-connection/aliases.json | 1 - .../direct-connection/config.json | 30 --- .../direct-connection/direct-client.trp | 63 ------ .../direct-connection/direct-server.trp | 44 ---- .../direct-connection/ids/client.json | 1 - .../direct-connection/ids/server.json | 1 - .../whereis-blocking/aliases.json | 1 - .../whereis-blocking/config.json | 31 --- .../whereis-blocking/delayed-server.trp | 35 ---- .../whereis-blocking/ids/delayed-server.json | 1 - .../whereis-blocking/ids/retry-client.json | 1 - .../whereis-blocking/retry-client.trp | 71 ------- .../whereis-timeout/aliases.json | 1 - .../whereis-timeout/config.json | 22 -- .../whereis-timeout/ids/timeout-client.json | 1 - .../whereis-timeout/timeout-client.trp | 58 ------ .../async-stream-ops/aliases.json | 1 - .../async-stream-ops/config.json | 30 --- .../async-stream-ops/ids/stream-client.json | 1 - .../async-stream-ops/ids/stream-server.json | 1 - .../async-stream-ops/stream-client.trp | 99 --------- .../async-stream-ops/stream-server.trp | 69 ------ 26 files changed, 1032 deletions(-) delete mode 100644 lib/NetHealth.trp delete mode 100644 tests/rt/libp2p-migration-tests/README.md delete mode 100644 tests/rt/libp2p-migration-tests/additional-simplifications.md delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/aliases.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/config.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-client.trp delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-server.trp delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/client.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/server.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/aliases.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/config.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/delayed-server.trp delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/delayed-server.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/retry-client.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/retry-client.trp delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/aliases.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/config.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/ids/timeout-client.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/timeout-client.trp delete mode 100644 tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/aliases.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/config.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-client.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-server.json delete mode 100644 tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-client.trp delete mode 100644 tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-server.trp diff --git a/lib/Makefile b/lib/Makefile index c54ee07d..c1fe48d2 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -16,7 +16,6 @@ build: $(COMPILER) ./nsuref.trp -l $(COMPILER) ./printService.trp -l $(COMPILER) ./timeout.trp -l - $(COMPILER) ./NetHealth.trp -l $(COMPILER) ./declassifyutil.trp -l $(COMPILER) ./stdio.trp -l $(COMPILER) ./bst.trp -l diff --git a/lib/NetHealth.trp b/lib/NetHealth.trp deleted file mode 100644 index a5f234cd..00000000 --- a/lib/NetHealth.trp +++ /dev/null @@ -1,197 +0,0 @@ -(* NetHealth - Network Testing Health and Monitoring Library *) -(* Common patterns for P2P and network testing *) - -import List -import timeout - -let - (* Configuration for NetHealth functions *) - (* Pass {print = print_function, auth = authority} as a record *) - (* This allows library to use print and authority without violating library restrictions *) - - (* Standard test timeout with configurable duration and node name *) - (* Uses timeout library to exit with code 124 after timeout *) - fun spawnTestTimeout({print, auth, ..}, timeoutMs, nodeName) = - exitAfterTimeout auth timeoutMs 124 (nodeName ^ ": Timeout") - - (* Standard successful exit with message delivery delay *) - (* Ensures P2P messages are delivered before process exits *) - fun exitSuccess({print, auth, ..}, nodeName, message, delayMs) = - let val _ = print (nodeName ^ ": " ^ message) - val _ = sleep delayMs (* Give time for message delivery *) - in exit(auth, 0) - end - - (* Standard failed exit *) - fun exitFailure({print, auth, ..}, nodeName, message) = - (print (nodeName ^ ": " ^ message); exit(auth, 1)) - - (* Log with timestamp - useful for debugging timing issues *) - fun logWithTime({print, auth, ..}, nodeName, message) = - let val time = getTime() - in print ("[" ^ intToString(time) ^ "] " ^ nodeName ^ ": " ^ message) - end - - (* Standard test result reporting *) - fun reportTestResult({print, auth, ..}, nodeName, testName, passed) = - if passed then - print (nodeName ^ ": " ^ testName ^ " test PASSED") - else - print (nodeName ^ ": " ^ testName ^ " test FAILED") - - (* Batch test results reporting - simplified with lists library *) - fun reportTestSummary({print, auth, ..}, nodeName, results) = - let (* Use List.filter to count passed tests *) - val passedTests = List.filter (fn (name, passed) => passed) results - val total = length results - val passed = length passedTests - - val _ = print (nodeName ^ ": Test summary:") - val _ = print (nodeName ^ ": Total tests: " ^ intToString(total)) - val _ = print (nodeName ^ ": Passed: " ^ intToString(passed)) - val _ = print (nodeName ^ ": Failed: " ^ intToString(total - passed)) - - (* Use lists.map to report each result *) - val _ = List.map (fn (name, passed) => - print (" - " ^ name ^ ": " ^ - (if passed then "PASSED" else "FAILED"))) - results - in passed = total - end - - (* Helper to check if all tests passed and exit accordingly *) - fun exitOnTestResults(config, nodeName, results, delayMs) = - if reportTestSummary(config, nodeName, results) then - exitSuccess(config, nodeName, "All tests passed", delayMs) - else - exitFailure(config, nodeName, "Some tests failed") - - (* Performance metrics helper *) - fun reportPerformanceMetric({print, auth, ..}, nodeName, metricName, value, unit) = - print (nodeName ^ ": " ^ metricName ^ ": " ^ intToString(value) ^ " " ^ unit) - - (* Measure time taken for an operation *) - fun measureTime(operation) = - let val start = getTime() - val result = operation() - val elapsed = getTime() - start - in (result, elapsed) - end - - (* Measure connection establishment time *) - fun measureConnectionTime(target, service) = - measureTime(fn () => whereis(target, service)) - - (* Safe whereis with timeout - prevents hanging forever *) - (* Returns ("found", pid) or ("timeout", dummy_pid) *) - (* Uses timeout library for cleaner implementation *) - fun whereisWithTimeout(node, service, timeoutMs) = - let val parent = self() - val nonce = mkuuid() - - val whereis_pid = spawn(fn () => - let val pid = whereis(node, service) - in send(parent, ("WHEREIS_RESULT", pid)) - end) - - val _ = timeout parent nonce timeoutMs - - val result = receive [ - hn ("WHEREIS_RESULT", pid) => ("found", pid), - hn x when x = nonce => ("timeout", parent) (* timeout occurred *) - ] - in result - end - - (* Send message with timeout helper *) - (* Returns the parent pid for custom receive patterns *) - fun sendWithTimeout(target, message, timeoutMs) = - let val parent = self() - val timeout_pid = spawn(fn () => - let val _ = sleep timeoutMs - in send(parent, ("TIMEOUT", "Operation timed out")) - end) - - val _ = send(target, message) - in parent - end - - (* Spawn a delayed process - useful for testing timing behaviors *) - fun spawnDelayed(delayMs, operation) = - spawn(fn () => - let val _ = sleep delayMs - in operation() - end) - - (* Test connection with retry logic *) - fun testConnectionWithRetry(target, service, maxAttempts, retryDelayMs) = - let fun tryConnect(attempt) = - if attempt > maxAttempts then - ("failed", 0) - else - let val (status, result) = whereisWithTimeout(target, service, retryDelayMs) - in if status = "found" then - ("success", attempt) - else - (sleep retryDelayMs; tryConnect(attempt + 1)) - end - in tryConnect(1) - end - - (* Calculate throughput from bytes and time *) - fun calculateThroughput(bytes, timeMs) = - if timeMs > 0 then - bytes * 1000 div timeMs (* bytes per second *) - else - 0 - - (* Count passed tests - simplified with lists library *) - fun countPassedTests(results) = - length (List.filter (fn (name, passed) => passed) results) - - (* Count total tests - simplified with lists library *) - fun countTotalTests(results) = - length results - - (* Check if all tests passed - simplified *) - fun allTestsPassed(results) = - let val total = length results - val passed = countPassedTests(results) - in total > 0 andalso passed = total - end - - (* Single exit point based on boolean result *) - fun exitOnResult({print, auth, ..}, nodeName, success, message, delayMs) = - if success then - exitSuccess({print = print, auth = auth}, nodeName, message ^ " successfully", delayMs) - else - exitFailure({print = print, auth = auth}, nodeName, message ^ " failed") - - (* Standard delay constants *) - val STARTUP_DELAY = 1000 (* Give nodes time to register *) - val MESSAGE_DELIVERY_DELAY = 1000 (* Ensure messages are delivered *) - -in - [ ("spawnTestTimeout", spawnTestTimeout) - , ("exitSuccess", exitSuccess) - , ("exitFailure", exitFailure) - , ("logWithTime", logWithTime) - , ("reportTestResult", reportTestResult) - , ("reportTestSummary", reportTestSummary) - , ("exitOnTestResults", exitOnTestResults) - , ("reportPerformanceMetric", reportPerformanceMetric) - , ("measureTime", measureTime) - , ("measureConnectionTime", measureConnectionTime) - , ("whereisWithTimeout", whereisWithTimeout) - , ("sendWithTimeout", sendWithTimeout) - , ("spawnDelayed", spawnDelayed) - , ("testConnectionWithRetry", testConnectionWithRetry) - , ("calculateThroughput", calculateThroughput) - , ("countPassedTests", countPassedTests) - , ("countTotalTests", countTotalTests) - , ("allTestsPassed", allTestsPassed) - , ("exitOnResult", exitOnResult) - , ("STARTUP_DELAY", STARTUP_DELAY) - , ("MESSAGE_DELIVERY_DELAY", MESSAGE_DELIVERY_DELAY) - ] -end diff --git a/tests/rt/libp2p-migration-tests/README.md b/tests/rt/libp2p-migration-tests/README.md deleted file mode 100644 index 952f0193..00000000 --- a/tests/rt/libp2p-migration-tests/README.md +++ /dev/null @@ -1,155 +0,0 @@ -# libp2p Migration Tests - -This directory contains specialized tests for validating the libp2p upgrade from v0.45.3 to v2.x. These tests focus on low-level P2P functionality that is not covered by the existing multinode tests. - -## Overview - -The libp2p v2 upgrade involves significant architectural changes: -- Migration to ESM-only modules -- Complete TypeScript rewrite -- New PeerId architecture (no embedded private keys) -- Async stream operations -- New error handling (.code → .name) -- Service extraction to separate packages - -These tests ensure that all P2P functionality works correctly after the upgrade. - -## Test Categories - -### 1. P2P Connection Tests (`p2p-connection-tests/`) -Tests for connection lifecycle, direct connections without relay, whereis blocking behavior, and transport fallback mechanisms. - -**CRITICAL**: The `whereis` operation in Troupe blocks INDEFINITELY with NO built-in timeout. It will wait forever until the service is found. This has major implications: -- Tests must implement their own timeout mechanisms -- A whereis call to a non-existent service will hang forever -- Connection tests must carefully manage this blocking behavior - -### 2. P2P Stream Tests (`p2p-stream-tests/`) -Tests for async stream operations (critical for v0.46+), stream lifecycle management, and concurrent stream handling. - -### 3. P2P Identity Tests (`p2p-identity-tests/`) -Tests for PeerId generation with new crypto APIs, identity persistence, and peer discovery with new formats. - -### 4. P2P Error Tests (`p2p-error-tests/`) -Tests for error type mapping, network error handling, and graceful degradation scenarios. - -### 5. P2P Performance Tests (`p2p-performance-tests/`) -Performance benchmarks for connection establishment, message throughput, and memory usage. - -### 6. P2P Migration Tests (`p2p-migration-tests/`) -Tests for version compatibility, feature flags, and rollback scenarios. - -### 7. Test Utilities (`test-utils/`) -Shared helper functions and utilities for P2P testing. - -## Running Tests - -### Run all libp2p migration tests: -```bash -# From the Troupe root directory -for test in tests/rt/libp2p-migration-tests/p2p-*/*/config.json; do - scripts/multinode-runner.sh "$test" -done -``` - -### Run a specific test category: -```bash -# Run all connection tests -for test in tests/rt/libp2p-migration-tests/p2p-connection-tests/*/config.json; do - scripts/multinode-runner.sh "$test" -done -``` - -### Run a single test: -```bash -scripts/multinode-runner.sh tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/config.json -``` - -### Run with verbose P2P debugging: -```bash -scripts/multinode-runner.sh -v tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/config.json -``` - -## Test Development Guidelines - -1. **Finite Execution**: All tests must have bounded execution time and clear exit conditions. - -2. **Blocking Operations**: `whereis` blocks INDEFINITELY with no timeout. It will wait forever for a service. This means: - - Never call `whereis` for a service that might not exist - - Always ensure services are registered before calling `whereis` - - Consider spawning `whereis` in a separate process with your own timeout - - The test harness timeout is your only protection against hanging - -3. **Error Handling**: Tests should handle both expected and unexpected errors gracefully. - -3. **Diagnostics**: Use the `--debug-p2p` flag in extra_argv for detailed P2P logging. - -4. **Performance Metrics**: Capture timing data where relevant for regression detection. - -5. **Baseline Comparison**: Where possible, run the same test on both v0.45.3 and v2.x for comparison. - -## Test Configuration - -Tests use the standard multinode test configuration format with some P2P-specific options: - -```json -{ - "test_name": "test-name", - "timeout": 30, - "network": { - "use_relay": false, // Set to false for direct connection tests - "relay_port": 5555, // Only used if use_relay is true - "bootstrap_peers": [] // Control peer discovery - }, - "nodes": [ - { - "id": "node-id", - "script": "script.trp", - "port": 6789, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" // Enable P2P debugging - } - ] -} -``` - -## Test Development Priority - -1. **High Priority** (Must have before migration): - - Connection tests (fundamental P2P operations) - - Identity tests (core system changes) - - Stream async operations (v0.46+ compatibility) - - Error type mapping (prevents runtime failures) - -2. **Medium Priority** (Should have): - - Performance benchmarks - - Circuit relay v2 tests - - Multi-transport tests - - DHT operations - -3. **Low Priority** (Nice to have): - - Load tests - - Network simulation - - Extended migration scenarios - -## Adding New Tests - -1. Create a new directory under the appropriate category -2. Add a `config.json` file with test configuration -3. Create `.trp` files for each node in the test -4. Optionally add an `expected.golden` file for output validation -5. Document the test purpose and what it validates - -## Debugging Tips - -- Use `--debug-p2p` flag to enable libp2p debug logging -- Check `/tmp/troupe-multinode-*/output/` for detailed node outputs -- Use `print` statements liberally to track test progress -- Monitor relay output when debugging connection issues - -## Known Limitations - -- Tests cannot directly inspect P2P internal state -- Version compatibility tests may be limited by breaking changes -- Performance measurements may vary based on system load -- Some edge cases may be difficult to reproduce reliably \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/additional-simplifications.md b/tests/rt/libp2p-migration-tests/additional-simplifications.md deleted file mode 100644 index fb0e9eea..00000000 --- a/tests/rt/libp2p-migration-tests/additional-simplifications.md +++ /dev/null @@ -1,116 +0,0 @@ -# Additional libp2p Test Simplifications - -## Summary -Now that we've implemented NetHealth library, here are additional simplifications we can make to reduce complexity while maintaining test coverage. - -## 1. Test Consolidation - -### Combine whereis-blocking and whereis-timeout tests -These two tests demonstrate related concepts and can be merged into a single "whereis-behavior" test: -- One test file that demonstrates both blocking behavior AND timeout pattern -- Reduces from 4 files to 2 files -- Maintains full coverage of whereis edge cases - -### Simplify direct-connection test -The current test has redundant message exchanges: -- The "GET_TIMING" exchange is unnecessary - bidirectional communication is already proven by CONNECTION_ACK -- Can reduce from 2 round-trips to 1 round-trip - -## 2. Message Pattern Simplification - -### async-stream-ops test -Currently expects exactly 5 messages. Can simplify to 3 core tests: -- Small message (basic async) -- Large message (chunking behavior) -- Concurrent messages (multiplexing) -This reduces complexity while maintaining coverage of critical v0.46+ features. - -## 3. Code Simplifications - -### Remove duplicate performance reporting -Some tests report the same metric twice (e.g., connection time). NetHealth already handles this consistently. - -### Standardize sleep patterns -Replace arbitrary sleep values with named constants: -```troupe -val STARTUP_DELAY = 1000 (* Give nodes time to register *) -val MESSAGE_DELIVERY_DELAY = 1000 (* Ensure messages are delivered *) -``` - -### Simplify test result checking -Many tests use verbose if/else patterns that can be simplified: -```troupe -(* Current *) -in if result = "success" then - exitSuccess(config, "SERVER", "Test completed successfully", 1000) - else - exitFailure(config, "SERVER", "Test failed") -end - -(* Simplified *) -in exitOnResult(config, "SERVER", result = "success", "Test completed", 1000) -end -``` - -## 4. Configuration Standardization - -### Create config templates -Many config.json files are nearly identical. Create a template: -```json -{ - "test_name": "p2p-${TEST_NAME}", - "timeout": 30, - "coordination": "parallel", - "network": { - "use_relay": false - }, - "nodes": [ - { - "id": "client", - "script": "client.trp", - "port": 6789, - "expected_exit_code": 0 - }, - { - "id": "server", - "script": "server.trp", - "port": 6790, - "expected_exit_code": 0 - } - ] -} -``` - -## 5. NetHealth Library Extensions - -Add these utility functions to NetHealth: -```troupe -(* Single exit point based on boolean *) -fun exitOnResult({print, auth, ..}, nodeName, success, message, delayMs) = - if success then - exitSuccess({print = print, auth = auth}, nodeName, message ^ " successfully", delayMs) - else - exitFailure({print = print, auth = auth}, nodeName, message ^ " failed") - -(* Standard delays *) -val STARTUP_DELAY = 1000 -val MESSAGE_DELIVERY_DELAY = 1000 -``` - -## 6. Remove Unnecessary Tests - -The peerId-generation test doesn't actually test PeerId generation - it just tests basic message passing which is covered by other tests. This test should be removed or completely rewritten to actually test identity-related functionality. - -## Benefits - -1. **Reduced Files**: Consolidation reduces test count from 8 files to ~4-5 files -2. **Clearer Intent**: Each test focuses on one specific libp2p behavior -3. **Less Duplication**: Common patterns extracted to NetHealth -4. **Faster Execution**: Fewer redundant message exchanges -5. **Easier Maintenance**: Simpler code is easier to update during migration - -## Implementation Priority - -1. **High**: Consolidate whereis tests (biggest reduction in complexity) -2. **Medium**: Simplify message patterns in existing tests -3. **Low**: Configuration templates and minor code cleanups \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/aliases.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/aliases.json deleted file mode 100644 index 28c21074..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/aliases.json +++ /dev/null @@ -1 +0,0 @@ -{"client":"12D3KooWB1Bj9waAeejS1eJUrLA8Da9Rt8QUAH7q4G3yZPJwmjuM","server":"12D3KooWAzwZrRWYATjAmdiYY3WvZCT9xeDm9aVxvAhP5WcGgQq3"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/config.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/config.json deleted file mode 100644 index de02c42a..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/config.json +++ /dev/null @@ -1,30 +0,0 @@ -{ - "test_name": "p2p-direct-connection", - "timeout": 30, - "coordination": "parallel", - "network": { - "use_relay": false, - "bootstrap_peers": [] - }, - "nodes": [ - { - "id": "server", - "script": "direct-server.trp", - "port": 6789, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - }, - { - "id": "client", - "script": "direct-client.trp", - "port": 6790, - "start_delay": 2, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - } - ], - "output": { - "merge_strategy": "timestamp", - "filter_patterns": ["uuid", "timestamp", "peer_id"] - } -} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-client.trp b/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-client.trp deleted file mode 100644 index 3d85891d..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-client.trp +++ /dev/null @@ -1,63 +0,0 @@ -(* Direct P2P Connection Test - Client *) -(* Tests direct peer-to-peer connection without relay *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 28000, "CLIENT") - - fun connection_test_client() = - let val _ = print "CLIENT: Starting direct connection test" - - (* Give server time to start and register *) - val _ = sleep 1000 - - (* Measure connection time *) - val _ = print "CLIENT: Looking up direct-test service on server" - val (test_service, connect_time) = measureConnectionTime("@server", "direct-test") - val _ = reportPerformanceMetric(config, "CLIENT", "Service lookup time", connect_time, "ms") - - (* Verify we got a valid service reference *) - val _ = print "CLIENT: Successfully found service" - - (* Send test message *) - val test_msg = "Hello via direct connection" - val _ = print "CLIENT: Sending connection test message" - val _ = send(test_service, ("CONNECTION_TEST", test_msg, self())) - - (* Wait for acknowledgment *) - val ack_result = receive [ - hn ("CONNECTION_ACK", msg) => - let val _ = print ("CLIENT: Received acknowledgment: " ^ msg) - in "ack_received" - end - ] - - (* Request timing data to verify bidirectional communication *) - val _ = print "CLIENT: Requesting timing data" - val _ = send(test_service, ("GET_TIMING", self())) - val _ = print "CLIENT: Waiting for timing data response" - val timing_result = receive [ - hn ("TIMING_DATA", data) => - let val _ = print ("CLIENT: Received timing data: " ^ data) - in "timing_received" - end - ] - - (* Collect test results *) - val test_results = [ - ("Connection established", connect_time < 5000), - ("Acknowledgment received", ack_result = "ack_received"), - ("Bidirectional communication", timing_result = "timing_received") - ] - - (* Report performance metrics *) - val _ = reportPerformanceMetric(config, "CLIENT", - "Connection establishment time", connect_time, "ms") - - in exitOnTestResults(config, "CLIENT", test_results, 0) - end - -in connection_test_client() -end \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-server.trp b/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-server.trp deleted file mode 100644 index 3f711b58..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/direct-server.trp +++ /dev/null @@ -1,44 +0,0 @@ -(* Direct P2P Connection Test - Server *) -(* Tests direct peer-to-peer connection without relay *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 25000, "SERVER") - - fun connection_test_server() = - let val _ = print "SERVER: Starting direct connection test server" - (* Register a test service *) - val _ = register("direct-test", self(), authority) - val _ = print "SERVER: Registered direct-test service" - - (* Wait for connection and test message *) - val result = receive [ - hn ("CONNECTION_TEST", msg, sender) => - let val _ = print ("SERVER: Received connection test: " ^ msg) - (* Send acknowledgment *) - val _ = send(sender, ("CONNECTION_ACK", "Direct connection successful")) - val _ = print "SERVER: Sent acknowledgment" - - (* Wait for timing data request *) - val timing_result = receive [ - hn ("GET_TIMING", sender2) => - let val _ = print "SERVER: Received timing request" - val _ = send(sender2, ("TIMING_DATA", "Connection established")) - val _ = print "SERVER: Sent timing data" - in "timing_sent" - end - ] - in if timing_result = "timing_sent" then "success" else "failed" - end - ] - - in if result = "success" then - exitSuccess(config, "SERVER", "Direct connection test completed successfully", 1000) - else - exitFailure(config, "SERVER", "Direct connection test failed") - end - -in connection_test_server() -end \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/client.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/client.json deleted file mode 100644 index 7b7e0571..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/client.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWB1Bj9waAeejS1eJUrLA8Da9Rt8QUAH7q4G3yZPJwmjuM","privKey":"CAESQM9Iez+9QcIaTY5djwIA6SP1uUe67402rTIJn5KN2WYyEaFFGd+Y8cHgi5manhxuDEiU2vF2SV8tx6n7ilhpXSQ=","pubKey":"CAESIBGhRRnfmPHB4IuZmp4cbgxIlNrxdklfLcep+4pYaV0k"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/server.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/server.json deleted file mode 100644 index da54f038..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/direct-connection/ids/server.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWAzwZrRWYATjAmdiYY3WvZCT9xeDm9aVxvAhP5WcGgQq3","privKey":"CAESQP5DjeHGm+pGTDrHQIByTAzU49YABshGVP61uX3pJge2EZFCPFkTEGsMVG2vvjHWwAzBdmboxaTD9WxMCDNJ70Y=","pubKey":"CAESIBGRQjxZExBrDFRtr74x1sAMwXZm6MWkw/VsTAgzSe9G"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/aliases.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/aliases.json deleted file mode 100644 index ea0b8f53..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/aliases.json +++ /dev/null @@ -1 +0,0 @@ -{"delayed-server":"12D3KooWFs4qkhUFST4n2SWsNjmn3sfA3WP7apvF7z6ycEC6ckva","retry-client":"12D3KooWS6H9Fo9N1iZYpiMu4NdoMjfBZfxwKVhFhLekgdUkGjVb"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/config.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/config.json deleted file mode 100644 index d393eb1c..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/config.json +++ /dev/null @@ -1,31 +0,0 @@ -{ - "test_name": "p2p-whereis-blocking", - "timeout": 45, - "coordination": "parallel", - "network": { - "use_relay": false, - "bootstrap_peers": [] - }, - "nodes": [ - { - "id": "delayed-server", - "script": "delayed-server.trp", - "port": 6791, - "start_delay": 10, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - }, - { - "id": "retry-client", - "script": "retry-client.trp", - "port": 6792, - "start_delay": 0, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - } - ], - "output": { - "merge_strategy": "timestamp", - "filter_patterns": ["uuid", "timestamp", "peer_id"] - } -} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/delayed-server.trp b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/delayed-server.trp deleted file mode 100644 index 68b664f2..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/delayed-server.trp +++ /dev/null @@ -1,35 +0,0 @@ -(* Whereis Blocking Test - Delayed Server *) -(* This server starts late to test whereis blocking behavior *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 30000, "DELAYED-SERVER") - - fun delayed_server() = - let val _ = print "DELAYED-SERVER: Starting after delay" - (* Register service *) - val _ = register("retry-test", self(), authority) - val _ = print "DELAYED-SERVER: Registered retry-test service" - - (* Wait for client connection attempts *) - val result = receive [ - hn ("RETRY_TEST", attempt_num, sender) => - let val _ = print ("DELAYED-SERVER: Received connection from client, attempt #" ^ - intToString(attempt_num)) - (* Send success response *) - val _ = send(sender, ("RETRY_SUCCESS", attempt_num)) - val _ = print "DELAYED-SERVER: Sent success response" - in "success" - end - ] - - in if result = "success" then - exitSuccess(config, "DELAYED-SERVER", "Connection retry test completed successfully", 1000) - else - exitFailure(config, "DELAYED-SERVER", "Connection retry test failed") - end - -in delayed_server() -end \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/delayed-server.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/delayed-server.json deleted file mode 100644 index cb3e2408..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/delayed-server.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWFs4qkhUFST4n2SWsNjmn3sfA3WP7apvF7z6ycEC6ckva","privKey":"CAESQB2xkcOtvyPrfnrdBTV3GgxhXR1x5HL2Q4ltbziLfGNqWddFlXRpHOJbL6GAPoNMM0ysKVpY5UG6TWkxDwDHspc=","pubKey":"CAESIFnXRZV0aRziWy+hgD6DTDNMrClaWOVBuk1pMQ8Ax7KX"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/retry-client.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/retry-client.json deleted file mode 100644 index 9fc76a4d..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/ids/retry-client.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWS6H9Fo9N1iZYpiMu4NdoMjfBZfxwKVhFhLekgdUkGjVb","privKey":"CAESQGdNA5t03fpHG54wpie/bz+cr3dk09kKPliywo9Q7X+q8c6Z6jThjU6ZOoAMFmVNcdIj5boNAKOQnZ9SeOjr48o=","pubKey":"CAESIPHOmeo04Y1OmTqADBZlTXHSI+W6DQCjkJ2fUnjo6+PK"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/retry-client.trp b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/retry-client.trp deleted file mode 100644 index b5bc062c..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-blocking/retry-client.trp +++ /dev/null @@ -1,71 +0,0 @@ -(* Whereis Blocking Test - Client *) -(* Tests that whereis blocks until the service is available *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 40000, "RETRY-CLIENT") - - (* whereis blocks indefinitely with NO timeout *) - (* This test demonstrates that whereis will wait forever for a service *) - fun waitForConnection() = - let val _ = print "RETRY-CLIENT: WARNING - whereis has no built-in timeout!" - val _ = print "RETRY-CLIENT: Calling whereis (will block indefinitely until service found)" - val _ = print "RETRY-CLIENT: The delayed server should start in ~10 seconds" - - (* Measure how long whereis blocks *) - val (service, whereis_time) = measureConnectionTime("@delayed-server", "retry-test") - - val _ = print ("RETRY-CLIENT: whereis finally returned after " ^ - intToString(whereis_time) ^ "ms") - val _ = print "RETRY-CLIENT: This demonstrates whereis blocks indefinitely" - in (service, whereis_time) - end - - fun retry_client() = - let val _ = print "RETRY-CLIENT: Starting connection retry test" - - (* Track timing *) - val (operation_result, total_time) = measureTime(fn () => - let (* Wait for connection - whereis will block *) - val (service, whereis_time) = waitForConnection() - - (* Send test message after connection *) - val final_attempt = 1 - val _ = print "RETRY-CLIENT: Sending RETRY_TEST message" - val _ = send(service, ("RETRY_TEST", final_attempt, self())) - val _ = print "RETRY-CLIENT: Waiting for RETRY_SUCCESS response" - - (* Wait for response *) - val response = receive [ - hn ("RETRY_SUCCESS", attempt_num) => - let val _ = print ("RETRY-CLIENT: Success after attempt " ^ - intToString(attempt_num)) - in "success" - end - ] - in (response, whereis_time) - end - ) - - val (response, whereis_time) = operation_result - - (* Report metrics *) - val _ = reportPerformanceMetric(config, "RETRY-CLIENT", - "whereis blocking time", whereis_time, "ms") - val _ = reportPerformanceMetric(config, "RETRY-CLIENT", - "Total operation time", total_time, "ms") - - (* Test results *) - val test_results = [ - ("whereis blocked for ~10s", whereis_time > 9000 andalso whereis_time < 12000), - ("Connection established", response = "success"), - ("Demonstrates indefinite blocking", whereis_time > 0) - ] - - in exitOnTestResults(config, "RETRY-CLIENT", test_results, 0) - end - -in retry_client() -end \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/aliases.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/aliases.json deleted file mode 100644 index 5344c8d2..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/aliases.json +++ /dev/null @@ -1 +0,0 @@ -{"timeout-client":"12D3KooWBJHHT6jjjsiaeuv5sfTwbho5j1MAbz3ApxTZYowi6wiq"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/config.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/config.json deleted file mode 100644 index 1045b8c8..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/config.json +++ /dev/null @@ -1,22 +0,0 @@ -{ - "test_name": "p2p-whereis-timeout", - "timeout": 30, - "coordination": "sequential", - "network": { - "use_relay": false, - "bootstrap_peers": [] - }, - "nodes": [ - { - "id": "timeout-client", - "script": "timeout-client.trp", - "port": 6797, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - } - ], - "output": { - "merge_strategy": "timestamp", - "filter_patterns": ["uuid", "timestamp", "peer_id"] - } -} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/ids/timeout-client.json b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/ids/timeout-client.json deleted file mode 100644 index 934efde7..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/ids/timeout-client.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWBJHHT6jjjsiaeuv5sfTwbho5j1MAbz3ApxTZYowi6wiq","privKey":"CAESQF2lyU3FxgVCWGXCn200AXtedCJL8lHWPGGyqGkVisIpFgJtQuSB5vSraHWh4gR47ljrzsF/iZ5IkZM/tnWkZio=","pubKey":"CAESIBYCbULkgeb0q2h1oeIEeO5Y687Bf4meSJGTP7Z1pGYq"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/timeout-client.trp b/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/timeout-client.trp deleted file mode 100644 index e7f8dae4..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-connection-tests/whereis-timeout/timeout-client.trp +++ /dev/null @@ -1,58 +0,0 @@ -(* Whereis Timeout Test - Demonstrates safe whereis usage *) -(* Shows how to implement timeout for whereis since it blocks forever *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 25000, "TEST") - - fun test_whereis_timeout() = - let val _ = print "TIMEOUT-CLIENT: Testing safe whereis with timeout" - - (* Test 1: Look for non-existent service with 5 second timeout *) - val _ = print "\nTEST 1: Looking for non-existent service with 5s timeout" - val (test1_result, test1_time) = measureTime(fn () => - whereisWithTimeout("@nonexistent", "noservice", 5000) - ) - val (status1, _) = test1_result - val _ = print ("TEST 1 Result: " ^ status1 ^ " after " ^ intToString(test1_time) ^ "ms") - val _ = reportTestResult(config, "TIMEOUT-CLIENT", "TEST 1", - status1 = "timeout" andalso test1_time > 5000 andalso test1_time < 6000) - - (* Test 2: Look for local service that exists *) - val _ = print "\nTEST 2: Looking for local service with 5s timeout" - val _ = register("test-service", self(), authority) - val (test2_result, test2_time) = measureTime(fn () => - whereisWithTimeout("@timeout-client", "test-service", 5000) - ) - val (status2, _) = test2_result - val _ = print ("TEST 2 Result: " ^ status2 ^ " after " ^ intToString(test2_time) ^ "ms") - val _ = reportTestResult(config, "TIMEOUT-CLIENT", "TEST 2", - status2 = "found" andalso test2_time < 100) - - (* Summary *) - val _ = print "\nSUMMARY: Safe whereis implementation" - val _ = print "- whereis blocks forever without timeout" - val _ = print "- Spawn whereis in separate process" - val _ = print "- Use receive with timeout pattern" - val _ = print "- Protects against hanging on non-existent services" - - (* Performance metrics *) - val _ = reportPerformanceMetric(config, "TIMEOUT-CLIENT", - "Test 1 timeout duration", test1_time, "ms") - val _ = reportPerformanceMetric(config, "TIMEOUT-CLIENT", - "Test 2 lookup time", test2_time, "ms") - - (* Test results *) - val test_results = [ - ("Timeout works correctly", status1 = "timeout"), - ("Found service quickly", status2 = "found" andalso test2_time < 100), - ("Timeout timing accurate", test1_time > 5000 andalso test1_time < 6000) - ] - - in exitOnTestResults(config, "TIMEOUT-CLIENT", test_results, 1000) - end - -in test_whereis_timeout() -end \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/aliases.json b/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/aliases.json deleted file mode 100644 index 6d2053c1..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/aliases.json +++ /dev/null @@ -1 +0,0 @@ -{"stream-client":"12D3KooWJAGTTtHLGqB8F4TjGVKeWd2ymBGX3AqzQfhPnPNzCURJ","stream-server":"12D3KooWG2Pt2Z4AD3j2tDDVrHKh5CMrLX2hXvUQ9a1G56w1GhPL"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/config.json b/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/config.json deleted file mode 100644 index bfc56a6f..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/config.json +++ /dev/null @@ -1,30 +0,0 @@ -{ - "test_name": "p2p-async-stream-ops", - "timeout": 35, - "coordination": "parallel", - "network": { - "use_relay": false, - "bootstrap_peers": [] - }, - "nodes": [ - { - "id": "stream-server", - "script": "stream-server.trp", - "port": 6795, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - }, - { - "id": "stream-client", - "script": "stream-client.trp", - "port": 6796, - "start_delay": 2, - "expected_exit_code": 0, - "extra_argv": "--debug-p2p" - } - ], - "output": { - "merge_strategy": "timestamp", - "filter_patterns": ["uuid", "timestamp", "peer_id"] - } -} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-client.json b/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-client.json deleted file mode 100644 index cf14c725..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-client.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWJAGTTtHLGqB8F4TjGVKeWd2ymBGX3AqzQfhPnPNzCURJ","privKey":"CAESQI3EF9xVcsiP2ne7Av4SwQHY13g/EXJ3QpZukyqBQ1Oce/anQC3kKStq2IckyBtSg9b+S0r40ULolpUFBh5G/rU=","pubKey":"CAESIHv2p0At5CkratiHJMgbUoPW/ktK+NFC6JaVBQYeRv61"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-server.json b/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-server.json deleted file mode 100644 index a1684f0b..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/ids/stream-server.json +++ /dev/null @@ -1 +0,0 @@ -{"id":"12D3KooWG2Pt2Z4AD3j2tDDVrHKh5CMrLX2hXvUQ9a1G56w1GhPL","privKey":"CAESQGkLSFfAnWYx2Cf5BdXaAUUhrZk3Nmocr1s3HjCui3enXDsG2xuxyXP/vS4M4lug4VqV6xVSRikl/a5cj3h81wc=","pubKey":"CAESIFw7Btsbsclz/70uDOJboOFalesVUkYpJf2uXI94fNcH"} \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-client.trp b/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-client.trp deleted file mode 100644 index 1b6699c6..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-client.trp +++ /dev/null @@ -1,99 +0,0 @@ -(* Async Stream Operations Test - Client *) -(* Tests async stream handling critical for libp2p v0.46+ *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 25000, "STREAM-CLIENT") - - fun stream_client() = - let val _ = print "STREAM-CLIENT: Starting async stream test client" - - (* Find stream server *) - val _ = sleep 1000 (* Give server time to register *) - val (server, connect_time) = measureConnectionTime("@stream-server", "stream-test") - val _ = print "STREAM-CLIENT: Found stream server" - val _ = reportPerformanceMetric(config, "STREAM-CLIENT", "Service lookup time", connect_time, "ms") - - (* Test 1: Small message (tests basic async operation) *) - val _ = print "\nSTREAM-CLIENT: Test 1 - Small message async operation" - val small_msg = "Hello Stream" - val (small_result, small_time) = measureTime(fn () => - let val _ = send(server, ("SMALL_MSG", small_msg, self())) - in receive [ - hn ("SMALL_ACK", ack) => - (print ("STREAM-CLIENT: Small message acknowledged: " ^ ack); true) - ] - end - ) - val _ = reportPerformanceMetric(config, "STREAM-CLIENT", "Small message RTT", small_time, "ms") - - (* Test 2: Large message (tests chunked/async transfer) *) - val _ = print "\nSTREAM-CLIENT: Test 2 - Large message async transfer" - val large_size = 1000 (* Request 1KB of data *) - val (large_result, large_time) = measureTime(fn () => - let val _ = send(server, ("LARGE_MSG", large_size, self())) - in receive [ - hn ("LARGE_DATA", data) => - let val _ = print ("STREAM-CLIENT: Received large data") - (* Check if we got data by seeing if it's non-empty *) - val got_data = data <> "" - in got_data - end - ] - end - ) - val _ = reportPerformanceMetric(config, "STREAM-CLIENT", "Large message transfer time", large_time, "ms") - - (* Test 3: Concurrent streams (tests multiplexing) *) - val _ = print "\nSTREAM-CLIENT: Test 3 - Concurrent stream operations" - val _ = print "STREAM-CLIENT: Sending multiple concurrent requests" - - (* Send multiple requests without waiting *) - val _ = send(server, ("CONCURRENT_TEST", 1, self())) - val _ = send(server, ("CONCURRENT_TEST", 2, self())) - val _ = send(server, ("CONCURRENT_TEST", 3, self())) - - (* Collect responses - they may arrive out of order *) - fun collect_responses(count, received_ids) = - if count <= 0 then received_ids - else - receive [ - hn ("STREAM_RESULT", id, status) => - let val _ = print ("STREAM-CLIENT: Received response for stream " ^ - intToString(id) ^ ": " ^ status) - in collect_responses(count - 1, id :: received_ids) - end - ] - - val received = collect_responses(3, []) - (* Check if we got 3 responses by counting *) - val concurrent_success = case received of - [_, _, _] => true - | _ => false - val _ = print ("STREAM-CLIENT: Concurrent test: " ^ - (if concurrent_success then "PASSED" else "FAILED")) - - (* Calculate throughput *) - val throughput = if large_time > 0 then - large_size * 1000 div large_time - else 0 - val _ = reportPerformanceMetric(config, "STREAM-CLIENT", "Throughput", throughput, "bytes/sec") - - (* Test results *) - val test_results = [ - ("Small message async", small_result), - ("Large message transfer", large_result), - ("Concurrent streams", concurrent_success), - ("Connection established quickly", connect_time < 5000) - ] - - (* Report test summary *) - val _ = reportTestSummary(config, "STREAM-CLIENT", test_results) - - in exitOnTestResults(config, "STREAM-CLIENT", test_results, 1000) - end - -in stream_client() -end \ No newline at end of file diff --git a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-server.trp b/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-server.trp deleted file mode 100644 index 436fdc75..00000000 --- a/tests/rt/libp2p-migration-tests/p2p-stream-tests/async-stream-ops/stream-server.trp +++ /dev/null @@ -1,69 +0,0 @@ -(* Async Stream Operations Test - Server *) -(* Tests async stream handling critical for libp2p v0.46+ *) - -import NetHealth - -let - val config = {print = print, auth = authority} - val timeout_pid = spawnTestTimeout(config, 30000, "STREAM-SERVER") - - fun generate_large_data(size) = - (* Generate data that will require chunking *) - let fun build(n, acc) = - if n <= 0 then acc - else build(n - 1, acc ^ "X") - in build(size, "DATA:") - end - - fun stream_server() = - let val _ = print "STREAM-SERVER: Starting async stream test server" - - (* Register stream test service *) - val _ = register("stream-test", self(), authority) - val _ = print "STREAM-SERVER: Registered stream-test service" - - (* Handle multiple message types to test async operations *) - fun handle_messages(msg_count) = - if msg_count >= 5 then "complete" (* Expect 5 messages: 1 small + 1 large + 3 concurrent *) - else - let val result = receive [ - (* Small message test *) - hn ("SMALL_MSG", data, sender) => - let val _ = print ("STREAM-SERVER: Received small message") - val _ = send(sender, ("SMALL_ACK", "Received: " ^ data)) - in handle_messages(msg_count + 1) - end, - - (* Large message test - simulates chunked transfer *) - hn ("LARGE_MSG", size_request, sender) => - let val _ = print ("STREAM-SERVER: Large message request for " ^ - intToString(size_request) ^ " bytes") - val large_data = generate_large_data(size_request) - val _ = print "STREAM-SERVER: Sending large response" - val _ = send(sender, ("LARGE_DATA", large_data)) - in handle_messages(msg_count + 1) - end, - - (* Concurrent stream test *) - hn ("CONCURRENT_TEST", stream_id, sender) => - let val _ = print ("STREAM-SERVER: Concurrent stream test, ID: " ^ - intToString(stream_id)) - (* Simulate async processing *) - val _ = sleep 100 - val _ = send(sender, ("STREAM_RESULT", stream_id, "Processed")) - in handle_messages(msg_count + 1) - end - ] - in result - end - - val test_result = handle_messages(0) - - in if test_result = "complete" then - exitSuccess(config, "STREAM-SERVER", "Async stream operations test completed successfully", 1000) - else - exitFailure(config, "STREAM-SERVER", "Async stream operations test failed") - end - -in stream_server() -end \ No newline at end of file From 017d9030f96bc28cbb740d383f137d2aa55d0055 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 09:41:33 +0200 Subject: [PATCH 13/25] Remove 'bst' library In a separate branch, I am already implementing this anew with a proper API (but still not properly balanced). --- lib/Makefile | 1 - lib/bst.trp | 55 ---------------------------------------------------- 2 files changed, 56 deletions(-) delete mode 100644 lib/bst.trp diff --git a/lib/Makefile b/lib/Makefile index c1fe48d2..9a430cf7 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -18,7 +18,6 @@ build: $(COMPILER) ./timeout.trp -l $(COMPILER) ./declassifyutil.trp -l $(COMPILER) ./stdio.trp -l - $(COMPILER) ./bst.trp -l clean: rm -rf out diff --git a/lib/bst.trp b/lib/bst.trp deleted file mode 100644 index db7a8b8d..00000000 --- a/lib/bst.trp +++ /dev/null @@ -1,55 +0,0 @@ -datatype Atoms = NOT_FOUND - -let - - val leaf = () - - val empty_tree = () - - fun insert k v t = - case t of - () => ((), k, v, ()) - | (l, k', v', r) => if k = k' then (l, k, v, r) - else if k > k' then (l, k', v', insert k v r) else (insert k v l, k', v', r) - - fun lookup k t = - case t of - () => NOT_FOUND - | (l, k', v', r) => if k = k' then v' - else if k > k' then lookup k r else lookup k l - - fun contains k t = - case t of - () => false - | (l, k', v', r) => if k = k' then true - else if k > k' then contains k r else contains k l - - fun remove k t = - let fun extract_smallest (l, k, v, r) = - case l of - () => (k, v, r) - | _ => let val (k', v', l') = extract_smallest l - in (k', v', (l', k, v, r)) end - in case t of - () => () - | (l, k', v', r) => - if k = k' then - case l of - () => r - | _ => case r of - () => l - | _ => let val (k'', v'', r') = extract_smallest r - in (l, k'', v'', r') end - else if k > k' then (l, k', v', remove k r) else (remove k l, k', v', r) - end - -in - [ ("empty_tree", empty_tree) - , ("insert", insert) - , ("lookup", lookup) - , ("contains", contains) - , ("remove", remove) - ] - -end - From 5a8065ba74e475f0c4ce5db811315439544959b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 09:42:26 +0200 Subject: [PATCH 14/25] Remove 'nsuref' library On a seperate branch, I am already trying to implement this anew --- lib/Makefile | 1 - lib/nsuref.trp | 19 ------------------- 2 files changed, 20 deletions(-) delete mode 100644 lib/nsuref.trp diff --git a/lib/Makefile b/lib/Makefile index 9a430cf7..616a4807 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -13,7 +13,6 @@ build: $(COMPILER) ./HashMap.trp -l $(COMPILER) ./HashSet.trp -l # Old stuff, here be dragons... - $(COMPILER) ./nsuref.trp -l $(COMPILER) ./printService.trp -l $(COMPILER) ./timeout.trp -l $(COMPILER) ./declassifyutil.trp -l diff --git a/lib/nsuref.trp b/lib/nsuref.trp deleted file mode 100644 index 870b287c..00000000 --- a/lib/nsuref.trp +++ /dev/null @@ -1,19 +0,0 @@ -datatype Atoms = WRITE | READ | VALUE - -let fun cell authority v = - let fun loop content = - rcv (`{}`, `{#TOP}` - , [ hn (WRITE, newcontent) => loop newcontent ] - , [ hn (READ, reader, nonce) => - send (reader, (VALUE, nonce, content)) - ; loop content - ] - ) - - in loop v - end - -in [("cell", cell)] -end - - \ No newline at end of file From dfa72f5c53fb33894f05726ab78f04ecb6766699 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 10:02:49 +0200 Subject: [PATCH 15/25] Remove 'printService' and 'stdio' libraries These should be reimplemented as a new IO library with an entirely new API. --- lib/Makefile | 2 -- lib/printService.trp | 21 --------------------- lib/stdio.trp | 17 ----------------- tests/rt/pos/ifc/inputpini.trp | 17 ++++++++++++++--- tests/rt/pos/ifc/tlev02.trp | 12 ++++++++---- 5 files changed, 22 insertions(+), 47 deletions(-) delete mode 100644 lib/printService.trp delete mode 100644 lib/stdio.trp diff --git a/lib/Makefile b/lib/Makefile index 616a4807..06866051 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -13,10 +13,8 @@ build: $(COMPILER) ./HashMap.trp -l $(COMPILER) ./HashSet.trp -l # Old stuff, here be dragons... - $(COMPILER) ./printService.trp -l $(COMPILER) ./timeout.trp -l $(COMPILER) ./declassifyutil.trp -l - $(COMPILER) ./stdio.trp -l clean: rm -rf out diff --git a/lib/printService.trp b/lib/printService.trp deleted file mode 100644 index 5f4f25b5..00000000 --- a/lib/printService.trp +++ /dev/null @@ -1,21 +0,0 @@ -datatype Atoms = PRINT | SHUTDOWN -let fun spawnLocalPrintService auth = - let fun loop () = - receive [ hn (PRINT, x) => fprintln (getStdout auth, x) - ; loop () - , hn SHUTDOWN => () (* probably needs authentication *) - , hn _ => loop () ] - (* TODO: pick messages with higher presence labels*) - (* TODO: shutdown message *) - val p = spawn loop - in register ("__localprintservice", p, auth ); p - end - - fun printLocal x = - let val pp = whereis (node (self()), "__localprintservice") - in send (pp, (PRINT,x)) - end - -in [("spawnLocalPrintService", spawnLocalPrintService) - ,("printLocal", printLocal)] -end \ No newline at end of file diff --git a/lib/stdio.trp b/lib/stdio.trp deleted file mode 100644 index ca8fbcad..00000000 --- a/lib/stdio.trp +++ /dev/null @@ -1,17 +0,0 @@ -let - fun inputLineWithPini auth = - let pini auth val s = inputLine () - in s - end - - (* this function takes as an argument the authority needed to *) - (* declassify the program counter and the result *) - - fun inputLineAtLevel auth lev = - let val s = inputLineWithPini auth - in declassify (s, auth, lev) - end - -in [("inputLineWithPini", inputLineWithPini) - ,("inputLineAtLevel", inputLineAtLevel)] -end \ No newline at end of file diff --git a/tests/rt/pos/ifc/inputpini.trp b/tests/rt/pos/ifc/inputpini.trp index 4056e834..5583033b 100644 --- a/tests/rt/pos/ifc/inputpini.trp +++ b/tests/rt/pos/ifc/inputpini.trp @@ -1,8 +1,19 @@ -import stdio let val out = getStdout authority + + fun inputLineWithPini auth = + let pini auth val s = inputLine () + in s + end + + fun inputLineAtLevel auth lev = + let val s = inputLineWithPini auth + in declassify (s, auth, lev) + end + fun writeString x = fwrite (out, x) + val _ = writeString "Please input something: " val s = inputLineAtLevel authority `{}` val _ = writeString ("You have provided input: " ^ s ^ "\n") -in s -end + +in s end diff --git a/tests/rt/pos/ifc/tlev02.trp b/tests/rt/pos/ifc/tlev02.trp index 4b1aeb39..e868c383 100644 --- a/tests/rt/pos/ifc/tlev02.trp +++ b/tests/rt/pos/ifc/tlev02.trp @@ -1,7 +1,11 @@ -import stdio +let fun inputLineWithPini auth = + let pini auth val s = inputLine () + in s + end + val out = getStdout authority + val _ = fwrite (out, "What's your name: ") + val input = inputLineWithPini authority -let val _ = fwrite (getStdout authority, "What's your name: ") - val input = inputLineWithPini authority -in printString ("Hello" ^ " " ^ input ) +in fwrite (out, "Hello" ^ " " ^ input ^ "\n") end From 8d7c0afd8a6b4a2a015e3015d9b1073831c03c4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 12:13:30 +0200 Subject: [PATCH 16/25] Clean up 'declassifyUtil' into a new module --- lib/DeclassifyUtil.trp | 110 ++++++++++++++++++++++++++++++++++ lib/Makefile | 2 +- lib/README.md | 19 +++--- lib/declassifyutil.trp | 102 ------------------------------- tests/rt/neg/ifc/pini_d.trp | 7 ++- tests/rt/pos/ifc/decl2.trp | 4 +- tests/rt/pos/ifc/pini.trp | 4 +- tests/rt/pos/ifc/tuples03.trp | 2 - 8 files changed, 128 insertions(+), 122 deletions(-) create mode 100644 lib/DeclassifyUtil.trp delete mode 100644 lib/declassifyutil.trp diff --git a/lib/DeclassifyUtil.trp b/lib/DeclassifyUtil.trp new file mode 100644 index 00000000..a6c880e9 --- /dev/null +++ b/lib/DeclassifyUtil.trp @@ -0,0 +1,110 @@ +import List + +let (* Mutually recursive deep declassification of tuples, lists, ... *) + + (* Declassification for (most) tuples *) + fun declassify2 ((x,y), a, lev) = + ( declassifyDeep (x, a, lev) + , declassifyDeep (y, a, lev)) + + and declassify3 ((x,y,z), a, lev) = + ( declassifyDeep (x, a, lev) + , declassifyDeep (y, a, lev) + , declassifyDeep (z, a, lev)) + + and declassify4 ((x,y,z,w), a, lev) = + ( declassifyDeep (x, a, lev) + , declassifyDeep (y, a, lev) + , declassifyDeep (z, a, lev) + , declassifyDeep (w, a, lev)) + + and declassify5 ((x1,x2,x3,x4,x5), a, lev) = + ( declassifyDeep (x1, a, lev) + , declassifyDeep (x2, a, lev) + , declassifyDeep (x3, a, lev) + , declassifyDeep (x4, a, lev) + , declassifyDeep (x5, a, lev) + ) + + and declassify6 ((x1,x2,x3,x4,x5,x6), a, lev) = + ( declassifyDeep (x1, a, lev) + , declassifyDeep (x2, a, lev) + , declassifyDeep (x3, a, lev) + , declassifyDeep (x4, a, lev) + , declassifyDeep (x5, a, lev) + , declassifyDeep (x6, a, lev) + ) + + and declassify7 ((x1,x2,x3,x4,x5,x6,x7), a, lev) = + ( declassifyDeep (x1, a, lev) + , declassifyDeep (x2, a, lev) + , declassifyDeep (x3, a, lev) + , declassifyDeep (x4, a, lev) + , declassifyDeep (x5, a, lev) + , declassifyDeep (x6, a, lev) + , declassifyDeep (x7, a, lev) + ) + + and declassify8 ((x1,x2,x3,x4,x5,x6,x7,x8), a, lev) = + ( declassifyDeep (x1, a, lev) + , declassifyDeep (x2, a, lev) + , declassifyDeep (x3, a, lev) + , declassifyDeep (x4, a, lev) + , declassifyDeep (x5, a, lev) + , declassifyDeep (x6, a, lev) + , declassifyDeep (x7, a, lev) + , declassifyDeep (x8, a, lev) + ) + + and declassify9 ((x1,x2,x3,x4,x5,x6,x7,x8,x9), a, lev) = + ( declassifyDeep (x1, a, lev) + , declassifyDeep (x2, a, lev) + , declassifyDeep (x3, a, lev) + , declassifyDeep (x4, a, lev) + , declassifyDeep (x5, a, lev) + , declassifyDeep (x6, a, lev) + , declassifyDeep (x7, a, lev) + , declassifyDeep (x8, a, lev) + , declassifyDeep (x9, a, lev) + ) + + (* Declassification for lists *) + and declassifyList (xs, a, lev) = + List.map (fn x => declassifyDeep (x, a, lev) ) xs + + (* TODO: Declassification of records? *) + + (** Deep declassification of value `x` to `level` via the given `authority`. *) + and declassifyDeep (x, authority, level) = + let (* Declassify the blocking label before touching the value. *) + val _ = blockdeclto (authority, level) + + (* declassification is a 2-step process: + * + * 1. We pattern match on the given value and figure out which function to apply; + * this choice of the function needs to be declassified itself. + * + * 2. We proceed onto the application of the function. *) + val x' = declassify (x, authority, level) + + val f = case x' of (_,_) => declassify2 + | (_,_,_) => declassify3 + | (_,_,_,_) => declassify4 + | (_,_,_,_,_) => declassify5 + | (_,_,_,_,_,_) => declassify6 + | (_,_,_,_,_,_,_) => declassify7 + | (_,_,_,_,_,_,_,_) => declassify8 + | (_,_,_,_,_,_,_,_,_) => declassify9 + | (_::_) => declassifyList + | _ => declassify + + in f(x', authority, level) + end + + (*--- Module ---*) + val DeclassifyUtil = { + declassifyDeep + } + +in [ ("DeclassifyUtil", DeclassifyUtil) ] +end diff --git a/lib/Makefile b/lib/Makefile index 06866051..64cfa0cc 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -6,6 +6,7 @@ build: $(COMPILER) ./Number.trp -l $(COMPILER) ./List.trp -l $(COMPILER) ./ListPair.trp -l + $(COMPILER) ./DeclassifyUtil.trp -l $(COMPILER) ./String.trp -l $(COMPILER) ./Hash.trp -l $(COMPILER) ./Unit.trp -l @@ -14,7 +15,6 @@ build: $(COMPILER) ./HashSet.trp -l # Old stuff, here be dragons... $(COMPILER) ./timeout.trp -l - $(COMPILER) ./declassifyutil.trp -l clean: rm -rf out diff --git a/lib/README.md b/lib/README.md index 44119947..1025a429 100644 --- a/lib/README.md +++ b/lib/README.md @@ -6,15 +6,16 @@ reviewed rigorously rather than depend on the monitor. ## Modules -- `Hash` : Hash functions for values of all types. -- `HashMap` : Map from keys to values via their hash. -- `HashSet` : Set of elements via their hash. -- `List` : Operations for lists, i.e. `[]` and `x::xs`. -- `ListPair` : Operations for list of pairs, i.e. `(x,y)::xs`. -- `Number` : Operations for numbers, i.e. integer and floats. -- `StencilVector` : Memory-efficient implementation of small (sparse) arrays. -- `String` : Operations for strings -- `Unit` : Unit testing. +- `DeclassifyUtil` : Helper functions for declassification. +- `Hash` : Hash functions for values of all types. +- `HashMap` : Map from keys to values via their hash. +- `HashSet` : Set of elements via their hash. +- `List` : Operations for lists, i.e. `[]` and `x::xs`. +- `ListPair` : Operations for list of pairs, i.e. `(x,y)::xs`. +- `Number` : Operations for numbers, i.e. integer and floats. +- `StencilVector` : Memory-efficient implementation of small (sparse) arrays. +- `String` : Operations for strings +- `Unit` : Unit testing. ## How to add a new file diff --git a/lib/declassifyutil.trp b/lib/declassifyutil.trp deleted file mode 100644 index adc04b9a..00000000 --- a/lib/declassifyutil.trp +++ /dev/null @@ -1,102 +0,0 @@ -(* Universal declassifier *) -(* Author: Aslan Askarov, aslan@askarov.net *) -(* Creation date: 2018-10-19 *) - -import List - -let - (* these are our primitive declassifiers; obs: mutual recursion *) - - fun declassify2 ((x,y), a, lev) = ( declassifydeep (x, a, lev) - , declassifydeep (y, a, lev)) - - and declassify3 ((x,y,z), a, lev) = ( declassifydeep (x, a, lev) - , declassifydeep (y, a, lev) - , declassifydeep (z, a, lev)) - - and declassify4 ((x,y,z,w), a, lev) = ( declassifydeep (x, a, lev) - , declassifydeep (y, a, lev) - , declassifydeep (z, a, lev) - , declassifydeep (w, a, lev)) - and declassify5 ((x1,x2,x3,x4,x5), a, lev) - = ( declassifydeep (x1, a, lev) - , declassifydeep (x2, a, lev) - , declassifydeep (x3, a, lev) - , declassifydeep (x4, a, lev) - , declassifydeep (x5, a, lev) - ) - and declassify6 ((x1,x2,x3,x4,x5,x6), a, lev) - = ( declassifydeep (x1, a, lev) - , declassifydeep (x2, a, lev) - , declassifydeep (x3, a, lev) - , declassifydeep (x4, a, lev) - , declassifydeep (x5, a, lev) - , declassifydeep (x6, a, lev) - ) - and declassify7 ((x1,x2,x3,x4,x5,x6,x7), a, lev) - = ( declassifydeep (x1, a, lev) - , declassifydeep (x2, a, lev) - , declassifydeep (x3, a, lev) - , declassifydeep (x4, a, lev) - , declassifydeep (x5, a, lev) - , declassifydeep (x6, a, lev) - , declassifydeep (x7, a, lev) - ) - and declassify8 ((x1,x2,x3,x4,x5,x6,x7,x8), a, lev) - = ( declassifydeep (x1, a, lev) - , declassifydeep (x2, a, lev) - , declassifydeep (x3, a, lev) - , declassifydeep (x4, a, lev) - , declassifydeep (x5, a, lev) - , declassifydeep (x6, a, lev) - , declassifydeep (x7, a, lev) - , declassifydeep (x8, a, lev) - ) - and declassify9 ((x1,x2,x3,x4,x5,x6,x7,x8,x9), a, lev) - = ( declassifydeep (x1, a, lev) - , declassifydeep (x2, a, lev) - , declassifydeep (x3, a, lev) - , declassifydeep (x4, a, lev) - , declassifydeep (x5, a, lev) - , declassifydeep (x6, a, lev) - , declassifydeep (x7, a, lev) - , declassifydeep (x8, a, lev) - , declassifydeep (x9, a, lev) - ) - - - - and declassifylist (xs, a, lev) = - List.map (fn x => declassifydeep (x, a, lev) ) xs - - and declassifydeep (x, a, lev) = - (* we declassify the blocking label before touching the value *) - blockdeclto ( a, lev); - - (* declassification is a 2-step process ; first we pattern match *) - (* on the given value and figure out which function to apply; *) - (* the choice of the function needs to be declassified before we *) - (* proceed further with the application of that function *) - let val y = declassify (x, a, lev) - val f = - case y of - (_,_) => declassify2 - | (_,_,_) => declassify3 - | (_,_,_,_) => declassify4 - | (_,_,_,_,_) => declassify5 - | (_,_,_,_,_,_) => declassify6 - | (_,_,_,_,_,_,_) => declassify7 - | (_,_,_,_,_,_,_,_) => declassify8 - | (_,_,_,_,_,_,_,_,_) => declassify9 - | (_::_) => declassifylist - | _ => declassify - in f(y, a, lev ) - end - - fun declassify_with_block (x, a, lev) = blockdeclto (a, lev); declassify (x, a, lev) - - - -in [("declassifydeep", declassifydeep) - ,("declassify_with_block", declassify_with_block)] -end diff --git a/tests/rt/neg/ifc/pini_d.trp b/tests/rt/neg/ifc/pini_d.trp index 31d2e08d..0a812c0e 100644 --- a/tests/rt/neg/ifc/pini_d.trp +++ b/tests/rt/neg/ifc/pini_d.trp @@ -1,4 +1,5 @@ -import declassifyutil +import DeclassifyUtil + (* testing various corner cases of declassification *) let val secretAlice = 1 raisedTo `` val secretBob = 1 raisedTo `` @@ -9,8 +10,8 @@ let val secretAlice = 1 raisedTo `` val (a,b) = if secretAlice > 0 then (1,2) else (3,4) val (x,y) = if secretBob > 0 then (5,6) else (7,8) val _ = blockdecl authority - val (a1, b1) = declassifydeep ( (a,b), aliceAuth, `{}` ) + val (a1, b1) = DeclassifyUtil.declassifyDeep ( (a,b), aliceAuth, `{}` ) val _ = if secretBob > secretAlice then () else () in adv a1 -end \ No newline at end of file +end diff --git a/tests/rt/pos/ifc/decl2.trp b/tests/rt/pos/ifc/decl2.trp index b4a0f5fd..f7d4608a 100644 --- a/tests/rt/pos/ifc/decl2.trp +++ b/tests/rt/pos/ifc/decl2.trp @@ -1,10 +1,10 @@ -import declassifyutil +import DeclassifyUtil import List let val x = 42 raisedTo `` val y = 100 raisedTo `` val tuple = (x,y,10) val ls = List.map (fn x => x) [x,y,10] - val z = declassifydeep (ls, authority, `{}`) + val z = DeclassifyUtil.declassifyDeep (ls, authority, `{}`) in z end diff --git a/tests/rt/pos/ifc/pini.trp b/tests/rt/pos/ifc/pini.trp index d338eca6..ac7b4743 100644 --- a/tests/rt/pos/ifc/pini.trp +++ b/tests/rt/pos/ifc/pini.trp @@ -1,5 +1,3 @@ -import declassifyutil - let val secret = 1 raisedTo `` val aliceAuth = attenuate (authority, ``) (* val t = if secret > 0 then (1,2) else (3,4) *) @@ -8,4 +6,4 @@ let val secret = 1 raisedTo `` val _ = pinipop c in adv 0 -end \ No newline at end of file +end diff --git a/tests/rt/pos/ifc/tuples03.trp b/tests/rt/pos/ifc/tuples03.trp index abe1249e..0389f72e 100644 --- a/tests/rt/pos/ifc/tuples03.trp +++ b/tests/rt/pos/ifc/tuples03.trp @@ -1,5 +1,3 @@ -import declassifyutil - let val x = 42 raisedTo `` val y = 100 raisedTo `` From c19cd014232c071c8d94979e167a148dabd32bb9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 14:34:10 +0200 Subject: [PATCH 17/25] Replace 'timeout.trp' with 'ThreadUtil' module This also adds the start of a 'Time' module (which is what I initially thought would be the place to put the new timeout function. --- .../fromuserguide/basic_updateableserver.trp | 8 ++++--- lib/Makefile | 3 +-- lib/README.md | 6 +++++ lib/ThreadUtil.trp | 23 ++++++++++++++++++ lib/timeout.trp | 24 ------------------- 5 files changed, 35 insertions(+), 29 deletions(-) create mode 100644 lib/ThreadUtil.trp delete mode 100644 lib/timeout.trp diff --git a/examples/fromuserguide/basic_updateableserver.trp b/examples/fromuserguide/basic_updateableserver.trp index 91f2d470..4debe535 100644 --- a/examples/fromuserguide/basic_updateableserver.trp +++ b/examples/fromuserguide/basic_updateableserver.trp @@ -1,4 +1,5 @@ -import timeout +import ThreadUtil + let fun v_one n = receive [ hn ("REQUEST", senderid) => let val _ = send (senderid, n) @@ -26,7 +27,8 @@ let fun v_one n = val _ = send (service, ("UPDATE", v_two)) val _ = send (service, ("COMPUTE", self(), fn x => x * x, 42)) val _ = receive [ hn x => print x] -in exitAfterTimeout - authority 1000 0 "force terminating the server example after 1s" +in ThreadUtil.spawnTimeout (fn () => print "force terminating the server example after 1s"; + exit (authority, 0)) + 1000 end diff --git a/lib/Makefile b/lib/Makefile index 64cfa0cc..29049454 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -5,6 +5,7 @@ build: # Standard Library $(COMPILER) ./Number.trp -l $(COMPILER) ./List.trp -l + $(COMPILER) ./ThreadUtil.trp -l $(COMPILER) ./ListPair.trp -l $(COMPILER) ./DeclassifyUtil.trp -l $(COMPILER) ./String.trp -l @@ -13,8 +14,6 @@ build: $(COMPILER) ./StencilVector.trp -l $(COMPILER) ./HashMap.trp -l $(COMPILER) ./HashSet.trp -l - # Old stuff, here be dragons... - $(COMPILER) ./timeout.trp -l clean: rm -rf out diff --git a/lib/README.md b/lib/README.md index 1025a429..b9d9ac24 100644 --- a/lib/README.md +++ b/lib/README.md @@ -15,6 +15,7 @@ reviewed rigorously rather than depend on the monitor. - `Number` : Operations for numbers, i.e. integer and floats. - `StencilVector` : Memory-efficient implementation of small (sparse) arrays. - `String` : Operations for strings +- `ThreadUtil` : Additional functions for thread management. - `Unit` : Unit testing. ## How to add a new file @@ -34,6 +35,11 @@ target of the *makefile*. - Each function that is exported has to be documented (`(** *)`). In the long run, we will auto-generate documentation for the Standard Library. +### Other notes + +- The `ThreadUtil` module was initially named `Thread`. But, this suggests incorrectly, that + threading is implemented here rather than being a language primitive. + ## TODO The [modules](#modules) mentioned above already follow the [design principles](#design-principles). diff --git a/lib/ThreadUtil.trp b/lib/ThreadUtil.trp new file mode 100644 index 00000000..84ac1ed7 --- /dev/null +++ b/lib/ThreadUtil.trp @@ -0,0 +1,23 @@ +let (** Run function `f` after `duration` milliseconds. The function `f` is given `()` as its + * argument. *) + fun spawnTimeout f duration = + spawn (fn () => sleep duration; f ()) + + (** Run function `f` each `duration` milliseconds. The function `f` is given the current + * iteration count as argument. *) + fun spawnInterval f duration = + (* TODO: If `f` takes a considerable time, this will drift! *) + let fun f' i = sleep duration; f i; f' (i+1) + in spawn (fn () => f' 0) end + + (* TODO: Cancel `spawnTimeout` and `spawnInterval`. But, this requires a non-blocking `receive` + * operation. *) + + (*--- Module ---*) + val ThreadUtil = { + spawnTimeout, + spawnInterval + } + +in [ ("ThreadUtil", ThreadUtil) ] +end diff --git a/lib/timeout.trp b/lib/timeout.trp deleted file mode 100644 index 0606e82b..00000000 --- a/lib/timeout.trp +++ /dev/null @@ -1,24 +0,0 @@ -let fun timeout who nonce duration = - spawn (fn () => - let val _ = sleep duration - in send (who, nonce) - end - ) - - - fun exitAfterTimeout authority duration exitcode message = - spawn (fn () => - let val nonce = mkuuid () - val this = self () - val _ = timeout this nonce duration - - in receive [ hn x when x = nonce => - let val _ = if message <> "" then fprintln (getStdout authority, message) else () - in exit (authority, exitcode) - end - ] - end) - - -in [("timeout", timeout), ("exitAfterTimeout", exitAfterTimeout)] -end \ No newline at end of file From 078e804c6d2688b57b23935069eb88cc0131ee97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 14:34:49 +0200 Subject: [PATCH 18/25] Describe compilation order (due to dependencies) in Makefile --- lib/Makefile | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/lib/Makefile b/lib/Makefile index 29049454..c4a03d33 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -2,16 +2,25 @@ COMPILER=../bin/troupec build: mkdir -p out - # Standard Library + + # No dependencies $(COMPILER) ./Number.trp -l $(COMPILER) ./List.trp -l $(COMPILER) ./ThreadUtil.trp -l + + # Dependency on `List` $(COMPILER) ./ListPair.trp -l + $(COMPILER) ./Unit.trp -l $(COMPILER) ./DeclassifyUtil.trp -l + $(COMPILER) ./StencilVector.trp -l + + # Dependency on `List` and `Number` $(COMPILER) ./String.trp -l + + # Dependency on `Number`, `String`, and `List` $(COMPILER) ./Hash.trp -l - $(COMPILER) ./Unit.trp -l - $(COMPILER) ./StencilVector.trp -l + + # Dependency on `List`, `ListPair`, and `StencilVector` $(COMPILER) ./HashMap.trp -l $(COMPILER) ./HashSet.trp -l From bdfdc8e337465b26cd471f601af81fb0fec1c707 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Tue, 21 Oct 2025 15:40:33 +0200 Subject: [PATCH 19/25] Change 'Number.maxInt'and 'Number.minInt' back to off-by-one --- lib/Number.trp | 6 +++--- tests/lib/Number.trp | 6 ++++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/Number.trp b/lib/Number.trp index a8867220..7cd779cc 100644 --- a/lib/Number.trp +++ b/lib/Number.trp @@ -1,13 +1,13 @@ (** In Troupe, there is not per-se an `int` type. Rather, there is a `number` and some integral * operations on them which treats them as if they were 32 bit signed integers. *) -let (** Largest (safe) possible integral value. Anything larger than this cannot represent an +let (** Largest (safe) possible integral value. Anything larger than +1 of this cannot represent an * increment of 1. * * NOTE: Value copied from the JavaScript documentation for `Number.MAX_SAFE_INTEGER`. *) - val maxInt = 9007199254740992 + val maxInt = 9007199254740991 - (** Smallest (safe) possible integral value. Anything smaller than this cannot represent an + (** Smallest (safe) possible integral value. Anything smaller than -1 this cannot represent an * increment of 1. *) val minInt = -maxInt diff --git a/tests/lib/Number.trp b/tests/lib/Number.trp index aa03aa02..e7cc7328 100644 --- a/tests/lib/Number.trp +++ b/tests/lib/Number.trp @@ -3,8 +3,10 @@ import Number let val tests = Unit.group "Number" [ Unit.group "maxInt / minInt" [ - Unit.it "maxInt++ = maxInt" (Unit.isEq Number.maxInt (Number.maxInt + 1)) - , Unit.it "minInt-- = minInt" (Unit.isEq Number.minInt (Number.minInt - 1)) + Unit.it "maxInt++ != maxInt" (Unit.isNeq Number.maxInt (Number.maxInt + 1)) + , Unit.it "minInt-- != minInt" (Unit.isNeq Number.minInt (Number.minInt - 1)) + , Unit.it "maxInt+2 == maxInt+1" (Unit.isEq (Number.maxInt + 1) (Number.maxInt + 2)) + , Unit.it "minInt-2 == minInt+1" (Unit.isEq (Number.minInt - 1) (Number.minInt - 2)) ], Unit.group "abs" [ Unit.it "keeps 0 as is" (Unit.isEq 0 (Number.abs 0)) From 4da2b83351854e3edffd772179852d5beabac5bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Wed, 22 Oct 2025 16:52:28 +0200 Subject: [PATCH 20/25] Add StdIO module & clean up IO in TCB This removes some derivable operations out of the TCB, e.g. `fprintln` and `fprintlnWithLabels`. At the same time, `inputLine` has been semi-generalised to be `freadln` (read a line from a file) and `stdin` is now a derivable capability similar to the one needed for printing to `stdout`. This also fixes the missing access to `stderr`. For now, there are lots of `runtime/core` tests that rely on the preamble functions, `print` and so on. In the long run, these tests should be rewritten such that they are completely independent. The tests for the preamble itself have been moved into a separate folder. --- compiler/src/AddAmbientMethods.hs | 78 ++++---- compiler/src/IR.hs | 14 +- lib/Makefile | 1 + lib/README.md | 1 + lib/StdIO.trp | 121 ++++++++++++ lib/Unit.trp | 6 +- rt/src/Asserts.mts | 3 +- rt/src/UserRuntime.mts | 6 +- rt/src/builtins/receive.mts | 13 -- rt/src/builtins/stdio.mts | 174 ++++++++++-------- rt/src/builtins/thread.mts | 26 +++ tests/_unautomated/question.trp | 3 - tests/lib/Number.golden | 12 +- tests/lib/StdIO.golden | 4 + tests/lib/StdIO.trp | 125 +++++++++++++ tests/lib/StdIO.trp.input | 6 + tests/rt/neg/core/fwrite.golden | 3 + tests/rt/neg/core/fwrite.trp | 1 + .../printString.golden} | 0 .../printString.nocolor.golden} | 0 .../printString.trp} | 0 tests/rt/pos/core/freadln.golden | 3 + tests/rt/pos/core/freadln.trp | 5 + ...nputline01.trp.input => freadln.trp.input} | 0 .../fwrite01.golden} | 4 +- tests/rt/pos/core/fwrite01.trp | 1 + .../fwrite02.golden} | 3 +- tests/rt/pos/core/fwrite02.trp | 1 + tests/rt/pos/core/toString01.golden | 2 + tests/rt/pos/core/toString01.trp | 1 + tests/rt/pos/core/toString02.golden | 2 + tests/rt/pos/core/toString02.trp | 1 + tests/rt/pos/core/toString03.golden | 2 + tests/rt/pos/core/toString03.trp | 1 + tests/rt/pos/core/toString04.golden | 2 + tests/rt/pos/core/toString04.trp | 1 + tests/rt/pos/core/toString05.golden | 2 + tests/rt/pos/core/toString05.trp | 1 + tests/rt/pos/core/toString06.golden | 2 + tests/rt/pos/core/toString06.trp | 1 + tests/rt/pos/ifc/freadln.golden | 4 + tests/rt/pos/ifc/freadln.trp | 5 + tests/rt/pos/ifc/freadln.trp.input | 1 + tests/rt/pos/ifc/fwrite.golden | 5 + tests/rt/pos/ifc/fwrite.trp | 5 + tests/rt/pos/ifc/getBL.golden | 2 + tests/rt/pos/ifc/getBL.trp | 4 + tests/rt/pos/ifc/getPC.golden | 5 +- tests/rt/pos/ifc/getPC.nocolor.golden | 3 - tests/rt/pos/ifc/getPC.trp | 4 +- tests/rt/pos/ifc/inputpini.trp | 18 +- tests/rt/pos/ifc/sandbox/guard01.golden | 2 +- .../rt/pos/ifc/sandbox/guard01.nocolor.golden | 2 +- tests/rt/pos/ifc/tlev02.trp | 2 +- tests/rt/pos/ifc/toString.golden | 3 + tests/rt/pos/ifc/toString.trp | 4 + tests/rt/pos/ifc/toStringL01.golden | 3 + tests/rt/pos/ifc/toStringL01.trp | 4 + ...tringlabeled.golden => toStringL02.golden} | 2 +- tests/rt/pos/ifc/toStringL02.trp | 4 + tests/rt/pos/ifc/tostring.golden | 4 - tests/rt/pos/ifc/tostring.nocolor.golden | 4 - tests/rt/pos/ifc/tostring.trp | 6 - .../rt/pos/ifc/tostringlabeled.nocolor.golden | 3 - tests/rt/pos/ifc/tostringlabeled.trp | 5 - tests/rt/pos/ifc/tostringlabeled02.golden | 4 - .../pos/ifc/tostringlabeled02.nocolor.golden | 4 - tests/rt/pos/ifc/tostringlabeled02.trp | 6 - .../pos/ifc/tostringlabeled03.nocolor.golden | 3 - tests/rt/pos/ifc/tostringlabeled03.trp | 5 - .../pos/ifc/tostringlabeled04.nocolor.golden | 3 - tests/rt/pos/ifc/tostringlabeled04.trp | 6 - .../inputLine01.golden} | 0 .../inputLine01.nocolor.golden} | 0 .../inputLine01.trp} | 0 tests/rt/pos/preamble/inputLine01.trp.input | 1 + .../inputLine02.golden} | 0 .../inputLine02.nocolor.golden} | 0 .../inputLine02.trp} | 0 .../inputLine02.trp.input} | 0 .../print.golden} | 0 .../print.nocolor.golden} | 0 .../printsimple.trp => preamble/print.trp} | 0 .../printString.golden} | 0 .../printString.nocolor.golden} | 0 .../printString.trp} | 0 .../printWithLabels.golden} | 0 .../printWithLabels.nocolor.golden} | 0 .../printWithLabels.trp} | 0 89 files changed, 542 insertions(+), 226 deletions(-) create mode 100644 lib/StdIO.trp create mode 100644 rt/src/builtins/thread.mts delete mode 100644 tests/_unautomated/question.trp create mode 100644 tests/lib/StdIO.golden create mode 100644 tests/lib/StdIO.trp create mode 100644 tests/lib/StdIO.trp.input create mode 100644 tests/rt/neg/core/fwrite.golden create mode 100644 tests/rt/neg/core/fwrite.trp rename tests/rt/neg/{core/printstring01.golden => preamble/printString.golden} (100%) rename tests/rt/neg/{core/printstring01.nocolor.golden => preamble/printString.nocolor.golden} (100%) rename tests/rt/neg/{core/printstring01.trp => preamble/printString.trp} (100%) create mode 100644 tests/rt/pos/core/freadln.golden create mode 100644 tests/rt/pos/core/freadln.trp rename tests/rt/pos/core/{inputline01.trp.input => freadln.trp.input} (100%) rename tests/rt/pos/{ifc/tostringlabeled03.golden => core/fwrite01.golden} (55%) create mode 100644 tests/rt/pos/core/fwrite01.trp rename tests/rt/pos/{ifc/tostringlabeled04.golden => core/fwrite02.golden} (51%) create mode 100644 tests/rt/pos/core/fwrite02.trp create mode 100644 tests/rt/pos/core/toString01.golden create mode 100644 tests/rt/pos/core/toString01.trp create mode 100644 tests/rt/pos/core/toString02.golden create mode 100644 tests/rt/pos/core/toString02.trp create mode 100644 tests/rt/pos/core/toString03.golden create mode 100644 tests/rt/pos/core/toString03.trp create mode 100644 tests/rt/pos/core/toString04.golden create mode 100644 tests/rt/pos/core/toString04.trp create mode 100644 tests/rt/pos/core/toString05.golden create mode 100644 tests/rt/pos/core/toString05.trp create mode 100644 tests/rt/pos/core/toString06.golden create mode 100644 tests/rt/pos/core/toString06.trp create mode 100644 tests/rt/pos/ifc/freadln.golden create mode 100644 tests/rt/pos/ifc/freadln.trp create mode 100644 tests/rt/pos/ifc/freadln.trp.input create mode 100644 tests/rt/pos/ifc/fwrite.golden create mode 100644 tests/rt/pos/ifc/fwrite.trp create mode 100644 tests/rt/pos/ifc/getBL.golden create mode 100644 tests/rt/pos/ifc/getBL.trp delete mode 100644 tests/rt/pos/ifc/getPC.nocolor.golden create mode 100644 tests/rt/pos/ifc/toString.golden create mode 100644 tests/rt/pos/ifc/toString.trp create mode 100644 tests/rt/pos/ifc/toStringL01.golden create mode 100644 tests/rt/pos/ifc/toStringL01.trp rename tests/rt/pos/ifc/{tostringlabeled.golden => toStringL02.golden} (73%) create mode 100644 tests/rt/pos/ifc/toStringL02.trp delete mode 100644 tests/rt/pos/ifc/tostring.golden delete mode 100644 tests/rt/pos/ifc/tostring.nocolor.golden delete mode 100644 tests/rt/pos/ifc/tostring.trp delete mode 100644 tests/rt/pos/ifc/tostringlabeled.nocolor.golden delete mode 100644 tests/rt/pos/ifc/tostringlabeled.trp delete mode 100644 tests/rt/pos/ifc/tostringlabeled02.golden delete mode 100644 tests/rt/pos/ifc/tostringlabeled02.nocolor.golden delete mode 100644 tests/rt/pos/ifc/tostringlabeled02.trp delete mode 100644 tests/rt/pos/ifc/tostringlabeled03.nocolor.golden delete mode 100644 tests/rt/pos/ifc/tostringlabeled03.trp delete mode 100644 tests/rt/pos/ifc/tostringlabeled04.nocolor.golden delete mode 100644 tests/rt/pos/ifc/tostringlabeled04.trp rename tests/rt/pos/{core/inputline01.golden => preamble/inputLine01.golden} (100%) rename tests/rt/pos/{core/inputline01.nocolor.golden => preamble/inputLine01.nocolor.golden} (100%) rename tests/rt/pos/{core/inputline01.trp => preamble/inputLine01.trp} (100%) create mode 100644 tests/rt/pos/preamble/inputLine01.trp.input rename tests/rt/pos/{core/inputline02.golden => preamble/inputLine02.golden} (100%) rename tests/rt/pos/{core/inputline02.nocolor.golden => preamble/inputLine02.nocolor.golden} (100%) rename tests/rt/pos/{core/inputline02.trp => preamble/inputLine02.trp} (100%) rename tests/rt/pos/{core/inputline02.trp.input => preamble/inputLine02.trp.input} (100%) rename tests/rt/pos/{core/printsimple.golden => preamble/print.golden} (100%) rename tests/rt/pos/{core/printsimple.nocolor.golden => preamble/print.nocolor.golden} (100%) rename tests/rt/pos/{core/printsimple.trp => preamble/print.trp} (100%) rename tests/rt/pos/{core/printstring.golden => preamble/printString.golden} (100%) rename tests/rt/pos/{core/printstring.nocolor.golden => preamble/printString.nocolor.golden} (100%) rename tests/rt/pos/{core/printstring.trp => preamble/printString.trp} (100%) rename tests/rt/pos/{core/printwithlabels.golden => preamble/printWithLabels.golden} (100%) rename tests/rt/pos/{core/printwithlabels.nocolor.golden => preamble/printWithLabels.nocolor.golden} (100%) rename tests/rt/pos/{core/printwithlabels.trp => preamble/printWithLabels.trp} (100%) diff --git a/compiler/src/AddAmbientMethods.hs b/compiler/src/AddAmbientMethods.hs index a88d67ac..bb0549c5 100644 --- a/compiler/src/AddAmbientMethods.hs +++ b/compiler/src/AddAmbientMethods.hs @@ -1,47 +1,61 @@ -- 2020-05-17, AA -- HACK --- This module add a number of standard --- ambient methods such as `print` to the --- beginning of the file. This provides some --- backward compatibility with prior test cases --- as well as minimizes some clutter - --- If these methods are unused they are --- eliminated by the optimization passes in --- the further passes. - -module AddAmbientMethods(addAmbientMethods) where +-- +-- This module add a number of standard ambient methods such as `print` to the beginning of the +-- file. This provides some backward compatibility with prior test cases as well as minimizes some +-- clutter. +-- +-- If these methods are unused they are eliminated by the optimization passes in the further passes. + +-- TODO +-- +-- Move this into a '.trp' file of the form +-- +-- ``` +-- let fun print x = fwrite (stdout authority, (toString x) ^"\n") +-- ... +-- in () end +-- ``` +-- +-- Which, similar to below, after parsing has the `dummy` value replaced by the actual program. This +-- preamble can then be specified at compile-time. + +module AddAmbientMethods(addAmbientMethods) where import Basics -import Direct +import Direct import TroupePositionInfo -printDecl :: FunDecl -printDecl = FunDecl "print" +printStringDecl :: FunDecl +printStringDecl = FunDecl "printString" [Lambda [VarPattern "x"] $ - Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos] - (App (Var "fprintln") [Tuple [Var "out", Var "x"]]) + Let [ ValDecl (VarPattern "fd") (App (Var "stdout") [Var "authority"]) NoPos + , ValDecl (VarPattern "x'") (Bin Concat (Var "x") (Lit $ LString "\\n")) NoPos + ] + (App (Var "fwrite") [Tuple [Var "fd", Var "x'"]]) ] NoPos -printWithLabelsDecl :: FunDecl -printWithLabelsDecl = FunDecl "printWithLabels" - [Lambda [VarPattern "x"] $ - Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos] - (App (Var "fprintlnWithLabels") [Tuple [Var "out", Var "x"]]) +printDecl :: FunDecl +printDecl = FunDecl "print" + [Lambda [ VarPattern "x" ] $ + (App (Var "printString") [App (Var "toString") [Var "x"]]) ] NoPos - -printStringDecl :: FunDecl -printStringDecl = FunDecl "printString" - [Lambda [VarPattern "x"] $ - Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos] - (App (Var "fwrite") [Tuple [Var "out", Bin Concat (Var "x") (Lit (LString "\\n"))]]) +printWithLabelsDecl :: FunDecl +printWithLabelsDecl = FunDecl "printWithLabels" + [Lambda [ VarPattern "x" ] $ + (App (Var "printString") [App (Var "toStringL") [Var "x"]]) ] NoPos +inputLineDecl :: FunDecl +inputLineDecl = FunDecl "inputLine" + [Lambda [ VarPattern "_" ] $ + Let [ValDecl (VarPattern "fd") (App (Var "stdin") [Var "authority"]) NoPos] + (App (Var "freadln") [App (Var "stdin") [Var "authority"]]) + ] NoPos - -addAmbientMethods :: Prog -> Prog -addAmbientMethods (Prog imports atoms t) = - let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t - in Prog imports atoms t' \ No newline at end of file +addAmbientMethods :: Prog -> Prog +addAmbientMethods (Prog imports atoms t) = + let t' = Let [FunDecs [printStringDecl,printDecl,printWithLabelsDecl,inputLineDecl]] t + in Prog imports atoms t' diff --git a/compiler/src/IR.hs b/compiler/src/IR.hs index c4836153..d155d5cb 100644 --- a/compiler/src/IR.hs +++ b/compiler/src/IR.hs @@ -261,7 +261,7 @@ instance WellFormedIRCheck IRExpr where -- code over wire. Such malformed code would result -- in a JS output returning a runtime error (which should -- generally be avoided) - if fname `elem`[ + if fname `elem`[ "$$authorityarg" , "adv" , "ladv" @@ -285,16 +285,13 @@ instance WellFormedIRCheck IRExpr where , "endorse" , "floor" , "flowsTo" - , "fprintln" - , "fprintlnWithLabels" - , "fwrite" + , "freadln" + , "fwrite" , "getTime" , "getType" , "getNanoTime" - , "getStdout" , "_getSystemProcess" , "guard" - , "inputLine" , "intToString" , "listToTuple" , "lowermbox" @@ -305,13 +302,13 @@ instance WellFormedIRCheck IRExpr where , "newlabel" , "node" , "_pc" + , "_bl" , "pcpop" , "peek" , "pinipush" , "pinipushto" , "pinipop" , "pcpush" - , "question" , "raisembox" , "raiseTrust" , "random" @@ -333,6 +330,9 @@ instance WellFormedIRCheck IRExpr where , "spawn" , "sqrt" , "substring" + , "stdin" + , "stdout" + , "stderr" , "stringToInt" , "strlen" , "restore" diff --git a/lib/Makefile b/lib/Makefile index c4a03d33..7b7391dd 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -6,6 +6,7 @@ build: # No dependencies $(COMPILER) ./Number.trp -l $(COMPILER) ./List.trp -l + $(COMPILER) ./StdIO.trp -l $(COMPILER) ./ThreadUtil.trp -l # Dependency on `List` diff --git a/lib/README.md b/lib/README.md index b9d9ac24..d611ef5b 100644 --- a/lib/README.md +++ b/lib/README.md @@ -13,6 +13,7 @@ reviewed rigorously rather than depend on the monitor. - `List` : Operations for lists, i.e. `[]` and `x::xs`. - `ListPair` : Operations for list of pairs, i.e. `(x,y)::xs`. - `Number` : Operations for numbers, i.e. integer and floats. +- `StdIO` : Standard input and output. - `StencilVector` : Memory-efficient implementation of small (sparse) arrays. - `String` : Operations for strings - `ThreadUtil` : Additional functions for thread management. diff --git a/lib/StdIO.trp b/lib/StdIO.trp new file mode 100644 index 00000000..b8fa5663 --- /dev/null +++ b/lib/StdIO.trp @@ -0,0 +1,121 @@ +let (** OS.IO module with file reading and writing. + * + * TODO: For now, this is only used internally for the StdIO library. But, when file reading and + * writing is properly added, then this needs to be moved to its own module. *) + fun OS_IO authority = + let (*--- File Reading ---*) + (* TODO: Sub-line input access. *) + + (** Obtain the next line from `fd`. + * + * This is merely reexposing the `freadln` language builtin. + **) + fun readln fd = + freadln fd + + (** Similar to `readln` but ensures the blocking label is not raised. *) + fun readln' fd = + let pini authority + val ln = readln fd + in ln end + + (** Similar to `readln'` but declassifies what is read to the given level. *) + fun readlnAtLevel fd level = + declassify (readln' fd, authority, level) + + (*--- File Writing ---*) + fun _write fd str = fwrite (fd, str) + + (** Write `x` to the given file descriptor. *) + fun write fd x = case getType x of "string" => _write fd x + | _ => _write fd (toString x) + + (** Write `x` and its security label(s) to the given file descriptor. *) + fun writeL fd x = _write fd (toStringL x) + + (** Write `x` and a newline to the given file descriptor. *) + fun writeln fd x = (write fd x; _write fd "\n") + + (** Write `x`, its security label(s), and a newline to the given file descriptor. *) + fun writelnL fd x = (writeL fd x; _write fd "\n") + in + { readln + , readln' + , readlnAtLevel + , write + , writeL + , writeln + , writelnL + } + end + + (** Standard input and output handling. *) + fun StdIO authority = + let val OS = OS_IO authority + + (*--- STD File Descriptors ---*) + + (** Capability for standard input. *) + val stdin = stdin authority + + (** Capability for standard output. *) + val stdout = stdout authority + + (** Capability for standard error. *) + val stderr = stderr authority + + (*--- Input/Output ---*) + + (** Write the given `question` to `stdout` and returns the answer provided from + * `stdin`. *) + fun input question = + (OS.write stdout question; OS.readln stdin) + + (** Similar to `input` but does not raise the blocking label. *) + fun input' question = + (OS.write stdout question; OS.readln' stdin) + + (** Similar to `input'` but also declassifies the result. *) + fun inputAtLevel question level = + (OS.write stdout question; OS.readlnAtLevel stdin level) + + (*--- Submodule(s) ---*) + + (** Reading from `stdin`. *) + val In = + { readln = fn () => OS.readln stdin + , readln' = fn () => OS.readln' stdin + , readlnAtLevel = fn l => OS.readlnAtLevel stdin l + } + + (** Printing to `stdout`. *) + val Out = + { print = OS.write stdout + , println = OS.writeln stdout + , printL = OS.writeL stdout + , printlnL = OS.writelnL stdout + } + + (** Printing to `stderr`. *) + val Err = + { print = OS.write stderr + , println = OS.writeln stderr + , printL = OS.writeL stderr + , printlnL = OS.writelnL stderr + } + + in (*--- Module(s) ---*) + { stdin + , In + , stdout + , Out + , stderr + , Err + , input + , input' + , inputAtLevel + } + end + +in [ ("StdIO", StdIO) ] +end diff --git a/lib/Unit.trp b/lib/Unit.trp index f4b49eba..fdee7343 100644 --- a/lib/Unit.trp +++ b/lib/Unit.trp @@ -6,11 +6,11 @@ let fun print auth indent str = let fun makeIndent 0 = "" | makeIndent i = " " ^ (makeIndent (i-1)) - in fwrite ((getStdout auth), (makeIndent indent) ^ str) + in fwrite ((stdout auth), (makeIndent indent) ^ str) end - fun printCR auth = fwrite ((getStdout auth), "\r") - fun printNL auth = fwrite ((getStdout auth), "\n") + fun printCR auth = fwrite ((stdout auth), "\r") + fun printNL auth = fwrite ((stdout auth), "\n") (* TODO (Issue #55) Move colours into helper functions. *) val testStr = "\x1b[33m" ^ "[ TEST ]" ^ "\x1b[0m" ^ " it " diff --git a/rt/src/Asserts.mts b/rt/src/Asserts.mts index 88ed0081..7ff90323 100644 --- a/rt/src/Asserts.mts +++ b/rt/src/Asserts.mts @@ -34,6 +34,7 @@ function __stringRep (v) { } let err = x => _thread().threadError(x) + export function assertIsAtom (x: any) { _thread().raiseBlockingThreadLev(x.tlev) if (x.val._troupeType != TroupeType.ATOM ) { @@ -209,7 +210,6 @@ export function assertIsProcessId(x: any) { } } - export function assertIsCapability(x: any) { _thread().raiseBlockingThreadLev(x.tlev); if (!(x.val instanceof Capability)) { @@ -229,6 +229,7 @@ export function rawAssertIsLevel (x:any) { err("value " + __stringRep(x) + " is not a level"); } } + export function assertIsRootAuthority(x: any) { let isTop = actsFor(x.val.authorityLevel, levels.ROOT); if (!isTop) { diff --git a/rt/src/UserRuntime.mts b/rt/src/UserRuntime.mts index d5668b9e..38d2faba 100644 --- a/rt/src/UserRuntime.mts +++ b/rt/src/UserRuntime.mts @@ -19,6 +19,7 @@ import { BuiltinToString } from './builtins/toString.mjs' import { BuiltinSend } from './builtins/send.mjs' import { BuiltinSpawn } from './builtins/spawn.mjs' import { BuiltinReceive } from './builtins/receive.mjs' +import { BuiltinThread } from './builtins/thread.mjs' import { BuiltinAttenuate } from './builtins/attenuate.mjs' import { BuiltinRegistry } from './builtins/whereis.mjs' import { BuiltinDeclassify } from './builtins/declassify.mjs' @@ -46,6 +47,7 @@ export const UserRuntime = BuiltinRegistry( BuiltinAttenuate( BuiltSpawnSendReceive( + BuiltinThread( BuiltinStringToInt( BuiltinToString( BuiltinGetTime( @@ -64,5 +66,5 @@ export const UserRuntime = BuiltinMath( BuiltinRecordReflection( BuiltinTypeInformation( - BuiltinStdIo(UserRuntimeZero) - ))))))))))))))))))))))))))))) + BuiltinStdIo(UserRuntimeZero) + )))))))))))))))))))))))))))))) diff --git a/rt/src/builtins/receive.mts b/rt/src/builtins/receive.mts index 0bbbc459..21ea4b6e 100644 --- a/rt/src/builtins/receive.mts +++ b/rt/src/builtins/receive.mts @@ -131,19 +131,6 @@ export function BuiltinReceive>(Base: return this.runtime.__mbox.consume ( consume_l, i.val, lowb.val, highb.val ) }) - _blockThread = mkBase ((arg) => { - assertIsUnit(arg) - this.runtime.__sched.blockThread(this.runtime.__sched.__currentThread); - return null; - }) - - _pc = mkBase ((arg) => { - assertIsUnit (arg) - return this.runtime.ret ( - new LVal (this.runtime.$t.pc, this.runtime.$t.pc, BOT)) - }) - - guard = mkBase (arg => { assertIsNTuple(arg, 3) let f = arg.val[0] diff --git a/rt/src/builtins/stdio.mts b/rt/src/builtins/stdio.mts index d46890e7..0d75e93c 100644 --- a/rt/src/builtins/stdio.mts +++ b/rt/src/builtins/stdio.mts @@ -1,36 +1,39 @@ import { UserRuntimeZero, Constructor, mkBase } from './UserRuntimeZero.mjs' import { LocalObject } from '../LocalObject.mjs' -import * as levels from '../Level.mjs' +import { mkV1Level, flowsTo, ROOT } from '../Level.mjs' import { mkLevel } from '../Level.mjs' import { assertIsAuthority, assertIsRootAuthority, assertIsNTuple, assertIsLocalObject, assertIsString, assertIsUnit, assertNormalState } from '../Asserts.mjs' import { __unit } from '../UnitVal.mjs'; import { getCliArgs, TroupeCliArg } from '../TroupeCliArgs.mjs'; const argv = getCliArgs(); -const flowsTo = levels.flowsTo; +import * as rl from 'node:readline'; -import * as _rl from 'node:readline'; - - -const readline = _rl.createInterface({ - input: process.stdin, - output: process.stdout -}) +const stdio_level = argv[TroupeCliArg.Stdiolev] + ? mkV1Level (argv[TroupeCliArg.Stdiolev]) + : ROOT +/** Buffer of input lines that have been provided but not consumed. */ const lineBuffer = []; -const readlineCallbacks = [] -const __stdio_lev = argv[TroupeCliArg.Stdiolev] ? levels.mkV1Level (argv[TroupeCliArg.Stdiolev]): levels.ROOT +/** Callbacks for awakening Troupe threads currently blocked due to them waiting for inputs. */ +const readlineCallbacks = [] +/** For every new line, update either the buffer or notify a thread. */ function lineListener(input) { - if (readlineCallbacks.length > 0) { - let cb = readlineCallbacks.shift(); - cb(input); - } else { + if (readlineCallbacks.length === 0) { lineBuffer.push(input); + } else { + const cb = readlineCallbacks.shift(); + cb(input); } } +/** Node's readline interface */ +const readline = rl.createInterface({ + input: process.stdin, + output: process.stdout +}) readline.on('line', lineListener) export function closeReadline() { @@ -39,84 +42,95 @@ export function closeReadline() { export function BuiltinStdIo>(Base: TBase) { return class extends Base { - getStdout = mkBase((arg) => { + stdin = mkBase((arg) => { assertIsAuthority(arg) - let sufficentAuthority = flowsTo(__stdio_lev, arg.val.authorityLevel) - if (sufficentAuthority) { - let obj = new LocalObject(process.stdout); - return this.runtime.ret(this.mkVal(obj)) - } else { + + const sufficentAuthority = flowsTo(stdio_level, arg.val.authorityLevel) + if (!sufficentAuthority) { + this.runtime.$t.threadError + (`Not sufficient authority for stdIn\n` + + ` | Provided authority level ${arg.val.authorityLevel.stringRep()}\n` + + ` | Required authority level ${stdio_level.stringRep()}`); + return; + } + + return this.runtime.ret(this.mkVal(new LocalObject(process.stdin))) + }, "stdin"); + + stdout = mkBase((arg) => { + assertIsAuthority(arg) + + const sufficentAuthority = flowsTo(stdio_level, arg.val.authorityLevel) + if (!sufficentAuthority) { this.runtime.$t.threadError - (`Not sufficient authority in getStdout\n` + + (`Not sufficient authority for stdOut\n` + ` | Provided authority level ${arg.val.authorityLevel.stringRep()}\n` + - ` | Required authority level ${__stdio_lev.stringRep()}`) + ` | Required authority level ${stdio_level.stringRep()}`) + return; } - - }) - fprintln = mkBase((arg) => { - assertNormalState("fprintln") - assertIsNTuple(arg, 2); - assertIsLocalObject(arg.val[0]); + return this.runtime.ret(this.mkVal(new LocalObject(process.stdout))); + }, "stdout"); - let out = arg.val[0].val._value; - out.write(arg.val[1].stringRep(true) + "\n"); - return this.runtime.ret(__unit); - }); + stderr = mkBase((arg) => { + assertIsAuthority(arg) - fprintlnWithLabels = mkBase((arg) => { - assertNormalState("fprintlnWithLabels") - assertIsNTuple(arg, 2); - assertIsLocalObject(arg.val[0]); - let out = arg.val[0].val._value; - out.write(this.runtime.$t.mkCopy(arg.val[1]).stringRep(false) + "\n"); - // out.write((arg.val[1]).stringRep(false) + "\n"); - return this.runtime.ret(__unit); - }); + const sufficentAuthority = flowsTo(stdio_level, arg.val.authorityLevel) + if (!sufficentAuthority) { + this.runtime.$t.threadError + (`Not sufficient authority for stdErr\n` + + ` | Provided authority level ${arg.val.authorityLevel.stringRep()}\n` + + ` | Required authority level ${stdio_level.stringRep()}`) + return; + } + + return this.runtime.ret(this.mkVal(new LocalObject(process.stderr))); + }, "stderr"); + + freadln = mkBase((arg) => { + assertNormalState("freadLine") + + assertIsLocalObject(arg); + const fd = arg.val._value; + if (fd !== process.stdin) { + this.runtime.$t + .threadError(`value ${fd.stringRep()} is not an input descriptor`); + } + + this.runtime.$t.raiseBlockingThreadLev(stdio_level) + + // If input already has been provided, then proceed immediately. + if (lineBuffer.length > 0) { + let s = lineBuffer.shift(); + let r = this.runtime.$t.mkValWithLev(s, stdio_level); + return this.runtime.$t.returnImmediateLValue(r); + } + + // Otherwise, wait for input to arrive. + readlineCallbacks.push((s) => { + let r = this.runtime.$t.mkValWithLev(s, stdio_level) + this.runtime.$t.returnSuspended(r) + this.runtime.__sched.scheduleThread(this.runtime.$t); + this.runtime.__sched.resumeLoopAsync() + }); + }, "freadln"); fwrite = mkBase((arg) => { assertNormalState("fwrite") assertIsNTuple(arg, 2); + assertIsLocalObject(arg.val[0]); - assertIsString(arg.val[1]); - let out = arg.val[0].val._value; - out.write(arg.val[1].val); - return this.runtime.ret(__unit); - }, "fwrite"); - inputLine = mkBase((arg) => { - assertNormalState("inputLine") - assertIsUnit(arg) - let theThread = this.runtime.$t; - theThread.raiseBlockingThreadLev(__stdio_lev) - if (lineBuffer.length > 0) { - let s = lineBuffer.shift(); - let r = theThread.mkValWithLev(s, __stdio_lev); - return theThread.returnImmediateLValue(r); - } else { - readlineCallbacks.push((s) => { - let r = theThread.mkValWithLev(s, __stdio_lev) - theThread.returnSuspended(r) - this.runtime.__sched.scheduleThread(theThread); - this.runtime.__sched.resumeLoopAsync() - }) + const fd = arg.val[0].val._value; + if (fd !== process.stdout && fd !== process.stderr) { + this.runtime.$t + .threadError(`value ${fd.stringRep()} is not an output descriptor`); } - }, "inputLine") - - rt_question = mkBase((arg) => { - assertNormalState("rt_question") - readline.removeListener('line', lineListener); - let theThread = this.runtime.$t; - assertIsString(arg); - theThread.raiseBlockingThreadLev(__stdio_lev) - readline.question(arg.val, (s) => { - let r = theThread.mkValWithLev(s, __stdio_lev) - theThread.returnSuspended(r) - this.runtime.__sched.scheduleThread(theThread); - this.runtime.__sched.resumeLoopAsync() - readline.on('line', lineListener) - }) - }, "question") + assertIsString(arg.val[1]); + + fd.write(arg.val[1].val); + return this.runtime.ret(__unit); + }, "fwrite"); } -} \ No newline at end of file +} diff --git a/rt/src/builtins/thread.mts b/rt/src/builtins/thread.mts new file mode 100644 index 00000000..015280fb --- /dev/null +++ b/rt/src/builtins/thread.mts @@ -0,0 +1,26 @@ +import { UserRuntimeZero, Constructor, mkBase } from './UserRuntimeZero.mjs' +import { assertIsUnit } from '../Asserts.mjs' +import { BOT } from '../Level.mjs'; +import { LVal } from '../Lval.mjs'; + +export function BuiltinThread>(Base: TBase) { + return class extends Base { + _blockThread = mkBase ((arg) => { + assertIsUnit(arg) + this.runtime.__sched.blockThread(this.runtime.__sched.__currentThread); + return null; + }) + + _pc = mkBase ((arg) => { + assertIsUnit (arg) + return this.runtime.ret ( + new LVal (this.runtime.$t.pc, this.runtime.$t.pc, BOT)) + }); + + _bl = mkBase ((arg) => { + assertIsUnit (arg) + return this.runtime.ret ( + new LVal (this.runtime.$t.bl, this.runtime.$t.bl, BOT)) + }); + }; +}; diff --git a/tests/_unautomated/question.trp b/tests/_unautomated/question.trp deleted file mode 100644 index 4e84666f..00000000 --- a/tests/_unautomated/question.trp +++ /dev/null @@ -1,3 +0,0 @@ -let val x = question "Introduce yourself" -in print ( "Welcome" ^ x ) -end diff --git a/tests/lib/Number.golden b/tests/lib/Number.golden index f1ffff2c..45ccabb5 100644 --- a/tests/lib/Number.golden +++ b/tests/lib/Number.golden @@ -1,8 +1,10 @@ -2025-09-19T11:39:50.589Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +2025-10-23T10:29:01.219Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. begin Number begin maxInt / minInt - [ TEST ] it maxInt++ = maxInt [ PASS ] it maxInt++ = maxInt - [ TEST ] it minInt-- = minInt [ PASS ] it minInt-- = minInt + [ TEST ] it maxInt++ != maxInt [ PASS ] it maxInt++ != maxInt + [ TEST ] it minInt-- != minInt [ PASS ] it minInt-- != minInt + [ TEST ] it maxInt+2 == maxInt+1 [ PASS ] it maxInt+2 == maxInt+1 + [ TEST ] it minInt-2 == minInt+1 [ PASS ] it minInt-2 == minInt+1 end  begin abs [ TEST ] it keeps 0 as is [ PASS ] it keeps 0 as is @@ -100,6 +102,6 @@ end  end  -Total: 72 -Passes: 72 +Total: 74 +Passes: 74 >>> Main thread finished with value: true@{}%{} diff --git a/tests/lib/StdIO.golden b/tests/lib/StdIO.golden new file mode 100644 index 00000000..8a8022ed --- /dev/null +++ b/tests/lib/StdIO.golden @@ -0,0 +1,4 @@ +2025-10-23T17:09:51.371Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +Hello, Alice @ stdout! +Runtime error in thread 7a514c9e-2862-4175-b00d-d56af61e60a0@{}%{} +>> value "PC: " is not a function diff --git a/tests/lib/StdIO.trp b/tests/lib/StdIO.trp new file mode 100644 index 00000000..838701f6 --- /dev/null +++ b/tests/lib/StdIO.trp @@ -0,0 +1,125 @@ +import StdIO + +let val StdIO = StdIO authority + + fun hello name = + let pini authority + val _ = StdIO.Out.print "Hello, " + val _ = StdIO.Out.printL name + val _ = StdIO.Out.print "\n" + in () end + + fun printThread () = + let val pcStr = toString (_pc ()) + val blStr = toString (_bl ()) + in StdIO.Out.println ("PC: " pcStr ^ ", BL: " ^ blStr) + end + + (* _____________________________________________________________________________________________ + * StdIO.Out + *) + val _ = let pini authority + val _ = StdIO.Out.print ("Hello, Alice @ stdout!\n" raisedTo `{alice}`) + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Out.println ("Hello, Alice @ stdout... again!" raisedTo `{alice}`) + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Out.printL ("Hello, Bob @ stdout!" raisedTo `{bob}`) + val _ = StdIO.Out.print "\n" + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Out.printlnL ("Hello, Eve @ stdout!" raisedTo `{eve}`) + + val _ = printThread () + in () end + + (* _____________________________________________________________________________________________ + * StdIO.Err + *) + val _ = let pini authority + val _ = StdIO.Err.print ("Hello, Alice @ stderr!\n" raisedTo `{alice}`) + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Err.println ("Hello, Alice @ stderr... again!" raisedTo `{alice}`) + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Err.printL ("Hello, Bob @ stderr!" raisedTo `{bob}`) + val _ = StdIO.Err.print "\n" + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Err.printlnL ("Hello, Eve @ stderr!" raisedTo `{eve}`) + + val _ = printThread () + in () end + + (* _____________________________________________________________________________________________ + * StdIO.In and also StdIO.Out some more + *) + val _ = let pini authority + val _ = StdIO.Out.print "What is your name: " + val n = StdIO.In.readln () + val _ = hello n + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Out.print "What is your name: " + val n = StdIO.In.readln' () + val _ = hello n + + val _ = printThread () + in () end + + val _ = let pini authority + val _ = StdIO.Out.print "What is your name: " + val n = StdIO.In.readlnAtLevel `{}` + val _ = hello n + + val _ = printThread () + in () end + + (* _____________________________________________________________________________________________ + * input* + *) + val _ = let pini authority + val n = StdIO.input "What is your name: " + val _ = hello n + + val _ = printThread () + in () end + + val _ = let pini authority + val n = StdIO.input' "What is your name: " + val _ = hello n + + val _ = printThread () + in () end + + val _ = let pini authority + val n = StdIO.inputAtLevel "What is your name: " `{}` + val _ = hello n + + val _ = printThread () + in () end +in () +end diff --git a/tests/lib/StdIO.trp.input b/tests/lib/StdIO.trp.input new file mode 100644 index 00000000..d115362f --- /dev/null +++ b/tests/lib/StdIO.trp.input @@ -0,0 +1,6 @@ +Alice +Bob +Charlie +Alice +Bob +Charlie diff --git a/tests/rt/neg/core/fwrite.golden b/tests/rt/neg/core/fwrite.golden new file mode 100644 index 00000000..5943639d --- /dev/null +++ b/tests/rt/neg/core/fwrite.golden @@ -0,0 +1,3 @@ +2025-10-23T10:48:07.125Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +Runtime error in thread 96f6e7df-1c4b-40be-8c0a-f0bbf23d0565@{}%{} +>> value LocalObject@{}%{} is not a 2-tuple diff --git a/tests/rt/neg/core/fwrite.trp b/tests/rt/neg/core/fwrite.trp new file mode 100644 index 00000000..e9e3eae0 --- /dev/null +++ b/tests/rt/neg/core/fwrite.trp @@ -0,0 +1 @@ +fwrite (stdout authority) 42 \ No newline at end of file diff --git a/tests/rt/neg/core/printstring01.golden b/tests/rt/neg/preamble/printString.golden similarity index 100% rename from tests/rt/neg/core/printstring01.golden rename to tests/rt/neg/preamble/printString.golden diff --git a/tests/rt/neg/core/printstring01.nocolor.golden b/tests/rt/neg/preamble/printString.nocolor.golden similarity index 100% rename from tests/rt/neg/core/printstring01.nocolor.golden rename to tests/rt/neg/preamble/printString.nocolor.golden diff --git a/tests/rt/neg/core/printstring01.trp b/tests/rt/neg/preamble/printString.trp similarity index 100% rename from tests/rt/neg/core/printstring01.trp rename to tests/rt/neg/preamble/printString.trp diff --git a/tests/rt/pos/core/freadln.golden b/tests/rt/pos/core/freadln.golden new file mode 100644 index 00000000..e5e46ca9 --- /dev/null +++ b/tests/rt/pos/core/freadln.golden @@ -0,0 +1,3 @@ +2025-10-23T10:52:38.750Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +What is your name? Hello Alice +>>> Main thread finished with value: ()@{#ROOT}%{#ROOT} diff --git a/tests/rt/pos/core/freadln.trp b/tests/rt/pos/core/freadln.trp new file mode 100644 index 00000000..1ee94459 --- /dev/null +++ b/tests/rt/pos/core/freadln.trp @@ -0,0 +1,5 @@ +let val _ = fwrite (stdout authority, "What is your name? ") + val name = freadln (stdin authority) + val _ = fwrite (stdout authority, "Hello " ^ name ^ "\n") +in () +end diff --git a/tests/rt/pos/core/inputline01.trp.input b/tests/rt/pos/core/freadln.trp.input similarity index 100% rename from tests/rt/pos/core/inputline01.trp.input rename to tests/rt/pos/core/freadln.trp.input diff --git a/tests/rt/pos/ifc/tostringlabeled03.golden b/tests/rt/pos/core/fwrite01.golden similarity index 55% rename from tests/rt/pos/ifc/tostringlabeled03.golden rename to tests/rt/pos/core/fwrite01.golden index 7c8d78ba..7d48942d 100644 --- a/tests/rt/pos/ifc/tostringlabeled03.golden +++ b/tests/rt/pos/core/fwrite01.golden @@ -1,3 +1,3 @@ -2019-03-07T14:31:36.595Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -"(42@{alice}%{}, 11@{bob}%{})@{}%{}" +2025-10-23T11:03:47.171Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +42 >>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/fwrite01.trp b/tests/rt/pos/core/fwrite01.trp new file mode 100644 index 00000000..f931b91c --- /dev/null +++ b/tests/rt/pos/core/fwrite01.trp @@ -0,0 +1 @@ +fwrite (stdout authority, "42\n") diff --git a/tests/rt/pos/ifc/tostringlabeled04.golden b/tests/rt/pos/core/fwrite02.golden similarity index 51% rename from tests/rt/pos/ifc/tostringlabeled04.golden rename to tests/rt/pos/core/fwrite02.golden index 40aca23f..33398f2e 100644 --- a/tests/rt/pos/ifc/tostringlabeled04.golden +++ b/tests/rt/pos/core/fwrite02.golden @@ -1,3 +1,2 @@ -2019-03-07T14:26:45.007Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -"(42@{alice}%{}, 11@{bob}%{})@{}%{}"@{alice,bob}%{} +2025-10-23T11:03:46.935Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. >>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/fwrite02.trp b/tests/rt/pos/core/fwrite02.trp new file mode 100644 index 00000000..971709c7 --- /dev/null +++ b/tests/rt/pos/core/fwrite02.trp @@ -0,0 +1 @@ +fwrite (stderr authority, "42\n") diff --git a/tests/rt/pos/core/toString01.golden b/tests/rt/pos/core/toString01.golden new file mode 100644 index 00000000..d94854d5 --- /dev/null +++ b/tests/rt/pos/core/toString01.golden @@ -0,0 +1,2 @@ +2025-10-23T10:47:48.841Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +42>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/toString01.trp b/tests/rt/pos/core/toString01.trp new file mode 100644 index 00000000..a8bc18f2 --- /dev/null +++ b/tests/rt/pos/core/toString01.trp @@ -0,0 +1 @@ +fwrite (stdout authority, toString 42) diff --git a/tests/rt/pos/core/toString02.golden b/tests/rt/pos/core/toString02.golden new file mode 100644 index 00000000..263acbc0 --- /dev/null +++ b/tests/rt/pos/core/toString02.golden @@ -0,0 +1,2 @@ +2025-10-23T10:47:48.721Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +"42">>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/toString02.trp b/tests/rt/pos/core/toString02.trp new file mode 100644 index 00000000..b0ba0635 --- /dev/null +++ b/tests/rt/pos/core/toString02.trp @@ -0,0 +1 @@ +fwrite (stdout authority, toString "42") diff --git a/tests/rt/pos/core/toString03.golden b/tests/rt/pos/core/toString03.golden new file mode 100644 index 00000000..e6eefc67 --- /dev/null +++ b/tests/rt/pos/core/toString03.golden @@ -0,0 +1,2 @@ +2025-10-23T10:47:48.848Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +{x=42}>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/toString03.trp b/tests/rt/pos/core/toString03.trp new file mode 100644 index 00000000..a4889d6b --- /dev/null +++ b/tests/rt/pos/core/toString03.trp @@ -0,0 +1 @@ +fwrite (stdout authority, toString { x = 42 }) diff --git a/tests/rt/pos/core/toString04.golden b/tests/rt/pos/core/toString04.golden new file mode 100644 index 00000000..d6075dae --- /dev/null +++ b/tests/rt/pos/core/toString04.golden @@ -0,0 +1,2 @@ +2025-10-23T10:47:49.072Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +fn => ..>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/toString04.trp b/tests/rt/pos/core/toString04.trp new file mode 100644 index 00000000..10d262b7 --- /dev/null +++ b/tests/rt/pos/core/toString04.trp @@ -0,0 +1 @@ +fwrite (stdout authority, toString (fn () => 42)) diff --git a/tests/rt/pos/core/toString05.golden b/tests/rt/pos/core/toString05.golden new file mode 100644 index 00000000..f12a98b3 --- /dev/null +++ b/tests/rt/pos/core/toString05.golden @@ -0,0 +1,2 @@ +2025-10-23T10:47:49.212Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +[42]>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/toString05.trp b/tests/rt/pos/core/toString05.trp new file mode 100644 index 00000000..9825a65e --- /dev/null +++ b/tests/rt/pos/core/toString05.trp @@ -0,0 +1 @@ +fwrite (stdout authority, toString [42]) diff --git a/tests/rt/pos/core/toString06.golden b/tests/rt/pos/core/toString06.golden new file mode 100644 index 00000000..7e66bfa0 --- /dev/null +++ b/tests/rt/pos/core/toString06.golden @@ -0,0 +1,2 @@ +2025-10-23T10:47:49.340Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +()>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/core/toString06.trp b/tests/rt/pos/core/toString06.trp new file mode 100644 index 00000000..496c306f --- /dev/null +++ b/tests/rt/pos/core/toString06.trp @@ -0,0 +1 @@ +fwrite (stdout authority, toString ()) diff --git a/tests/rt/pos/ifc/freadln.golden b/tests/rt/pos/ifc/freadln.golden new file mode 100644 index 00000000..849197da --- /dev/null +++ b/tests/rt/pos/ifc/freadln.golden @@ -0,0 +1,4 @@ +2025-10-23T11:12:20.156Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +{} +{} +>>> Main thread finished with value: ()@{#ROOT}%{#ROOT} diff --git a/tests/rt/pos/ifc/freadln.trp b/tests/rt/pos/ifc/freadln.trp new file mode 100644 index 00000000..acf2a566 --- /dev/null +++ b/tests/rt/pos/ifc/freadln.trp @@ -0,0 +1,5 @@ +let val _ = fwrite (stdout authority, (toString (_pc ())) ^ "\n") + val _ = freadln (stdin authority) + val _ = fwrite (stdout authority, (toString (_pc ())) ^ "\n") +in () end + diff --git a/tests/rt/pos/ifc/freadln.trp.input b/tests/rt/pos/ifc/freadln.trp.input new file mode 100644 index 00000000..1d7fcc4a --- /dev/null +++ b/tests/rt/pos/ifc/freadln.trp.input @@ -0,0 +1 @@ +Hello, program! \ No newline at end of file diff --git a/tests/rt/pos/ifc/fwrite.golden b/tests/rt/pos/ifc/fwrite.golden new file mode 100644 index 00000000..0c45f9ad --- /dev/null +++ b/tests/rt/pos/ifc/fwrite.golden @@ -0,0 +1,5 @@ +2025-10-23T11:12:19.952Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +{} +Hello, World! +{} +>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/fwrite.trp b/tests/rt/pos/ifc/fwrite.trp new file mode 100644 index 00000000..eaa889a0 --- /dev/null +++ b/tests/rt/pos/ifc/fwrite.trp @@ -0,0 +1,5 @@ +let val _ = fwrite (stdout authority, (toString (_pc ())) ^ "\n") + val _ = fwrite (stdout authority, "Hello, World!\n") + val _ = fwrite (stdout authority, (toString (_pc ())) ^ "\n") +in () end + diff --git a/tests/rt/pos/ifc/getBL.golden b/tests/rt/pos/ifc/getBL.golden new file mode 100644 index 00000000..8513c686 --- /dev/null +++ b/tests/rt/pos/ifc/getBL.golden @@ -0,0 +1,2 @@ +2025-10-23T13:35:31.723Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: {bob}@{bob}%{bob} diff --git a/tests/rt/pos/ifc/getBL.trp b/tests/rt/pos/ifc/getBL.trp new file mode 100644 index 00000000..df6ba143 --- /dev/null +++ b/tests/rt/pos/ifc/getBL.trp @@ -0,0 +1,4 @@ +let val x = if true raisedTo `{bob}` then 21 else "..." + val y = x + (21 raisedTo `{alice}`) +in _bl () +end diff --git a/tests/rt/pos/ifc/getPC.golden b/tests/rt/pos/ifc/getPC.golden index c751a4b7..0841f2d3 100644 --- a/tests/rt/pos/ifc/getPC.golden +++ b/tests/rt/pos/ifc/getPC.golden @@ -1,3 +1,2 @@ -2021-08-09T20:19:14.846Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -{secret}@{secret}%{} ->>> Main thread finished with value: ()@{secret}%{secret} +2025-10-23T13:35:25.385Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: {secret}@{secret}%{secret} diff --git a/tests/rt/pos/ifc/getPC.nocolor.golden b/tests/rt/pos/ifc/getPC.nocolor.golden deleted file mode 100644 index 674ebd78..00000000 --- a/tests/rt/pos/ifc/getPC.nocolor.golden +++ /dev/null @@ -1,3 +0,0 @@ -2025-06-24T21:28:34.520Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -{secret}@{secret}%{} ->>> Main thread finished with value: ()@{secret}%{secret} diff --git a/tests/rt/pos/ifc/getPC.trp b/tests/rt/pos/ifc/getPC.trp index e552cbea..1a8db1e2 100644 --- a/tests/rt/pos/ifc/getPC.trp +++ b/tests/rt/pos/ifc/getPC.trp @@ -1,3 +1 @@ -let val x = if true raisedTo `{secret}` then _pc () else 1 - in printWithLabels x - end \ No newline at end of file +if true raisedTo `{secret}` then _pc () else 1 diff --git a/tests/rt/pos/ifc/inputpini.trp b/tests/rt/pos/ifc/inputpini.trp index 5583033b..e1454acb 100644 --- a/tests/rt/pos/ifc/inputpini.trp +++ b/tests/rt/pos/ifc/inputpini.trp @@ -1,19 +1,17 @@ -let val out = getStdout authority - - fun inputLineWithPini auth = - let pini auth val s = inputLine () +let fun inputLineWithPini () = + let pini authority val s = freadln (stdin authority) in s end - fun inputLineAtLevel auth lev = - let val s = inputLineWithPini auth - in declassify (s, auth, lev) + fun inputLineAtLevel authority level = + let val s = inputLineWithPini () + in declassify (s, authority, level) end - fun writeString x = fwrite (out, x) + fun print x = fwrite (stdout authority, x) - val _ = writeString "Please input something: " + val _ = print "Please input something: " val s = inputLineAtLevel authority `{}` - val _ = writeString ("You have provided input: " ^ s ^ "\n") + val _ = print ("You have provided input: " ^ s ^ "\n") in s end diff --git a/tests/rt/pos/ifc/sandbox/guard01.golden b/tests/rt/pos/ifc/sandbox/guard01.golden index 544b8fd9..d2615f6b 100644 --- a/tests/rt/pos/ifc/sandbox/guard01.golden +++ b/tests/rt/pos/ifc/sandbox/guard01.golden @@ -1,3 +1,3 @@ 2023-03-17T21:23:20.814Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -Warning: runtime exception in the handler or sandbox: invalid handler state in fprintln -- side effects are prohbited in handler pattern matching or sandboxed code +Warning: runtime exception in the handler or sandbox: invalid handler state in fwrite -- side effects are prohbited in handler pattern matching or sandboxed code >>> Main thread finished with value: 0@{}%{} diff --git a/tests/rt/pos/ifc/sandbox/guard01.nocolor.golden b/tests/rt/pos/ifc/sandbox/guard01.nocolor.golden index 861e0c2d..bd5370fb 100644 --- a/tests/rt/pos/ifc/sandbox/guard01.nocolor.golden +++ b/tests/rt/pos/ifc/sandbox/guard01.nocolor.golden @@ -1,3 +1,3 @@ 2025-06-24T21:28:33.638Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -Warning: runtime exception in the handler or sandbox: invalid handler state in fprintln -- side effects are prohbited in handler pattern matching or sandboxed code +Warning: runtime exception in the handler or sandbox: invalid handler state in fwrite -- side effects are prohbited in handler pattern matching or sandboxed code >>> Main thread finished with value: 0@{}%{} diff --git a/tests/rt/pos/ifc/tlev02.trp b/tests/rt/pos/ifc/tlev02.trp index e868c383..cf9933bf 100644 --- a/tests/rt/pos/ifc/tlev02.trp +++ b/tests/rt/pos/ifc/tlev02.trp @@ -3,7 +3,7 @@ let fun inputLineWithPini auth = in s end - val out = getStdout authority + val out = stdout authority val _ = fwrite (out, "What's your name: ") val input = inputLineWithPini authority diff --git a/tests/rt/pos/ifc/toString.golden b/tests/rt/pos/ifc/toString.golden new file mode 100644 index 00000000..e7d7a0e4 --- /dev/null +++ b/tests/rt/pos/ifc/toString.golden @@ -0,0 +1,3 @@ +2025-10-23T10:54:49.942Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +(42, 11) +>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/toString.trp b/tests/rt/pos/ifc/toString.trp new file mode 100644 index 00000000..7bfbf796 --- /dev/null +++ b/tests/rt/pos/ifc/toString.trp @@ -0,0 +1,4 @@ +let val x = 42 raisedTo `{alice}` + val y = 11 raisedTo `{bob}` +in fwrite (stdout authority, (toString (x,y)) ^ "\n") +end diff --git a/tests/rt/pos/ifc/toStringL01.golden b/tests/rt/pos/ifc/toStringL01.golden new file mode 100644 index 00000000..30c16281 --- /dev/null +++ b/tests/rt/pos/ifc/toStringL01.golden @@ -0,0 +1,3 @@ +2025-10-23T10:54:51.132Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +(42@{alice}%{}, 11@{bob}%{})@{}%{} +>>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/toStringL01.trp b/tests/rt/pos/ifc/toStringL01.trp new file mode 100644 index 00000000..7a4b7f3c --- /dev/null +++ b/tests/rt/pos/ifc/toStringL01.trp @@ -0,0 +1,4 @@ +let val x = 42 raisedTo `{alice}` + val y = 11 raisedTo `{bob}` +in fwrite (stdout authority, (toStringL (x,y)) ^ "\n") +end diff --git a/tests/rt/pos/ifc/tostringlabeled.golden b/tests/rt/pos/ifc/toStringL02.golden similarity index 73% rename from tests/rt/pos/ifc/tostringlabeled.golden rename to tests/rt/pos/ifc/toStringL02.golden index 0e63c17c..c0385cb5 100644 --- a/tests/rt/pos/ifc/tostringlabeled.golden +++ b/tests/rt/pos/ifc/toStringL02.golden @@ -1,3 +1,3 @@ -2019-03-07T14:31:34.913Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +2025-10-23T10:54:50.869Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. "(42@{alice}%{}, 11@{bob}%{})@{}%{}"@{alice,bob}%{} >>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/toStringL02.trp b/tests/rt/pos/ifc/toStringL02.trp new file mode 100644 index 00000000..c888da5a --- /dev/null +++ b/tests/rt/pos/ifc/toStringL02.trp @@ -0,0 +1,4 @@ +let val x = 42 raisedTo `{alice}` + val y = 11 raisedTo `{bob}` +in fwrite (stdout authority, (toStringL (toStringL (x,y))) ^ "\n") +end diff --git a/tests/rt/pos/ifc/tostring.golden b/tests/rt/pos/ifc/tostring.golden deleted file mode 100644 index bf5bc28c..00000000 --- a/tests/rt/pos/ifc/tostring.golden +++ /dev/null @@ -1,4 +0,0 @@ -2019-03-07T19:02:13.843Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -The result of toString is (42, 11) -Observe how the PC-level and blocking-level are now tainted because of the string concatenation (and the usage of printString) above ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostring.nocolor.golden b/tests/rt/pos/ifc/tostring.nocolor.golden deleted file mode 100644 index 0b1d293b..00000000 --- a/tests/rt/pos/ifc/tostring.nocolor.golden +++ /dev/null @@ -1,4 +0,0 @@ -2025-06-24T21:28:35.027Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -The result of toString is (42, 11) -Observe how the PC-level and blocking-level are now tainted because of the string concatenation (and the usage of printString) above ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostring.trp b/tests/rt/pos/ifc/tostring.trp deleted file mode 100644 index b7d57bdb..00000000 --- a/tests/rt/pos/ifc/tostring.trp +++ /dev/null @@ -1,6 +0,0 @@ -let val x = 42 raisedTo `{alice}` - val y = 11 raisedTo `{bob}` - val s = toString (x,y) - val _ = printString ("The result of toString is " ^ s ) -in printString "Observe how the PC-level and blocking-level are now tainted because of the string concatenation (and the usage of printString) above" -end diff --git a/tests/rt/pos/ifc/tostringlabeled.nocolor.golden b/tests/rt/pos/ifc/tostringlabeled.nocolor.golden deleted file mode 100644 index 6aa81670..00000000 --- a/tests/rt/pos/ifc/tostringlabeled.nocolor.golden +++ /dev/null @@ -1,3 +0,0 @@ -2025-06-24T21:28:31.950Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -"(42@{alice}%{}, 11@{bob}%{})@{}%{}"@{alice,bob}%{} ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostringlabeled.trp b/tests/rt/pos/ifc/tostringlabeled.trp deleted file mode 100644 index 6e1a1a02..00000000 --- a/tests/rt/pos/ifc/tostringlabeled.trp +++ /dev/null @@ -1,5 +0,0 @@ -let val x = 42 raisedTo `{alice}` - val y = 11 raisedTo `{bob}` - val s = toStringL (x,y) -in printWithLabels ( s ) -end diff --git a/tests/rt/pos/ifc/tostringlabeled02.golden b/tests/rt/pos/ifc/tostringlabeled02.golden deleted file mode 100644 index ce82fe45..00000000 --- a/tests/rt/pos/ifc/tostringlabeled02.golden +++ /dev/null @@ -1,4 +0,0 @@ -2019-03-07T19:02:08.670Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -The level of the string is (42@{alice}%{}, 11@{bob}%{})@{}%{} -Observe how the PC-level and blocking-level are now tainted because of the string concatenation (and the usage of printString) above ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostringlabeled02.nocolor.golden b/tests/rt/pos/ifc/tostringlabeled02.nocolor.golden deleted file mode 100644 index 4e9c4e48..00000000 --- a/tests/rt/pos/ifc/tostringlabeled02.nocolor.golden +++ /dev/null @@ -1,4 +0,0 @@ -2025-06-24T21:28:32.777Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -The level of the string is (42@{alice}%{}, 11@{bob}%{})@{}%{} -Observe how the PC-level and blocking-level are now tainted because of the string concatenation (and the usage of printString) above ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostringlabeled02.trp b/tests/rt/pos/ifc/tostringlabeled02.trp deleted file mode 100644 index 5804c074..00000000 --- a/tests/rt/pos/ifc/tostringlabeled02.trp +++ /dev/null @@ -1,6 +0,0 @@ -let val x = 42 raisedTo `{alice}` - val y = 11 raisedTo `{bob}` - val s = toStringL (x,y) - val _ = printString ("The level of the string is " ^ s ) -in printString "Observe how the PC-level and blocking-level are now tainted because of the string concatenation (and the usage of printString) above" -end diff --git a/tests/rt/pos/ifc/tostringlabeled03.nocolor.golden b/tests/rt/pos/ifc/tostringlabeled03.nocolor.golden deleted file mode 100644 index 84e8659b..00000000 --- a/tests/rt/pos/ifc/tostringlabeled03.nocolor.golden +++ /dev/null @@ -1,3 +0,0 @@ -2025-06-24T21:28:32.751Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -"(42@{alice}%{}, 11@{bob}%{})@{}%{}" ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostringlabeled03.trp b/tests/rt/pos/ifc/tostringlabeled03.trp deleted file mode 100644 index b8b6e850..00000000 --- a/tests/rt/pos/ifc/tostringlabeled03.trp +++ /dev/null @@ -1,5 +0,0 @@ -let val x = 42 raisedTo `{alice}` - val y = 11 raisedTo `{bob}` - val s = toStringL (x,y) -in print ( s ) -end diff --git a/tests/rt/pos/ifc/tostringlabeled04.nocolor.golden b/tests/rt/pos/ifc/tostringlabeled04.nocolor.golden deleted file mode 100644 index 7f8a17f4..00000000 --- a/tests/rt/pos/ifc/tostringlabeled04.nocolor.golden +++ /dev/null @@ -1,3 +0,0 @@ -2025-06-24T21:28:32.242Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. -"(42@{alice}%{}, 11@{bob}%{})@{}%{}"@{alice,bob}%{} ->>> Main thread finished with value: ()@{}%{} diff --git a/tests/rt/pos/ifc/tostringlabeled04.trp b/tests/rt/pos/ifc/tostringlabeled04.trp deleted file mode 100644 index e20ed4a2..00000000 --- a/tests/rt/pos/ifc/tostringlabeled04.trp +++ /dev/null @@ -1,6 +0,0 @@ -let val x = 42 raisedTo `{alice}` - val y = 11 raisedTo `{bob}` - val s = toStringL (x,y) - -in printWithLabels s -end diff --git a/tests/rt/pos/core/inputline01.golden b/tests/rt/pos/preamble/inputLine01.golden similarity index 100% rename from tests/rt/pos/core/inputline01.golden rename to tests/rt/pos/preamble/inputLine01.golden diff --git a/tests/rt/pos/core/inputline01.nocolor.golden b/tests/rt/pos/preamble/inputLine01.nocolor.golden similarity index 100% rename from tests/rt/pos/core/inputline01.nocolor.golden rename to tests/rt/pos/preamble/inputLine01.nocolor.golden diff --git a/tests/rt/pos/core/inputline01.trp b/tests/rt/pos/preamble/inputLine01.trp similarity index 100% rename from tests/rt/pos/core/inputline01.trp rename to tests/rt/pos/preamble/inputLine01.trp diff --git a/tests/rt/pos/preamble/inputLine01.trp.input b/tests/rt/pos/preamble/inputLine01.trp.input new file mode 100644 index 00000000..08b64854 --- /dev/null +++ b/tests/rt/pos/preamble/inputLine01.trp.input @@ -0,0 +1 @@ +Alice diff --git a/tests/rt/pos/core/inputline02.golden b/tests/rt/pos/preamble/inputLine02.golden similarity index 100% rename from tests/rt/pos/core/inputline02.golden rename to tests/rt/pos/preamble/inputLine02.golden diff --git a/tests/rt/pos/core/inputline02.nocolor.golden b/tests/rt/pos/preamble/inputLine02.nocolor.golden similarity index 100% rename from tests/rt/pos/core/inputline02.nocolor.golden rename to tests/rt/pos/preamble/inputLine02.nocolor.golden diff --git a/tests/rt/pos/core/inputline02.trp b/tests/rt/pos/preamble/inputLine02.trp similarity index 100% rename from tests/rt/pos/core/inputline02.trp rename to tests/rt/pos/preamble/inputLine02.trp diff --git a/tests/rt/pos/core/inputline02.trp.input b/tests/rt/pos/preamble/inputLine02.trp.input similarity index 100% rename from tests/rt/pos/core/inputline02.trp.input rename to tests/rt/pos/preamble/inputLine02.trp.input diff --git a/tests/rt/pos/core/printsimple.golden b/tests/rt/pos/preamble/print.golden similarity index 100% rename from tests/rt/pos/core/printsimple.golden rename to tests/rt/pos/preamble/print.golden diff --git a/tests/rt/pos/core/printsimple.nocolor.golden b/tests/rt/pos/preamble/print.nocolor.golden similarity index 100% rename from tests/rt/pos/core/printsimple.nocolor.golden rename to tests/rt/pos/preamble/print.nocolor.golden diff --git a/tests/rt/pos/core/printsimple.trp b/tests/rt/pos/preamble/print.trp similarity index 100% rename from tests/rt/pos/core/printsimple.trp rename to tests/rt/pos/preamble/print.trp diff --git a/tests/rt/pos/core/printstring.golden b/tests/rt/pos/preamble/printString.golden similarity index 100% rename from tests/rt/pos/core/printstring.golden rename to tests/rt/pos/preamble/printString.golden diff --git a/tests/rt/pos/core/printstring.nocolor.golden b/tests/rt/pos/preamble/printString.nocolor.golden similarity index 100% rename from tests/rt/pos/core/printstring.nocolor.golden rename to tests/rt/pos/preamble/printString.nocolor.golden diff --git a/tests/rt/pos/core/printstring.trp b/tests/rt/pos/preamble/printString.trp similarity index 100% rename from tests/rt/pos/core/printstring.trp rename to tests/rt/pos/preamble/printString.trp diff --git a/tests/rt/pos/core/printwithlabels.golden b/tests/rt/pos/preamble/printWithLabels.golden similarity index 100% rename from tests/rt/pos/core/printwithlabels.golden rename to tests/rt/pos/preamble/printWithLabels.golden diff --git a/tests/rt/pos/core/printwithlabels.nocolor.golden b/tests/rt/pos/preamble/printWithLabels.nocolor.golden similarity index 100% rename from tests/rt/pos/core/printwithlabels.nocolor.golden rename to tests/rt/pos/preamble/printWithLabels.nocolor.golden diff --git a/tests/rt/pos/core/printwithlabels.trp b/tests/rt/pos/preamble/printWithLabels.trp similarity index 100% rename from tests/rt/pos/core/printwithlabels.trp rename to tests/rt/pos/preamble/printWithLabels.trp From 0318a8185a9d1fe101107dc2750aea17fc59c75b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Fri, 24 Oct 2025 09:25:06 +0200 Subject: [PATCH 21/25] Make 'String.sub' more ergonomic --- lib/Hash.trp | 12 ++++---- lib/README.md | 6 ++-- lib/String.trp | 17 +++++----- tests/lib/String.trp | 36 +++++++++++----------- tests/rt/pos/core/string_manipulations.trp | 8 ++--- 5 files changed, 40 insertions(+), 39 deletions(-) diff --git a/lib/Hash.trp b/lib/Hash.trp index f10ec7b0..bb58a000 100644 --- a/lib/Hash.trp +++ b/lib/Hash.trp @@ -10,15 +10,15 @@ let *) fun hashString s = (* String hash with fast paths for small strings *) - let val len = strlen s - val radix = 127 - fun charCodeAt i = String.subCode (s,i) + let val len = String.size s + val radix = 127 + val subCode = String.subCode s in case len of 0 => 0 - | 1 => charCodeAt 0 - | 2 => (radix * charCodeAt 0 + charCodeAt 1) andb Number.maxInt32 + | 1 => subCode 0 + | 2 => (radix * subCode 0 + subCode 1) andb Number.maxInt32 | _ => let fun go idx acc = if len <= idx then acc - else go (idx + 1) ((acc * radix + charCodeAt idx) andb Number.maxInt32) + else go (idx + 1) ((acc * radix + subCode idx) andb Number.maxInt32) in go 0 0 end end diff --git a/lib/README.md b/lib/README.md index d611ef5b..916d5797 100644 --- a/lib/README.md +++ b/lib/README.md @@ -27,9 +27,9 @@ target of the *makefile*. ## Design Principles - File names are written in `CamelCase`. This makes them conform to the Standard ML Basis Library. -- It is more important to match the function names and signatures in the Standard ML library than to - improve on them. For example, `String.sub` would make more sense with the type `[Char] -> Int -> - Char` but to match the SML library, we will stick with `[Char] * Int -> Char`. +- While we will try to match function names in the Standard ML library, we may take the liberty to + improve on the function signatures. For example, the function `String.sub` uses the same name as + in SML but uses the signature `[Char] -> Int -> Char` rather than `[Char] * Int -> Char`. - Each module exports a single *record* with the same name as the file. This (1) makes it closer to the SML module system and (2) allows for name resolution, e.g. `HashMap.findOpt` and `ListPair.findOpt` can be used in the same file. diff --git a/lib/String.trp b/lib/String.trp index 2dfe068e..9671811c 100644 --- a/lib/String.trp +++ b/lib/String.trp @@ -1,9 +1,12 @@ -(* TODO: Make strings merely lists of characters, similar to Haskell? Then a lot of things can be - * moved out of the TCB? *) import Number import List -let (** The maximum length of a string. +(* TODO: Make strings merely lists of characters, similar to Haskell and SML? Then a lot of things + * can be moved out of the TCB. *) + +let val __substring = substring + + (** The maximum length of a string. * * ECMA-262: 6.1.4 The String Type * @@ -19,15 +22,15 @@ let (** The maximum length of a string. (** Returns the `i`th character of `s`, counting from zero. If `i` is out of bounds, then "" is * returned. *) - fun sub (s,i) = substring (s, i, i+1) + fun sub s i = __substring (s, i, i+1) (** The character value at the given index. If `i` is out of bounds, then 0 (NULL) is * returned. *) (* TODO (#59): Rename to `sub'` when `'` symbols are properly supported. *) - fun subCode (s,i) = charCodeAtWithDefault (s, i, 0) + fun subCode s i = charCodeAtWithDefault (s, i, 0) (** Returns the substring of `s`. Indices beyond the end of string are silently truncated. *) - val substring = substring + fun substring s i j = __substring (s, i, j) (** The concatenation of all strings in `xs`. *) fun concat xs = let fun f ("",x') = x' @@ -55,7 +58,7 @@ let (** The maximum length of a string. (** Returns the list of characters in the string `s`. *) fun explode s = let fun go 0 acc = acc - | go i acc = go (i-1) ((sub (s,i-1))::acc) + | go i acc = go (i-1) ((sub s (i-1))::acc) in go (size s) [] end (** Applies `f` to each element of `f` from left to right, returning the resulting string. *) diff --git a/tests/lib/String.trp b/tests/lib/String.trp index 8f39c381..65326589 100644 --- a/tests/lib/String.trp +++ b/tests/lib/String.trp @@ -11,32 +11,32 @@ let val tests = Unit.group "String" [ ], let val s = "Hello" in Unit.group "sub" [ - Unit.it "is 'H' for 0" (Unit.isEq "H" (String.sub (s, 0))) - , Unit.it "is 'e' for 1" (Unit.isEq "e" (String.sub (s, 1))) - , Unit.it "is 'l' for 2" (Unit.isEq "l" (String.sub (s, 2))) - , Unit.it "is 'l' for 3" (Unit.isEq "l" (String.sub (s, 3))) - , Unit.it "is 'o' for 4" (Unit.isEq "o" (String.sub (s, 4))) - , Unit.it "is '' for 5" (Unit.isEq "" (String.sub (s, 5))) - , Unit.it "is '' for 6" (Unit.isEq "" (String.sub (s, 6))) + Unit.it "is 'H' for 0" (Unit.isEq "H" (String.sub s 0)) + , Unit.it "is 'e' for 1" (Unit.isEq "e" (String.sub s 1)) + , Unit.it "is 'l' for 2" (Unit.isEq "l" (String.sub s 2)) + , Unit.it "is 'l' for 3" (Unit.isEq "l" (String.sub s 3)) + , Unit.it "is 'o' for 4" (Unit.isEq "o" (String.sub s 4)) + , Unit.it "is '' for 5" (Unit.isEq "" (String.sub s 5)) + , Unit.it "is '' for 6" (Unit.isEq "" (String.sub s 6)) ] end, let val s = "World!" in Unit.group "subCode" [ - Unit.it "is 87 for 0" (Unit.isEq 87 (String.subCode (s,0))) - , Unit.it "is 111 for 1" (Unit.isEq 111 (String.subCode (s,1))) - , Unit.it "is 114 for 2" (Unit.isEq 114 (String.subCode (s,2))) - , Unit.it "is 108 for 3" (Unit.isEq 108 (String.subCode (s,3))) - , Unit.it "is 100 for 4" (Unit.isEq 100 (String.subCode (s,4))) - , Unit.it "is 33 for 5" (Unit.isEq 33 (String.subCode (s,5))) - , Unit.it "is 0 for 6" (Unit.isEq 0 (String.subCode (s,6))) + Unit.it "is 87 for 0" (Unit.isEq 87 (String.subCode s 0)) + , Unit.it "is 111 for 1" (Unit.isEq 111 (String.subCode s 1)) + , Unit.it "is 114 for 2" (Unit.isEq 114 (String.subCode s 2)) + , Unit.it "is 108 for 3" (Unit.isEq 108 (String.subCode s 3)) + , Unit.it "is 100 for 4" (Unit.isEq 100 (String.subCode s 4)) + , Unit.it "is 33 for 5" (Unit.isEq 33 (String.subCode s 5)) + , Unit.it "is 0 for 6" (Unit.isEq 0 (String.subCode s 6)) ] end, let val s = "Hello Troupe!" in Unit.group "substring" [ - Unit.it "is 'Hello' for 0 5" (Unit.isEq "Hello" (String.substring (s, 0, 5))) - , Unit.it "is 'Troupe' for 6 12" (Unit.isEq "Troupe" (String.substring (s, 6, 12))) - , Unit.it "is 'Troupe!' for 6 13" (Unit.isEq "Troupe!" (String.substring (s, 6, 13))) - , Unit.it "is 'Troupe!' for 6 14" (Unit.isEq "Troupe!" (String.substring (s, 6, 13))) + Unit.it "is 'Hello' for 0 5" (Unit.isEq "Hello" (String.substring s 0 5)) + , Unit.it "is 'Troupe' for 6 12" (Unit.isEq "Troupe" (String.substring s 6 12)) + , Unit.it "is 'Troupe!' for 6 13" (Unit.isEq "Troupe!" (String.substring s 6 13)) + , Unit.it "is 'Troupe!' for 6 14" (Unit.isEq "Troupe!" (String.substring s 6 14)) ] end, Unit.group "concat" [ diff --git a/tests/rt/pos/core/string_manipulations.trp b/tests/rt/pos/core/string_manipulations.trp index 10767830..edd504d0 100644 --- a/tests/rt/pos/core/string_manipulations.trp +++ b/tests/rt/pos/core/string_manipulations.trp @@ -1,9 +1,7 @@ -import String - -let val x = String.sub ("hello", 0) +let val x = substring ("hello", 0, 1) val y = "1" ^ "2" val s = ("Hello" raisedTo `{alice}`) ^ ", " ^ ("World" raisedTo `{bob}`) val i = 3 raisedTo `{charlie}` val j = 5 raisedTo `{dorothy}` -in (x,y,s, substring (s, i, j)) -end \ No newline at end of file +in (x, y, s, substring (s, i, j)) +end From 978af0cf0ae3df39bd1b5d624cbe7d22962b82e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Fri, 24 Oct 2025 10:05:00 +0200 Subject: [PATCH 22/25] Fix todo on renaming 'String.subCode' --- lib/Hash.trp | 12 ++++++------ lib/String.trp | 5 ++--- tests/lib/String.golden | 2 +- tests/lib/String.trp | 16 ++++++++-------- 4 files changed, 17 insertions(+), 18 deletions(-) diff --git a/lib/Hash.trp b/lib/Hash.trp index bb58a000..7f3b75bc 100644 --- a/lib/Hash.trp +++ b/lib/Hash.trp @@ -10,15 +10,15 @@ let *) fun hashString s = (* String hash with fast paths for small strings *) - let val len = String.size s - val radix = 127 - val subCode = String.subCode s + let val len = String.size s + val radix = 127 + val codeAt = String.sub' s in case len of 0 => 0 - | 1 => subCode 0 - | 2 => (radix * subCode 0 + subCode 1) andb Number.maxInt32 + | 1 => codeAt 0 + | 2 => (radix * codeAt 0 + codeAt 1) andb Number.maxInt32 | _ => let fun go idx acc = if len <= idx then acc - else go (idx + 1) ((acc * radix + subCode idx) andb Number.maxInt32) + else go (idx + 1) ((acc * radix + codeAt idx) andb Number.maxInt32) in go 0 0 end end diff --git a/lib/String.trp b/lib/String.trp index 9671811c..a3b917c5 100644 --- a/lib/String.trp +++ b/lib/String.trp @@ -26,8 +26,7 @@ let val __substring = substring (** The character value at the given index. If `i` is out of bounds, then 0 (NULL) is * returned. *) - (* TODO (#59): Rename to `sub'` when `'` symbols are properly supported. *) - fun subCode s i = charCodeAtWithDefault (s, i, 0) + fun sub' s i = charCodeAtWithDefault (s, i, 0) (** Returns the substring of `s`. Indices beyond the end of string are silently truncated. *) fun substring s i j = __substring (s, i, j) @@ -76,7 +75,7 @@ let val __substring = substring maxSize, size, sub, - subCode, + sub', substring, concat, concatWith, diff --git a/tests/lib/String.golden b/tests/lib/String.golden index 5d33b594..6644ef1b 100644 --- a/tests/lib/String.golden +++ b/tests/lib/String.golden @@ -16,7 +16,7 @@ [ TEST ] it is '' for 5 [ PASS ] it is '' for 5 [ TEST ] it is '' for 6 [ PASS ] it is '' for 6 end  - begin subCode + begin sub' [ TEST ] it is 87 for 0 [ PASS ] it is 87 for 0 [ TEST ] it is 111 for 1 [ PASS ] it is 111 for 1 [ TEST ] it is 114 for 2 [ PASS ] it is 114 for 2 diff --git a/tests/lib/String.trp b/tests/lib/String.trp index 65326589..eb8f6004 100644 --- a/tests/lib/String.trp +++ b/tests/lib/String.trp @@ -21,14 +21,14 @@ let val tests = Unit.group "String" [ ] end, let val s = "World!" - in Unit.group "subCode" [ - Unit.it "is 87 for 0" (Unit.isEq 87 (String.subCode s 0)) - , Unit.it "is 111 for 1" (Unit.isEq 111 (String.subCode s 1)) - , Unit.it "is 114 for 2" (Unit.isEq 114 (String.subCode s 2)) - , Unit.it "is 108 for 3" (Unit.isEq 108 (String.subCode s 3)) - , Unit.it "is 100 for 4" (Unit.isEq 100 (String.subCode s 4)) - , Unit.it "is 33 for 5" (Unit.isEq 33 (String.subCode s 5)) - , Unit.it "is 0 for 6" (Unit.isEq 0 (String.subCode s 6)) + in Unit.group "sub'" [ + Unit.it "is 87 for 0" (Unit.isEq 87 (String.sub' s 0)) + , Unit.it "is 111 for 1" (Unit.isEq 111 (String.sub' s 1)) + , Unit.it "is 114 for 2" (Unit.isEq 114 (String.sub' s 2)) + , Unit.it "is 108 for 3" (Unit.isEq 108 (String.sub' s 3)) + , Unit.it "is 100 for 4" (Unit.isEq 100 (String.sub' s 4)) + , Unit.it "is 33 for 5" (Unit.isEq 33 (String.sub' s 5)) + , Unit.it "is 0 for 6" (Unit.isEq 0 (String.sub' s 6)) ] end, let val s = "Hello Troupe!" From 84d3f2f3b23c164cff18c25fefb0ec76f5dc4018 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Fri, 24 Oct 2025 10:06:16 +0200 Subject: [PATCH 23/25] Move and split up 'tests/rt/pos/core/string_manipulation.trp' This test was in 'core' even though it was testing 'ifc' stuff. Furthermore, it was on testing one particular combination instead of each possible. --- tests/rt/pos/core/string_manipulations.golden | 2 -- tests/rt/pos/core/string_manipulations.nocolor.golden | 2 -- tests/rt/pos/core/string_manipulations.trp | 7 ------- tests/rt/pos/core/substring01.golden | 2 ++ tests/rt/pos/core/substring01.trp | 1 + tests/rt/pos/core/substring02.golden | 2 ++ tests/rt/pos/core/substring02.trp | 1 + tests/rt/pos/core/substring03.golden | 2 ++ tests/rt/pos/core/substring03.trp | 1 + tests/rt/pos/ifc/concat01.golden | 2 ++ tests/rt/pos/ifc/concat01.trp | 4 ++++ tests/rt/pos/ifc/concat02.golden | 2 ++ tests/rt/pos/ifc/concat02.trp | 3 +++ tests/rt/pos/ifc/concat03.golden | 2 ++ tests/rt/pos/ifc/concat03.trp | 4 ++++ tests/rt/pos/ifc/substring01.golden | 2 ++ tests/rt/pos/ifc/substring01.trp | 5 +++++ tests/rt/pos/ifc/substring02.golden | 2 ++ tests/rt/pos/ifc/substring02.trp | 5 +++++ tests/rt/pos/ifc/substring03.golden | 2 ++ tests/rt/pos/ifc/substring03.trp | 5 +++++ tests/rt/pos/ifc/substring04.golden | 2 ++ tests/rt/pos/ifc/substring04.trp | 5 +++++ tests/rt/pos/ifc/substring05.golden | 2 ++ tests/rt/pos/ifc/substring05.trp | 5 +++++ 25 files changed, 61 insertions(+), 11 deletions(-) delete mode 100644 tests/rt/pos/core/string_manipulations.golden delete mode 100644 tests/rt/pos/core/string_manipulations.nocolor.golden delete mode 100644 tests/rt/pos/core/string_manipulations.trp create mode 100644 tests/rt/pos/core/substring01.golden create mode 100644 tests/rt/pos/core/substring01.trp create mode 100644 tests/rt/pos/core/substring02.golden create mode 100644 tests/rt/pos/core/substring02.trp create mode 100644 tests/rt/pos/core/substring03.golden create mode 100644 tests/rt/pos/core/substring03.trp create mode 100644 tests/rt/pos/ifc/concat01.golden create mode 100644 tests/rt/pos/ifc/concat01.trp create mode 100644 tests/rt/pos/ifc/concat02.golden create mode 100644 tests/rt/pos/ifc/concat02.trp create mode 100644 tests/rt/pos/ifc/concat03.golden create mode 100644 tests/rt/pos/ifc/concat03.trp create mode 100644 tests/rt/pos/ifc/substring01.golden create mode 100644 tests/rt/pos/ifc/substring01.trp create mode 100644 tests/rt/pos/ifc/substring02.golden create mode 100644 tests/rt/pos/ifc/substring02.trp create mode 100644 tests/rt/pos/ifc/substring03.golden create mode 100644 tests/rt/pos/ifc/substring03.trp create mode 100644 tests/rt/pos/ifc/substring04.golden create mode 100644 tests/rt/pos/ifc/substring04.trp create mode 100644 tests/rt/pos/ifc/substring05.golden create mode 100644 tests/rt/pos/ifc/substring05.trp diff --git a/tests/rt/pos/core/string_manipulations.golden b/tests/rt/pos/core/string_manipulations.golden deleted file mode 100644 index 606953de..00000000 --- a/tests/rt/pos/core/string_manipulations.golden +++ /dev/null @@ -1,2 +0,0 @@ -2025-09-09T15:01:25.333Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. ->>> Main thread finished with value: ("h"@{}%{}, "12"@{}%{}, "Hello, World"@{alice,bob}%{}, "lo"@{alice,bob,charlie,dorothy}%{alice,bob,charlie,dorothy})@{}%{} diff --git a/tests/rt/pos/core/string_manipulations.nocolor.golden b/tests/rt/pos/core/string_manipulations.nocolor.golden deleted file mode 100644 index 10853922..00000000 --- a/tests/rt/pos/core/string_manipulations.nocolor.golden +++ /dev/null @@ -1,2 +0,0 @@ -2025-06-24T21:28:17.677Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. ->>> Main thread finished with value: ("h"@{}%{}, "12"@{}%{}, "Hello, World"@{alice,bob}%{}, "lo"@{alice,bob,charlie,dorothy}%{alice,bob,charlie,dorothy})@{}%{} diff --git a/tests/rt/pos/core/string_manipulations.trp b/tests/rt/pos/core/string_manipulations.trp deleted file mode 100644 index edd504d0..00000000 --- a/tests/rt/pos/core/string_manipulations.trp +++ /dev/null @@ -1,7 +0,0 @@ -let val x = substring ("hello", 0, 1) - val y = "1" ^ "2" - val s = ("Hello" raisedTo `{alice}`) ^ ", " ^ ("World" raisedTo `{bob}`) - val i = 3 raisedTo `{charlie}` - val j = 5 raisedTo `{dorothy}` -in (x, y, s, substring (s, i, j)) -end diff --git a/tests/rt/pos/core/substring01.golden b/tests/rt/pos/core/substring01.golden new file mode 100644 index 00000000..12765b56 --- /dev/null +++ b/tests/rt/pos/core/substring01.golden @@ -0,0 +1,2 @@ +2025-10-24T07:53:46.865Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "Hello"@{}%{} diff --git a/tests/rt/pos/core/substring01.trp b/tests/rt/pos/core/substring01.trp new file mode 100644 index 00000000..622cbb60 --- /dev/null +++ b/tests/rt/pos/core/substring01.trp @@ -0,0 +1 @@ +substring ("Hello, World", 0, 5) diff --git a/tests/rt/pos/core/substring02.golden b/tests/rt/pos/core/substring02.golden new file mode 100644 index 00000000..2341bd8d --- /dev/null +++ b/tests/rt/pos/core/substring02.golden @@ -0,0 +1,2 @@ +2025-10-24T07:53:47.069Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "World"@{}%{} diff --git a/tests/rt/pos/core/substring02.trp b/tests/rt/pos/core/substring02.trp new file mode 100644 index 00000000..8b7941ab --- /dev/null +++ b/tests/rt/pos/core/substring02.trp @@ -0,0 +1 @@ +substring ("Hello, World", 7, 20) diff --git a/tests/rt/pos/core/substring03.golden b/tests/rt/pos/core/substring03.golden new file mode 100644 index 00000000..a2423125 --- /dev/null +++ b/tests/rt/pos/core/substring03.golden @@ -0,0 +1,2 @@ +2025-10-24T07:53:47.730Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "l"@{}%{} diff --git a/tests/rt/pos/core/substring03.trp b/tests/rt/pos/core/substring03.trp new file mode 100644 index 00000000..71bee2ed --- /dev/null +++ b/tests/rt/pos/core/substring03.trp @@ -0,0 +1 @@ +substring ("Hello, World", 4, 3) diff --git a/tests/rt/pos/ifc/concat01.golden b/tests/rt/pos/ifc/concat01.golden new file mode 100644 index 00000000..c1af8b34 --- /dev/null +++ b/tests/rt/pos/ifc/concat01.golden @@ -0,0 +1,2 @@ +2025-10-24T07:47:58.485Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "Hello, Alice"@{alice}%{} diff --git a/tests/rt/pos/ifc/concat01.trp b/tests/rt/pos/ifc/concat01.trp new file mode 100644 index 00000000..befdb299 --- /dev/null +++ b/tests/rt/pos/ifc/concat01.trp @@ -0,0 +1,4 @@ +let val x = "Hello" + val y = "Alice" raisedTo `{alice}` +in x ^ ", " ^ y +end diff --git a/tests/rt/pos/ifc/concat02.golden b/tests/rt/pos/ifc/concat02.golden new file mode 100644 index 00000000..3e117c8d --- /dev/null +++ b/tests/rt/pos/ifc/concat02.golden @@ -0,0 +1,2 @@ +2025-10-24T07:47:58.356Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "Bob says 'Hello!'"@{bob}%{} diff --git a/tests/rt/pos/ifc/concat02.trp b/tests/rt/pos/ifc/concat02.trp new file mode 100644 index 00000000..fe54ff79 --- /dev/null +++ b/tests/rt/pos/ifc/concat02.trp @@ -0,0 +1,3 @@ +let val x = "Bob" raisedTo `{bob}` +in x ^ " says 'Hello!'" +end diff --git a/tests/rt/pos/ifc/concat03.golden b/tests/rt/pos/ifc/concat03.golden new file mode 100644 index 00000000..a15a21c7 --- /dev/null +++ b/tests/rt/pos/ifc/concat03.golden @@ -0,0 +1,2 @@ +2025-10-24T07:47:59.033Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "Alice and Bob say 'Hello!'"@{alice,bob}%{} diff --git a/tests/rt/pos/ifc/concat03.trp b/tests/rt/pos/ifc/concat03.trp new file mode 100644 index 00000000..114367d1 --- /dev/null +++ b/tests/rt/pos/ifc/concat03.trp @@ -0,0 +1,4 @@ +let val a = "Alice" raisedTo `{alice}` + val b = "Bob" raisedTo `{bob}` +in ((a ^ " and ") ^ b) ^ " say 'Hello!'" +end diff --git a/tests/rt/pos/ifc/substring01.golden b/tests/rt/pos/ifc/substring01.golden new file mode 100644 index 00000000..07ea710e --- /dev/null +++ b/tests/rt/pos/ifc/substring01.golden @@ -0,0 +1,2 @@ +2025-10-24T07:54:02.945Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "lo"@{alice}%{alice} diff --git a/tests/rt/pos/ifc/substring01.trp b/tests/rt/pos/ifc/substring01.trp new file mode 100644 index 00000000..b23a2a82 --- /dev/null +++ b/tests/rt/pos/ifc/substring01.trp @@ -0,0 +1,5 @@ +let val s = "Hello, World!" + val i = 3 raisedTo `{alice}` + val j = 5 +in substring (s, i, j) +end diff --git a/tests/rt/pos/ifc/substring02.golden b/tests/rt/pos/ifc/substring02.golden new file mode 100644 index 00000000..b1217dd2 --- /dev/null +++ b/tests/rt/pos/ifc/substring02.golden @@ -0,0 +1,2 @@ +2025-10-24T07:54:02.986Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "lo"@{bob}%{bob} diff --git a/tests/rt/pos/ifc/substring02.trp b/tests/rt/pos/ifc/substring02.trp new file mode 100644 index 00000000..9f717a0f --- /dev/null +++ b/tests/rt/pos/ifc/substring02.trp @@ -0,0 +1,5 @@ +let val s = "Hello, World!" + val i = 3 + val j = 5 raisedTo `{bob}` +in substring (s, i, j) +end diff --git a/tests/rt/pos/ifc/substring03.golden b/tests/rt/pos/ifc/substring03.golden new file mode 100644 index 00000000..4bbafac5 --- /dev/null +++ b/tests/rt/pos/ifc/substring03.golden @@ -0,0 +1,2 @@ +2025-10-24T07:54:02.997Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "lo"@{charlie}%{charlie} diff --git a/tests/rt/pos/ifc/substring03.trp b/tests/rt/pos/ifc/substring03.trp new file mode 100644 index 00000000..1fdc4672 --- /dev/null +++ b/tests/rt/pos/ifc/substring03.trp @@ -0,0 +1,5 @@ +let val s = "Hello, World!" raisedTo `{charlie}` + val i = 3 + val j = 5 +in substring (s, i, j) +end diff --git a/tests/rt/pos/ifc/substring04.golden b/tests/rt/pos/ifc/substring04.golden new file mode 100644 index 00000000..dadbbeda --- /dev/null +++ b/tests/rt/pos/ifc/substring04.golden @@ -0,0 +1,2 @@ +2025-10-24T07:54:03.258Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "lo"@{alice,charlie}%{alice,charlie} diff --git a/tests/rt/pos/ifc/substring04.trp b/tests/rt/pos/ifc/substring04.trp new file mode 100644 index 00000000..8d1ccb03 --- /dev/null +++ b/tests/rt/pos/ifc/substring04.trp @@ -0,0 +1,5 @@ +let val s = "Hello, World!" raisedTo `{charlie}` + val i = 3 raisedTo `{alice}` + val j = 5 +in substring (s, i, j) +end diff --git a/tests/rt/pos/ifc/substring05.golden b/tests/rt/pos/ifc/substring05.golden new file mode 100644 index 00000000..0dafcf6a --- /dev/null +++ b/tests/rt/pos/ifc/substring05.golden @@ -0,0 +1,2 @@ +2025-10-24T07:54:03.611Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +>>> Main thread finished with value: "lo"@{alice,bob,charlie}%{alice,bob,charlie} diff --git a/tests/rt/pos/ifc/substring05.trp b/tests/rt/pos/ifc/substring05.trp new file mode 100644 index 00000000..70d23b6f --- /dev/null +++ b/tests/rt/pos/ifc/substring05.trp @@ -0,0 +1,5 @@ +let val s = "Hello, World!" raisedTo `{charlie}` + val i = 3 raisedTo `{alice}` + val j = 5 raisedTo `{bob}` +in substring (s, i, j) +end From 8bdbb02c55b4b5bbafcdc6900f08058f6164345c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Fri, 24 Oct 2025 10:31:45 +0200 Subject: [PATCH 24/25] Add 'List.foldl1' --- lib/List.trp | 4 ++++ tests/lib/List.golden | 21 ++++++++++++++++++--- tests/lib/List.trp | 19 +++++++++++++++++++ 3 files changed, 41 insertions(+), 3 deletions(-) diff --git a/lib/List.trp b/lib/List.trp index 775007e3..73e108cd 100644 --- a/lib/List.trp +++ b/lib/List.trp @@ -83,6 +83,9 @@ let (* -- List Access -- *) fun foldl f y [] = y | foldl f y x::xs = foldl f (f (x,y)) xs + (** Left-fold of `f` on a non-empty list using the head as the initial value. *) + fun foldl1 f x::xs = foldl f x xs + (* TODO: foldr *) (** Returns the sublist of elements that satisfy `f`. Not tail-recursive. *) @@ -183,6 +186,7 @@ let (* -- List Access -- *) map, mapi, foldl, + foldl1, filter, filteri, partition, diff --git a/tests/lib/List.golden b/tests/lib/List.golden index 5c33bd7f..71c633c0 100644 --- a/tests/lib/List.golden +++ b/tests/lib/List.golden @@ -1,4 +1,4 @@ -2025-09-09T14:12:55.766Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. +2025-10-24T08:31:14.889Z [RTM] info: Skipping network creation. Observe that all external IO operations will yield a runtime error. begin List begin head [ TEST ] it returns 42 for [42] [ PASS ] it returns 42 for [42] @@ -91,6 +91,21 @@ [ TEST ] it id [1,1] [ PASS ] it id [1,1] [ TEST ] it id [1,3] [ PASS ] it id [1,3] end  + begin foldl + [ TEST ] it sums 0 [] [ PASS ] it sums 0 [] + [ TEST ] it sums 2 [] [ PASS ] it sums 2 [] + [ TEST ] it sums 0 [1] [ PASS ] it sums 0 [1] + [ TEST ] it sums 0 [1,1] [ PASS ] it sums 0 [1,1] + [ TEST ] it sums 0 [1,3] [ PASS ] it sums 0 [1,3] + [ TEST ] it sums 2 [1,3] [ PASS ] it sums 2 [1,3] + end  + begin foldl1 + [ TEST ] it sums [0] [ PASS ] it sums [0] + [ TEST ] it sums [1] [ PASS ] it sums [1] + [ TEST ] it sums [2] [ PASS ] it sums [2] + [ TEST ] it sums [1,1] [ PASS ] it sums [1,1] + [ TEST ] it sums [1,3] [ PASS ] it sums [1,3] + end  begin filter [ TEST ] it isOdd [] [ PASS ] it isOdd [] [ TEST ] it isEven [] [ PASS ] it isEven [] @@ -128,6 +143,6 @@ end  end  -Total: 90 -Passes: 90 +Total: 101 +Passes: 101 >>> Main thread finished with value: true@{}%{} diff --git a/tests/lib/List.trp b/tests/lib/List.trp index d10c09aa..4477ea6c 100644 --- a/tests/lib/List.trp +++ b/tests/lib/List.trp @@ -105,6 +105,25 @@ let val tests = Unit.group "List" [ , Unit.it "id [1,3]" (Unit.isEq [(0,1), (1,3)] (List.mapi id [1,3])) ] end, + let fun sum (a,b) = a+b + in Unit.group "foldl" [ + Unit.it "sums 0 []" (Unit.isEq 0 (List.foldl sum 0 [])) + , Unit.it "sums 2 []" (Unit.isEq 2 (List.foldl sum 2 [])) + , Unit.it "sums 0 [1]" (Unit.isEq 1 (List.foldl sum 0 [1])) + , Unit.it "sums 0 [1,1]" (Unit.isEq 2 (List.foldl sum 0 [1,1])) + , Unit.it "sums 0 [1,3]" (Unit.isEq 4 (List.foldl sum 0 [1,3])) + , Unit.it "sums 2 [1,3]" (Unit.isEq 6 (List.foldl sum 2 [1,3])) + ] + end, + let fun sum (a,b) = a+b + in Unit.group "foldl1" [ + Unit.it "sums [0]" (Unit.isEq 0 (List.foldl1 sum [0])) + , Unit.it "sums [1]" (Unit.isEq 1 (List.foldl1 sum [1])) + , Unit.it "sums [2]" (Unit.isEq 2 (List.foldl1 sum [2])) + , Unit.it "sums [1,1]" (Unit.isEq 2 (List.foldl1 sum [1,1])) + , Unit.it "sums [1,3]" (Unit.isEq 4 (List.foldl1 sum [1,3])) + ] + end, let val xs = [0,1,2,3,4,5,6,7,8,9] fun isOdd x = (x mod 2) = 1 fun isEven x = (x mod 2) = 0 From a3fbf453e750fcd05daa8390d14e432063a04609 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Steffan=20S=C3=B8lvsten?= Date: Fri, 24 Oct 2025 10:32:41 +0200 Subject: [PATCH 25/25] Some cleanup in 'List.mapi' --- lib/List.trp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/List.trp b/lib/List.trp index 73e108cd..ace8649a 100644 --- a/lib/List.trp +++ b/lib/List.trp @@ -72,9 +72,9 @@ let (* -- List Access -- *) (** Same as `List.map` but `f` is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. Not tail-recursive. *) fun mapi f list = - let fun mapj j [] = [] - | mapj j x::xs = (f (j,x)) :: (mapj (j+1) xs) - in mapj 0 list + let fun mapi_aux j [] = [] + | mapi_aux j x::xs = (f (j,x)) :: (mapi_aux (j+1) xs) + in mapi_aux 0 list end (* TODO: revMap *)