ref: 65c23aff173e59f56472498f0f0c2002ee563451
parent: b6ad2fabec6bb804c3c71c6e126cb45e3c8515be
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Sep 1 13:08:22 EDT 2023
Add $IO.dropArgs to allow -r to work with arguments.
--- a/Tools/Addcombs.hs
+++ b/Tools/Addcombs.hs
@@ -15,7 +15,8 @@
main :: IO ()
main = do
args <- getArgs
- file <- readFile (head args)
+ let fn = case args of { [a] -> a; _ -> error "Usage: Addcombs file" }+ file <- readFile fn
let size = length file
chunks = chunkify 20 file
putStrLn $ "struct { size_t b_size; size_t b_pos; uint8_t b_buffer[]; } combs = { " ++ showInt size ++ ", 0, {"--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.2
-740
-(($A :0 ((_550 _504) ((($S' ($C ((($C' ($S' _550)) (($B ($C _2)) _491)) (($B ($B (_550 _578))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _551)) ((($C' $B) (($B _639) (($B _568) ((($C' _677) _8) 0)))) (($B (_639 _571)) (($B (_584 "top level defns: ")) _532)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _551)) ((($C' $B) (($B _639) (($B _568) ((($C' _677) _8) 1)))) (_567 ($T (($B ($B (_639 _571))) ((($C' $B) (($B _584) _495)) (($B (_584 " = ")) _350))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _551))) ((($C' $B) ($B' (($B _639) (($B _573) _11)))) (($B ($B (_584 _1))) (($B (($C' _584) _532)) (_584 (($O 10) $K))))))) (($B ($B (_550 _578))) ((($C' $B) ($B' (($B _639) (($B _568) ((($C' _677) _8) 0))))) (($B ($B (_639 _571))) (($B ($B (_584 "final pass "))) ((($C' ($C' _584)) (($B ($B (_545 6))) (($B ($B _532)) _671))) "ms")))))))) _3)))) _529))) (($B (($C' $C) (($B ($C _589)) _350))) (($C _602) (_619 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_584 "(($A :"))))) (($B ($B (($C' $B) (($B _584) _532)))) (($B ($B ($B (_584 (($O 32) $K))))) ((($C' $B) (($B ($C' _584)) ($B _350))) (($B (_584 ") ")) (($C _584) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _327)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _639) (($B _636) (($B (_639 _686)) (($B (_584 "main: findIdent: ")) _495))))) (($C' _522) _493)))) (($B ($B _526)) (($B (($C' _586) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _493))) $K)))))) (($C _602) (_619 0)))))) (($B (_639 _326)) (($B (_639 _491)) (($B (_584 (($O 95) $K))) _532)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _601) (_588 (_543 "-v")))) ((_618 _543) "-r"))) (($B (_582 (($O 46) $K))) (($B _638) (_587 ((_606 _662) "-i")))))) (($B (_639 _613)) ((($C' _584) (($B _638) (_587 ((_606 _662) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _673) _601) 1)) (_686 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _613)) (_588 ((_640 _682) ((_640 (_543 (($O 45) $K))) (_599 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _550)) _16) (($B ($B ($B (_550 _578)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _551) (($B (_639 _569)) (($B (_639 (_600 1000000))) _189)))))) (($B ($B ($B ($B (_550 _578))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _551))) ((($C' $B) ($B' (($B _639) (($B _568) ((($C' _677) _8) 0))))) (($B ($B (_639 _571))) (($B ($B (_584 "combinator conversion "))) ((($C' ($C' _584)) (($B ($B (_545 6))) (($B ($B _532)) _671))) "ms"))))))) (($B ($B _552)) (($B $P) (($C _497) (_491 "main")))))))) (_586 ($T ((($C' ($C' $O)) ((($C' $B) $P) _353)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_639 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _482))) (($C' ($C' _586)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _639) (($B _636) (($B (_639 _686)) (($B (_584 "not found ")) _495))))) ($C _483))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _352))) (($B (_639 (_636 (_686 "primlookup")))) (($C (_622 _543)) _5))))) (_686 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O
\ No newline at end of file
+743
+(($A :0 ((_551 _504) (($B ((($S' ($C ((($C' ($S' _551)) (($B ($C _2)) _491)) (($B ($B (_551 _579))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _552)) ((($C' $B) (($B _640) (($B _569) ((($C' _678) _8) 0)))) (($B (_640 _572)) (($B (_585 "top level defns: ")) _533)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _552)) ((($C' $B) (($B _640) (($B _569) ((($C' _678) _8) 1)))) (_568 ($T (($B ($B (_640 _572))) ((($C' $B) (($B _585) _495)) (($B (_585 " = ")) _350))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _552))) ((($C' $B) ($B' (($B _640) (($B _574) _11)))) (($B ($B (_585 _1))) (($B (($C' _585) _533)) (_585 (($O 10) $K))))))) (($B ($B (_551 _579))) ((($C' $B) ($B' (($B _640) (($B _569) ((($C' _678) _8) 0))))) (($B ($B (_640 _572))) (($B ($B (_585 "final pass "))) ((($C' ($C' _585)) (($B ($B (_546 6))) (($B ($B _533)) _672))) "ms")))))))) _3)))) _530))) (($B (($C' $C) (($B ($C _590)) _350))) (($C _603) (_620 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_585 "(($A :"))))) (($B ($B (($C' $B) (($B _585) _533)))) (($B ($B ($B (_585 (($O 32) $K))))) ((($C' $B) (($B ($C' _585)) ($B _350))) (($B (_585 ") ")) (($C _585) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _327)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _640) (($B _637) (($B (_640 _687)) (($B (_585 "main: findIdent: ")) _495))))) (($C' _523) _493)))) (($B ($B _527)) (($B (($C' _587) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _493))) $K)))))) (($C _603) (_620 0)))))) (($B (_640 _326)) (($B (_640 _491)) (($B (_585 (($O 95) $K))) _533)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _602) (_589 (_544 "-v")))) ((_619 _544) "-r"))) (($B (_583 (($O 46) $K))) (($B _639) (_588 ((_607 _663) "-i")))))) (($B (_640 _614)) ((($C' _585) (($B _639) (_588 ((_607 _663) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _674) _602) 1)) (_687 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _614)) (_589 ((_641 _683) ((_641 (_544 (($O 45) $K))) (_600 1))))))) (_610 ((_641 _683) (_544 "--")))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _551)) _16) (($B ($B ($B (_551 _579)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _552) (($B (_640 _570)) (($B (_640 (_601 1000000))) _189)))))) (($B ($B ($B ($B (_551 _579))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _552))) ((($C' $B) ($B' (($B _640) (($B _569) ((($C' _678) _8) 0))))) (($B ($B (_640 _572))) (($B ($B (_585 "combinator conversion "))) ((($C' ($C' _585)) (($B ($B (_546 6))) (($B ($B _533)) _672))) "ms"))))))) (($B ($B _553)) (($B $P) (($C _497) (_491 "main")))))))) (_587 ($T ((($C' ($C' $O)) ((($C' $B) $P) _353)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_551 _504)))) (($B ($B ($B (($C' _505) ((($C' _667) (($B _602) (_610 ((_641 _683) (_544 "--"))))) 1))))) (($B ($B ($B (_640 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _482))) (($C' ($C' _587)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _640) (($B _637) (($B (_640 _687)) (($B (_585 "not found ")) _495))))) ($C _483))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _352))) (($B (_640 (_637 (_687 "primlookup")))) (($C (_623 _544)) _5))))) (_687 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -148,7 +148,12 @@
primStdin = stdin
primStdout = stdout
primStderr = stderr
+primGetArgs :: IO [[Char]]
primGetArgs = getArgs
+primWithDropArgs :: Int -> IO a -> IO a
+primWithDropArgs i ioa = do
+ as <- getArgs
+ withArgs (drop i as) ioa
primPerformIO :: IO a -> a
primPerformIO = unsafePerformIO
-- Current time (since 1970-01-01T00:00:00UTC) in ms
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -115,7 +115,12 @@
primStderr = primitive "IO.stderr"
primGetArgs :: IO [[Char]]
primGetArgs = primitive "IO.getArgs"
+primDropArgs :: Int -> IO ()
+primDropArgs = primitive "IO.dropArgs"
primPerformIO :: forall a . IO a -> a
primPerformIO = primitive "IO.performIO"
primGetTimeMilli :: IO Int
primGetTimeMilli = primitive "IO.getTimeMilli"
+
+primWithDropArgs :: forall a . Int -> IO a -> IO a
+primWithDropArgs i ioa = primThen (primDropArgs i) ioa
--- a/lib/System/Environment.hs
+++ b/lib/System/Environment.hs
@@ -2,7 +2,11 @@
-- See LICENSE file for full license.
module System.Environment(module System.Environment) where
import Primitives
-import Data.Char -- for String
+--import Data.Char -- for String
+import System.IO --Y()
-getArgs :: IO [String]
+getArgs :: IO [[Char]]
getArgs = primGetArgs
+
+withDropArgs :: forall a . Int -> IO a -> IO a
+withDropArgs = primWithDropArgs
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -8,6 +8,7 @@
import qualified Control.Monad as M
import Control.Exception
import Data.List
+import System.Environment
import System.IO
-- Functions needed for ghc
@@ -132,3 +133,9 @@
rec r [] = (reverse r, [])
rec r (x:xs) = if p x then rec (x:r) xs else (reverse (x:r), xs)
in rec []
+
+-- A hack until we have a real withArgs
+withDropArgs :: Int -> IO a -> IO a
+withDropArgs i ioa = do
+ as <- getArgs
+ withArgs (drop i as) ioa
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -16,8 +16,9 @@
main :: IO ()
main = do
- args <- getArgs
+ aargs <- getArgs
let
+ args = takeWhile (not . eqString "--") aargs
mn =
let
ss = filter (not . (eqString "-") . take 1) args
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -6,6 +6,7 @@
import Prelude
import Data.Maybe
import qualified MicroHs.IdentMap as M
+import System.Environment
--Ximport GHC.Types
import Unsafe.Coerce
--Ximport Compat
@@ -18,13 +19,17 @@
import MicroHs.Ident
translate :: (Ident, [LDef]) -> IO ()
-translate (mainName, ds) =
+translate (mainName, ds) = do
let
--Xlook :: M.Map Any -> Ident -> Any
look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup n m
--Xmp :: M.Map Any
mp = M.fromList [(n, trans (look mp) d) | (n, d) <- ds ]
- in unsafeCoerce $ look mp mainName
+ -- Drop all argument up to '--'
+ args <- getArgs
+ let prog = unsafeCoerce $ look mp mainName
+ withDropArgs (length (takeWhile (not . eqString "--") args) + 1)
+ prog
trans :: (Ident -> Any) -> Exp -> Any
trans r ae =
@@ -88,5 +93,6 @@
("IO.stdout", primitive "IO.stdout"), ("IO.stderr", primitive "IO.stderr"), ("IO.getArgs", primitive "IO.getArgs"),+ ("IO.dropArgs", primitive "IO.dropArgs"), ("IO.performIO", primitive "IO.performIO")]
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -89,7 +89,8 @@
T_ERROR, T_SEQ,
T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
- T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_PERFORMIO,
+ T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
+ T_IO_PERFORMIO,
T_IO_GETTIMEMILLI, T_IO_PRINT,
T_STR,
T_LAST_TAG,
@@ -389,6 +390,7 @@
{ "IO.stdout", T_IO_STDOUT }, { "IO.stderr", T_IO_STDERR }, { "IO.getArgs", T_IO_GETARGS },+ { "IO.dropArgs", T_IO_DROPARGS }, { "IO.getTimeMilli", T_IO_GETTIMEMILLI }, { "IO.performIO", T_IO_PERFORMIO },};
@@ -1005,6 +1007,7 @@
case T_IO_CLOSE: fprintf(f, "$IO.close"); break;
case T_IO_ISNULLHANDLE: fprintf(f, "$IO.isNullHandle"); break;
case T_IO_GETARGS: fprintf(f, "$IO.getArgs"); break;
+ case T_IO_DROPARGS: fprintf(f, "$IO.dropArgs"); break;
case T_IO_GETTIMEMILLI: fprintf(f, "$IO.getTimeMilli"); break;
case T_IO_PERFORMIO: fprintf(f, "$IO.performIO"); break;
default: ERR("print tag");@@ -1320,6 +1323,7 @@
case T_IO_OPEN:
case T_IO_CLOSE:
case T_IO_GETARGS:
+ case T_IO_DROPARGS:
case T_IO_GETTIMEMILLI:
RET;
@@ -1478,6 +1482,14 @@
}
}
RETIO(n);
+ case T_IO_DROPARGS:
+ CHECKIO(1);
+ c = (int)evalint(ARG(TOP(1)));
+ if (c > glob_argc)
+ c = glob_argc;
+ glob_argc -= c;
+ glob_argv += c;
+ RETIO(combUnit);
case T_IO_GETTIMEMILLI:
CHECKIO(0);
GCCHECK(1);
--
⑨