Changeset 4871
- Timestamp:
- 06/20/05 16:11:39 (4 years ago)
- svk:copy_cache_prev:
- 6641
- Files:
-
- 1 removed
- 4 modified
-
src/Emit/PIR.hs (modified) (5 diffs)
-
src/Pugs/Compile.hs (modified) (1 diff)
-
src/Pugs/Compile/PIR.hs (modified) (7 diffs)
-
src/Pugs/Compile/Parrot.hs (deleted)
-
t/pugsrun/09-dash-uppercase-c.t (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/Emit/PIR.hs
r4861 r4871 489 489 vop1ss :: SubName -> PrimName -> Decl 490 490 vop1ss p6name opname = vop1x p6name opname tempSTR tempSTR 491 {-| Wrapper for a opcode which returns a @S@ register and accepts a @I@ register. -} 492 vop1si :: SubName -> PrimName -> Decl 493 vop1si p6name opname = vop1x p6name opname tempSTR tempINT 494 {-| Wrapper for a opcode which returns a @I@ register and accepts a @S@ register. -} 495 vop1is :: SubName -> PrimName -> Decl 496 vop1is p6name opname = vop1x p6name opname tempINT tempSTR 497 {-| Wrapper for a opcode which returns a @I@ register and accepts a @P@ register. -} 498 vop1ip :: SubName -> PrimName -> Decl 499 vop1ip p6name opname = vop1x p6name opname tempINT tempPMC 491 500 492 501 {-| Wrapper for a opcode which accepts and returns @I@ registers. -} … … 635 644 , "exit" .- [tempINT] 636 645 ] 646 , vop1is "&system" "spawnw" 637 647 638 648 -- Operators … … 701 711 702 712 -- Strings 703 , vop1 x "&chars" "length" tempINT tempSTR704 , vop1 x "&bytes" "bytelength" tempINT tempSTR713 , vop1is "&chars" "length" 714 , vop1is "&bytes" "bytelength" 705 715 , sub "&prefix:\\" [arg0] 706 716 [ tempPMC <-- "new" $ [lit PerlRef, arg0] … … 728 738 , rv <:= tempSTR2 729 739 ] --> [rv] 730 , vop1 x "&chr" "chr" tempSTR tempINT731 , vop1 x "&ord" "ord" tempINT tempSTR740 , vop1si "&chr" "chr" 741 , vop1is "&ord" "ord" 732 742 , vop2x "&infix:x" "repeat" tempSTR tempSTR tempINT 733 743 , vop1ss "&lc" "downcase" … … 742 752 , arg0 <== tempPMC 743 753 ] --> [arg0] 744 , vop1 x "&defined" "defined" tempINT tempPMC754 , vop1ip "&defined" "defined" 745 755 {- XXX saying hash 746 756 -- causes error:imcc:syntax error, unexpected IREG, expecting '(' -
src/Pugs/Compile.hs
r4655 r4871 13 13 import Pugs.AST 14 14 import Pugs.Internals 15 import Pugs.Compile.PIR (genPIR) 15 16 import Pugs.Compile.Pugs (genPugs) 16 import Pugs.Compile.Pugs2 (genPugs2)17 import Pugs.Compile.Parrot (genPIR)18 import Pugs.Compile.PIR (genPIR')19 17 import Pugs.Compile.Haskell (genGHC) 20 18 21 19 compile :: String -> Env -> IO String 20 compile "GHC" env = fmap vCast $ runEvalIO env genGHC 21 compile "Ghc" env = fmap vCast $ runEvalIO env genGHC 22 22 compile "Haskell" env = fmap vCast $ runEvalIO env genGHC 23 compile "Parrot" env = fmap vCast $ runEvalIO env genPIR 24 compile "Pir" env = fmap vCast $ runEvalIO env genPIR 25 compile "PIR" env = fmap vCast $ runEvalIO env genPIR 23 26 compile "Pugs" env = fmap vCast $ runEvalIO env genPugs 24 compile "Pugs2" env = fmap vCast $ runEvalIO env genPugs225 compile "Parrot" env = fmap vCast $ runEvalIO env genPIR26 compile "Pir" env = fmap vCast $ runEvalIO env genPIR'27 compile "PIR" env = fmap vCast $ runEvalIO env genPIR'28 27 compile s _ = fail $ "Cannot compile to " ++ s 29 28 -
src/Pugs/Compile/PIR.hs
r4869 r4871 1 1 {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-undecidable-instances -cpp #-} 2 2 3 module Pugs.Compile.PIR (genPIR') where 4 import Pugs.Compile.Parrot 3 module Pugs.Compile.PIR (genPIR) where 5 4 import Pugs.Internals 6 5 import Pugs.AST … … 20 19 PNoop :: PIL Stmt 21 20 22 PRaw :: !Exp -> PIL Stmt -- XXX HACK!23 21 PRawName :: !VarName -> PIL Expression -- XXX HACK! 24 22 … … 79 77 show (PThunk x) = "(PThunk " ++ show x ++ ")" 80 78 show (PBlock x) = "(PBlock " ++ show x ++ ")" 81 show (PRaw x) = "(PRaw " ++ show x ++ ")"82 79 show (PRawName x) = "(PRawName " ++ show x ++ ")" 83 80 show (PSub x y z) = "(PSub " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")" … … 175 172 compile (Stmts (Pad SMy pad exp) rest) = do 176 173 expC <- compile $ mergeStmts exp rest 177 padC <- mapM compile (padToList pad)174 padC <- compile $ padToList pad 178 175 return $ PPad ((map fst (padToList pad)) `zip` padC) expC 179 176 compile exp = compileStmts exp … … 494 491 tellLabel endC 495 492 return (ExpLV this) 496 trans (PRaw exp) = do497 env <- asks tEnv498 raw <- liftIO $ runEvalIO env{ envStash = "$P0" } $ do499 doc <- compile' exp500 return $ VStr (render doc)501 return $ StmtRaw (text $ vCast raw)502 493 trans (PRawName name) = do 503 494 -- generate fresh supply and things... … … 597 588 return $ reg (VAR var) 598 589 590 padSort :: (Var, [(TVar Bool, TVar VRef)]) -> (String, [(a, b)]) -> Ordering 591 padSort ((a::[Char]), [(_, _)]) ((b::[Char]), [(_, _)]) 592 | (head a == ':' && head b == '&') = LT 593 | (head b == ':' && head a == '&') = GT 594 | otherwise = GT 595 padSort _ _ = EQ 596 599 597 varText :: String -> Doc 600 598 varText ('$':name) = text $ "s__" ++ escaped name … … 611 609 612 610 {-| Compiles the current environment to PIR code. -} 613 genPIR ':: Eval Val614 genPIR '= do611 genPIR :: Eval Val 612 genPIR = do 615 613 tenv <- initTEnv 616 614 -- Load the PIR Prelude. 617 local (\env -> env{ envDebug = Nothing}) $ do615 local (\env -> env{ envDebug = Nothing }) $ do 618 616 opEval style "<prelude-pir>" preludeStr 619 617 glob <- askGlobal 620 618 main <- asks envBody 621 globPIL <- compile glob622 mainPIL <- compile main619 globPIL <- compile glob 620 mainPIL <- compile main 623 621 globPIR <- runTransGlob tenv globPIL :: Eval [Decl] 624 622 mainPIR <- runTransMain tenv mainPIL :: Eval [Stmt] -
t/pugsrun/09-dash-uppercase-c.t
r4549 r4871 15 15 my @t_good = map &flatten, ( 16 16 any('-C') 17 ~ any('Pugs', 'p ugs', 'pUGs')17 ~ any('Pugs', 'pUGs') 18 18 ~ ' ' 19 19 ~ any('-e1', map { "examples/$_.p6" } < … … 27 27 >), 28 28 any('-C') 29 ~ any('Parrot', 'pa rrot', 'paRRot')29 ~ any('Parrot', 'paRRot') 30 30 ~ ' ' 31 31 ~ any('-e1', map {"examples/$_.p6"} < … … 36 36 junctions/all-all 37 37 junctions/grades 38 functional/fp 39 algorithms/hanoi 40 junctions/all-any 38 41 >) 39 42 ); 40 43 41 my @t_todo = map &flatten, (42 '-C'43 ~ any('Parrot', 'parrot', 'paRRot')44 ~ ' examples/'45 ~ any(<46 functional/fp47 algorithms/hanoi48 junctions/all-any49 >) ~ '.p6'50 );51 52 44 # I don't know (yet) how to force a junction into expansion 53 my (@tests_ok ,@tests_todo);45 my (@tests_ok); 54 46 for @t_good -> $test { 55 47 push @tests_ok, $test; 56 48 }; 57 49 58 for @t_todo -> $test {59 push @tests_todo, $test;60 };61 50 62 63 plan ((+@tests_ok+@tests_todo)*3); 51 plan ((+@tests_ok)*2); 64 52 65 53 diag "Running under $*OS"; 66 54 67 55 # 2>&1 only works on WinNT upwards (cmd.exe) ! 68 my ($pugs,$redir, $redir_stderr) = ("./pugs", ">" , "2>&1");56 my ($pugs,$redir, $redir_stderr) = ("./pugs", ">"); 69 57 if($*OS eq any(<MSWin32 mingw msys cygwin>)) { 70 58 $pugs = 'pugs.exe'; … … 74 62 sub run_pugs ($c) { 75 63 my $tempfile = "temp-ex-output" ~ nonce; 76 my $command = "$pugs $c $redir $tempfile $redir_stderr";64 my $command = "$pugs $c $redir $tempfile"; 77 65 diag $command; 78 66 system $command; … … 89 77 $fh.close(); 90 78 91 my $output = run_pugs($test); 92 is( $output, "", "No error output"); 93 94 my $f = slurp $dump_file; 95 ok( defined $f, "dump.ast was created" ); 79 my $f = run_pugs($test); 80 ok( defined $f, "dump file was created" ); 96 81 ok( $f ~~ rx:perl5/.../, "... and it contains some output" ); 97 82 … … 100 85 }; 101 86 102 for @tests_todo -> $test {103 104 my $fh = open("$dump_file", :w);105 $fh.close();106 107 my $output = run_pugs($test);108 if (is( $output, "", "No error output", :todo)) {109 110 my $f = slurp $dump_file;111 ok( defined $f, "dump.ast was created" );112 ok( $f ~~ rx:perl5/.../, "... and it contains some output" , :todo);113 } else {114 fail("No clean compile", :todo);115 fail("No clean compile", :todo);116 };117 118 unlink($dump_file)119 or diag "$dump_file was not removed for next run";120 };
