timberc (empty) → 1.0.1
raw patch · 78 files changed
+33207/−0 lines, 78 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, bzlib, filepath, haskell98, mtl, pretty
Files
- LICENSE +32/−0
- Setup.lhs +33/−0
- dist/build/timberc/timberc-tmp/Parser.hs +3712/−0
- examples/Counter.t +18/−0
- examples/Echo.t +13/−0
- examples/Echo2.t +22/−0
- examples/Echo3.t +19/−0
- examples/EchoServer.t +35/−0
- examples/EchoServer2.t +49/−0
- examples/Makefile +14/−0
- examples/MasterMind.t +131/−0
- examples/PingTimeServers.t +42/−0
- examples/Primes.t +40/−0
- examples/Reflex.t +43/−0
- examples/TCPClient.t +42/−0
- examples/UnionFind.t +37/−0
- include/arrays.c +90/−0
- include/float.c +53/−0
- include/timber.c +162/−0
- include/timber.h +173/−0
- lib/BitOps.t +174/−0
- lib/Data.Functional.List.t +117/−0
- lib/Data.Objects.Dictionary.t +104/−0
- lib/Data.Objects.Stack.t +58/−0
- lib/POSIX.t +86/−0
- lib/Prelude.t +553/−0
- lib/RandomGenerator.t +60/−0
- rtsPOSIX/Makefile.in +42/−0
- rtsPOSIX/config.guess +1526/−0
- rtsPOSIX/config.h.in +69/−0
- rtsPOSIX/config.sub +1658/−0
- rtsPOSIX/configure +6122/−0
- rtsPOSIX/cyclic.c +144/−0
- rtsPOSIX/env.c +618/−0
- rtsPOSIX/env.h +46/−0
- rtsPOSIX/gc.c +373/−0
- rtsPOSIX/install-sh +294/−0
- rtsPOSIX/main.c +52/−0
- rtsPOSIX/rts.c +500/−0
- rtsPOSIX/rts.h +185/−0
- rtsPOSIX/timberc.cfg.in +5/−0
- rtsPOSIX/timer.c +305/−0
- src/Common.hs +657/−0
- src/Config.hs +326/−0
- src/Core.hs +1151/−0
- src/Core2Kindle.hs +887/−0
- src/Decls.hs +208/−0
- src/Depend.hs +119/−0
- src/Derive.hs +199/−0
- src/Desugar1.hs +395/−0
- src/Desugar2.hs +393/−0
- src/Env.hs +881/−0
- src/Execution.hs +119/−0
- src/Fixity.hs +110/−0
- src/Interfaces.hs +270/−0
- src/Kind.hs +231/−0
- src/Kindle.hs +776/−0
- src/Kindle2C.hs +487/−0
- src/Kindlered.hs +231/−0
- src/Lambdalift.hs +182/−0
- src/Lexer.hs +460/−0
- src/Main.hs +448/−0
- src/Match.hs +175/−0
- src/Name.hs +619/−0
- src/PP.hs +91/−0
- src/ParseMonad.hs +136/−0
- src/Parser.y +686/−0
- src/Prepare4C.hs +547/−0
- src/Reduce.hs +950/−0
- src/Rename.hs +516/−0
- src/Syntax.hs +1051/−0
- src/Syntax2Core.hs +412/−0
- src/Termred.hs +465/−0
- src/Token.hs +179/−0
- src/Type.hs +535/−0
- src/Type2.hs +284/−0
- timberc.cabal +97/−0
- timberc.spec +83/−0
+ LICENSE view
@@ -0,0 +1,32 @@+The Timber compiler <timber-lang.org>++Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the names of the copyright holder and any identified+ contributors, nor the names of their affiliations, may be used to + endorse or promote products derived from this software without + specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,33 @@+#! /usr/bin/env runhaskell++ +> import System.Cmd+> import System.Directory+> import System.FilePath++> import Distribution.Simple.UserHooks+> import Distribution.Simple.Setup+> import Distribution.Simple.Command+> import Distribution.Simple.Utils ( rawSystemExit )+> import Distribution.Simple -- (defaultMainWithHooks, autoconfUserHooks)+> import Distribution.Simple.InstallDirs (CopyDest(..))+> import Distribution.Simple.LocalBuildInfo (absoluteInstallDirs, InstallDirs(..) )+> main = defaultMainWithHooks simpleUserHooks { postInst = myPostInst }++> buildRTS timberc dataDir+> = do +> system("cd rtsPOSIX && chmod +x configure")+> system("cd rtsPOSIX && ./configure --prefix=" ++ dataDir ++ " --with-timberc=" ++ timberc)+> system("cd rtsPOSIX && make install")+> return ()++> myPostInst args iflags pkg_descr lbi = do+> let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest +> dataDir = datadir dirs+> timberc = bindir dirs </> "timberc"+> script = "#!/bin/sh\n\nexec " ++ dataDir ++ "/timberc ${1+\"$@\"} --datadir " ++ dataDir ++ "\n"+> copyFile timberc (dataDir </> "timberc")+> writeFile timberc script+> buildRTS timberc dataDir+> return ()+
+ dist/build/timberc/timberc-tmp/Parser.hs view
@@ -0,0 +1,3712 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+module Parser (parser) where++import Common+import Token+import Lexer+import ParseMonad+import Syntax+import Fixity+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif++-- parser produced by Happy Version 1.18.2++newtype HappyAbsSyn = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = GHC.Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: (Module) -> (HappyAbsSyn )+happyIn4 x = unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn ) -> (Module)+happyOut4 x = unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: (([Import],[Decl],[Decl])) -> (HappyAbsSyn )+happyIn5 x = unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn ) -> (([Import],[Decl],[Decl]))+happyOut5 x = unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: ([Decl]) -> (HappyAbsSyn )+happyIn6 x = unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn ) -> ([Decl])+happyOut6 x = unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: ([Decl]) -> (HappyAbsSyn )+happyIn7 x = unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn ) -> ([Decl])+happyOut7 x = unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: ([Import]) -> (HappyAbsSyn )+happyIn8 x = unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn ) -> ([Import])+happyOut8 x = unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: (Import) -> (HappyAbsSyn )+happyIn9 x = unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn ) -> (Import)+happyOut9 x = unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyIn10 :: ([Decl]) -> (HappyAbsSyn )+happyIn10 x = unsafeCoerce# x+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn ) -> ([Decl])+happyOut10 x = unsafeCoerce# x+{-# INLINE happyOut10 #-}+happyIn11 :: ([Decl]) -> (HappyAbsSyn )+happyIn11 x = unsafeCoerce# x+{-# INLINE happyIn11 #-}+happyOut11 :: (HappyAbsSyn ) -> ([Decl])+happyOut11 x = unsafeCoerce# x+{-# INLINE happyOut11 #-}+happyIn12 :: ([Type]) -> (HappyAbsSyn )+happyIn12 x = unsafeCoerce# x+{-# INLINE happyIn12 #-}+happyOut12 :: (HappyAbsSyn ) -> ([Type])+happyOut12 x = unsafeCoerce# x+{-# INLINE happyOut12 #-}+happyIn13 :: ([Type]) -> (HappyAbsSyn )+happyIn13 x = unsafeCoerce# x+{-# INLINE happyIn13 #-}+happyOut13 :: (HappyAbsSyn ) -> ([Type])+happyOut13 x = unsafeCoerce# x+{-# INLINE happyOut13 #-}+happyIn14 :: ([Type]) -> (HappyAbsSyn )+happyIn14 x = unsafeCoerce# x+{-# INLINE happyIn14 #-}+happyOut14 :: (HappyAbsSyn ) -> ([Type])+happyOut14 x = unsafeCoerce# x+{-# INLINE happyOut14 #-}+happyIn15 :: ([Name]) -> (HappyAbsSyn )+happyIn15 x = unsafeCoerce# x+{-# INLINE happyIn15 #-}+happyOut15 :: (HappyAbsSyn ) -> ([Name])+happyOut15 x = unsafeCoerce# x+{-# INLINE happyOut15 #-}+happyIn16 :: ([Name]) -> (HappyAbsSyn )+happyIn16 x = unsafeCoerce# x+{-# INLINE happyIn16 #-}+happyOut16 :: (HappyAbsSyn ) -> ([Name])+happyOut16 x = unsafeCoerce# x+{-# INLINE happyOut16 #-}+happyIn17 :: ([Default Type]) -> (HappyAbsSyn )+happyIn17 x = unsafeCoerce# x+{-# INLINE happyIn17 #-}+happyOut17 :: (HappyAbsSyn ) -> ([Default Type])+happyOut17 x = unsafeCoerce# x+{-# INLINE happyOut17 #-}+happyIn18 :: ([Default Type]) -> (HappyAbsSyn )+happyIn18 x = unsafeCoerce# x+{-# INLINE happyIn18 #-}+happyOut18 :: (HappyAbsSyn ) -> ([Default Type])+happyOut18 x = unsafeCoerce# x+{-# INLINE happyOut18 #-}+happyIn19 :: (Default Type) -> (HappyAbsSyn )+happyIn19 x = unsafeCoerce# x+{-# INLINE happyIn19 #-}+happyOut19 :: (HappyAbsSyn ) -> (Default Type)+happyOut19 x = unsafeCoerce# x+{-# INLINE happyOut19 #-}+happyIn20 :: ([Constr]) -> (HappyAbsSyn )+happyIn20 x = unsafeCoerce# x+{-# INLINE happyIn20 #-}+happyOut20 :: (HappyAbsSyn ) -> ([Constr])+happyOut20 x = unsafeCoerce# x+{-# INLINE happyOut20 #-}+happyIn21 :: ([Constr]) -> (HappyAbsSyn )+happyIn21 x = unsafeCoerce# x+{-# INLINE happyIn21 #-}+happyOut21 :: (HappyAbsSyn ) -> ([Constr])+happyOut21 x = unsafeCoerce# x+{-# INLINE happyOut21 #-}+happyIn22 :: ([Sig]) -> (HappyAbsSyn )+happyIn22 x = unsafeCoerce# x+{-# INLINE happyIn22 #-}+happyOut22 :: (HappyAbsSyn ) -> ([Sig])+happyOut22 x = unsafeCoerce# x+{-# INLINE happyOut22 #-}+happyIn23 :: ([Sig]) -> (HappyAbsSyn )+happyIn23 x = unsafeCoerce# x+{-# INLINE happyIn23 #-}+happyOut23 :: (HappyAbsSyn ) -> ([Sig])+happyOut23 x = unsafeCoerce# x+{-# INLINE happyOut23 #-}+happyIn24 :: ([Sig]) -> (HappyAbsSyn )+happyIn24 x = unsafeCoerce# x+{-# INLINE happyIn24 #-}+happyOut24 :: (HappyAbsSyn ) -> ([Sig])+happyOut24 x = unsafeCoerce# x+{-# INLINE happyOut24 #-}+happyIn25 :: ([Sig]) -> (HappyAbsSyn )+happyIn25 x = unsafeCoerce# x+{-# INLINE happyIn25 #-}+happyOut25 :: (HappyAbsSyn ) -> ([Sig])+happyOut25 x = unsafeCoerce# x+{-# INLINE happyOut25 #-}+happyIn26 :: (Sig) -> (HappyAbsSyn )+happyIn26 x = unsafeCoerce# x+{-# INLINE happyIn26 #-}+happyOut26 :: (HappyAbsSyn ) -> (Sig)+happyOut26 x = unsafeCoerce# x+{-# INLINE happyOut26 #-}+happyIn27 :: ([Bind]) -> (HappyAbsSyn )+happyIn27 x = unsafeCoerce# x+{-# INLINE happyIn27 #-}+happyOut27 :: (HappyAbsSyn ) -> ([Bind])+happyOut27 x = unsafeCoerce# x+{-# INLINE happyOut27 #-}+happyIn28 :: ([Bind]) -> (HappyAbsSyn )+happyIn28 x = unsafeCoerce# x+{-# INLINE happyIn28 #-}+happyOut28 :: (HappyAbsSyn ) -> ([Bind])+happyOut28 x = unsafeCoerce# x+{-# INLINE happyOut28 #-}+happyIn29 :: (Bind) -> (HappyAbsSyn )+happyIn29 x = unsafeCoerce# x+{-# INLINE happyIn29 #-}+happyOut29 :: (HappyAbsSyn ) -> (Bind)+happyOut29 x = unsafeCoerce# x+{-# INLINE happyOut29 #-}+happyIn30 :: ([Field]) -> (HappyAbsSyn )+happyIn30 x = unsafeCoerce# x+{-# INLINE happyIn30 #-}+happyOut30 :: (HappyAbsSyn ) -> ([Field])+happyOut30 x = unsafeCoerce# x+{-# INLINE happyOut30 #-}+happyIn31 :: (Field) -> (HappyAbsSyn )+happyIn31 x = unsafeCoerce# x+{-# INLINE happyIn31 #-}+happyOut31 :: (HappyAbsSyn ) -> (Field)+happyOut31 x = unsafeCoerce# x+{-# INLINE happyOut31 #-}+happyIn32 :: ([Name]) -> (HappyAbsSyn )+happyIn32 x = unsafeCoerce# x+{-# INLINE happyIn32 #-}+happyOut32 :: (HappyAbsSyn ) -> ([Name])+happyOut32 x = unsafeCoerce# x+{-# INLINE happyOut32 #-}+happyIn33 :: (Lhs) -> (HappyAbsSyn )+happyIn33 x = unsafeCoerce# x+{-# INLINE happyIn33 #-}+happyOut33 :: (HappyAbsSyn ) -> (Lhs)+happyOut33 x = unsafeCoerce# x+{-# INLINE happyOut33 #-}+happyIn34 :: (Rhs Exp) -> (HappyAbsSyn )+happyIn34 x = unsafeCoerce# x+{-# INLINE happyIn34 #-}+happyOut34 :: (HappyAbsSyn ) -> (Rhs Exp)+happyOut34 x = unsafeCoerce# x+{-# INLINE happyOut34 #-}+happyIn35 :: ([GExp Exp]) -> (HappyAbsSyn )+happyIn35 x = unsafeCoerce# x+{-# INLINE happyIn35 #-}+happyOut35 :: (HappyAbsSyn ) -> ([GExp Exp])+happyOut35 x = unsafeCoerce# x+{-# INLINE happyOut35 #-}+happyIn36 :: (GExp Exp) -> (HappyAbsSyn )+happyIn36 x = unsafeCoerce# x+{-# INLINE happyIn36 #-}+happyOut36 :: (HappyAbsSyn ) -> (GExp Exp)+happyOut36 x = unsafeCoerce# x+{-# INLINE happyOut36 #-}+happyIn37 :: (Type) -> (HappyAbsSyn )+happyIn37 x = unsafeCoerce# x+{-# INLINE happyIn37 #-}+happyOut37 :: (HappyAbsSyn ) -> (Type)+happyOut37 x = unsafeCoerce# x+{-# INLINE happyOut37 #-}+happyIn38 :: (Type) -> (HappyAbsSyn )+happyIn38 x = unsafeCoerce# x+{-# INLINE happyIn38 #-}+happyOut38 :: (HappyAbsSyn ) -> (Type)+happyOut38 x = unsafeCoerce# x+{-# INLINE happyOut38 #-}+happyIn39 :: ([Type]) -> (HappyAbsSyn )+happyIn39 x = unsafeCoerce# x+{-# INLINE happyIn39 #-}+happyOut39 :: (HappyAbsSyn ) -> ([Type])+happyOut39 x = unsafeCoerce# x+{-# INLINE happyOut39 #-}+happyIn40 :: (Type) -> (HappyAbsSyn )+happyIn40 x = unsafeCoerce# x+{-# INLINE happyIn40 #-}+happyOut40 :: (HappyAbsSyn ) -> (Type)+happyOut40 x = unsafeCoerce# x+{-# INLINE happyOut40 #-}+happyIn41 :: (Type) -> (HappyAbsSyn )+happyIn41 x = unsafeCoerce# x+{-# INLINE happyIn41 #-}+happyOut41 :: (HappyAbsSyn ) -> (Type)+happyOut41 x = unsafeCoerce# x+{-# INLINE happyOut41 #-}+happyIn42 :: ([Type]) -> (HappyAbsSyn )+happyIn42 x = unsafeCoerce# x+{-# INLINE happyIn42 #-}+happyOut42 :: (HappyAbsSyn ) -> ([Type])+happyOut42 x = unsafeCoerce# x+{-# INLINE happyOut42 #-}+happyIn43 :: (Int) -> (HappyAbsSyn )+happyIn43 x = unsafeCoerce# x+{-# INLINE happyIn43 #-}+happyOut43 :: (HappyAbsSyn ) -> (Int)+happyOut43 x = unsafeCoerce# x+{-# INLINE happyOut43 #-}+happyIn44 :: ([Pred]) -> (HappyAbsSyn )+happyIn44 x = unsafeCoerce# x+{-# INLINE happyIn44 #-}+happyOut44 :: (HappyAbsSyn ) -> ([Pred])+happyOut44 x = unsafeCoerce# x+{-# INLINE happyOut44 #-}+happyIn45 :: (Pred) -> (HappyAbsSyn )+happyIn45 x = unsafeCoerce# x+{-# INLINE happyIn45 #-}+happyOut45 :: (HappyAbsSyn ) -> (Pred)+happyOut45 x = unsafeCoerce# x+{-# INLINE happyOut45 #-}+happyIn46 :: (Kind) -> (HappyAbsSyn )+happyIn46 x = unsafeCoerce# x+{-# INLINE happyIn46 #-}+happyOut46 :: (HappyAbsSyn ) -> (Kind)+happyOut46 x = unsafeCoerce# x+{-# INLINE happyOut46 #-}+happyIn47 :: (Kind) -> (HappyAbsSyn )+happyIn47 x = unsafeCoerce# x+{-# INLINE happyIn47 #-}+happyOut47 :: (HappyAbsSyn ) -> (Kind)+happyOut47 x = unsafeCoerce# x+{-# INLINE happyOut47 #-}+happyIn48 :: (Exp) -> (HappyAbsSyn )+happyIn48 x = unsafeCoerce# x+{-# INLINE happyIn48 #-}+happyOut48 :: (HappyAbsSyn ) -> (Exp)+happyOut48 x = unsafeCoerce# x+{-# INLINE happyOut48 #-}+happyIn49 :: (Exp) -> (HappyAbsSyn )+happyIn49 x = unsafeCoerce# x+{-# INLINE happyIn49 #-}+happyOut49 :: (HappyAbsSyn ) -> (Exp)+happyOut49 x = unsafeCoerce# x+{-# INLINE happyOut49 #-}+happyIn50 :: (Exp) -> (HappyAbsSyn )+happyIn50 x = unsafeCoerce# x+{-# INLINE happyIn50 #-}+happyOut50 :: (HappyAbsSyn ) -> (Exp)+happyOut50 x = unsafeCoerce# x+{-# INLINE happyOut50 #-}+happyIn51 :: (Exp) -> (HappyAbsSyn )+happyIn51 x = unsafeCoerce# x+{-# INLINE happyIn51 #-}+happyOut51 :: (HappyAbsSyn ) -> (Exp)+happyOut51 x = unsafeCoerce# x+{-# INLINE happyOut51 #-}+happyIn52 :: (OpExp) -> (HappyAbsSyn )+happyIn52 x = unsafeCoerce# x+{-# INLINE happyIn52 #-}+happyOut52 :: (HappyAbsSyn ) -> (OpExp)+happyOut52 x = unsafeCoerce# x+{-# INLINE happyOut52 #-}+happyIn53 :: (OpExp) -> (HappyAbsSyn )+happyIn53 x = unsafeCoerce# x+{-# INLINE happyIn53 #-}+happyOut53 :: (HappyAbsSyn ) -> (OpExp)+happyOut53 x = unsafeCoerce# x+{-# INLINE happyOut53 #-}+happyIn54 :: (Exp) -> (HappyAbsSyn )+happyIn54 x = unsafeCoerce# x+{-# INLINE happyIn54 #-}+happyOut54 :: (HappyAbsSyn ) -> (Exp)+happyOut54 x = unsafeCoerce# x+{-# INLINE happyOut54 #-}+happyIn55 :: (Exp) -> (HappyAbsSyn )+happyIn55 x = unsafeCoerce# x+{-# INLINE happyIn55 #-}+happyOut55 :: (HappyAbsSyn ) -> (Exp)+happyOut55 x = unsafeCoerce# x+{-# INLINE happyOut55 #-}+happyIn56 :: (Exp) -> (HappyAbsSyn )+happyIn56 x = unsafeCoerce# x+{-# INLINE happyIn56 #-}+happyOut56 :: (HappyAbsSyn ) -> (Exp)+happyOut56 x = unsafeCoerce# x+{-# INLINE happyOut56 #-}+happyIn57 :: (Exp) -> (HappyAbsSyn )+happyIn57 x = unsafeCoerce# x+{-# INLINE happyIn57 #-}+happyOut57 :: (HappyAbsSyn ) -> (Exp)+happyOut57 x = unsafeCoerce# x+{-# INLINE happyOut57 #-}+happyIn58 :: (Exp) -> (HappyAbsSyn )+happyIn58 x = unsafeCoerce# x+{-# INLINE happyIn58 #-}+happyOut58 :: (HappyAbsSyn ) -> (Exp)+happyOut58 x = unsafeCoerce# x+{-# INLINE happyOut58 #-}+happyIn59 :: (Exp) -> (HappyAbsSyn )+happyIn59 x = unsafeCoerce# x+{-# INLINE happyIn59 #-}+happyOut59 :: (HappyAbsSyn ) -> (Exp)+happyOut59 x = unsafeCoerce# x+{-# INLINE happyOut59 #-}+happyIn60 :: (Exp) -> (HappyAbsSyn )+happyIn60 x = unsafeCoerce# x+{-# INLINE happyIn60 #-}+happyOut60 :: (HappyAbsSyn ) -> (Exp)+happyOut60 x = unsafeCoerce# x+{-# INLINE happyOut60 #-}+happyIn61 :: (Lit) -> (HappyAbsSyn )+happyIn61 x = unsafeCoerce# x+{-# INLINE happyIn61 #-}+happyOut61 :: (HappyAbsSyn ) -> (Lit)+happyOut61 x = unsafeCoerce# x+{-# INLINE happyOut61 #-}+happyIn62 :: (Exp) -> (HappyAbsSyn )+happyIn62 x = unsafeCoerce# x+{-# INLINE happyIn62 #-}+happyOut62 :: (HappyAbsSyn ) -> (Exp)+happyOut62 x = unsafeCoerce# x+{-# INLINE happyOut62 #-}+happyIn63 :: ([Exp]) -> (HappyAbsSyn )+happyIn63 x = unsafeCoerce# x+{-# INLINE happyIn63 #-}+happyOut63 :: (HappyAbsSyn ) -> ([Exp])+happyOut63 x = unsafeCoerce# x+{-# INLINE happyOut63 #-}+happyIn64 :: ([Qual]) -> (HappyAbsSyn )+happyIn64 x = unsafeCoerce# x+{-# INLINE happyIn64 #-}+happyOut64 :: (HappyAbsSyn ) -> ([Qual])+happyOut64 x = unsafeCoerce# x+{-# INLINE happyOut64 #-}+happyIn65 :: (Qual) -> (HappyAbsSyn )+happyIn65 x = unsafeCoerce# x+{-# INLINE happyIn65 #-}+happyOut65 :: (HappyAbsSyn ) -> (Qual)+happyOut65 x = unsafeCoerce# x+{-# INLINE happyOut65 #-}+happyIn66 :: ([Alt Exp]) -> (HappyAbsSyn )+happyIn66 x = unsafeCoerce# x+{-# INLINE happyIn66 #-}+happyOut66 :: (HappyAbsSyn ) -> ([Alt Exp])+happyOut66 x = unsafeCoerce# x+{-# INLINE happyOut66 #-}+happyIn67 :: ([Alt Exp]) -> (HappyAbsSyn )+happyIn67 x = unsafeCoerce# x+{-# INLINE happyIn67 #-}+happyOut67 :: (HappyAbsSyn ) -> ([Alt Exp])+happyOut67 x = unsafeCoerce# x+{-# INLINE happyOut67 #-}+happyIn68 :: (Alt Exp) -> (HappyAbsSyn )+happyIn68 x = unsafeCoerce# x+{-# INLINE happyIn68 #-}+happyOut68 :: (HappyAbsSyn ) -> (Alt Exp)+happyOut68 x = unsafeCoerce# x+{-# INLINE happyOut68 #-}+happyIn69 :: (Rhs Exp) -> (HappyAbsSyn )+happyIn69 x = unsafeCoerce# x+{-# INLINE happyIn69 #-}+happyOut69 :: (HappyAbsSyn ) -> (Rhs Exp)+happyOut69 x = unsafeCoerce# x+{-# INLINE happyOut69 #-}+happyIn70 :: ([GExp Exp]) -> (HappyAbsSyn )+happyIn70 x = unsafeCoerce# x+{-# INLINE happyIn70 #-}+happyOut70 :: (HappyAbsSyn ) -> ([GExp Exp])+happyOut70 x = unsafeCoerce# x+{-# INLINE happyOut70 #-}+happyIn71 :: (GExp Exp) -> (HappyAbsSyn )+happyIn71 x = unsafeCoerce# x+{-# INLINE happyIn71 #-}+happyOut71 :: (HappyAbsSyn ) -> (GExp Exp)+happyOut71 x = unsafeCoerce# x+{-# INLINE happyOut71 #-}+happyIn72 :: ([Alt [Stmt]]) -> (HappyAbsSyn )+happyIn72 x = unsafeCoerce# x+{-# INLINE happyIn72 #-}+happyOut72 :: (HappyAbsSyn ) -> ([Alt [Stmt]])+happyOut72 x = unsafeCoerce# x+{-# INLINE happyOut72 #-}+happyIn73 :: ([Alt [Stmt]]) -> (HappyAbsSyn )+happyIn73 x = unsafeCoerce# x+{-# INLINE happyIn73 #-}+happyOut73 :: (HappyAbsSyn ) -> ([Alt [Stmt]])+happyOut73 x = unsafeCoerce# x+{-# INLINE happyOut73 #-}+happyIn74 :: (Alt [Stmt]) -> (HappyAbsSyn )+happyIn74 x = unsafeCoerce# x+{-# INLINE happyIn74 #-}+happyOut74 :: (HappyAbsSyn ) -> (Alt [Stmt])+happyOut74 x = unsafeCoerce# x+{-# INLINE happyOut74 #-}+happyIn75 :: (Rhs [Stmt]) -> (HappyAbsSyn )+happyIn75 x = unsafeCoerce# x+{-# INLINE happyIn75 #-}+happyOut75 :: (HappyAbsSyn ) -> (Rhs [Stmt])+happyOut75 x = unsafeCoerce# x+{-# INLINE happyOut75 #-}+happyIn76 :: ([GExp [Stmt]]) -> (HappyAbsSyn )+happyIn76 x = unsafeCoerce# x+{-# INLINE happyIn76 #-}+happyOut76 :: (HappyAbsSyn ) -> ([GExp [Stmt]])+happyOut76 x = unsafeCoerce# x+{-# INLINE happyOut76 #-}+happyIn77 :: (GExp [Stmt]) -> (HappyAbsSyn )+happyIn77 x = unsafeCoerce# x+{-# INLINE happyIn77 #-}+happyOut77 :: (HappyAbsSyn ) -> (GExp [Stmt])+happyOut77 x = unsafeCoerce# x+{-# INLINE happyOut77 #-}+happyIn78 :: ([Stmt]) -> (HappyAbsSyn )+happyIn78 x = unsafeCoerce# x+{-# INLINE happyIn78 #-}+happyOut78 :: (HappyAbsSyn ) -> ([Stmt])+happyOut78 x = unsafeCoerce# x+{-# INLINE happyOut78 #-}+happyIn79 :: ([Stmt]) -> (HappyAbsSyn )+happyIn79 x = unsafeCoerce# x+{-# INLINE happyIn79 #-}+happyOut79 :: (HappyAbsSyn ) -> ([Stmt])+happyOut79 x = unsafeCoerce# x+{-# INLINE happyOut79 #-}+happyIn80 :: ([Stmt]) -> (HappyAbsSyn )+happyIn80 x = unsafeCoerce# x+{-# INLINE happyIn80 #-}+happyOut80 :: (HappyAbsSyn ) -> ([Stmt])+happyOut80 x = unsafeCoerce# x+{-# INLINE happyOut80 #-}+happyIn81 :: (Stmt) -> (HappyAbsSyn )+happyIn81 x = unsafeCoerce# x+{-# INLINE happyIn81 #-}+happyOut81 :: (HappyAbsSyn ) -> (Stmt)+happyOut81 x = unsafeCoerce# x+{-# INLINE happyOut81 #-}+happyIn82 :: (Exp) -> (HappyAbsSyn )+happyIn82 x = unsafeCoerce# x+{-# INLINE happyIn82 #-}+happyOut82 :: (HappyAbsSyn ) -> (Exp)+happyOut82 x = unsafeCoerce# x+{-# INLINE happyOut82 #-}+happyIn83 :: (Exp) -> (HappyAbsSyn )+happyIn83 x = unsafeCoerce# x+{-# INLINE happyIn83 #-}+happyOut83 :: (HappyAbsSyn ) -> (Exp)+happyOut83 x = unsafeCoerce# x+{-# INLINE happyOut83 #-}+happyIn84 :: (Exp) -> (HappyAbsSyn )+happyIn84 x = unsafeCoerce# x+{-# INLINE happyIn84 #-}+happyOut84 :: (HappyAbsSyn ) -> (Exp)+happyOut84 x = unsafeCoerce# x+{-# INLINE happyOut84 #-}+happyIn85 :: (Exp) -> (HappyAbsSyn )+happyIn85 x = unsafeCoerce# x+{-# INLINE happyIn85 #-}+happyOut85 :: (HappyAbsSyn ) -> (Exp)+happyOut85 x = unsafeCoerce# x+{-# INLINE happyOut85 #-}+happyIn86 :: (OpExp) -> (HappyAbsSyn )+happyIn86 x = unsafeCoerce# x+{-# INLINE happyIn86 #-}+happyOut86 :: (HappyAbsSyn ) -> (OpExp)+happyOut86 x = unsafeCoerce# x+{-# INLINE happyOut86 #-}+happyIn87 :: (OpExp) -> (HappyAbsSyn )+happyIn87 x = unsafeCoerce# x+{-# INLINE happyIn87 #-}+happyOut87 :: (HappyAbsSyn ) -> (OpExp)+happyOut87 x = unsafeCoerce# x+{-# INLINE happyOut87 #-}+happyIn88 :: (Pat) -> (HappyAbsSyn )+happyIn88 x = unsafeCoerce# x+{-# INLINE happyIn88 #-}+happyOut88 :: (HappyAbsSyn ) -> (Pat)+happyOut88 x = unsafeCoerce# x+{-# INLINE happyOut88 #-}+happyIn89 :: ([Pat]) -> (HappyAbsSyn )+happyIn89 x = unsafeCoerce# x+{-# INLINE happyIn89 #-}+happyOut89 :: (HappyAbsSyn ) -> ([Pat])+happyOut89 x = unsafeCoerce# x+{-# INLINE happyOut89 #-}+happyIn90 :: (Pat) -> (HappyAbsSyn )+happyIn90 x = unsafeCoerce# x+{-# INLINE happyIn90 #-}+happyOut90 :: (HappyAbsSyn ) -> (Pat)+happyOut90 x = unsafeCoerce# x+{-# INLINE happyOut90 #-}+happyIn91 :: (Name) -> (HappyAbsSyn )+happyIn91 x = unsafeCoerce# x+{-# INLINE happyIn91 #-}+happyOut91 :: (HappyAbsSyn ) -> (Name)+happyOut91 x = unsafeCoerce# x+{-# INLINE happyOut91 #-}+happyIn92 :: (Name) -> (HappyAbsSyn )+happyIn92 x = unsafeCoerce# x+{-# INLINE happyIn92 #-}+happyOut92 :: (HappyAbsSyn ) -> (Name)+happyOut92 x = unsafeCoerce# x+{-# INLINE happyOut92 #-}+happyIn93 :: (Name) -> (HappyAbsSyn )+happyIn93 x = unsafeCoerce# x+{-# INLINE happyIn93 #-}+happyOut93 :: (HappyAbsSyn ) -> (Name)+happyOut93 x = unsafeCoerce# x+{-# INLINE happyOut93 #-}+happyIn94 :: (Name) -> (HappyAbsSyn )+happyIn94 x = unsafeCoerce# x+{-# INLINE happyIn94 #-}+happyOut94 :: (HappyAbsSyn ) -> (Name)+happyOut94 x = unsafeCoerce# x+{-# INLINE happyOut94 #-}+happyIn95 :: (Name) -> (HappyAbsSyn )+happyIn95 x = unsafeCoerce# x+{-# INLINE happyIn95 #-}+happyOut95 :: (HappyAbsSyn ) -> (Name)+happyOut95 x = unsafeCoerce# x+{-# INLINE happyOut95 #-}+happyIn96 :: (Name) -> (HappyAbsSyn )+happyIn96 x = unsafeCoerce# x+{-# INLINE happyIn96 #-}+happyOut96 :: (HappyAbsSyn ) -> (Name)+happyOut96 x = unsafeCoerce# x+{-# INLINE happyOut96 #-}+happyIn97 :: (Name) -> (HappyAbsSyn )+happyIn97 x = unsafeCoerce# x+{-# INLINE happyIn97 #-}+happyOut97 :: (HappyAbsSyn ) -> (Name)+happyOut97 x = unsafeCoerce# x+{-# INLINE happyOut97 #-}+happyIn98 :: (Name) -> (HappyAbsSyn )+happyIn98 x = unsafeCoerce# x+{-# INLINE happyIn98 #-}+happyOut98 :: (HappyAbsSyn ) -> (Name)+happyOut98 x = unsafeCoerce# x+{-# INLINE happyOut98 #-}+happyIn99 :: (Name) -> (HappyAbsSyn )+happyIn99 x = unsafeCoerce# x+{-# INLINE happyIn99 #-}+happyOut99 :: (HappyAbsSyn ) -> (Name)+happyOut99 x = unsafeCoerce# x+{-# INLINE happyOut99 #-}+happyIn100 :: (Name) -> (HappyAbsSyn )+happyIn100 x = unsafeCoerce# x+{-# INLINE happyIn100 #-}+happyOut100 :: (HappyAbsSyn ) -> (Name)+happyOut100 x = unsafeCoerce# x+{-# INLINE happyOut100 #-}+happyIn101 :: (Name) -> (HappyAbsSyn )+happyIn101 x = unsafeCoerce# x+{-# INLINE happyIn101 #-}+happyOut101 :: (HappyAbsSyn ) -> (Name)+happyOut101 x = unsafeCoerce# x+{-# INLINE happyOut101 #-}+happyIn102 :: ((String,String)) -> (HappyAbsSyn )+happyIn102 x = unsafeCoerce# x+{-# INLINE happyIn102 #-}+happyOut102 :: (HappyAbsSyn ) -> ((String,String))+happyOut102 x = unsafeCoerce# x+{-# INLINE happyOut102 #-}+happyIn103 :: ((String,String)) -> (HappyAbsSyn )+happyIn103 x = unsafeCoerce# x+{-# INLINE happyIn103 #-}+happyOut103 :: (HappyAbsSyn ) -> ((String,String))+happyOut103 x = unsafeCoerce# x+{-# INLINE happyOut103 #-}+happyIn104 :: (()) -> (HappyAbsSyn )+happyIn104 x = unsafeCoerce# x+{-# INLINE happyIn104 #-}+happyOut104 :: (HappyAbsSyn ) -> (())+happyOut104 x = unsafeCoerce# x+{-# INLINE happyOut104 #-}+happyIn105 :: (()) -> (HappyAbsSyn )+happyIn105 x = unsafeCoerce# x+{-# INLINE happyIn105 #-}+happyOut105 :: (HappyAbsSyn ) -> (())+happyOut105 x = unsafeCoerce# x+{-# INLINE happyOut105 #-}+happyIn106 :: (()) -> (HappyAbsSyn )+happyIn106 x = unsafeCoerce# x+{-# INLINE happyIn106 #-}+happyOut106 :: (HappyAbsSyn ) -> (())+happyOut106 x = unsafeCoerce# x+{-# INLINE happyOut106 #-}+happyIn107 :: ((Int,Int)) -> (HappyAbsSyn )+happyIn107 x = unsafeCoerce# x+{-# INLINE happyIn107 #-}+happyOut107 :: (HappyAbsSyn ) -> ((Int,Int))+happyOut107 x = unsafeCoerce# x+{-# INLINE happyOut107 #-}+happyInTok :: (Token) -> (HappyAbsSyn )+happyInTok x = unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn ) -> (Token)+happyOutTok x = unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\xbe\x04\xbe\x04\x00\x00\xaf\x04\xae\x04\xe7\x04\x00\x00\xda\x04\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x06\xd9\x04\xbc\x01\x00\x00\x4f\x02\x31\x03\xd0\x01\x00\x00\x39\x07\xcb\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x01\x00\x00\x35\x02\xd4\x04\x00\x00\xc8\x04\x88\x01\xb7\x03\x1c\x07\xf1\x07\x00\x00\x06\x03\x06\x03\x06\x03\x00\x00\xd1\x04\x00\x00\xd3\x04\xcd\x04\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x06\xb6\x02\x00\x00\xc7\x04\x00\x00\x00\x00\x0f\x00\x2d\x01\x00\x00\x00\x00\xab\x04\x12\x0b\x00\x00\xbd\x04\xb5\x04\xb1\x04\x00\x00\x9e\x01\x00\x00\x00\x00\xbb\x04\x00\x00\x00\x00\xd5\x07\x00\x00\x00\x00\x00\x00\x66\x03\xd5\x07\x84\x04\x08\x01\x00\x00\x6d\x01\x00\x00\x81\x04\x00\x00\xd0\x01\x00\x00\xd0\x01\x00\x00\x00\x00\x00\x00\x86\x04\x83\x04\x2f\x0b\x00\x00\x0d\x08\x0d\x08\x89\x04\x0a\x03\xa2\x02\x53\x0b\xa1\x02\x00\x00\x06\x03\x88\x04\x7e\x04\x00\x00\x7a\x04\x91\x07\x24\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x04\x74\x04\x74\x04\x74\x04\xa2\x01\x00\x00\x00\x00\x00\x00\xff\x0a\x00\x00\x00\x00\x00\x00\x7b\x04\x00\x00\x00\x00\x6d\x04\x5b\x04\xf7\x0a\x3a\x04\x52\x04\x00\x00\x0d\x08\xec\x0a\x37\x04\xbd\x02\x0e\x04\x00\x00\xed\x06\x00\x00\x00\x00\x00\x00\x00\x00\x32\x04\x00\x00\x20\x04\x14\x04\xe9\x02\x00\x00\x00\x00\x00\x00\x7c\x03\xf6\x02\x00\x00\x00\x00\x2f\x04\x36\x02\x00\x00\x21\x04\x1f\x04\x1d\x04\x00\x00\x00\x00\x1d\x04\x00\x00\x00\x00\xb7\x03\x00\x00\x16\x04\x15\x04\x00\x00\x00\x00\x00\x00\xb7\x03\x10\x01\x00\x00\x02\x04\x00\x00\xa2\x01\x00\x00\x00\x00\x57\x03\x00\x00\x00\x00\x00\x00\x00\x00\x11\x04\x05\x04\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x0d\x08\x47\x0a\x00\x00\x0d\x08\x00\x00\x00\x00\x00\x00\xb3\x03\xe4\x03\x76\x02\x00\x00\x6f\x0a\x4c\x0a\xbd\x02\x0d\x08\x0d\x08\xec\x0a\x00\x00\x0d\x08\x00\x00\x00\x00\x81\x02\xd6\x03\x58\x01\x00\x00\x0b\x00\xbd\x02\x00\x00\xda\x0a\x48\x01\x00\x00\xfe\x01\x95\x02\x0d\x08\x1c\x00\xcf\x03\x09\x00\xb5\x03\x00\x00\xac\x03\x00\x00\xbd\x02\xd7\x03\xbd\x02\x00\x00\xa9\x03\x00\x00\xa4\x03\xbd\x02\x00\x00\xda\x0a\x93\x02\x00\x00\x7d\x00\xd3\x03\xbd\x02\x00\x00\xd3\x03\x59\x02\xc6\x03\xbd\x02\x00\x00\xc7\x03\x00\x00\xc0\x03\xeb\x01\x00\x00\x00\x00\x2f\x0b\x00\x00\x00\x00\x2f\x0b\x3b\x02\x00\x00\xb6\x03\x00\x00\xc8\x03\x0d\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x06\xb8\x01\x49\x02\x81\x00\xc4\x03\x00\x00\x00\x00\x58\x02\xe4\x01\x0d\x08\xc5\x03\x0d\x08\xcf\x0a\x0d\x08\x0d\x08\x0d\x08\xbf\x03\xa2\x01\x32\x00\x00\x00\xbb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x03\xc7\x0a\xb4\x0a\x0d\x08\xb1\x03\x00\x00\xb9\x03\xcd\x00\xec\x01\xa6\x00\xb8\x03\x8d\x01\x00\x00\x00\x00\xbd\x02\xbd\x02\xbd\x02\x00\x00\xed\x06\x00\x00\xed\x06\x37\x01\x00\x00\xae\x03\x00\x00\xa6\x03\xeb\x01\xeb\x01\x00\x00\x00\x00\xbd\x02\xbd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x7f\x03\x00\x00\x00\x00\x6b\x03\x00\x00\x59\x03\x38\x00\x52\x03\x00\x00\x58\x03\x0d\x08\x0d\x08\xab\x06\x00\x00\x4a\x03\xb6\x07\xbd\x02\x75\x03\x5b\x03\x00\x00\xb2\x0a\x00\x00\x0d\x08\x00\x00\x72\x03\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x08\x00\x00\x61\x03\x00\x00\xbd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x41\x03\x68\x03\x00\x00\x00\x00\x00\x00\x00\x00\x67\x03\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x5e\x03\x00\x00\xd8\x01\x81\x00\x5c\x03\x00\x00\xa3\x01\x00\x00\x00\x00\x00\x00\x4b\x03\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x0a\x1e\x01\x00\x00\x00\x00\xf9\x01\x0d\x08\x00\x00\x00\x00\x0d\x08\x00\x00\x00\x00\x00\x00\x4f\x03\x40\x03\x40\x03\x40\x03\x40\x03\x00\x00\x39\x03\x00\x00\x00\x00\xa2\x01\xbd\x02\x00\x00\x9a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x0a\x00\x00\x00\x00\x00\x00\xfc\x02\xf9\x02\x00\x00\x9f\x0a\x0d\x08\x00\x00\x97\x0a\x61\x01\xbd\x02\xbd\x02\x21\x03\x00\x00\x0b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x04\x03\x97\x0a\x04\x01\x00\x00\xfc\x00\xc7\x02\xee\x02\x00\x00\x8c\x0a\xe8\x02\x00\x00\x74\x0a\x74\x00\x00\x00\x0d\x08\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\xdf\x02\x00\x00\xd9\x02\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\xe6\x02\x00\x00\xb7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\xcb\x02\x80\x02\xc2\x02\x37\x00\x00\x00\x3d\x02\x00\x00\x00\x00\x3e\x03\x73\x04\x00\x00\xf4\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x09\xf4\x02\x0e\x03\x00\x00\x43\x09\x6e\x09\x98\x08\xb3\x01\x05\x00\x65\x01\x1b\x00\x1a\x00\x40\x01\xbb\xff\xfc\xff\xb7\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x02\x00\x00\xaa\x02\x8d\x02\x00\x00\x26\x01\x2e\x02\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x01\x00\x00\x00\x00\x36\x00\x2d\x02\x7d\x02\x46\x06\x00\x00\x00\x00\x00\x00\x00\x00\x38\x06\x00\x00\xea\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x04\x00\x00\xd8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x07\x20\x02\x2a\x06\xee\x05\x19\x00\x00\x00\x00\x00\xc3\x03\x00\x00\x00\x00\xaf\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x01\x59\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x7b\x00\x73\x00\x72\x00\x23\x02\x13\x02\x00\x00\x00\x00\xd2\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\xe9\x00\x00\x00\xc5\x08\x00\x00\x64\x02\x00\x00\xe0\x05\x30\x09\x8c\x00\x85\x02\x77\x02\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x3f\x01\x7b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x6b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x08\xb9\x00\x00\x00\x00\x00\x00\x00\x15\x02\x00\x00\x00\x00\xbd\x01\xf4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x02\x00\x00\xd2\x05\x6d\x07\x00\x00\x96\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x6d\x07\x37\x07\xb7\x02\x88\x05\x7a\x05\x1f\x09\x00\x00\x3e\x05\x00\x00\x00\x00\x0a\x00\x1d\x00\xd2\x01\x00\x00\x00\x00\x6a\x02\x9d\x01\x1c\x01\xca\x01\x00\x00\x00\x00\x18\x03\x30\x05\x02\x00\x94\x00\xfb\xff\x29\x02\x00\x00\xf3\x01\x00\x00\x0e\x02\xf9\xff\x5a\x02\x00\x00\xee\x01\x00\x00\x00\x00\x4d\x02\x00\x00\x63\x01\x00\x00\x00\x00\x15\x03\xc1\xff\x3c\x02\x00\x00\x39\x00\x00\x00\xed\x01\x04\x02\x00\x00\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\x00\x00\x2d\x07\x00\x00\x00\x00\x23\x07\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x22\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x01\x00\x00\x12\x03\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x04\x62\x00\xd8\x04\xf2\x08\xca\x04\x8e\x04\x80\x04\x00\x00\xc0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x09\x9b\x09\x72\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x02\x89\x02\x9b\x02\x00\x00\xa7\x00\xf1\x00\x6f\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\xff\xe2\xff\x00\x00\x00\x00\xb3\x02\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x04\x28\x04\xea\x01\x00\x00\x00\x00\x1a\x04\x32\x02\x00\x00\x00\x00\x00\x00\xe1\x08\xdc\x00\xde\x03\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x03\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\xd3\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xbb\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x08\x6e\x00\x00\x00\x00\x00\x8e\x01\xc2\x03\x00\x00\x00\x00\x86\x03\x00\x00\x00\x00\x00\x00\xd5\xff\x52\x00\x50\x00\xdc\xff\xd9\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xa9\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x08\x54\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x5a\x08\x78\x03\x00\x00\x8a\x09\x00\x00\x22\x02\x29\x01\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x2d\x08\xe6\xff\x00\x00\x4e\x02\x00\x00\x49\x00\x00\x00\x00\x08\xcd\xff\x00\x00\x5d\x09\x00\x00\x00\x00\x6a\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xc4\xff\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\xf1\xfe\x00\x00\x00\x00\x00\x00\xff\xfe\xf2\xfe\xfe\xff\xf6\xff\xf3\xfe\xf6\xff\xf1\xfe\x00\x00\x00\x00\xf2\xff\x00\x00\x00\x00\x20\xff\x1e\xff\x75\xff\x6d\xff\x6b\xff\x67\xff\xba\xff\x23\xff\x22\xff\x21\xff\x1f\xff\x6a\xff\x68\xff\x0f\xff\x0d\xff\x00\x00\xf1\xfe\xf1\xfe\xf1\xfe\x69\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf2\xfe\xf1\xfe\xf1\xfe\xf2\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xf4\xff\xeb\xff\xd9\xff\x05\xff\x04\xff\x00\x00\xdb\xff\xdb\xff\x00\x00\xf1\xfe\xf3\xfe\xe7\xff\x00\x00\x05\xff\x04\xff\x00\x00\xf5\xff\xe6\xff\xf1\xfe\xf3\xfe\xdb\xff\xf1\xfe\x6a\xff\x68\xff\x0d\xff\x00\x00\xf1\xfe\x10\xff\xf1\xfe\x11\xff\x59\xff\x94\xff\x92\xff\x91\xff\x90\xff\x8e\xff\x8f\xff\x7f\xff\x8d\xff\x73\xff\x00\x00\x58\xff\xf1\xfe\xf3\xfe\xf1\xfe\xf1\xfe\xf2\xfe\x00\x00\x00\x00\xf1\xfe\x00\x00\x01\xff\xf1\xfe\x00\x00\x09\xff\xfe\xfe\x03\xff\x00\x00\xf1\xfe\xf9\xfe\xf8\xfe\xf7\xfe\xfa\xfe\x66\xff\x9f\xff\xf1\xfe\xf1\xfe\xf6\xfe\x1b\xff\x16\xff\x00\xff\x5e\xff\x5d\xff\x5c\xff\x5b\xff\xf2\xfe\xf2\xfe\xf2\xfe\xf2\xfe\x00\x00\xf3\xfe\x07\xff\x06\xff\xf1\xfe\x0b\xff\x09\xff\xfc\xfe\x00\x00\xfb\xfe\xf1\xfe\xf1\xfe\x6e\xff\xf1\xfe\xe4\xff\xb8\xff\xb5\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xfa\xff\xf4\xfe\xf1\xfe\xf5\xfe\xf7\xff\xf3\xff\xfc\xff\xf2\xfe\xe5\xff\xb2\xff\xb1\xff\xae\xff\xac\xff\xab\xff\xaa\xff\xf1\xfe\xf1\xfe\xa9\xff\xbc\xff\x00\x00\x00\x00\x51\xff\x4f\xff\x00\x00\xf2\xfe\xb9\xff\xb6\xff\xf2\xfe\x19\xff\x14\xff\xf1\xfe\x6c\xff\x00\x00\x00\x00\xfd\xfe\x1c\xff\x17\xff\xf1\xfe\xf1\xfe\xf1\xff\x99\xff\x98\xff\x00\x00\x97\xff\x7b\xff\x34\xff\xf3\xfe\x7e\xff\x7d\xff\x7c\xff\x00\x00\x00\x00\x8a\xff\x85\xff\x0c\xff\x0e\xff\xf1\xfe\x63\xff\xf1\xfe\xf1\xfe\x64\xff\xf1\xfe\x5f\xff\xa0\xff\x93\xff\x00\x00\x00\x00\xf1\xfe\x62\xff\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x12\xff\xf1\xfe\x70\xff\x6f\xff\xdd\xff\xf1\xfe\x00\x00\xd5\xff\x00\x00\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xc2\xff\x00\x00\x00\x00\xf1\xfe\xe0\xff\xf1\xfe\xf1\xfe\xfa\xff\xfd\xff\xcd\xff\xdc\xff\xf1\xfe\xf2\xfe\xf1\xfe\xe1\xff\xcd\xff\x71\xff\xc0\xff\xf1\xfe\xc4\xff\xf1\xfe\x00\x00\xda\xff\xea\xff\xf1\xfe\xf1\xfe\xd7\xff\xf1\xfe\x00\x00\xd1\xff\xf1\xfe\x72\xff\x55\xff\x57\xff\x53\xff\x95\xff\x8b\xff\x86\xff\xf1\xfe\x88\xff\x83\xff\xf1\xfe\x00\x00\xbe\xff\x00\x00\x80\xff\xf2\xfe\xf1\xfe\x53\xff\x61\xff\x54\xff\x60\xff\x02\xff\x65\xff\xf1\xfe\x00\x00\x00\x00\x00\x00\x35\xff\x32\xff\x30\xff\x24\xff\x00\x00\xf1\xfe\xf2\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\x00\x00\x00\x00\x76\xff\x00\x00\x1d\xff\x18\xff\x08\xff\x0a\xff\x1a\xff\x15\xff\xb7\xff\x4e\xff\xf1\xfe\xf1\xfe\xf1\xfe\x00\x00\xa8\xff\x00\x00\xb2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xff\xad\xff\xf1\xfe\xf1\xfe\xf1\xfe\xfb\xff\xf1\xfe\xf3\xfe\xf1\xfe\x00\x00\x9c\xff\xb3\xff\x9d\xff\xaa\xff\xaf\xff\xb0\xff\xa7\xff\xa4\xff\xf1\xfe\xf1\xfe\xa5\xff\xa3\xff\xb4\xff\x52\xff\x50\xff\x77\xff\x7a\xff\xf1\xfe\x00\x00\x9a\xff\x96\xff\x00\x00\x2b\xff\x00\x00\x00\x00\x00\x00\x27\xff\x00\x00\xf1\xfe\xf1\xfe\xf1\xfe\x36\xff\x2e\xff\xf1\xfe\xf1\xfe\x00\x00\x00\x00\x82\xff\xf1\xfe\xf3\xfe\xf1\xfe\x81\xff\xf1\xfe\x89\xff\x84\xff\x8c\xff\x87\xff\xf1\xfe\xde\xff\xdf\xff\xef\xff\xf1\xfe\xd8\xff\xd6\xff\xd3\xff\xd4\xff\xe8\xff\xf2\xfe\xc5\xff\xc3\xff\xc1\xff\xee\xff\xf2\xfe\xf0\xff\xec\xff\xc9\xff\xf3\xfe\xe2\xff\xe3\xff\xed\xff\xf1\xfe\x00\x00\xca\xff\xc7\xff\x00\x00\xbb\xff\xce\xff\xe9\xff\xd2\xff\xcf\xff\x56\xff\xbf\xff\xbd\xff\xf1\xfe\x00\x00\x4a\xff\x13\xff\x00\x00\xf1\xfe\x37\xff\x2f\xff\xf1\xfe\x33\xff\x31\xff\x2c\xff\xf2\xfe\xf2\xfe\xf2\xfe\xf2\xfe\xf2\xfe\x79\xff\x00\x00\xa1\xff\xa2\xff\x00\x00\xf1\xfe\xf8\xff\x00\x00\xf9\xff\x9e\xff\x9b\xff\x78\xff\x26\xff\x29\xff\x2a\xff\x28\xff\x25\xff\xf1\xfe\xf3\xfe\x2d\xff\x74\xff\x49\xff\x47\xff\x44\xff\xf1\xfe\xf1\xfe\x4c\xff\xf1\xfe\x00\x00\xf1\xfe\xf1\xfe\xf1\xfe\xcb\xff\x00\x00\xcc\xff\xc8\xff\xc6\xff\xd0\xff\x4d\xff\x4b\xff\x48\xff\x00\x00\x45\xff\xf2\xfe\xf1\xfe\x00\x00\x3f\xff\x00\x00\x3e\xff\x3c\xff\x39\xff\xf1\xfe\xf2\xfe\x41\xff\xf1\xfe\x00\x00\x46\xff\xf1\xfe\x43\xff\x42\xff\x40\xff\x3d\xff\x00\x00\x3a\xff\xf2\xfe\x3b\xff\xf2\xfe\x38\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x08\x00\x05\x00\x06\x00\x07\x00\x25\x00\x0c\x00\x13\x00\x08\x00\x09\x00\x13\x00\x04\x00\x4a\x00\x04\x00\x01\x00\x3e\x00\x0d\x00\x04\x00\x0a\x00\x01\x00\x5f\x00\x4a\x00\x57\x00\x44\x00\x5f\x00\x1c\x00\x1d\x00\x01\x00\x67\x00\x5e\x00\x04\x00\x0d\x00\x67\x00\x4a\x00\x17\x00\x1a\x00\x4a\x00\x0c\x00\x67\x00\x17\x00\x66\x00\x0e\x00\x0f\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x33\x00\x66\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x66\x00\x58\x00\x66\x00\x05\x00\x06\x00\x07\x00\x66\x00\x5e\x00\x5f\x00\x66\x00\x11\x00\x0e\x00\x0f\x00\x3d\x00\x15\x00\x0f\x00\x67\x00\x64\x00\x19\x00\x3d\x00\x15\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x1c\x00\x1d\x00\x1b\x00\x57\x00\x58\x00\x5c\x00\x5e\x00\x5e\x00\x5f\x00\x66\x00\x5e\x00\x5f\x00\x66\x00\x5e\x00\x29\x00\x67\x00\x67\x00\x66\x00\x43\x00\x67\x00\x66\x00\x5e\x00\x67\x00\x33\x00\x66\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x57\x00\x66\x00\x57\x00\x06\x00\x07\x00\x5c\x00\x66\x00\x5e\x00\x5f\x00\x5e\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x00\x00\x67\x00\x0f\x00\x67\x00\x11\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x1c\x00\x1d\x00\x57\x00\x57\x00\x58\x00\x57\x00\x57\x00\x49\x00\x12\x00\x5e\x00\x5e\x00\x5f\x00\x5e\x00\x5e\x00\x1c\x00\x4a\x00\x1e\x00\x4a\x00\x67\x00\x67\x00\x11\x00\x67\x00\x67\x00\x33\x00\x16\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x1c\x00\x15\x00\x0d\x00\x4a\x00\x06\x00\x07\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x0e\x00\x20\x00\x66\x00\x19\x00\x66\x00\x65\x00\x3d\x00\x15\x00\x4a\x00\x4a\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x1c\x00\x1d\x00\x4a\x00\x57\x00\x58\x00\x66\x00\x4a\x00\x15\x00\x1a\x00\x1b\x00\x5e\x00\x5f\x00\x14\x00\x15\x00\x16\x00\x64\x00\x1a\x00\x1b\x00\x20\x00\x67\x00\x1c\x00\x66\x00\x66\x00\x33\x00\x07\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x66\x00\x15\x00\x57\x00\x57\x00\x66\x00\x58\x00\x14\x00\x15\x00\x16\x00\x5e\x00\x5e\x00\x5e\x00\x5f\x00\x21\x00\x1c\x00\x1c\x00\x1d\x00\x5e\x00\x67\x00\x67\x00\x67\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x67\x00\x2a\x00\x2b\x00\x57\x00\x58\x00\x22\x00\x23\x00\x24\x00\x25\x00\x00\x00\x5e\x00\x5f\x00\x33\x00\x57\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x5e\x00\x57\x00\x64\x00\x57\x00\x0f\x00\x65\x00\x0d\x00\x12\x00\x5e\x00\x67\x00\x5e\x00\x1e\x00\x13\x00\x20\x00\x0d\x00\x00\x00\x17\x00\x67\x00\x11\x00\x67\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x20\x00\x19\x00\x57\x00\x57\x00\x58\x00\x0f\x00\x01\x00\x02\x00\x12\x00\x5e\x00\x5e\x00\x5f\x00\x18\x00\x19\x00\x58\x00\x00\x00\x1c\x00\x1d\x00\x67\x00\x67\x00\x5e\x00\x5f\x00\x18\x00\x19\x00\x57\x00\x65\x00\x1c\x00\x1d\x00\x64\x00\x67\x00\x0f\x00\x5e\x00\x00\x00\x12\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x33\x00\x67\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x65\x00\x0f\x00\x00\x00\x33\x00\x12\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x0f\x00\x5e\x00\x5f\x00\x12\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x0f\x00\x67\x00\x11\x00\x57\x00\x58\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x5e\x00\x5f\x00\x19\x00\x57\x00\x58\x00\x1c\x00\x1d\x00\x58\x00\x15\x00\x67\x00\x5e\x00\x5f\x00\x19\x00\x5e\x00\x5f\x00\x01\x00\x02\x00\x1e\x00\x64\x00\x67\x00\x01\x00\x02\x00\x67\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x08\x00\x33\x00\x58\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5e\x00\x5f\x00\x5f\x00\x61\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x67\x00\x67\x00\x06\x00\x0f\x00\x22\x00\x11\x00\x1c\x00\x1d\x00\x26\x00\x0d\x00\x57\x00\x29\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x5e\x00\x15\x00\x17\x00\x57\x00\x58\x00\x00\x00\x1a\x00\x36\x00\x21\x00\x67\x00\x5e\x00\x5f\x00\x33\x00\x5f\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x0f\x00\x67\x00\x15\x00\x12\x00\x41\x00\x42\x00\x43\x00\x1a\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1c\x00\x1d\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x0d\x00\x16\x00\x57\x00\x58\x00\x11\x00\x2a\x00\x2b\x00\x01\x00\x02\x00\x5e\x00\x5f\x00\x33\x00\x21\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x0d\x00\x5c\x00\x0e\x00\x5e\x00\x5f\x00\x10\x00\x13\x00\x1b\x00\x12\x00\x15\x00\x17\x00\x1f\x00\x67\x00\x12\x00\x1c\x00\x1d\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x5f\x00\x15\x00\x57\x00\x58\x00\x5f\x00\x1e\x00\x1a\x00\x20\x00\x67\x00\x5e\x00\x5f\x00\x33\x00\x67\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x02\x00\x5e\x00\x5f\x00\x64\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x67\x00\x64\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x2a\x00\x2b\x00\x57\x00\x58\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5e\x00\x5f\x00\x15\x00\x15\x00\x11\x00\x2a\x00\x2b\x00\x1a\x00\x15\x00\x67\x00\x1c\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x60\x00\x65\x00\x62\x00\x63\x00\x58\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5e\x00\x5f\x00\x15\x00\x1c\x00\x58\x00\x1e\x00\x0f\x00\x1a\x00\x11\x00\x67\x00\x5e\x00\x5f\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1b\x00\x1c\x00\x67\x00\x1e\x00\x1f\x00\x65\x00\x02\x00\x58\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5e\x00\x5f\x00\x01\x00\x0d\x00\x20\x00\x65\x00\x05\x00\x11\x00\x0b\x00\x67\x00\x58\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5e\x00\x5f\x00\x65\x00\x65\x00\x58\x00\x47\x00\x48\x00\x49\x00\x0b\x00\x67\x00\x5e\x00\x5f\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x64\x00\x0f\x00\x67\x00\x11\x00\x58\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5e\x00\x5f\x00\x24\x00\x25\x00\x0e\x00\x0e\x00\x1c\x00\x58\x00\x1e\x00\x67\x00\x0b\x00\x15\x00\x15\x00\x5e\x00\x5f\x00\x24\x00\x25\x00\x0b\x00\x22\x00\x23\x00\x24\x00\x25\x00\x67\x00\x58\x00\x28\x00\x29\x00\x0f\x00\x04\x00\x11\x00\x5e\x00\x5f\x00\x0d\x00\x22\x00\x23\x00\x24\x00\x25\x00\x04\x00\x13\x00\x67\x00\x29\x00\x58\x00\x17\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5e\x00\x5f\x00\x24\x00\x25\x00\x58\x00\x37\x00\x38\x00\x39\x00\x58\x00\x67\x00\x5e\x00\x5f\x00\x65\x00\x00\x00\x5e\x00\x5f\x00\x10\x00\x01\x00\x02\x00\x67\x00\x04\x00\x58\x00\x10\x00\x67\x00\x0d\x00\x0e\x00\x58\x00\x5e\x00\x5f\x00\x0d\x00\x13\x00\x10\x00\x5e\x00\x5f\x00\x17\x00\x13\x00\x67\x00\x57\x00\x58\x00\x17\x00\x58\x00\x67\x00\x0d\x00\x3d\x00\x5e\x00\x5f\x00\x5e\x00\x5f\x00\x13\x00\x14\x00\x58\x00\x1e\x00\x17\x00\x67\x00\x58\x00\x67\x00\x5e\x00\x5f\x00\x0d\x00\x10\x00\x5e\x00\x5f\x00\x1e\x00\x0e\x00\x13\x00\x67\x00\x27\x00\x11\x00\x17\x00\x67\x00\x15\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0d\x00\x3b\x00\x1e\x00\x1f\x00\x20\x00\x1e\x00\x1f\x00\x20\x00\x1e\x00\x1f\x00\x20\x00\x3d\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x11\x00\x57\x00\x58\x00\x1c\x00\x5a\x00\x1e\x00\x10\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x01\x00\x02\x00\x03\x00\x67\x00\x1e\x00\x1f\x00\x20\x00\x10\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x57\x00\x58\x00\x01\x00\x02\x00\x1e\x00\x13\x00\x0f\x00\x5e\x00\x5f\x00\x17\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x15\x00\x1d\x00\x67\x00\x15\x00\x10\x00\x10\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x3d\x00\x0d\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2a\x00\x11\x00\x3d\x00\x31\x00\x0d\x00\x0e\x00\x39\x00\x34\x00\x36\x00\x37\x00\x13\x00\x11\x00\x15\x00\x39\x00\x17\x00\x29\x00\x3e\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x1a\x00\x57\x00\x58\x00\x15\x00\x0d\x00\x14\x00\x0e\x00\x0e\x00\x5e\x00\x5f\x00\x13\x00\x30\x00\x11\x00\x0e\x00\x17\x00\x57\x00\x58\x00\x67\x00\x1c\x00\x0f\x00\x1d\x00\x10\x00\x5e\x00\x5f\x00\x10\x00\x19\x00\x23\x00\x24\x00\x15\x00\x57\x00\x58\x00\x67\x00\x0d\x00\x3d\x00\x1c\x00\x0d\x00\x5e\x00\x5f\x00\x3d\x00\x10\x00\x31\x00\x3d\x00\x35\x00\x1c\x00\x39\x00\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x34\x00\x57\x00\x58\x00\x16\x00\x59\x00\x5a\x00\x5b\x00\x0e\x00\x5e\x00\x5f\x00\x20\x00\x60\x00\x61\x00\x62\x00\x63\x00\x57\x00\x58\x00\x67\x00\x67\x00\x16\x00\x16\x00\x10\x00\x5e\x00\x5f\x00\x01\x00\x59\x00\x5a\x00\x5b\x00\x20\x00\x57\x00\x58\x00\x67\x00\x60\x00\x61\x00\x62\x00\x63\x00\x5e\x00\x5f\x00\x1f\x00\x67\x00\x1f\x00\x21\x00\x10\x00\x35\x00\x0d\x00\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x1e\x00\x57\x00\x58\x00\x18\x00\x59\x00\x5a\x00\x5b\x00\x3d\x00\x5e\x00\x5f\x00\x0d\x00\x60\x00\x61\x00\x62\x00\x63\x00\x57\x00\x58\x00\x67\x00\x67\x00\x08\x00\x10\x00\x0d\x00\x5e\x00\x5f\x00\x0e\x00\x59\x00\x5a\x00\x5b\x00\x0e\x00\x57\x00\x58\x00\x67\x00\x60\x00\x61\x00\x62\x00\x63\x00\x5e\x00\x5f\x00\x0e\x00\x67\x00\x15\x00\x10\x00\x14\x00\x1a\x00\x18\x00\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0d\x00\x57\x00\x58\x00\x1a\x00\x59\x00\x5a\x00\x5b\x00\x1a\x00\x5e\x00\x5f\x00\x15\x00\x60\x00\x61\x00\x62\x00\x63\x00\x57\x00\x58\x00\x67\x00\x67\x00\x30\x00\x15\x00\x10\x00\x5e\x00\x5f\x00\x0d\x00\x10\x00\x1a\x00\x18\x00\x10\x00\x57\x00\x58\x00\x67\x00\x0f\x00\x02\x00\x10\x00\x3d\x00\x5e\x00\x5f\x00\x3f\x00\xff\xff\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x67\x00\x03\x00\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x57\x00\x58\x00\x67\x00\x11\x00\xff\xff\x13\x00\xff\xff\x5e\x00\x5f\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x67\x00\x03\x00\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\x0d\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x13\x00\xff\xff\x31\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\x1d\x00\xff\xff\x03\x00\xff\xff\xff\xff\x3e\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\x0d\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x13\x00\xff\xff\x31\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\x1d\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3e\x00\x23\x00\x24\x00\xff\xff\xff\xff\x27\x00\x28\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\xff\xff\x31\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x38\x00\x13\x00\x3a\x00\x3b\x00\x3c\x00\x17\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\x27\x00\x28\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\x31\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\x38\x00\xff\xff\x3a\x00\x3b\x00\x0d\x00\x0e\x00\xff\xff\x10\x00\xff\xff\xff\xff\x13\x00\xff\xff\x15\x00\x16\x00\x17\x00\x18\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x01\x00\x02\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x13\x00\x31\x00\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x38\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x5e\x00\x5f\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\x01\x00\x02\x00\x67\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x67\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\xff\xff\x03\x00\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x57\x00\x58\x00\x10\x00\x36\x00\xff\xff\x13\x00\xff\xff\x5e\x00\x5f\x00\x17\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\x1d\x00\x67\x00\x5e\x00\x5f\x00\xff\xff\x03\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x0d\x00\x2d\x00\xff\xff\x10\x00\xff\xff\x31\x00\x13\x00\x33\x00\xff\xff\xff\xff\x17\x00\x18\x00\x38\x00\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\x10\x00\x2d\x00\xff\xff\x13\x00\x14\x00\x31\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x38\x00\x1d\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\x10\x00\x2d\x00\xff\xff\x13\x00\xff\xff\x31\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x38\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2d\x00\xff\xff\x3c\x00\x3d\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x00\x38\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\x45\x00\x46\x00\xff\xff\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\x3c\x00\x3d\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x5e\x00\x5f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x46\x00\xff\xff\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x67\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\xff\xff\x3d\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\xff\xff\x67\x00\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x67\x00\xff\xff\xff\xff\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\x57\x00\x58\x00\x37\x00\x38\x00\x39\x00\xff\xff\x67\x00\x5e\x00\x5f\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\x03\x00\x57\x00\x58\x00\xff\xff\xff\xff\x03\x00\xff\xff\x67\x00\x5e\x00\x5f\x00\x0d\x00\x0e\x00\xff\xff\x10\x00\xff\xff\x0d\x00\x13\x00\x67\x00\x10\x00\xff\xff\x17\x00\x13\x00\xff\xff\xff\xff\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x03\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x03\x00\x31\x00\x2d\x00\xff\xff\xff\xff\x0d\x00\x31\x00\xff\xff\x10\x00\xff\xff\x0d\x00\x13\x00\xff\xff\xff\xff\xff\xff\x17\x00\x13\x00\xff\xff\xff\xff\xff\xff\x17\x00\x1d\x00\xff\xff\xff\xff\x03\x00\xff\xff\x1d\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\x23\x00\x24\x00\x0d\x00\x03\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x13\x00\x31\x00\xff\xff\x03\x00\x17\x00\x0d\x00\x31\x00\xff\xff\xff\xff\xff\xff\x1d\x00\x13\x00\xff\xff\x0d\x00\xff\xff\x17\x00\x23\x00\x24\x00\xff\xff\x13\x00\xff\xff\x1d\x00\x03\x00\x17\x00\x03\x00\xff\xff\xff\xff\x23\x00\x24\x00\x1d\x00\x31\x00\xff\xff\x0d\x00\xff\xff\x0d\x00\x23\x00\x24\x00\xff\xff\x13\x00\xff\xff\x13\x00\x31\x00\x17\x00\x03\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1d\x00\x31\x00\x1d\x00\x03\x00\xff\xff\x0d\x00\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x13\x00\xff\xff\x0d\x00\x03\x00\x17\x00\xff\xff\xff\xff\xff\xff\x13\x00\x31\x00\x1d\x00\x31\x00\x17\x00\x0d\x00\xff\xff\xff\xff\x23\x00\x24\x00\x1d\x00\x13\x00\xff\xff\x03\x00\xff\xff\x17\x00\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x1d\x00\x31\x00\x0d\x00\x03\x00\xff\xff\xff\xff\x23\x00\x24\x00\x13\x00\x31\x00\xff\xff\x03\x00\x17\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x13\x00\x31\x00\x0d\x00\xff\xff\x17\x00\x23\x00\x24\x00\xff\xff\x13\x00\xff\xff\x1d\x00\x03\x00\x17\x00\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x1d\x00\x31\x00\xff\xff\x0d\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\x13\x00\xff\xff\xff\xff\x31\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x31\x00\x0d\x00\x0e\x00\xff\xff\x10\x00\x23\x00\x24\x00\x13\x00\xff\xff\xff\xff\xff\xff\x17\x00\x0d\x00\xff\xff\xff\xff\x10\x00\xff\xff\x1d\x00\x13\x00\x31\x00\xff\xff\xff\xff\x17\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x23\x00\x24\x00\x25\x00\x31\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\x31\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x53\x01\x08\x00\xf9\x00\x0d\x00\x33\x00\x0f\x00\x4f\x01\x35\x00\xa4\x01\xfe\x00\xff\x00\x98\x01\xfc\x00\xff\x01\x09\x01\xdb\xff\x7d\x01\x45\x00\xdb\xff\x0d\x01\xf1\xfe\x34\x00\xf9\x01\x8f\x01\xcc\x01\x3a\x00\x10\x00\x11\x00\xf1\xfe\x05\x00\x1f\x00\xfc\x00\x44\x00\x05\x00\xc8\x01\xfd\x01\x0a\x01\xc9\x01\x3f\x00\xab\x00\xf4\x01\xc5\x00\x0c\x01\xea\x00\xa5\x01\x41\x01\x42\x01\xd8\x00\x3c\x00\x12\x00\xc5\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x7e\x01\xa5\x00\xcd\x01\x0d\x00\x0e\x00\x0f\x00\xc5\x00\xa6\x00\x4c\x00\xc5\x00\x69\x01\xe9\x00\xea\x00\xfd\x00\x6a\x01\x8d\x01\x39\x00\xf1\x01\x6b\x01\xdb\xff\x45\x01\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x10\x00\x11\x00\xa9\x01\x1d\x00\x1e\x00\x36\x00\xfa\x00\x37\x00\x38\x00\x99\x01\x1f\x00\x20\x00\x99\x01\xfa\x00\xba\x01\xab\x00\x39\x00\x54\x01\xe6\x01\x21\x00\x09\x00\xfa\x00\xab\x00\x12\x00\x46\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\xab\x00\x40\x00\x3d\x00\xeb\x00\xc3\x01\x0f\x00\x36\x00\x3d\x00\x41\x00\x42\x00\x1f\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x9a\x00\x39\x00\xf3\x01\xab\x00\xf8\x01\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x10\x00\x11\x00\xeb\x00\x1d\x00\x1e\x00\xeb\x00\x1c\x01\xfb\x01\x9c\x00\x1f\x00\x1f\x00\x20\x00\x1f\x00\x1f\x00\x95\x00\xca\x01\x96\x00\xcb\x01\xab\x00\x21\x00\xa6\x01\xab\x00\xab\x00\x12\x00\xdf\x01\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\xa2\x01\x45\x01\x44\x00\x72\x01\x57\x01\x0f\x00\xa7\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\x5f\x01\xff\x01\xc5\x00\xbe\x01\xc5\x00\xe8\x01\x92\x01\xd8\x00\xc4\x00\xc7\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x10\x00\x11\x00\xc8\x00\x1d\x00\x1e\x00\xc5\x00\xc9\x00\x45\x01\x1a\x01\x1b\x01\x1f\x00\x20\x00\xdd\x01\xa0\x01\xa1\x01\xd6\x01\x38\x01\x1b\x01\xf6\x01\x21\x00\xa2\x01\xc5\x00\xc5\x00\x12\x00\x9d\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\xc5\x00\x62\x01\xaa\x00\xa3\x01\xc5\x00\xa5\x00\x9f\x01\xa0\x01\xa1\x01\x1f\x00\x1f\x00\xa6\x00\x4c\x00\x53\x01\xa2\x01\x10\x00\x11\x00\xfa\x00\xab\x00\xab\x00\x39\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xab\x00\xc6\x01\xc0\x00\x1d\x00\x1e\x00\xbe\x01\xa2\x00\xa3\x00\xa4\x00\x9a\x00\x1f\x00\x20\x00\x12\x00\x1c\x01\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x1f\x00\x1c\x01\xdc\x01\xa3\x01\xf3\x01\x9e\x01\x24\x00\x9c\x00\x1f\x00\xab\x00\x1f\x00\xf0\x01\x25\x00\xf1\x01\x44\x00\x9a\x00\x26\x00\xab\x00\x3a\x01\xab\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xe5\x00\x3b\x01\xa3\x01\x1d\x00\x1e\x00\xd8\x01\x7b\x00\x07\x00\x9c\x00\x1f\x00\x1f\x00\x20\x00\x05\x01\xf0\x00\xa5\x00\x9a\x00\xf1\x00\xf2\x00\xab\x00\x21\x00\xa6\x00\x4c\x00\xef\x00\xf0\x00\xb7\x00\xab\x01\xf1\x00\xf2\x00\xc2\x01\x39\x00\x9b\x00\x1f\x00\x9a\x00\x9c\x00\xe0\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\x12\x00\xab\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x56\x01\x05\x01\x9a\x00\x12\x00\x9c\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x48\x01\x49\x01\xa2\x00\xa3\x00\xa4\x00\x4a\x01\x4b\x01\x0c\x01\xb8\x00\xb9\x00\x9c\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xd8\x01\x39\x00\xe3\x01\x1d\x00\x1e\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1f\x00\x4c\x00\x93\x01\x1d\x00\x1e\x00\xf1\x00\xf2\x00\xa5\x00\xe1\x00\x21\x00\x1f\x00\x4c\x00\xe2\x00\xa6\x00\x4c\x00\x7b\x00\x07\x00\xe3\x00\x77\x01\x21\x00\x7b\x00\x07\x00\x39\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xbb\x00\x12\x00\xa5\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\xa6\x00\x4c\x00\x3b\x00\x4c\x01\x8d\x00\x70\x00\x71\x00\x72\x00\x73\x00\x4d\x01\x05\x00\xc2\x00\x9b\x00\x80\x00\xc5\x01\x27\x01\x28\x01\x81\x00\xc3\x00\xca\x00\x82\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1f\x00\x97\x00\xc4\x00\x1d\x00\x1e\x00\x9a\x00\xdb\x01\x83\x00\x78\x00\xab\x00\x1f\x00\x4c\x00\x12\x00\x44\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x9b\x00\x05\x00\x97\x00\x9c\x00\xd1\x01\xd2\x01\xd3\x01\x7b\x01\x8d\x00\x70\x00\x71\x00\x72\x00\x73\x00\xf1\xfe\x27\x01\x28\x01\x7b\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x2e\x01\x44\x00\x8e\x00\x1d\x00\x1e\x00\xc9\xff\x6b\x01\xc0\x00\xf1\xfe\xf1\xfe\x1f\x00\x4c\x00\x12\x00\x78\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\xa8\x00\x06\x01\x60\x01\x37\x00\x42\x00\x8a\x01\xa9\x00\x75\x01\x95\x01\x61\x01\xaa\x00\x76\x01\x39\x00\x9d\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x2e\x01\x48\x00\x97\x00\x1d\x00\x1e\x00\x04\x00\xd5\x01\x03\x01\xd6\x01\x05\x00\x1f\x00\x4c\x00\x12\x00\x05\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x88\x01\x49\x01\xa2\x00\xa3\x00\xa4\x00\x89\x01\xf8\x00\xcb\x00\xb9\x00\x03\x01\x9b\x01\x49\x01\xa2\x00\xa3\x00\xa4\x00\x9c\x01\x39\x00\x0a\x01\xb4\x01\x2c\x01\x2d\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x2e\x01\x36\x01\xc0\x00\x1d\x00\x1e\x00\xe1\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\x1f\x00\x4c\x00\xbb\xff\x45\x01\x82\x01\xbf\x00\xc0\x00\xbb\xff\x83\x01\x21\x00\x46\x01\xb2\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\x69\x00\x26\x01\x6b\x00\x8a\x00\xa5\x00\x8e\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa6\x00\x4c\x00\x97\x00\x7a\x01\xa5\x00\x96\x00\x0c\x01\x98\x00\x8d\x01\x39\x00\xa6\x00\x4c\x00\x94\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\x13\xff\xba\xff\x39\x00\xba\xff\x13\xff\xbe\x00\x9e\x00\xa5\x00\x97\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa6\x00\x4c\x00\xf1\xfe\x44\x00\xb2\x00\xdb\x00\x0f\x01\x1e\x01\xe7\x00\x39\x00\xa5\x00\x07\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa6\x00\x4c\x00\xe8\x00\xee\x00\xa5\x00\xec\x01\xed\x01\xee\x01\xf4\x00\x39\x00\xa6\x00\x4c\x00\x46\x01\xa1\x00\xa2\x00\xa3\x00\xa4\x00\x98\x00\x05\x01\x39\x00\x93\x01\xa5\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa6\x00\x4c\x00\x5c\x01\xa4\x00\xd2\x00\xd5\x00\x95\x00\xa5\x00\x96\x00\x39\x00\xf5\x00\xd3\x00\xd6\x00\xa6\x00\x4c\x00\x5d\x01\xa4\x00\xf6\x00\x58\x01\xa2\x00\xa3\x00\xa4\x00\x39\x00\xa5\x00\x59\x01\x5a\x01\x9b\x00\x32\x00\xf8\x00\xa6\x00\x4c\x00\xa8\x00\x58\x01\xa2\x00\xa3\x00\xa4\x00\x0c\x00\xa9\x00\x39\x00\xc5\x01\xa5\x00\xaa\x00\xbf\x01\xa2\x00\xa3\x00\xa4\x00\xa6\x00\x4c\x00\x13\x01\xa4\x00\xa5\x00\x8f\x00\x16\x00\x17\x00\xa5\x00\x39\x00\xa6\x00\x4c\x00\x0b\x00\x03\x00\xa6\x00\x4c\x00\xc7\x00\xf1\xfe\xf1\xfe\x39\x00\x51\x01\xa5\x00\x3f\x00\x39\x00\x24\x00\x24\x01\xa5\x00\xa6\x00\x4c\x00\xa8\x00\x25\x00\xc7\x00\x5b\x01\x4c\x00\x26\x00\xa9\x00\x39\x00\x4a\x00\x4b\x00\xaa\x00\xa5\x00\x39\x00\xa8\x00\xfd\x01\x1f\x00\x4c\x00\x5b\x01\x4c\x00\xa9\x00\x48\x01\xa5\x00\xf0\x01\xaa\x00\x4d\x00\xa5\x00\x39\x00\xa6\x00\x4c\x00\x24\x00\x3f\x00\xa6\x00\x4c\x00\xd5\x01\xd7\x00\x25\x00\x39\x00\x63\x00\xdf\x01\x26\x00\x39\x00\xd8\x00\x64\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x65\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x44\x00\x66\x00\x78\x01\x92\x00\x93\x00\x90\x01\x92\x00\x93\x00\x01\x01\x92\x00\x93\x00\xe8\x01\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x5c\x00\x5d\x00\xc8\x01\x4a\x00\x1e\x00\x95\x00\x67\x00\x96\x00\xc7\x00\x68\x00\x1f\x00\x4c\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\xf1\xfe\xf1\xfe\x23\x00\x6d\x00\x91\x00\x92\x00\x93\x00\xcf\x01\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x24\x00\x4a\x00\x1e\x00\x7b\x00\x07\x00\xda\x01\x25\x00\xdc\x01\x1f\x00\x4c\x00\x26\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x61\x01\x27\x00\x21\x00\x61\x01\x9b\x01\x3f\x00\xf1\xfe\x28\x00\x29\x00\x30\x01\xf1\xfe\xb4\x00\x44\x00\xf1\xfe\x31\x01\x32\x01\x33\x01\x34\x01\xb1\x01\xb2\x01\xb4\x00\x2e\x00\xa8\x00\x4f\x01\xb9\x01\xb8\x01\xf1\xfe\x35\x01\xa9\x00\xbd\x01\x75\x00\xbb\x01\xaa\x00\xbc\x01\x36\x01\xf6\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xe4\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xcf\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xc1\x01\x4a\x00\x1e\x00\xc2\x01\x24\x00\x64\x01\xcf\x00\x63\x01\x1f\x00\x4c\x00\x25\x00\xf4\x00\x68\x01\x6d\x01\x26\x00\x4a\x00\x1e\x00\x21\x00\x81\x01\x77\x01\x27\x00\xc7\x00\x1f\x00\x4c\x00\x80\x01\x88\x01\x28\x00\x29\x00\x45\x01\x4a\x00\x1e\x00\x21\x00\x44\x00\xb4\x00\x8c\x01\x44\x00\x1f\x00\x4c\x00\x97\x01\x9b\x01\x2e\x00\x97\x01\xa0\x00\xfe\x00\x20\x01\x21\x00\xd0\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xa8\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xaa\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x1f\x01\x4a\x00\x1e\x00\x25\x01\x85\x00\x86\x00\xd3\x00\x26\x01\x1f\x00\x4c\x00\x38\x01\x88\x00\x89\x00\x6b\x00\x8a\x00\x4a\x00\x1e\x00\x21\x00\x8b\x00\x3e\x01\x3f\x01\x3f\x00\x1f\x00\x4c\x00\x7b\x00\x85\x00\x86\x00\xdd\x00\x52\x01\x4a\x00\x1e\x00\x21\x00\x88\x00\x89\x00\x6b\x00\x8a\x00\x1f\x00\x4c\x00\x44\x01\x8b\x00\x13\xff\x53\x01\x56\x01\xa0\x00\x44\x00\x21\x00\xb1\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xb5\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xb6\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x96\x00\x4a\x00\x1e\x00\x8f\x00\x85\x00\x86\x00\xde\x00\xb4\x00\x1f\x00\x4c\x00\x44\x00\x88\x00\x89\x00\x6b\x00\x8a\x00\x4a\x00\x1e\x00\x21\x00\x8b\x00\xbb\x00\xc7\x00\x44\x00\x1f\x00\x4c\x00\xfc\xfe\x85\x00\x86\x00\x87\x00\xcf\x00\x4a\x00\x1e\x00\x21\x00\x88\x00\x89\x00\x6b\x00\x8a\x00\x1f\x00\x4c\x00\xd0\x00\x8b\x00\xd3\x00\x3f\x00\xdd\x00\xe0\x00\x8f\x00\x21\x00\x64\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x6d\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x6e\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x44\x00\x4a\x00\x1e\x00\x0f\xff\x85\x00\x86\x00\x90\x00\xed\x00\x1f\x00\x4c\x00\xee\x00\x88\x00\x89\x00\x6b\x00\x8a\x00\x4a\x00\x1e\x00\x21\x00\x8b\x00\xf4\x00\xee\x00\x3f\x00\x1f\x00\x4c\x00\x44\x00\x48\x00\x84\x00\x8f\x00\x85\x00\x4a\x00\x1e\x00\x21\x00\x9d\x00\x07\x00\x0b\x00\x08\x00\x1f\x00\x4c\x00\xff\xff\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x6f\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x71\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x73\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x7c\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x0f\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x11\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x12\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x20\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x22\x01\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xb1\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xd9\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\xda\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xe5\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\xe6\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x21\x00\x23\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x4a\x00\x1e\x00\x21\x00\x34\xff\x00\x00\x25\x00\x00\x00\x1f\x00\x4c\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x21\x00\x23\x00\x00\x00\x00\x00\x00\x00\x28\x00\x29\x00\x30\x01\x00\x00\x00\x00\x00\x00\x24\x00\x31\x01\x32\x01\x33\x01\x34\x01\x00\x00\x25\x00\x00\x00\x2e\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x35\x01\x00\x00\x27\x00\x00\x00\x23\x00\x00\x00\x00\x00\x36\x01\x28\x00\x29\x00\x30\x01\x00\x00\x00\x00\x00\x00\x24\x00\x31\x01\x32\x01\x33\x01\x34\x01\x00\x00\x25\x00\x00\x00\x2e\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x35\x01\x00\x00\x27\x00\xd0\x00\x15\x00\x16\x00\x17\x00\x36\x01\x28\x00\x29\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x25\x00\x30\x00\x31\x00\x32\x00\x26\x00\x00\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x2e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x31\x00\x24\x00\x74\x00\x00\x00\x60\x00\x00\x00\x00\x00\x25\x00\x00\x00\x75\x00\x76\x00\x26\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\xf1\xfe\xf1\xfe\x00\x00\x78\x00\x00\x00\x28\x00\x29\x00\x61\x00\xf1\xfe\xf1\xfe\xf1\xfe\xf1\xfe\x24\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x25\x00\x2e\x00\x00\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x63\x00\x83\x01\x59\x00\x84\x01\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x85\x01\x59\x00\x86\x01\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x14\x01\x59\x00\x15\x01\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1f\x00\x4c\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x7b\x00\x07\x00\x21\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\xbb\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x21\x00\x17\x01\x59\x00\x18\x01\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\xcc\x00\x59\x00\xcd\x00\x5b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x5f\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x4a\x00\x1e\x00\x60\x00\x83\x00\x00\x00\x25\x00\x00\x00\x1f\x00\x4c\x00\x26\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x27\x00\x21\x00\x1f\x00\x4c\x00\x00\x00\x5f\x00\x28\x00\x29\x00\x61\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x24\x00\x62\x00\x00\x00\x60\x00\x00\x00\x2e\x00\x25\x00\xb4\x01\x00\x00\x00\x00\x26\x00\x8f\x00\x63\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x28\x00\x29\x00\x61\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x60\x00\x62\x00\x00\x00\x25\x00\x5a\xff\x2e\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x27\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x28\x00\x29\x00\x61\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x60\x00\x62\x00\x00\x00\x25\x00\x00\x00\x2e\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x29\x00\x61\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x62\x00\x00\x00\xfa\x01\xad\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x01\x63\x00\x3c\x01\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\xf3\x01\xea\x01\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\xae\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xeb\x01\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x00\x00\xe5\x01\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x01\x00\x00\x40\x01\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\xe9\x01\xea\x01\x00\x00\x49\x00\x16\x00\x17\x00\x21\x00\x00\x00\x00\x00\x00\x00\xae\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xeb\x01\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\xd8\x01\xad\x01\x00\x00\x1f\x00\x4c\x00\xb4\x00\x00\x00\xb5\x00\x14\x00\x15\x00\x16\x00\x17\x00\x4d\x00\x00\x00\x00\x00\x00\x00\xae\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x01\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\xac\x01\xad\x01\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x00\x00\x70\x01\xad\x00\xae\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x01\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\xae\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x00\x00\x00\x21\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x00\x00\x10\x01\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\xac\x00\xad\x00\xae\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x4f\x00\x16\x00\x17\x00\x1f\x00\x4c\x00\xae\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x00\x00\x00\x21\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x50\x00\x51\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\xf8\x01\x00\x00\x4e\x00\x16\x00\x17\x00\x00\x00\x00\x00\x4d\x00\x00\x00\xae\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xeb\x01\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\xe3\x01\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x4d\x00\x00\x00\x00\x00\x65\x01\xae\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x01\x00\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\xae\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xaf\x00\x00\x00\x21\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x12\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x21\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xbc\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x79\x00\x14\x00\x15\x00\x16\x00\x17\x00\x00\x00\x66\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x1e\x00\x4f\x00\x16\x00\x17\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x00\x00\x4a\x00\x1e\x00\x8f\x00\x16\x00\x17\x00\x00\x00\x21\x00\x1f\x00\x4c\x00\x00\x00\x4a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x4a\x00\x4b\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x4c\x00\x1a\x01\x4a\x00\x4b\x00\x00\x00\x00\x00\x17\x01\x00\x00\x4d\x00\x1f\x00\x4c\x00\x24\x00\x22\x01\x00\x00\x60\x00\x00\x00\x24\x00\x25\x00\x4d\x00\x60\x00\x00\x00\x26\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x28\x00\x29\x00\x61\x00\x00\x00\x00\x00\x28\x00\x29\x00\x61\x00\x1a\x01\x00\x00\x62\x00\x00\x00\x00\x00\x23\x00\x2e\x00\x62\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x00\x00\x60\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x23\x00\x00\x00\x27\x00\x28\x00\x29\x00\x61\x00\x00\x00\x00\x00\x28\x00\x29\x00\x24\x00\x23\x00\x00\x00\x62\x00\x00\x00\x00\x00\x25\x00\x2e\x00\x00\x00\x23\x00\x26\x00\x24\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x27\x00\x25\x00\x00\x00\x24\x00\x00\x00\x26\x00\x28\x00\x29\x00\x00\x00\x25\x00\x00\x00\x27\x00\x23\x00\x26\x00\x23\x00\x00\x00\x00\x00\x28\x00\x29\x00\x27\x00\xb1\x00\x00\x00\x24\x00\x00\x00\x24\x00\x28\x00\x29\x00\x00\x00\x25\x00\x00\x00\x25\x00\x2e\x00\x26\x00\x23\x00\x26\x00\x00\x00\x00\x00\x00\x00\x27\x00\xb1\x00\x27\x00\x23\x00\x00\x00\x24\x00\x28\x00\x29\x00\x28\x00\x29\x00\x00\x00\x25\x00\x00\x00\x24\x00\x23\x00\x26\x00\x00\x00\x00\x00\x00\x00\x25\x00\x2e\x00\x27\x00\xb1\x00\x26\x00\x24\x00\x00\x00\x00\x00\x28\x00\x29\x00\x27\x00\x25\x00\x00\x00\x23\x00\x00\x00\x26\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x27\x00\x2e\x00\x24\x00\xb7\x00\x00\x00\x00\x00\x28\x00\x29\x00\x25\x00\xb1\x00\x00\x00\xbe\x00\x26\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x25\x00\x2e\x00\x24\x00\x00\x00\x26\x00\x28\x00\x29\x00\x00\x00\x25\x00\x00\x00\x27\x00\x23\x00\x26\x00\x00\x00\x00\x00\x00\x00\x28\x00\x29\x00\x27\x00\xb1\x00\x00\x00\x24\x00\x00\x00\x00\x00\x28\x00\x29\x00\x00\x00\x25\x00\x00\x00\x00\x00\x2e\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x2e\x00\x24\x00\xfb\xfe\x00\x00\x60\x00\x28\x00\x29\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x24\x00\x00\x00\x00\x00\x60\x00\x00\x00\x27\x00\x25\x00\x2e\x00\x00\x00\x00\x00\x26\x00\x28\x00\x29\x00\x61\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x28\x00\x29\x00\x61\x00\x2e\x00\x8d\x00\x70\x00\x71\x00\x72\x00\x73\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\xff\x8e\x00\x00\x00\x00\x00\x00\x00\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = array (1, 270) [+ (1 , happyReduce_1),+ (2 , happyReduce_2),+ (3 , happyReduce_3),+ (4 , happyReduce_4),+ (5 , happyReduce_5),+ (6 , happyReduce_6),+ (7 , happyReduce_7),+ (8 , happyReduce_8),+ (9 , happyReduce_9),+ (10 , happyReduce_10),+ (11 , happyReduce_11),+ (12 , happyReduce_12),+ (13 , happyReduce_13),+ (14 , happyReduce_14),+ (15 , happyReduce_15),+ (16 , happyReduce_16),+ (17 , happyReduce_17),+ (18 , happyReduce_18),+ (19 , happyReduce_19),+ (20 , happyReduce_20),+ (21 , happyReduce_21),+ (22 , happyReduce_22),+ (23 , happyReduce_23),+ (24 , happyReduce_24),+ (25 , happyReduce_25),+ (26 , happyReduce_26),+ (27 , happyReduce_27),+ (28 , happyReduce_28),+ (29 , happyReduce_29),+ (30 , happyReduce_30),+ (31 , happyReduce_31),+ (32 , happyReduce_32),+ (33 , happyReduce_33),+ (34 , happyReduce_34),+ (35 , happyReduce_35),+ (36 , happyReduce_36),+ (37 , happyReduce_37),+ (38 , happyReduce_38),+ (39 , happyReduce_39),+ (40 , happyReduce_40),+ (41 , happyReduce_41),+ (42 , happyReduce_42),+ (43 , happyReduce_43),+ (44 , happyReduce_44),+ (45 , happyReduce_45),+ (46 , happyReduce_46),+ (47 , happyReduce_47),+ (48 , happyReduce_48),+ (49 , happyReduce_49),+ (50 , happyReduce_50),+ (51 , happyReduce_51),+ (52 , happyReduce_52),+ (53 , happyReduce_53),+ (54 , happyReduce_54),+ (55 , happyReduce_55),+ (56 , happyReduce_56),+ (57 , happyReduce_57),+ (58 , happyReduce_58),+ (59 , happyReduce_59),+ (60 , happyReduce_60),+ (61 , happyReduce_61),+ (62 , happyReduce_62),+ (63 , happyReduce_63),+ (64 , happyReduce_64),+ (65 , happyReduce_65),+ (66 , happyReduce_66),+ (67 , happyReduce_67),+ (68 , happyReduce_68),+ (69 , happyReduce_69),+ (70 , happyReduce_70),+ (71 , happyReduce_71),+ (72 , happyReduce_72),+ (73 , happyReduce_73),+ (74 , happyReduce_74),+ (75 , happyReduce_75),+ (76 , happyReduce_76),+ (77 , happyReduce_77),+ (78 , happyReduce_78),+ (79 , happyReduce_79),+ (80 , happyReduce_80),+ (81 , happyReduce_81),+ (82 , happyReduce_82),+ (83 , happyReduce_83),+ (84 , happyReduce_84),+ (85 , happyReduce_85),+ (86 , happyReduce_86),+ (87 , happyReduce_87),+ (88 , happyReduce_88),+ (89 , happyReduce_89),+ (90 , happyReduce_90),+ (91 , happyReduce_91),+ (92 , happyReduce_92),+ (93 , happyReduce_93),+ (94 , happyReduce_94),+ (95 , happyReduce_95),+ (96 , happyReduce_96),+ (97 , happyReduce_97),+ (98 , happyReduce_98),+ (99 , happyReduce_99),+ (100 , happyReduce_100),+ (101 , happyReduce_101),+ (102 , happyReduce_102),+ (103 , happyReduce_103),+ (104 , happyReduce_104),+ (105 , happyReduce_105),+ (106 , happyReduce_106),+ (107 , happyReduce_107),+ (108 , happyReduce_108),+ (109 , happyReduce_109),+ (110 , happyReduce_110),+ (111 , happyReduce_111),+ (112 , happyReduce_112),+ (113 , happyReduce_113),+ (114 , happyReduce_114),+ (115 , happyReduce_115),+ (116 , happyReduce_116),+ (117 , happyReduce_117),+ (118 , happyReduce_118),+ (119 , happyReduce_119),+ (120 , happyReduce_120),+ (121 , happyReduce_121),+ (122 , happyReduce_122),+ (123 , happyReduce_123),+ (124 , happyReduce_124),+ (125 , happyReduce_125),+ (126 , happyReduce_126),+ (127 , happyReduce_127),+ (128 , happyReduce_128),+ (129 , happyReduce_129),+ (130 , happyReduce_130),+ (131 , happyReduce_131),+ (132 , happyReduce_132),+ (133 , happyReduce_133),+ (134 , happyReduce_134),+ (135 , happyReduce_135),+ (136 , happyReduce_136),+ (137 , happyReduce_137),+ (138 , happyReduce_138),+ (139 , happyReduce_139),+ (140 , happyReduce_140),+ (141 , happyReduce_141),+ (142 , happyReduce_142),+ (143 , happyReduce_143),+ (144 , happyReduce_144),+ (145 , happyReduce_145),+ (146 , happyReduce_146),+ (147 , happyReduce_147),+ (148 , happyReduce_148),+ (149 , happyReduce_149),+ (150 , happyReduce_150),+ (151 , happyReduce_151),+ (152 , happyReduce_152),+ (153 , happyReduce_153),+ (154 , happyReduce_154),+ (155 , happyReduce_155),+ (156 , happyReduce_156),+ (157 , happyReduce_157),+ (158 , happyReduce_158),+ (159 , happyReduce_159),+ (160 , happyReduce_160),+ (161 , happyReduce_161),+ (162 , happyReduce_162),+ (163 , happyReduce_163),+ (164 , happyReduce_164),+ (165 , happyReduce_165),+ (166 , happyReduce_166),+ (167 , happyReduce_167),+ (168 , happyReduce_168),+ (169 , happyReduce_169),+ (170 , happyReduce_170),+ (171 , happyReduce_171),+ (172 , happyReduce_172),+ (173 , happyReduce_173),+ (174 , happyReduce_174),+ (175 , happyReduce_175),+ (176 , happyReduce_176),+ (177 , happyReduce_177),+ (178 , happyReduce_178),+ (179 , happyReduce_179),+ (180 , happyReduce_180),+ (181 , happyReduce_181),+ (182 , happyReduce_182),+ (183 , happyReduce_183),+ (184 , happyReduce_184),+ (185 , happyReduce_185),+ (186 , happyReduce_186),+ (187 , happyReduce_187),+ (188 , happyReduce_188),+ (189 , happyReduce_189),+ (190 , happyReduce_190),+ (191 , happyReduce_191),+ (192 , happyReduce_192),+ (193 , happyReduce_193),+ (194 , happyReduce_194),+ (195 , happyReduce_195),+ (196 , happyReduce_196),+ (197 , happyReduce_197),+ (198 , happyReduce_198),+ (199 , happyReduce_199),+ (200 , happyReduce_200),+ (201 , happyReduce_201),+ (202 , happyReduce_202),+ (203 , happyReduce_203),+ (204 , happyReduce_204),+ (205 , happyReduce_205),+ (206 , happyReduce_206),+ (207 , happyReduce_207),+ (208 , happyReduce_208),+ (209 , happyReduce_209),+ (210 , happyReduce_210),+ (211 , happyReduce_211),+ (212 , happyReduce_212),+ (213 , happyReduce_213),+ (214 , happyReduce_214),+ (215 , happyReduce_215),+ (216 , happyReduce_216),+ (217 , happyReduce_217),+ (218 , happyReduce_218),+ (219 , happyReduce_219),+ (220 , happyReduce_220),+ (221 , happyReduce_221),+ (222 , happyReduce_222),+ (223 , happyReduce_223),+ (224 , happyReduce_224),+ (225 , happyReduce_225),+ (226 , happyReduce_226),+ (227 , happyReduce_227),+ (228 , happyReduce_228),+ (229 , happyReduce_229),+ (230 , happyReduce_230),+ (231 , happyReduce_231),+ (232 , happyReduce_232),+ (233 , happyReduce_233),+ (234 , happyReduce_234),+ (235 , happyReduce_235),+ (236 , happyReduce_236),+ (237 , happyReduce_237),+ (238 , happyReduce_238),+ (239 , happyReduce_239),+ (240 , happyReduce_240),+ (241 , happyReduce_241),+ (242 , happyReduce_242),+ (243 , happyReduce_243),+ (244 , happyReduce_244),+ (245 , happyReduce_245),+ (246 , happyReduce_246),+ (247 , happyReduce_247),+ (248 , happyReduce_248),+ (249 , happyReduce_249),+ (250 , happyReduce_250),+ (251 , happyReduce_251),+ (252 , happyReduce_252),+ (253 , happyReduce_253),+ (254 , happyReduce_254),+ (255 , happyReduce_255),+ (256 , happyReduce_256),+ (257 , happyReduce_257),+ (258 , happyReduce_258),+ (259 , happyReduce_259),+ (260 , happyReduce_260),+ (261 , happyReduce_261),+ (262 , happyReduce_262),+ (263 , happyReduce_263),+ (264 , happyReduce_264),+ (265 , happyReduce_265),+ (266 , happyReduce_266),+ (267 , happyReduce_267),+ (268 , happyReduce_268),+ (269 , happyReduce_269),+ (270 , happyReduce_270)+ ]++happy_n_terms = 64 :: Int+happy_n_nonterms = 104 :: Int++happyReduce_1 = happyReduce 4# 0# happyReduction_1+happyReduction_1 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut99 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + happyIn4+ (mkModule happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_2 = happyReduce 6# 1# happyReduction_2+happyReduction_2 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_3 of { happy_var_3 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + case happyOut6 happy_x_6 of { happy_var_6 -> + happyIn5+ ((reverse happy_var_3,reverse happy_var_4, happy_var_6)+ ) `HappyStk` happyRest}}}++happyReduce_3 = happyReduce 5# 1# happyReduction_3+happyReduction_3 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + case happyOut6 happy_x_5 of { happy_var_5 -> + happyIn5+ ((reverse happy_var_2, reverse happy_var_3, happy_var_5)+ ) `HappyStk` happyRest}}}++happyReduce_4 = happySpecReduce_2 2# happyReduction_4+happyReduction_4 happy_x_2+ happy_x_1+ = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn6+ (happy_var_2+ )}++happyReduce_5 = happySpecReduce_0 2# happyReduction_5+happyReduction_5 = happyIn6+ ([]+ )++happyReduce_6 = happyReduce 4# 3# happyReduction_6+happyReduction_6 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn7+ (reverse happy_var_3+ ) `HappyStk` happyRest}++happyReduce_7 = happySpecReduce_3 3# happyReduction_7+happyReduction_7 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn7+ (reverse happy_var_2+ )}++happyReduce_8 = happySpecReduce_3 4# happyReduction_8+happyReduction_8 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn8+ (happy_var_2 : happy_var_1+ )}}++happyReduce_9 = happySpecReduce_0 4# happyReduction_9+happyReduction_9 = happyIn8+ ([]+ )++happyReduce_10 = happySpecReduce_2 5# happyReduction_10+happyReduction_10 happy_x_2+ happy_x_1+ = case happyOut99 happy_x_2 of { happy_var_2 -> + happyIn9+ (Import True (modId happy_var_2)+ )}++happyReduce_11 = happySpecReduce_2 5# happyReduction_11+happyReduction_11 happy_x_2+ happy_x_1+ = case happyOut99 happy_x_2 of { happy_var_2 -> + happyIn9+ (Import False (modId happy_var_2)+ )}++happyReduce_12 = happySpecReduce_3 6# happyReduction_12+happyReduction_12 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + happyIn10+ (happy_var_3 ++ happy_var_1+ )}}++happyReduce_13 = happySpecReduce_1 6# happyReduction_13+happyReduction_13 happy_x_1+ = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10+ (happy_var_1+ )}++happyReduce_14 = happySpecReduce_3 7# happyReduction_14+happyReduction_14 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut99 happy_x_1 of { happy_var_1 -> + case happyOut46 happy_x_3 of { happy_var_3 -> + happyIn11+ ([DKSig happy_var_1 happy_var_3]+ )}}++happyReduce_15 = happyReduce 5# 7# happyReduction_15+happyReduction_15 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut99 happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOut37 happy_x_5 of { happy_var_5 -> + happyIn11+ ([DType happy_var_2 (reverse happy_var_3) happy_var_5]+ ) `HappyStk` happyRest}}}++happyReduce_16 = happyReduce 5# 7# happyReduction_16+happyReduction_16 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut99 happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOut14 happy_x_4 of { happy_var_4 -> + case happyOut20 happy_x_5 of { happy_var_5 -> + happyIn11+ ([DData happy_var_2 (reverse happy_var_3) happy_var_4 happy_var_5]+ ) `HappyStk` happyRest}}}}++happyReduce_17 = happyReduce 5# 7# happyReduction_17+happyReduction_17 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut99 happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOut13 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_5 of { happy_var_5 -> + happyIn11+ ([DRec False happy_var_2 (reverse happy_var_3) happy_var_4 happy_var_5]+ ) `HappyStk` happyRest}}}}++happyReduce_18 = happyReduce 5# 7# happyReduction_18+happyReduction_18 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut99 happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOut12 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_5 of { happy_var_5 -> + happyIn11+ ([DRec True happy_var_2 (reverse happy_var_3) happy_var_4 happy_var_5]+ ) `HappyStk` happyRest}}}}++happyReduce_19 = happyReduce 5# 7# happyReduction_19+happyReduction_19 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut99 happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOut23 happy_x_5 of { happy_var_5 -> + happyIn11+ ([DRec True happy_var_2 (reverse happy_var_3) [] happy_var_5]+ ) `HappyStk` happyRest}}}++happyReduce_20 = happySpecReduce_2 7# happyReduction_20+happyReduction_20 happy_x_2+ happy_x_1+ = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn11+ ([DTClass happy_var_2]+ )}++happyReduce_21 = happyReduce 4# 7# happyReduction_21+happyReduction_21 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut91 happy_x_2 of { happy_var_2 -> + case happyOut37 happy_x_4 of { happy_var_4 -> + happyIn11+ ([DPSig happy_var_2 happy_var_4]+ ) `HappyStk` happyRest}}++happyReduce_22 = happyReduce 6# 7# happyReduction_22+happyReduction_22 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut91 happy_x_2 of { happy_var_2 -> + case happyOut37 happy_x_4 of { happy_var_4 -> + case happyOut27 happy_x_6 of { happy_var_6 -> + happyIn11+ ([DBind [BEqn (exp2lhs (EVar happy_var_2)) (RExp (EBStruct Nothing [] happy_var_6))], DPSig happy_var_2 happy_var_4]+ ) `HappyStk` happyRest}}}++happyReduce_23 = happyReduce 5# 7# happyReduction_23+happyReduction_23 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut91 happy_x_2 of { happy_var_2 -> + case happyOut37 happy_x_4 of { happy_var_4 -> + case happyOut34 happy_x_5 of { happy_var_5 -> + happyIn11+ ([DBind [BEqn (exp2lhs (EVar happy_var_2)) happy_var_5], DPSig happy_var_2 happy_var_4]+ ) `HappyStk` happyRest}}}++happyReduce_24 = happySpecReduce_2 7# happyReduction_24+happyReduction_24 happy_x_2+ happy_x_1+ = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn11+ ([DInstance happy_var_2]+ )}++happyReduce_25 = happySpecReduce_2 7# happyReduction_25+happyReduction_25 happy_x_2+ happy_x_1+ = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn11+ ([DDefault (reverse happy_var_2)]+ )}++happyReduce_26 = happySpecReduce_3 7# happyReduction_26+happyReduction_26 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn11+ ([DBind [BSig (reverse happy_var_1) happy_var_3]]+ )}}++happyReduce_27 = happySpecReduce_2 7# happyReduction_27+happyReduction_27 happy_x_2+ happy_x_1+ = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn11+ ([DBind [BEqn happy_var_1 happy_var_2]]+ )}}++happyReduce_28 = happySpecReduce_2 8# happyReduction_28+happyReduction_28 happy_x_2+ happy_x_1+ = case happyOut42 happy_x_2 of { happy_var_2 -> + happyIn12+ (reverse happy_var_2+ )}++happyReduce_29 = happySpecReduce_2 8# happyReduction_29+happyReduction_29 happy_x_2+ happy_x_1+ = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn12+ ([happy_var_2]+ )}++happyReduce_30 = happySpecReduce_1 9# happyReduction_30+happyReduction_30 happy_x_1+ = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn13+ (happy_var_1+ )}++happyReduce_31 = happySpecReduce_0 9# happyReduction_31+happyReduction_31 = happyIn13+ ([]+ )++happyReduce_32 = happySpecReduce_2 10# happyReduction_32+happyReduction_32 happy_x_2+ happy_x_1+ = case happyOut42 happy_x_2 of { happy_var_2 -> + happyIn14+ (reverse happy_var_2+ )}++happyReduce_33 = happySpecReduce_2 10# happyReduction_33+happyReduction_33 happy_x_2+ happy_x_1+ = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn14+ ([happy_var_2]+ )}++happyReduce_34 = happySpecReduce_0 10# happyReduction_34+happyReduction_34 = happyIn14+ ([]+ )++happyReduce_35 = happySpecReduce_2 11# happyReduction_35+happyReduction_35 happy_x_2+ happy_x_1+ = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut98 happy_x_2 of { happy_var_2 -> + happyIn15+ (happy_var_2 : happy_var_1+ )}}++happyReduce_36 = happySpecReduce_0 11# happyReduction_36+happyReduction_36 = happyIn15+ ([]+ )++happyReduce_37 = happySpecReduce_3 12# happyReduction_37+happyReduction_37 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut96 happy_x_3 of { happy_var_3 -> + happyIn16+ (happy_var_3 : happy_var_1+ )}}++happyReduce_38 = happySpecReduce_1 12# happyReduction_38+happyReduction_38 happy_x_1+ = case happyOut96 happy_x_1 of { happy_var_1 -> + happyIn16+ ([happy_var_1]+ )}++happyReduce_39 = happyReduce 4# 13# happyReduction_39+happyReduction_39 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut18 happy_x_3 of { happy_var_3 -> + happyIn17+ (happy_var_3+ ) `HappyStk` happyRest}++happyReduce_40 = happySpecReduce_3 13# happyReduction_40+happyReduction_40 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut18 happy_x_2 of { happy_var_2 -> + happyIn17+ (happy_var_2+ )}++happyReduce_41 = happySpecReduce_3 14# happyReduction_41+happyReduction_41 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn18+ (happy_var_3 : happy_var_1+ )}}++happyReduce_42 = happySpecReduce_1 14# happyReduction_42+happyReduction_42 happy_x_1+ = case happyOut19 happy_x_1 of { happy_var_1 -> + happyIn18+ ([happy_var_1]+ )}++happyReduce_43 = happySpecReduce_3 15# happyReduction_43+happyReduction_43 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut91 happy_x_1 of { happy_var_1 -> + case happyOut91 happy_x_3 of { happy_var_3 -> + happyIn19+ (Default True happy_var_1 happy_var_3+ )}}++happyReduce_44 = happySpecReduce_3 15# happyReduction_44+happyReduction_44 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut91 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn19+ (Derive happy_var_1 happy_var_3+ )}}++happyReduce_45 = happySpecReduce_2 16# happyReduction_45+happyReduction_45 happy_x_2+ happy_x_1+ = case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn20+ (reverse happy_var_2+ )}++happyReduce_46 = happySpecReduce_0 16# happyReduction_46+happyReduction_46 = happyIn20+ ([]+ )++happyReduce_47 = happySpecReduce_3 17# happyReduction_47+happyReduction_47 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut21 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn21+ (type2cons happy_var_3 : happy_var_1+ )}}++happyReduce_48 = happySpecReduce_1 17# happyReduction_48+happyReduction_48 happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn21+ ([type2cons happy_var_1]+ )}++happyReduce_49 = happySpecReduce_2 18# happyReduction_49+happyReduction_49 happy_x_2+ happy_x_1+ = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn22+ (happy_var_2+ )}++happyReduce_50 = happySpecReduce_0 18# happyReduction_50+happyReduction_50 = happyIn22+ ([]+ )++happyReduce_51 = happyReduce 4# 19# happyReduction_51+happyReduction_51 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut24 happy_x_3 of { happy_var_3 -> + happyIn23+ (reverse happy_var_3+ ) `HappyStk` happyRest}++happyReduce_52 = happySpecReduce_3 19# happyReduction_52+happyReduction_52 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn23+ (reverse happy_var_2+ )}++happyReduce_53 = happySpecReduce_1 20# happyReduction_53+happyReduction_53 happy_x_1+ = case happyOut25 happy_x_1 of { happy_var_1 -> + happyIn24+ (happy_var_1+ )}++happyReduce_54 = happySpecReduce_0 20# happyReduction_54+happyReduction_54 = happyIn24+ ([]+ )++happyReduce_55 = happySpecReduce_3 21# happyReduction_55+happyReduction_55 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut25 happy_x_1 of { happy_var_1 -> + case happyOut26 happy_x_3 of { happy_var_3 -> + happyIn25+ (happy_var_3 : happy_var_1+ )}}++happyReduce_56 = happySpecReduce_1 21# happyReduction_56+happyReduction_56 happy_x_1+ = case happyOut26 happy_x_1 of { happy_var_1 -> + happyIn25+ ([happy_var_1]+ )}++happyReduce_57 = happySpecReduce_3 22# happyReduction_57+happyReduction_57 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn26+ (Sig (reverse happy_var_1) happy_var_3+ )}}++happyReduce_58 = happyReduce 4# 23# happyReduction_58+happyReduction_58 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut28 happy_x_3 of { happy_var_3 -> + happyIn27+ (reverse happy_var_3+ ) `HappyStk` happyRest}++happyReduce_59 = happySpecReduce_3 23# happyReduction_59+happyReduction_59 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut28 happy_x_2 of { happy_var_2 -> + happyIn27+ (reverse happy_var_2+ )}++happyReduce_60 = happySpecReduce_3 24# happyReduction_60+happyReduction_60 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut28 happy_x_1 of { happy_var_1 -> + case happyOut29 happy_x_3 of { happy_var_3 -> + happyIn28+ (happy_var_3 : happy_var_1+ )}}++happyReduce_61 = happySpecReduce_1 24# happyReduction_61+happyReduction_61 happy_x_1+ = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn28+ ([happy_var_1]+ )}++happyReduce_62 = happySpecReduce_3 25# happyReduction_62+happyReduction_62 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn29+ (BSig (reverse happy_var_1) happy_var_3+ )}}++happyReduce_63 = happySpecReduce_2 25# happyReduction_63+happyReduction_63 happy_x_2+ happy_x_1+ = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn29+ (BEqn happy_var_1 happy_var_2+ )}}++happyReduce_64 = happySpecReduce_3 26# happyReduction_64+happyReduction_64 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_3 of { happy_var_3 -> + happyIn30+ (happy_var_3 : happy_var_1+ )}}++happyReduce_65 = happySpecReduce_1 26# happyReduction_65+happyReduction_65 happy_x_1+ = case happyOut31 happy_x_1 of { happy_var_1 -> + happyIn30+ ([happy_var_1]+ )}++happyReduce_66 = happySpecReduce_3 27# happyReduction_66+happyReduction_66 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut91 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn31+ (Field happy_var_1 happy_var_3+ )}}++happyReduce_67 = happySpecReduce_3 28# happyReduction_67+happyReduction_67 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut91 happy_x_3 of { happy_var_3 -> + happyIn32+ (happy_var_3 : happy_var_1+ )}}++happyReduce_68 = happySpecReduce_1 28# happyReduction_68+happyReduction_68 happy_x_1+ = case happyOut91 happy_x_1 of { happy_var_1 -> + happyIn32+ ([happy_var_1]+ )}++happyReduce_69 = happySpecReduce_1 29# happyReduction_69+happyReduction_69 happy_x_1+ = case happyOut83 happy_x_1 of { happy_var_1 -> + happyIn33+ (exp2lhs happy_var_1+ )}++happyReduce_70 = happySpecReduce_2 30# happyReduction_70+happyReduction_70 happy_x_2+ happy_x_1+ = case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn34+ (RExp happy_var_2+ )}++happyReduce_71 = happySpecReduce_1 30# happyReduction_71+happyReduction_71 happy_x_1+ = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn34+ (RGrd (reverse happy_var_1)+ )}++happyReduce_72 = happySpecReduce_3 30# happyReduction_72+happyReduction_72 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut34 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn34+ (RWhere happy_var_1 happy_var_3+ )}}++happyReduce_73 = happySpecReduce_2 31# happyReduction_73+happyReduction_73 happy_x_2+ happy_x_1+ = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn35+ (happy_var_2 : happy_var_1+ )}}++happyReduce_74 = happySpecReduce_1 31# happyReduction_74+happyReduction_74 happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn35+ ([happy_var_1]+ )}++happyReduce_75 = happyReduce 4# 32# happyReduction_75+happyReduction_75 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut64 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + happyIn36+ (GExp (reverse happy_var_2) happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_76 = happySpecReduce_3 33# happyReduction_76+happyReduction_76 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut44 happy_x_3 of { happy_var_3 -> + happyIn37+ (TQual happy_var_1 happy_var_3+ )}}++happyReduce_77 = happySpecReduce_1 33# happyReduction_77+happyReduction_77 happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn37+ (happy_var_1+ )}++happyReduce_78 = happySpecReduce_1 34# happyReduction_78+happyReduction_78 happy_x_1+ = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn38+ (tFun (reverse (tail happy_var_1)) (head happy_var_1)+ )}++happyReduce_79 = happySpecReduce_3 34# happyReduction_79+happyReduction_79 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn38+ (TSub happy_var_1 happy_var_3+ )}}++happyReduce_80 = happySpecReduce_3 35# happyReduction_80+happyReduction_80 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut39 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn39+ (happy_var_3 : happy_var_1+ )}}++happyReduce_81 = happySpecReduce_1 35# happyReduction_81+happyReduction_81 happy_x_1+ = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn39+ ([happy_var_1]+ )}++happyReduce_82 = happySpecReduce_2 36# happyReduction_82+happyReduction_82 happy_x_2+ happy_x_1+ = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut41 happy_x_2 of { happy_var_2 -> + happyIn40+ (TAp happy_var_1 happy_var_2+ )}}++happyReduce_83 = happySpecReduce_1 36# happyReduction_83+happyReduction_83 happy_x_1+ = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn40+ (happy_var_1+ )}++happyReduce_84 = happySpecReduce_1 37# happyReduction_84+happyReduction_84 happy_x_1+ = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn41+ (TCon happy_var_1+ )}++happyReduce_85 = happySpecReduce_1 37# happyReduction_85+happyReduction_85 happy_x_1+ = case happyOut98 happy_x_1 of { happy_var_1 -> + happyIn41+ (TVar happy_var_1+ )}++happyReduce_86 = happySpecReduce_1 37# happyReduction_86+happyReduction_86 happy_x_1+ = happyIn41+ (TWild+ )++happyReduce_87 = happySpecReduce_2 37# happyReduction_87+happyReduction_87 happy_x_2+ happy_x_1+ = happyIn41+ (TCon (prim LIST)+ )++happyReduce_88 = happySpecReduce_3 37# happyReduction_88+happyReduction_88 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut43 happy_x_2 of { happy_var_2 -> + happyIn41+ (TCon (tuple (happy_var_2+1))+ )}++happyReduce_89 = happySpecReduce_2 37# happyReduction_89+happyReduction_89 happy_x_2+ happy_x_1+ = happyIn41+ (TCon (prim UNITTYPE)+ )++happyReduce_90 = happySpecReduce_3 37# happyReduction_90+happyReduction_90 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn41+ (happy_var_2+ )}++happyReduce_91 = happySpecReduce_3 37# happyReduction_91+happyReduction_91 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut42 happy_x_2 of { happy_var_2 -> + happyIn41+ (TTup (reverse happy_var_2)+ )}++happyReduce_92 = happySpecReduce_3 37# happyReduction_92+happyReduction_92 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn41+ (TList happy_var_2+ )}++happyReduce_93 = happySpecReduce_3 38# happyReduction_93+happyReduction_93 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + happyIn42+ (happy_var_3 : happy_var_1+ )}}++happyReduce_94 = happySpecReduce_3 38# happyReduction_94+happyReduction_94 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + happyIn42+ ([happy_var_3, happy_var_1]+ )}}++happyReduce_95 = happySpecReduce_2 39# happyReduction_95+happyReduction_95 happy_x_2+ happy_x_1+ = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn43+ (happy_var_1 + 1+ )}++happyReduce_96 = happySpecReduce_1 39# happyReduction_96+happyReduction_96 happy_x_1+ = happyIn43+ (1+ )++happyReduce_97 = happySpecReduce_3 40# happyReduction_97+happyReduction_97 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOut45 happy_x_3 of { happy_var_3 -> + happyIn44+ (happy_var_3 : happy_var_1+ )}}++happyReduce_98 = happySpecReduce_1 40# happyReduction_98+happyReduction_98 happy_x_1+ = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn44+ ([happy_var_1]+ )}++happyReduce_99 = happySpecReduce_1 41# happyReduction_99+happyReduction_99 happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn45+ (PType happy_var_1+ )}++happyReduce_100 = happySpecReduce_3 41# happyReduction_100+happyReduction_100 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut98 happy_x_1 of { happy_var_1 -> + case happyOut46 happy_x_3 of { happy_var_3 -> + happyIn45+ (PKind happy_var_1 happy_var_3+ )}}++happyReduce_101 = happySpecReduce_3 42# happyReduction_101+happyReduction_101 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut46 happy_x_3 of { happy_var_3 -> + happyIn46+ (KFun happy_var_1 happy_var_3+ )}}++happyReduce_102 = happySpecReduce_1 42# happyReduction_102+happyReduction_102 happy_x_1+ = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn46+ (happy_var_1+ )}++happyReduce_103 = happySpecReduce_1 43# happyReduction_103+happyReduction_103 happy_x_1+ = happyIn47+ (Star+ )++happyReduce_104 = happySpecReduce_1 43# happyReduction_104+happyReduction_104 happy_x_1+ = happyIn47+ (KWild+ )++happyReduce_105 = happySpecReduce_3 43# happyReduction_105+happyReduction_105 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut46 happy_x_2 of { happy_var_2 -> + happyIn47+ (happy_var_2+ )}++happyReduce_106 = happySpecReduce_3 44# happyReduction_106+happyReduction_106 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn48+ (ESig happy_var_1 happy_var_3+ )}}++happyReduce_107 = happySpecReduce_1 44# happyReduction_107+happyReduction_107 happy_x_1+ = case happyOut49 happy_x_1 of { happy_var_1 -> + happyIn48+ (happy_var_1+ )}++happyReduce_108 = happySpecReduce_2 44# happyReduction_108+happyReduction_108 happy_x_2+ happy_x_1+ = case happyOut27 happy_x_2 of { happy_var_2 -> + happyIn48+ (EBStruct Nothing [] happy_var_2+ )}++happyReduce_109 = happySpecReduce_1 45# happyReduction_109+happyReduction_109 happy_x_1+ = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn49+ (happy_var_1+ )}++happyReduce_110 = happySpecReduce_1 45# happyReduction_110+happyReduction_110 happy_x_1+ = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn49+ (happy_var_1+ )}++happyReduce_111 = happySpecReduce_1 46# happyReduction_111+happyReduction_111 happy_x_1+ = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn50+ (transFix happy_var_1+ )}++happyReduce_112 = happySpecReduce_1 46# happyReduction_112+happyReduction_112 happy_x_1+ = case happyOut54 happy_x_1 of { happy_var_1 -> + happyIn50+ (happy_var_1+ )}++happyReduce_113 = happySpecReduce_1 47# happyReduction_113+happyReduction_113 happy_x_1+ = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn51+ (transFix happy_var_1+ )}++happyReduce_114 = happySpecReduce_1 47# happyReduction_114+happyReduction_114 happy_x_1+ = case happyOut56 happy_x_1 of { happy_var_1 -> + happyIn51+ (happy_var_1+ )}++happyReduce_115 = happyReduce 4# 48# happyReduction_115+happyReduction_115 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_4 of { happy_var_4 -> + happyIn52+ (Cons happy_var_1 happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_116 = happySpecReduce_3 48# happyReduction_116+happyReduction_116 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn52+ (Cons happy_var_1 happy_var_2 happy_var_3+ )}}}++happyReduce_117 = happySpecReduce_2 48# happyReduction_117+happyReduction_117 happy_x_2+ happy_x_1+ = case happyOut54 happy_x_2 of { happy_var_2 -> + happyIn52+ (Nil (ENeg happy_var_2)+ )}++happyReduce_118 = happyReduce 4# 48# happyReduction_118+happyReduction_118 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_4 of { happy_var_4 -> + happyIn52+ (Cons (Nil happy_var_1) happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_119 = happySpecReduce_3 48# happyReduction_119+happyReduction_119 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn52+ (Cons (Nil happy_var_1) happy_var_2 happy_var_3+ )}}}++happyReduce_120 = happyReduce 4# 49# happyReduction_120+happyReduction_120 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_4 of { happy_var_4 -> + happyIn53+ (Cons happy_var_1 happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_121 = happySpecReduce_3 49# happyReduction_121+happyReduction_121 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_3 of { happy_var_3 -> + happyIn53+ (Cons happy_var_1 happy_var_2 happy_var_3+ )}}}++happyReduce_122 = happySpecReduce_2 49# happyReduction_122+happyReduction_122 happy_x_2+ happy_x_1+ = case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn53+ (Nil (ENeg happy_var_2)+ )}++happyReduce_123 = happyReduce 4# 49# happyReduction_123+happyReduction_123 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_4 of { happy_var_4 -> + happyIn53+ (Cons (Nil happy_var_1) happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_124 = happySpecReduce_3 49# happyReduction_124+happyReduction_124 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_3 of { happy_var_3 -> + happyIn53+ (Cons (Nil happy_var_1) happy_var_2 happy_var_3+ )}}}++happyReduce_125 = happyReduce 4# 50# happyReduction_125+happyReduction_125 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_2 of { happy_var_2 -> + case happyOut66 happy_x_4 of { happy_var_4 -> + happyIn54+ (ECase happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_126 = happyReduce 4# 50# happyReduction_126+happyReduction_126 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn54+ (ERec Nothing (reverse happy_var_3)+ ) `HappyStk` happyRest}++happyReduce_127 = happySpecReduce_3 50# happyReduction_127+happyReduction_127 happy_x_3+ happy_x_2+ happy_x_1+ = happyIn54+ (ERec Nothing []+ )++happyReduce_128 = happySpecReduce_1 50# happyReduction_128+happyReduction_128 happy_x_1+ = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn54+ (happy_var_1+ )}++happyReduce_129 = happySpecReduce_3 51# happyReduction_129+happyReduction_129 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut78 happy_x_3 of { happy_var_3 -> + happyIn55+ (EDo Nothing Nothing happy_var_3+ )}++happyReduce_130 = happySpecReduce_3 51# happyReduction_130+happyReduction_130 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut78 happy_x_3 of { happy_var_3 -> + happyIn55+ (ETempl Nothing Nothing happy_var_3+ )}++happyReduce_131 = happySpecReduce_3 51# happyReduction_131+happyReduction_131 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut78 happy_x_3 of { happy_var_3 -> + happyIn55+ (EAct Nothing happy_var_3+ )}++happyReduce_132 = happySpecReduce_3 51# happyReduction_132+happyReduction_132 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut78 happy_x_3 of { happy_var_3 -> + happyIn55+ (EReq Nothing happy_var_3+ )}++happyReduce_133 = happyReduce 5# 51# happyReduction_133+happyReduction_133 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut92 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_4 of { happy_var_4 -> + happyIn55+ (ERec (Just (happy_var_1,True)) (reverse happy_var_4)+ ) `HappyStk` happyRest}}++happyReduce_134 = happyReduce 6# 51# happyReduction_134+happyReduction_134 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut92 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_4 of { happy_var_4 -> + happyIn55+ (ERec (Just (happy_var_1,False)) (reverse happy_var_4)+ ) `HappyStk` happyRest}}++happyReduce_135 = happyReduce 7# 51# happyReduction_135+happyReduction_135 (happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut92 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_4 of { happy_var_4 -> + happyIn55+ (ERec (Just (happy_var_1,False)) (reverse happy_var_4)+ ) `HappyStk` happyRest}}++happyReduce_136 = happyReduce 5# 51# happyReduction_136+happyReduction_136 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn55+ (ERec (Just (happy_var_1,False)) []+ ) `HappyStk` happyRest}++happyReduce_137 = happyReduce 4# 51# happyReduction_137+happyReduction_137 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn55+ (ERec (Just (happy_var_1,True)) []+ ) `HappyStk` happyRest}++happyReduce_138 = happySpecReduce_1 51# happyReduction_138+happyReduction_138 happy_x_1+ = case happyOut58 happy_x_1 of { happy_var_1 -> + happyIn55+ (happy_var_1+ )}++happyReduce_139 = happyReduce 6# 52# happyReduction_139+happyReduction_139 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + case happyOut48 happy_x_6 of { happy_var_6 -> + happyIn56+ (EIf happy_var_2 happy_var_4 happy_var_6+ ) `HappyStk` happyRest}}}++happyReduce_140 = happySpecReduce_1 52# happyReduction_140+happyReduction_140 happy_x_1+ = case happyOut57 happy_x_1 of { happy_var_1 -> + happyIn56+ (happy_var_1+ )}++happyReduce_141 = happyReduce 4# 53# happyReduction_141+happyReduction_141 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut89 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + happyIn57+ (ELam (reverse happy_var_2) happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_142 = happyReduce 4# 53# happyReduction_142+happyReduction_142 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut27 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + happyIn57+ (ELet happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_143 = happySpecReduce_3 53# happyReduction_143+happyReduction_143 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut59 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn57+ (EAfter happy_var_2 happy_var_3+ )}}++happyReduce_144 = happySpecReduce_3 53# happyReduction_144+happyReduction_144 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut59 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn57+ (EBefore happy_var_2 happy_var_3+ )}}++happyReduce_145 = happySpecReduce_2 54# happyReduction_145+happyReduction_145 happy_x_2+ happy_x_1+ = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut59 happy_x_2 of { happy_var_2 -> + happyIn58+ (EAp happy_var_1 happy_var_2+ )}}++happyReduce_146 = happySpecReduce_1 54# happyReduction_146+happyReduction_146 happy_x_1+ = case happyOut59 happy_x_1 of { happy_var_1 -> + happyIn58+ (happy_var_1+ )}++happyReduce_147 = happySpecReduce_3 55# happyReduction_147+happyReduction_147 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut59 happy_x_1 of { happy_var_1 -> + case happyOut91 happy_x_3 of { happy_var_3 -> + happyIn59+ (ESelect happy_var_1 happy_var_3+ )}}++happyReduce_148 = happySpecReduce_1 55# happyReduction_148+happyReduction_148 happy_x_1+ = case happyOut60 happy_x_1 of { happy_var_1 -> + happyIn59+ (happy_var_1+ )}++happyReduce_149 = happySpecReduce_1 56# happyReduction_149+happyReduction_149 happy_x_1+ = case happyOut91 happy_x_1 of { happy_var_1 -> + happyIn60+ (EVar happy_var_1+ )}++happyReduce_150 = happySpecReduce_1 56# happyReduction_150+happyReduction_150 happy_x_1+ = happyIn60+ (EWild+ )++happyReduce_151 = happySpecReduce_1 56# happyReduction_151+happyReduction_151 happy_x_1+ = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn60+ (ECon happy_var_1+ )}++happyReduce_152 = happySpecReduce_1 56# happyReduction_152+happyReduction_152 happy_x_1+ = case happyOut61 happy_x_1 of { happy_var_1 -> + happyIn60+ (ELit happy_var_1+ )}++happyReduce_153 = happySpecReduce_2 56# happyReduction_153+happyReduction_153 happy_x_2+ happy_x_1+ = happyIn60+ (ECon (prim UNITTERM)+ )++happyReduce_154 = happyReduce 4# 56# happyReduction_154+happyReduction_154 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut91 happy_x_3 of { happy_var_3 -> + happyIn60+ (ESel happy_var_3+ ) `HappyStk` happyRest}++happyReduce_155 = happySpecReduce_3 56# happyReduction_155+happyReduction_155 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn60+ (happy_var_2+ )}++happyReduce_156 = happySpecReduce_3 56# happyReduction_156+happyReduction_156 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut63 happy_x_2 of { happy_var_2 -> + happyIn60+ (ETup (reverse happy_var_2)+ )}++happyReduce_157 = happySpecReduce_3 56# happyReduction_157+happyReduction_157 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut62 happy_x_2 of { happy_var_2 -> + happyIn60+ (happy_var_2+ )}++happyReduce_158 = happyReduce 4# 56# happyReduction_158+happyReduction_158 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut54 happy_x_2 of { happy_var_2 -> + case happyOut95 happy_x_3 of { happy_var_3 -> + happyIn60+ (ESectR happy_var_2 happy_var_3+ ) `HappyStk` happyRest}}++happyReduce_159 = happyReduce 4# 56# happyReduction_159+happyReduction_159 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut97 happy_x_2 of { happy_var_2 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + happyIn60+ (ESectL happy_var_2 happy_var_3+ ) `HappyStk` happyRest}}++happyReduce_160 = happySpecReduce_3 56# happyReduction_160+happyReduction_160 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut43 happy_x_2 of { happy_var_2 -> + happyIn60+ (ECon (tuple (happy_var_2+1))+ )}++happyReduce_161 = happySpecReduce_2 57# happyReduction_161+happyReduction_161 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (IntTok happy_var_2) -> + happyIn61+ (LInt (Just happy_var_1) (readInteger happy_var_2)+ )}}++happyReduce_162 = happySpecReduce_2 57# happyReduction_162+happyReduction_162 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (FloatTok happy_var_2) -> + happyIn61+ (LRat (Just happy_var_1) (readRational happy_var_2)+ )}}++happyReduce_163 = happySpecReduce_2 57# happyReduction_163+happyReduction_163 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (Character happy_var_2) -> + happyIn61+ (LChr (Just happy_var_1) happy_var_2+ )}}++happyReduce_164 = happySpecReduce_2 57# happyReduction_164+happyReduction_164 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (StringTok happy_var_2) -> + happyIn61+ (LStr (Just happy_var_1) happy_var_2+ )}}++happyReduce_165 = happySpecReduce_0 58# happyReduction_165+happyReduction_165 = happyIn62+ (EList []+ )++happyReduce_166 = happySpecReduce_1 58# happyReduction_166+happyReduction_166 happy_x_1+ = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn62+ (EList [happy_var_1]+ )}++happyReduce_167 = happySpecReduce_1 58# happyReduction_167+happyReduction_167 happy_x_1+ = case happyOut63 happy_x_1 of { happy_var_1 -> + happyIn62+ (EList (reverse happy_var_1)+ )}++happyReduce_168 = happySpecReduce_3 58# happyReduction_168+happyReduction_168 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn62+ (ESeq happy_var_1 Nothing happy_var_3+ )}}++happyReduce_169 = happyReduce 5# 58# happyReduction_169+happyReduction_169 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + case happyOut48 happy_x_5 of { happy_var_5 -> + happyIn62+ (ESeq happy_var_1 (Just happy_var_3) happy_var_5+ ) `HappyStk` happyRest}}}++happyReduce_170 = happySpecReduce_3 58# happyReduction_170+happyReduction_170 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + happyIn62+ (EComp happy_var_1 (reverse happy_var_3)+ )}}++happyReduce_171 = happySpecReduce_3 59# happyReduction_171+happyReduction_171 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut63 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn63+ (happy_var_3 : happy_var_1+ )}}++happyReduce_172 = happySpecReduce_3 59# happyReduction_172+happyReduction_172 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn63+ ([happy_var_3,happy_var_1]+ )}}++happyReduce_173 = happySpecReduce_3 60# happyReduction_173+happyReduction_173 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut64 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_3 of { happy_var_3 -> + happyIn64+ (happy_var_3 : happy_var_1+ )}}++happyReduce_174 = happySpecReduce_1 60# happyReduction_174+happyReduction_174 happy_x_1+ = case happyOut65 happy_x_1 of { happy_var_1 -> + happyIn64+ ([happy_var_1]+ )}++happyReduce_175 = happySpecReduce_3 61# happyReduction_175+happyReduction_175 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut88 happy_x_1 of { happy_var_1 -> + case happyOut83 happy_x_3 of { happy_var_3 -> + happyIn65+ (QGen happy_var_1 happy_var_3+ )}}++happyReduce_176 = happySpecReduce_1 61# happyReduction_176+happyReduction_176 happy_x_1+ = case happyOut83 happy_x_1 of { happy_var_1 -> + happyIn65+ (QExp happy_var_1+ )}++happyReduce_177 = happySpecReduce_2 61# happyReduction_177+happyReduction_177 happy_x_2+ happy_x_1+ = case happyOut27 happy_x_2 of { happy_var_2 -> + happyIn65+ (QLet happy_var_2+ )}++happyReduce_178 = happyReduce 4# 62# happyReduction_178+happyReduction_178 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut67 happy_x_3 of { happy_var_3 -> + happyIn66+ (reverse happy_var_3+ ) `HappyStk` happyRest}++happyReduce_179 = happySpecReduce_3 62# happyReduction_179+happyReduction_179 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut67 happy_x_2 of { happy_var_2 -> + happyIn66+ (reverse happy_var_2+ )}++happyReduce_180 = happySpecReduce_3 63# happyReduction_180+happyReduction_180 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut67 happy_x_1 of { happy_var_1 -> + case happyOut68 happy_x_3 of { happy_var_3 -> + happyIn67+ (happy_var_3 : happy_var_1+ )}}++happyReduce_181 = happySpecReduce_1 63# happyReduction_181+happyReduction_181 happy_x_1+ = case happyOut68 happy_x_1 of { happy_var_1 -> + happyIn67+ ([happy_var_1]+ )}++happyReduce_182 = happySpecReduce_2 64# happyReduction_182+happyReduction_182 happy_x_2+ happy_x_1+ = case happyOut88 happy_x_1 of { happy_var_1 -> + case happyOut69 happy_x_2 of { happy_var_2 -> + happyIn68+ (Alt happy_var_1 happy_var_2+ )}}++happyReduce_183 = happySpecReduce_2 65# happyReduction_183+happyReduction_183 happy_x_2+ happy_x_1+ = case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn69+ (RExp happy_var_2+ )}++happyReduce_184 = happySpecReduce_1 65# happyReduction_184+happyReduction_184 happy_x_1+ = case happyOut70 happy_x_1 of { happy_var_1 -> + happyIn69+ (RGrd (reverse happy_var_1)+ )}++happyReduce_185 = happySpecReduce_3 65# happyReduction_185+happyReduction_185 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn69+ (RWhere happy_var_1 happy_var_3+ )}}++happyReduce_186 = happySpecReduce_2 66# happyReduction_186+happyReduction_186 happy_x_2+ happy_x_1+ = case happyOut70 happy_x_1 of { happy_var_1 -> + case happyOut71 happy_x_2 of { happy_var_2 -> + happyIn70+ (happy_var_2 : happy_var_1+ )}}++happyReduce_187 = happySpecReduce_1 66# happyReduction_187+happyReduction_187 happy_x_1+ = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn70+ ([happy_var_1]+ )}++happyReduce_188 = happyReduce 4# 67# happyReduction_188+happyReduction_188 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut64 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + happyIn71+ (GExp (reverse happy_var_2) happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_189 = happyReduce 4# 68# happyReduction_189+happyReduction_189 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut73 happy_x_3 of { happy_var_3 -> + happyIn72+ (reverse happy_var_3+ ) `HappyStk` happyRest}++happyReduce_190 = happySpecReduce_3 68# happyReduction_190+happyReduction_190 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn72+ (reverse happy_var_2+ )}++happyReduce_191 = happySpecReduce_3 69# happyReduction_191+happyReduction_191 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut73 happy_x_1 of { happy_var_1 -> + case happyOut74 happy_x_3 of { happy_var_3 -> + happyIn73+ (happy_var_3 : happy_var_1+ )}}++happyReduce_192 = happySpecReduce_1 69# happyReduction_192+happyReduction_192 happy_x_1+ = case happyOut74 happy_x_1 of { happy_var_1 -> + happyIn73+ ([happy_var_1]+ )}++happyReduce_193 = happySpecReduce_2 70# happyReduction_193+happyReduction_193 happy_x_2+ happy_x_1+ = case happyOut88 happy_x_1 of { happy_var_1 -> + case happyOut75 happy_x_2 of { happy_var_2 -> + happyIn74+ (Alt happy_var_1 happy_var_2+ )}}++happyReduce_194 = happySpecReduce_2 71# happyReduction_194+happyReduction_194 happy_x_2+ happy_x_1+ = case happyOut78 happy_x_2 of { happy_var_2 -> + happyIn75+ (RExp happy_var_2+ )}++happyReduce_195 = happySpecReduce_1 71# happyReduction_195+happyReduction_195 happy_x_1+ = case happyOut76 happy_x_1 of { happy_var_1 -> + happyIn75+ (RGrd (reverse happy_var_1)+ )}++happyReduce_196 = happySpecReduce_3 71# happyReduction_196+happyReduction_196 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut75 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn75+ (RWhere happy_var_1 happy_var_3+ )}}++happyReduce_197 = happySpecReduce_2 72# happyReduction_197+happyReduction_197 happy_x_2+ happy_x_1+ = case happyOut76 happy_x_1 of { happy_var_1 -> + case happyOut77 happy_x_2 of { happy_var_2 -> + happyIn76+ (happy_var_2 : happy_var_1+ )}}++happyReduce_198 = happySpecReduce_1 72# happyReduction_198+happyReduction_198 happy_x_1+ = case happyOut77 happy_x_1 of { happy_var_1 -> + happyIn76+ ([happy_var_1]+ )}++happyReduce_199 = happyReduce 4# 73# happyReduction_199+happyReduction_199 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut64 happy_x_2 of { happy_var_2 -> + case happyOut78 happy_x_4 of { happy_var_4 -> + happyIn77+ (GExp (reverse happy_var_2) happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_200 = happyReduce 4# 74# happyReduction_200+happyReduction_200 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut79 happy_x_3 of { happy_var_3 -> + happyIn78+ (reverse happy_var_3+ ) `HappyStk` happyRest}++happyReduce_201 = happySpecReduce_3 74# happyReduction_201+happyReduction_201 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut79 happy_x_2 of { happy_var_2 -> + happyIn78+ (reverse happy_var_2+ )}++happyReduce_202 = happySpecReduce_1 75# happyReduction_202+happyReduction_202 happy_x_1+ = case happyOut80 happy_x_1 of { happy_var_1 -> + happyIn79+ (happy_var_1+ )}++happyReduce_203 = happySpecReduce_0 75# happyReduction_203+happyReduction_203 = happyIn79+ ([]+ )++happyReduce_204 = happySpecReduce_3 76# happyReduction_204+happyReduction_204 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut80 happy_x_1 of { happy_var_1 -> + case happyOut81 happy_x_3 of { happy_var_3 -> + happyIn80+ (happy_var_3 : happy_var_1+ )}}++happyReduce_205 = happySpecReduce_1 76# happyReduction_205+happyReduction_205 happy_x_1+ = case happyOut81 happy_x_1 of { happy_var_1 -> + happyIn80+ ([happy_var_1]+ )}++happyReduce_206 = happySpecReduce_3 77# happyReduction_206+happyReduction_206 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut88 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn81+ (SGen happy_var_1 happy_var_3+ )}}++happyReduce_207 = happySpecReduce_1 77# happyReduction_207+happyReduction_207 happy_x_1+ = case happyOut82 happy_x_1 of { happy_var_1 -> + happyIn81+ (SExp happy_var_1+ )}++happyReduce_208 = happySpecReduce_3 77# happyReduction_208+happyReduction_208 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn81+ (SBind [BSig happy_var_1 happy_var_3]+ )}}++happyReduce_209 = happySpecReduce_2 77# happyReduction_209+happyReduction_209 happy_x_2+ happy_x_1+ = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn81+ (SBind [BEqn happy_var_1 happy_var_2]+ )}}++happyReduce_210 = happyReduce 4# 77# happyReduction_210+happyReduction_210 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + happyIn81+ (SBind [BEqn happy_var_1 (RExp (EAp (EVar (prim New)) happy_var_4))]+ ) `HappyStk` happyRest}}++happyReduce_211 = happySpecReduce_3 77# happyReduction_211+happyReduction_211 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut88 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + happyIn81+ (SAss happy_var_1 happy_var_3+ )}}++happyReduce_212 = happySpecReduce_2 77# happyReduction_212+happyReduction_212 happy_x_2+ happy_x_1+ = case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn81+ (SRet happy_var_2+ )}++happyReduce_213 = happyReduce 4# 77# happyReduction_213+happyReduction_213 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut64 happy_x_2 of { happy_var_2 -> + case happyOut78 happy_x_4 of { happy_var_4 -> + happyIn81+ (SForall (reverse happy_var_2) happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_214 = happyReduce 4# 77# happyReduction_214+happyReduction_214 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_2 of { happy_var_2 -> + case happyOut78 happy_x_4 of { happy_var_4 -> + happyIn81+ (SIf happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_215 = happyReduce 4# 77# happyReduction_215+happyReduction_215 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_2 of { happy_var_2 -> + case happyOut78 happy_x_4 of { happy_var_4 -> + happyIn81+ (SElsif happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_216 = happySpecReduce_2 77# happyReduction_216+happyReduction_216 happy_x_2+ happy_x_1+ = case happyOut78 happy_x_2 of { happy_var_2 -> + happyIn81+ (SElse happy_var_2+ )}++happyReduce_217 = happyReduce 4# 77# happyReduction_217+happyReduction_217 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_2 of { happy_var_2 -> + case happyOut78 happy_x_4 of { happy_var_4 -> + happyIn81+ (SWhile happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_218 = happyReduce 4# 77# happyReduction_218+happyReduction_218 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut48 happy_x_2 of { happy_var_2 -> + case happyOut72 happy_x_4 of { happy_var_4 -> + happyIn81+ (SCase happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_219 = happySpecReduce_1 78# happyReduction_219+happyReduction_219 happy_x_1+ = case happyOut83 happy_x_1 of { happy_var_1 -> + happyIn82+ (happy_var_1+ )}++happyReduce_220 = happySpecReduce_1 79# happyReduction_220+happyReduction_220 happy_x_1+ = case happyOut84 happy_x_1 of { happy_var_1 -> + happyIn83+ (happy_var_1+ )}++happyReduce_221 = happySpecReduce_1 79# happyReduction_221+happyReduction_221 happy_x_1+ = case happyOut85 happy_x_1 of { happy_var_1 -> + happyIn83+ (happy_var_1+ )}++happyReduce_222 = happySpecReduce_1 80# happyReduction_222+happyReduction_222 happy_x_1+ = case happyOut86 happy_x_1 of { happy_var_1 -> + happyIn84+ (transFix happy_var_1+ )}++happyReduce_223 = happySpecReduce_1 80# happyReduction_223+happyReduction_223 happy_x_1+ = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn84+ (happy_var_1+ )}++happyReduce_224 = happySpecReduce_1 81# happyReduction_224+happyReduction_224 happy_x_1+ = case happyOut87 happy_x_1 of { happy_var_1 -> + happyIn85+ (transFix happy_var_1+ )}++happyReduce_225 = happySpecReduce_1 81# happyReduction_225+happyReduction_225 happy_x_1+ = case happyOut57 happy_x_1 of { happy_var_1 -> + happyIn85+ (happy_var_1+ )}++happyReduce_226 = happyReduce 4# 82# happyReduction_226+happyReduction_226 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut86 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut55 happy_x_4 of { happy_var_4 -> + happyIn86+ (Cons happy_var_1 happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_227 = happySpecReduce_3 82# happyReduction_227+happyReduction_227 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut86 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn86+ (Cons happy_var_1 happy_var_2 happy_var_3+ )}}}++happyReduce_228 = happySpecReduce_2 82# happyReduction_228+happyReduction_228 happy_x_2+ happy_x_1+ = case happyOut55 happy_x_2 of { happy_var_2 -> + happyIn86+ (Nil (ENeg happy_var_2)+ )}++happyReduce_229 = happyReduce 4# 82# happyReduction_229+happyReduction_229 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut55 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut55 happy_x_4 of { happy_var_4 -> + happyIn86+ (Cons (Nil happy_var_1) happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_230 = happySpecReduce_3 82# happyReduction_230+happyReduction_230 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut55 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn86+ (Cons (Nil happy_var_1) happy_var_2 happy_var_3+ )}}}++happyReduce_231 = happyReduce 4# 83# happyReduction_231+happyReduction_231 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut86 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut57 happy_x_4 of { happy_var_4 -> + happyIn87+ (Cons happy_var_1 happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_232 = happySpecReduce_3 83# happyReduction_232+happyReduction_232 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut86 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut57 happy_x_3 of { happy_var_3 -> + happyIn87+ (Cons happy_var_1 happy_var_2 happy_var_3+ )}}}++happyReduce_233 = happySpecReduce_2 83# happyReduction_233+happyReduction_233 happy_x_2+ happy_x_1+ = case happyOut57 happy_x_2 of { happy_var_2 -> + happyIn87+ (Nil (ENeg happy_var_2)+ )}++happyReduce_234 = happyReduce 4# 83# happyReduction_234+happyReduction_234 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut55 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut57 happy_x_4 of { happy_var_4 -> + happyIn87+ (Cons (Nil happy_var_1) happy_var_2 (ENeg happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_235 = happySpecReduce_3 83# happyReduction_235+happyReduction_235 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut55 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + case happyOut57 happy_x_3 of { happy_var_3 -> + happyIn87+ (Cons (Nil happy_var_1) happy_var_2 happy_var_3+ )}}}++happyReduce_236 = happySpecReduce_1 84# happyReduction_236+happyReduction_236 happy_x_1+ = case happyOut83 happy_x_1 of { happy_var_1 -> + happyIn88+ (happy_var_1+ )}++happyReduce_237 = happySpecReduce_2 85# happyReduction_237+happyReduction_237 happy_x_2+ happy_x_1+ = case happyOut89 happy_x_1 of { happy_var_1 -> + case happyOut90 happy_x_2 of { happy_var_2 -> + happyIn89+ (happy_var_2 : happy_var_1+ )}}++happyReduce_238 = happySpecReduce_1 85# happyReduction_238+happyReduction_238 happy_x_1+ = case happyOut90 happy_x_1 of { happy_var_1 -> + happyIn89+ ([happy_var_1]+ )}++happyReduce_239 = happySpecReduce_1 86# happyReduction_239+happyReduction_239 happy_x_1+ = case happyOut59 happy_x_1 of { happy_var_1 -> + happyIn90+ (happy_var_1+ )}++happyReduce_240 = happySpecReduce_1 87# happyReduction_240+happyReduction_240 happy_x_1+ = case happyOut98 happy_x_1 of { happy_var_1 -> + happyIn91+ (happy_var_1+ )}++happyReduce_241 = happySpecReduce_3 87# happyReduction_241+happyReduction_241 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut100 happy_x_2 of { happy_var_2 -> + happyIn91+ (happy_var_2+ )}++happyReduce_242 = happySpecReduce_1 88# happyReduction_242+happyReduction_242 happy_x_1+ = case happyOut99 happy_x_1 of { happy_var_1 -> + happyIn92+ (happy_var_1+ )}++happyReduce_243 = happySpecReduce_3 88# happyReduction_243+happyReduction_243 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut101 happy_x_2 of { happy_var_2 -> + happyIn92+ (happy_var_2+ )}++happyReduce_244 = happySpecReduce_1 89# happyReduction_244+happyReduction_244 happy_x_1+ = case happyOut100 happy_x_1 of { happy_var_1 -> + happyIn93+ (happy_var_1+ )}++happyReduce_245 = happySpecReduce_3 89# happyReduction_245+happyReduction_245 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut98 happy_x_2 of { happy_var_2 -> + happyIn93+ (happy_var_2+ )}++happyReduce_246 = happySpecReduce_1 90# happyReduction_246+happyReduction_246 happy_x_1+ = case happyOut101 happy_x_1 of { happy_var_1 -> + happyIn94+ (happy_var_1+ )}++happyReduce_247 = happySpecReduce_3 90# happyReduction_247+happyReduction_247 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut99 happy_x_2 of { happy_var_2 -> + happyIn94+ (happy_var_2+ )}++happyReduce_248 = happySpecReduce_1 91# happyReduction_248+happyReduction_248 happy_x_1+ = case happyOut93 happy_x_1 of { happy_var_1 -> + happyIn95+ (happy_var_1+ )}++happyReduce_249 = happySpecReduce_1 91# happyReduction_249+happyReduction_249 happy_x_1+ = case happyOut94 happy_x_1 of { happy_var_1 -> + happyIn95+ (happy_var_1+ )}++happyReduce_250 = happySpecReduce_1 92# happyReduction_250+happyReduction_250 happy_x_1+ = case happyOut98 happy_x_1 of { happy_var_1 -> + happyIn96+ (happy_var_1+ )}++happyReduce_251 = happySpecReduce_1 92# happyReduction_251+happyReduction_251 happy_x_1+ = case happyOut99 happy_x_1 of { happy_var_1 -> + happyIn96+ (happy_var_1+ )}++happyReduce_252 = happyMonadReduce 1# 93# happyReduction_252+happyReduction_252 (happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen (case happyOut103 happy_x_1 of { happy_var_1 -> + ( do l <- getSrcLoc; return (name l happy_var_1))}+ ) (\r -> happyReturn (happyIn97 r))++happyReduce_253 = happySpecReduce_3 93# happyReduction_253+happyReduction_253 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut98 happy_x_2 of { happy_var_2 -> + happyIn97+ (happy_var_2+ )}++happyReduce_254 = happySpecReduce_1 93# happyReduction_254+happyReduction_254 happy_x_1+ = case happyOut94 happy_x_1 of { happy_var_1 -> + happyIn97+ (happy_var_1+ )}++happyReduce_255 = happySpecReduce_2 94# happyReduction_255+happyReduction_255 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (VarId happy_var_2) -> + happyIn98+ (name happy_var_1 happy_var_2+ )}}++happyReduce_256 = happySpecReduce_2 95# happyReduction_256+happyReduction_256 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (ConId happy_var_2) -> + happyIn99+ (name happy_var_1 happy_var_2+ )}}++happyReduce_257 = happyMonadReduce 1# 96# happyReduction_257+happyReduction_257 (happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen (case happyOut102 happy_x_1 of { happy_var_1 -> + ( do l <- getSrcLoc; return (name l happy_var_1))}+ ) (\r -> happyReturn (happyIn100 r))++happyReduce_258 = happySpecReduce_2 97# happyReduction_258+happyReduction_258 happy_x_2+ happy_x_1+ = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (ConSym happy_var_2) -> + happyIn101+ (name happy_var_1 happy_var_2+ )}}++happyReduce_259 = happySpecReduce_1 98# happyReduction_259+happyReduction_259 happy_x_1+ = case happyOut103 happy_x_1 of { happy_var_1 -> + happyIn102+ (happy_var_1+ )}++happyReduce_260 = happySpecReduce_1 98# happyReduction_260+happyReduction_260 happy_x_1+ = happyIn102+ (("","-")+ )++happyReduce_261 = happySpecReduce_1 99# happyReduction_261+happyReduction_261 happy_x_1+ = case happyOutTok happy_x_1 of { (VarSym happy_var_1) -> + happyIn103+ (happy_var_1+ )}++happyReduce_262 = happySpecReduce_1 99# happyReduction_262+happyReduction_262 happy_x_1+ = happyIn103+ (("","<")+ )++happyReduce_263 = happySpecReduce_1 99# happyReduction_263+happyReduction_263 happy_x_1+ = happyIn103+ (("",">")+ )++happyReduce_264 = happySpecReduce_1 99# happyReduction_264+happyReduction_264 happy_x_1+ = happyIn103+ (("","*")+ )++happyReduce_265 = happySpecReduce_1 99# happyReduction_265+happyReduction_265 happy_x_1+ = happyIn103+ (("","\\\\")+ )++happyReduce_266 = happySpecReduce_1 100# happyReduction_266+happyReduction_266 happy_x_1+ = happyIn104+ (()+ )++happyReduce_267 = happyMonadReduce 1# 100# happyReduction_267+happyReduction_267 (happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen (( popContext)+ ) (\r -> happyReturn (happyIn104 r))++happyReduce_268 = happyMonadReduce 0# 101# happyReduction_268+happyReduction_268 (happyRest) tk+ = happyThen (( pushContext NoLayout)+ ) (\r -> happyReturn (happyIn105 r))++happyReduce_269 = happyMonadReduce 0# 102# happyReduction_269+happyReduction_269 (happyRest) tk+ = happyThen (( do { (r,c) <- getSrcLoc ;+ pushContext (Layout c)+ })+ ) (\r -> happyReturn (happyIn106 r))++happyReduce_270 = happyMonadReduce 0# 103# happyReduction_270+happyReduction_270 (happyRest) tk+ = happyThen (( getSrcLoc)+ ) (\r -> happyReturn (happyIn107 r))++happyNewToken action sts stk+ = lexer(\tk -> + let cont i = happyDoAction i tk action sts stk in+ case tk of {+ EOF -> happyDoAction 63# tk action sts stk;+ VarId happy_dollar_dollar -> cont 1#;+ ConId happy_dollar_dollar -> cont 2#;+ VarSym ("","-") -> cont 3#;+ VarSym ("","<") -> cont 4#;+ VarSym ("",">") -> cont 5#;+ VarSym ("","*") -> cont 6#;+ VarSym happy_dollar_dollar -> cont 7#;+ ConSym happy_dollar_dollar -> cont 8#;+ IntTok happy_dollar_dollar -> cont 9#;+ FloatTok happy_dollar_dollar -> cont 10#;+ Character happy_dollar_dollar -> cont 11#;+ StringTok happy_dollar_dollar -> cont 12#;+ LeftParen -> cont 13#;+ RightParen -> cont 14#;+ SemiColon -> cont 15#;+ LeftCurly -> cont 16#;+ RightCurly -> cont 17#;+ VRightCurly -> cont 18#;+ LeftSquare -> cont 19#;+ RightSquare -> cont 20#;+ Comma -> cont 21#;+ BackQuote -> cont 22#;+ Wildcard -> cont 23#;+ Dot -> cont 24#;+ DotDot -> cont 25#;+ DoubleColon -> cont 26#;+ Assign -> cont 27#;+ Equals -> cont 28#;+ Backslash -> cont 29#;+ Bar -> cont 30#;+ LeftArrow -> cont 31#;+ RightArrow -> cont 32#;+ Backslash2 -> cont 33#;+ KW_Action -> cont 34#;+ KW_After -> cont 35#;+ KW_Before -> cont 36#;+ KW_Case -> cont 37#;+ KW_Class -> cont 38#;+ KW_Data -> cont 39#;+ KW_Default -> cont 40#;+ KW_Do -> cont 41#;+ KW_Else -> cont 42#;+ KW_Elsif -> cont 43#;+ KW_Forall -> cont 44#;+ KW_If -> cont 45#;+ KW_Import -> cont 46#;+ KW_Instance -> cont 47#;+ KW_In -> cont 48#;+ KW_Let -> cont 49#;+ KW_Module -> cont 50#;+ KW_New -> cont 51#;+ KW_Of -> cont 52#;+ KW_Private -> cont 53#;+ KW_Request -> cont 54#;+ KW_Result -> cont 55#;+ KW_Struct -> cont 56#;+ KW_Then -> cont 57#;+ KW_Type -> cont 58#;+ KW_Typeclass -> cont 59#;+ KW_Use -> cont 60#;+ KW_Where -> cont 61#;+ KW_While -> cont 62#;+ _ -> happyError' tk+ })++happyError_ tk = happyError' tk++happyThen :: () => PM a -> (a -> PM b) -> PM b+happyThen = (thenPM)+happyReturn :: () => a -> PM a+happyReturn = (returnPM)+happyThen1 = happyThen+happyReturn1 :: () => a -> PM a+happyReturn1 = happyReturn+happyError' :: () => (Token) -> PM a+happyError' tk = (\token -> happyError) tk++parse = happySomeParser where+ happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++parser :: String -> M s Module+parser str = runPM2 parse str++happyError = parseError "parse error"+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 28 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Int# Happy_IntList++++++{-# LINE 49 "templates/GenericTemplate.hs" #-}++{-# LINE 59 "templates/GenericTemplate.hs" #-}++{-# LINE 68 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser). We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+ happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+ = {- nothing -}+++ case action of+ 0# -> {- nothing -}+ happyFail i tk st+ -1# -> {- nothing -}+ happyAccept i tk st+ n | (n <# (0# :: Int#)) -> {- nothing -}++ (happyReduceArr ! rule) i tk st+ where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))+ n -> {- nothing -}+++ happyShift new_state i tk st+ where new_state = (n -# (1# :: Int#))+ where off = indexShortOffAddr happyActOffsets st+ off_i = (off +# i)+ check = if (off_i >=# (0# :: Int#))+ then (indexShortOffAddr happyCheck off_i ==# i)+ else False+ action | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st++{-# LINE 127 "templates/GenericTemplate.hs" #-}+++indexShortOffAddr (HappyA# arr) off =+#if __GLASGOW_HASKELL__ > 500+ narrow16Int# i+#elif __GLASGOW_HASKELL__ == 500+ intToInt16# i+#else+ (i `iShiftL#` 16#) `iShiftRA#` 16#+#endif+ where+#if __GLASGOW_HASKELL__ >= 503+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+#else+ i = word2Int# ((high `shiftL#` 8#) `or#` low)+#endif+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#++++++data HappyAddr = HappyA# Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 170 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+ let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in+-- trace "shifting the error token" $+ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+ = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+ = case happyDrop (k -# (1# :: Int#)) sts of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let r = fn stk in -- it doesn't hurt to always seq here...+ happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))+ where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++happyMonad2Reduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+ where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++ off = indexShortOffAddr happyGotoOffsets st1+ off_i = (off +# nt)+ new_state = indexShortOffAddr happyTable off_i+++++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = + {- nothing -}+ happyDoAction j tk new_state+ where off = indexShortOffAddr happyGotoOffsets st+ off_i = (off +# nt)+ new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk =+-- trace "failing" $ + happyError_ tk++{- We don't need state discarding for our restricted implementation of+ "error". In fact, it can cause some bogus parses, so I've disabled it+ for now --SDM++-- discard a state+happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) =+-- trace ("discarding state, depth " ++ show (length stk)) $+ happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+-- save the old token and carry on.+happyFail i tk (action) sts stk =+-- trace "entering error recovery" $+ happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq+-- otherwise it emits+-- happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template. GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ examples/Counter.t view
@@ -0,0 +1,18 @@+module Counter where++struct Counter where+ incr :: Action+ decr :: Action+ value :: Request Int++counter = class++ n := 0++ incr = action n := n+1++ decr = action n := n-1+ + value = request result n++ result Counter{..}
+ examples/Echo.t view
@@ -0,0 +1,13 @@+module Echo where++import POSIX++root env = class++ echo str = action+ env.stdout.write str++ result + action + env.stdin.installR echo+
+ examples/Echo2.t view
@@ -0,0 +1,22 @@+module Echo2 where++import POSIX++root env = class++ count := 1++ prompt = do+ env.stdout.write (show count++"> ")+ count := count+1++ echo str = action+ env.stdout.write str+ prompt++ result + action + env.stdin.installR echo+ env.stdout.write "Welcome to Echo2!\n"+ prompt+
+ examples/Echo3.t view
@@ -0,0 +1,19 @@+module Echo3 where++import POSIX++root env = class++ current := "Hello!\n"++ save str = action+ current := str++ tick = action+ env.stdout.write current+ after (sec 1) tick++ result + action + env.stdin.installR save+ tick
+ examples/EchoServer.t view
@@ -0,0 +1,35 @@+module EchoServer where++import POSIX++port = Port 12345++root env = class++ log str = action+ env.stdout.write ('[':str ++ "]\n")++ result action+ env.inet.tcp.listen port (server log)++server log sock = class++ n := 1++ p = show sock.remoteHost++ echo str = action+ sock.outFile.write (show n ++"> "++str)+ n := n+1++ close = request+ log (p ++ " closing")+ result ()++ neterror str = log ("Neterror: "++str)++ established = action+ log ("Connected from " ++ p)+ sock.inFile.installR echo++ result Connection{..}
+ examples/EchoServer2.t view
@@ -0,0 +1,49 @@+module EchoServer2 where++import POSIX+import Counter++port = Port 12345++root env = class+ + clients = new counter++ log str = action+ env.stdout.write ('[':str ++ "]\n")++ result action+ case parse (env.argv!1) of+ Right n -> env.inet.tcp.listen port (server n clients log)+ _ -> env.stdout.write "usage: EchoServer n, where n is number of concurrent clients\n"+ env.exit 1+server :: Int -> Counter -> (String -> Action) -> Socket -> Class Connection+server maxClients clients log sock = class++ n := 1++ p = show sock.remoteHost++ echo str = action+ sock.outFile.write (show n ++"> "++str)+ n := n+1++ close = request+ clients.decr+ log (p ++ " closing")+ result ()++ neterror str = log ("Neterror: "++str)++ established = action+ cl <- clients.value+ if cl < maxClients then+ clients.incr+ log ("Connected from " ++ p)+ sock.inFile.installR echo+ else+ sock.outFile.write "Server busy"+ log ("Refused " ++ p)+ sock.close++ result Connection{..}
+ examples/Makefile view
@@ -0,0 +1,14 @@+LOCALCOMP = ../dist/build/timberc/timberc --datadir ..+TIMBERC=timberc++EXAMPLES = Echo Echo2 Echo3 EchoServer EchoServer2 MasterMind Primes Reflex TCPClient PingTimeServers++examples: + @for ex in $(EXAMPLES); do \+ $(TIMBERC) --make $$ex; \+ done++local:+ @for ex in $(EXAMPLES); do \+ $(LOCALCOMP) --make $$ex; \+ done
+ examples/MasterMind.t view
@@ -0,0 +1,131 @@+module MasterMind where++import Data.Functional.List+import RandomGenerator+import POSIX++{-+Standard Mastermind, where the program does the guessing. Answers are given as two integers (separated by space(s)) on +one row, indicating number of bulls and cows. Command line argument acts as seed for random number generation.+-}++data Colour = Red | Blue | Green | Yellow | Black | White++default eqColour :: Eq Colour+ showColour :: Show Colour + parseColour :: Parse Colour+ eqAnswer :: Eq Answer++type Guess = [Colour]++data Answer = Answer Int Int++instance showAnswer :: Show Answer where+ show (Answer e n) = show e ++ " " ++ show n++instance showGuess :: Show Guess where+ show ss = unwords (map show ss)++type Board = [(Guess,Answer)]++allColours = [Red, Blue, Green, Yellow, Black, White]++allCodes :: Int -> [Guess]+allCodes 0 = [[]]+allCodes n = concat [[c:cs | c <- allColours] | cs <- allCodes (n-1)]++answer :: Guess -> Guess -> Answer+answer guess code = Answer e n+ where e = equals guess code++ n = sum [min (count c guess) (count c code) | c <- allColours] - e++ count c xs = length [x | x <- xs, x==c]++ equals [] [] = 0+ equals (x:xs) (y:ys)+ |x==y = 1 + equals xs ys+ |otherwise = equals xs ys+++contradictions :: Board -> Guess -> Board+contradictions board c = [(g,r) | (g,r) <- board, answer g c /= r]++consistent :: Board -> [Guess] -> [Guess]+consistent board cs = [ c | c <- cs, null (contradictions board c)]++data State = Idle | JustGuessed | GameOver | GetSecret+ +root env = class+ + gen = new baseGen(microsecOf env.startTime)++ board := []+ cs := [] + state := Idle++ shift = do+ r <- gen.next+ n = r `mod` (length cs)+ ys = take n cs+ zs = drop n cs+ cs := zs ++ ys+ + startGame = do+ board := []+ cs := []+ env.stdout.write "Choose your secret. Press return when ready.\n"+ state := Idle++ mkGuess = do+ if null cs then+ env.stdout.write "Contradictory answers!\n"+ env.stdout.write "Tell me your secret: "+ state := GetSecret+ else+ shift+ env.stdout.write ("My guess: "++ show (head cs) ++"\n")+ env.stdout.write "Answer (two integers): "+ state := JustGuessed++ checkQuit = do+ env.stdout.write "Do you want to play again? (y/n) "+ state := GameOver++ inpHandler inp = action+ case state of+ Idle -> cs := allCodes 4+ mkGuess++ JustGuessed -> case map parse (words inp) of+ [Right e, Right n] ->+ if e == 4 then+ env.stdout.write "Yippee!\n"+ checkQuit + else+ c:cs' = cs+ board := (c,Answer e n) : board+ cs := consistent board cs'+ mkGuess+ _ -> env.stdout.write "Answer must be two integers separated by spaces; try again\n"+ + GameOver -> if head inp == 'y' then+ startGame+ else+ env.exit 0++ GetSecret -> case map parse (words inp) of+ es | length es==4 && all isRight es ->+ ss = map fromRight es+ (g',r'):_ = contradictions board ss+ env.stdout.write ("When I guessed "++show g'++ ", you answered " ++ show r'++".\n")+ env.stdout.write ("Correct answer should have been "++show (answer g' ss)++".\n")+ checkQuit+ _ -> env.stdout.write "Secret must be four colours separated by spaces; try again\n"++ result + action+ env.stdin.installR inpHandler+ env.stdout.write "Welcome to Mastermind!\n"+ startGame+
+ examples/PingTimeServers.t view
@@ -0,0 +1,42 @@+-- Possible call+-- ./PingTimeServers time.nist.gov time-a.nist.gov time.ien.it+-- NB: It is explicitly disallowed to ask a NIST time server for time +-- more frequently than once every 4 seconds.+++module PingTimeServers where++import POSIX+import Data.Functional.List++port = Port 13 -- standard port for time servers++client neterror report sock = class++ established = action+ sock.inFile.installR report++ close = request result ()++ result Connection {..}+ ++root env = class++ args = [1..size env.argv-1] + print i mess = env.stdout.write (env.argv!i ++ ": "++ mess ++ "\n")++ outstanding := args++ report i mess = action+ outstanding := delete i outstanding+ print i mess+ if (null outstanding) then env.exit 0+ + result action+ forall i <- args do+ env.inet.tcp.connect (Host (env.argv!i)) port (client (report i) (report i))+ after (sec 2) action+ forall i <- outstanding do + print i "no response"+ env.exit 0
+ examples/Primes.t view
@@ -0,0 +1,40 @@+module Primes where++import POSIX ++root env = class+ limit :: Int+ limit = fromRight (parse (env.argv!1))+ primesBound = limit `div` log3 limit++ primes := uniarray primesBound 0+ count := 0++ isPrime k = loop 0+ where loop n = do + p = primes!n+ if p*p > k then+ result True+ elsif k `mod` p == 0 then+ result False+ else loop (n+1)++ checkFrom k = do+ p <- isPrime k+ if p then + primes!count := k+ count := count + 1+ if k < limit then checkFrom (k+1)++ result action+ primes!0 := 2+ count := 1+ checkFrom 3+ env.stdout.write (show count++"\n")+ env.exit 0+++log3 :: Int -> Int+log3 n + | n < 3 = 0+ | otherwise = 1 + log3 (n `div` 3)
+ examples/Reflex.t view
@@ -0,0 +1,43 @@+module Reflex where++import POSIX+import RandomGenerator++data State = Idle | Waiting Msg | Counting++root env = class+ + print str = env.stdout.write (str ++ "\n")++ tmr = new timer+ gen = new baseGen (microsecOf env.startTime)++ state := Idle+ + enter _ = action+ case state of+ Idle -> r <- gen.next+ waitingTime = sec 2 + millisec (r `mod` 2000)+ msg <- after waitingTime action+ tmr.reset+ print "Go!"+ state := Counting + print "Wait..."+ state := Waiting msg+ + Waiting msg -> abort msg+ print "Cheat!!!"+ state := Idle++ Counting -> t <- tmr.sample+ print (format t)+ state := Idle++ result + action+ env.stdin.installR enter+ print "Press return to start"++format t = show (secOf t) ++ '.' : fracs ++ " secs"+ where t100 = microsecOf t `div` 10000+ fracs = if t100<10 then '0':show t100 else show t100
+ examples/TCPClient.t view
@@ -0,0 +1,42 @@+module TCPClient where++ import POSIX++ root env = class++ result action+ if size env.argv /= 3 then+ env.stdout.write "Usage: TCPClient host port\n"+ env.exit 0+ host = Host (env.argv!1)+ port = Port (fromRight (parse (env.argv!2)))+ env.stdout.write "Connecting... "+ env.inet.tcp.connect host port (handler env)++private++ handler env sock = class++ rounds := 0 ++ neterror err = action + env.stdout.write (err ++ "\n")+ env.exit 0++ close = request + env.stdout.write ("Server closing after "++show rounds++" rounds\n")+ env.exit 0++ receive str = action+ env.stdout.write (str ++ "\n")+ rounds := rounds + 1++ echo str = action+ sock.outFile.write (init str)+ + established = action+ env.stdout.write "Hello!\n"+ env.stdin.installR echo+ sock.inFile.installR receive++ result Connection{..}
+ examples/UnionFind.t view
@@ -0,0 +1,37 @@+module UnionFind where++struct EqRel where+ equal :: Int -> Int -> Request Bool+ mkEqual :: Int -> Int -> Action++unionFind :: Int -> Class EqRel+unionFind n = class+ a := uniarray n (-1)++ find k = do + if a!k < 0 then+ result k+ else+ s <- find(a!k)+ a!k := s+ result s++ equal i j = request+ si <- find i+ sj <- find j+ result (si==sj)++ mkEqual i j = action+ si <- find i + sj <- find j+ if si/=sj then+ asi = a!si+ asj = a!sj+ if asj < asi then+ a!si := sj+ else + a!sj := si+ if asi==asj then+ a!si := asi-1++ result EqRel{..}
+ include/arrays.c view
@@ -0,0 +1,90 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++// Array primitives++#include "timber.h"++Array primListArray(BITS32 polytag, LIST xs) {+ Int len = 0;+ Int i = 0;+ LIST ys = xs;+ while ((Int)ys) {len++; ys = ((CONS)ys)->b;}; // not nice to compute the length here ...+ Array res; NEW(Array,res,WORDS(sizeof(struct Array))+len);+ res->GCINFO = (polytag ? __GC__Array1 : __GC__Array0);+ res->size = len;+ ys = xs;+ while((Int)ys) {res->elems[i] = ((CONS)ys)->a; ys = ((CONS)ys)->b; i++;}+ return res;+}++Array primUniArray(BITS32 polytag, Int len, POLY a) {+ Int i;+ Array res; NEW(Array,res,WORDS(sizeof(struct Array))+len);+ res->GCINFO = (polytag ? __GC__Array1 : __GC__Array0);+ res->size = len;+ for(i=0; i<len; i++) res->elems[i] = a;+ return res;+}++Array EmptyArray(BITS32 polytag, Int len) {+ Array res; NEW(Array,res,WORDS(sizeof(struct Array))+len);+ res->GCINFO = (polytag ? __GC__Array1 : __GC__Array0);+ res->size = len;+ return res;+}++Array CloneArray(BITS32 polytag, Array a, Int lev) {+ if (!lev)+ return a;+ Int i; + Array res; NEW(Array,res,WORDS(sizeof(struct Array))+a->size);+ res->size = a->size;+ lev--;+ if (lev) {+ res->GCINFO = __GC__Array0;+ for (i=0; i < a->size; i++) + res->elems[i] = (ADDR)CloneArray(polytag, (Array)a->elems[i], lev);+ } else {+ res->GCINFO = (polytag ? __GC__Array1 : __GC__Array0);+ for (i=0; i < a->size; i++) + res->elems[i] = a->elems[i]; + }+ return res;+}++Array primUpdateArray(BITS32 polytag, Array a, Int i, POLY v) {+ a = CloneArray(polytag, a, 1);+ a->elems[i] = v;+ return a;+}
+ include/float.c view
@@ -0,0 +1,53 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#include "timber.h"++struct DummyStruct {+ WORD *GCINFO;+ Int n;+};++typedef struct DummyStruct *DummyStruct;++static WORD __GC__DummyStruct[] = {WORDS(sizeof(struct DummyStruct)+20), GC_STD, 0};++LIST primShowFloat(Float x) {+ DummyStruct p;+ NEW(DummyStruct,p,sizeof(struct DummyStruct)+20);+ p->GCINFO = __GC__DummyStruct;+ snprintf((char*)&p->n,20,"%e",x);+ LIST res = getStr((char*)&p->n);+ return res;+}+
+ include/timber.c view
@@ -0,0 +1,162 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#define HEAD(X) WORDS(sizeof(struct X)), GC_STD+#define OFF(X,Y) WORDS(offsetof(struct X, Y))++WORD __GC__TUP2[] = + {+ HEAD(TUP2), OFF(TUP2, a), OFF(TUP2, b), 0,+ HEAD(TUP2), OFF(TUP2, b), 0,0,+ HEAD(TUP2), OFF(TUP2, a), 0,0,+ HEAD(TUP2), 0,0,0+ };+ +WORD __GC__TUP3[] = + {+ HEAD(TUP3), OFF(TUP3, a), OFF(TUP3, b), OFF(TUP3, c), 0,+ HEAD(TUP3), OFF(TUP3, b), OFF(TUP3, c), 0,0,+ HEAD(TUP3), OFF(TUP3, a), OFF(TUP3, c), 0,0,+ HEAD(TUP3), OFF(TUP3, c), 0,0,0,+ HEAD(TUP3), OFF(TUP3, a), OFF(TUP3, b), 0,0,+ HEAD(TUP3), OFF(TUP3, b), 0,0,0,+ HEAD(TUP3), OFF(TUP3, a), 0,0,0,+ HEAD(TUP3), 0,0,0,0+ };+ +WORD __GC__TUP4[] = + { + HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, b), OFF(TUP4, c), OFF(TUP4, d), 0,+ HEAD(TUP4), OFF(TUP4, b), OFF(TUP4, c), OFF(TUP4, d), 0,0,+ HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, c), OFF(TUP4, d), 0,0,+ HEAD(TUP4), OFF(TUP4, c), OFF(TUP4, d), 0,0,0,+ HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, b), OFF(TUP4, d), 0,0,+ HEAD(TUP4), OFF(TUP4, b), OFF(TUP4, d), 0,0,0,+ HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, d), 0,0,0,+ HEAD(TUP4), OFF(TUP4, d), 0,0,0,0,+ HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, b), OFF(TUP4, c), 0,0,+ HEAD(TUP4), OFF(TUP4, b), OFF(TUP4, c), 0,0,0,+ HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, c), 0,0,0,+ HEAD(TUP4), OFF(TUP4, c), 0,0,0,0,+ HEAD(TUP4), OFF(TUP4, a), OFF(TUP4, b), 0,0,0,+ HEAD(TUP4), OFF(TUP4, b), 0,0,0,0,+ HEAD(TUP4), OFF(TUP4, a), 0,0,0,0,+ HEAD(TUP4), 0,0,0,0,0+ };++WORD __GC__CONS[] = {+ HEAD(CONS), OFF(CONS, a), OFF(CONS, b), 0,+ HEAD(CONS), OFF(CONS, b), 0,0+ };++WORD __GC__LEFT[] = {+ HEAD(LEFT), OFF(LEFT, a), 0,+ HEAD(LEFT), 0,0+ };++WORD __GC__RIGHT[] = {+ HEAD(RIGHT), OFF(RIGHT, a), 0,+ HEAD(RIGHT), 0,0+ };++WORD __GC__Timer[] = {+ HEAD(Timer), 0+ };++/*+struct Msg {+ Int (*Code)(Msg);+ AbsTime baseline;+ AbsTime deadline;+ Msg next;+};+*/+WORD __GC__Msg[] = {WORDS(sizeof(struct Msg)), GC_STD, 0}; // sole pointer field "next" is custom handled by the gc++WORD __GC__Ref[] = {WORDS(sizeof(struct Ref)), GC_MUT, OFF(Ref,STATE), 0,+ WORDS(sizeof(struct Ref)), GC_MUT, 0, 0 };++/*+struct Array {+ Int size;+ POLY elems[];+};+*/+WORD __GC__Array0[] = {WORDS(sizeof(struct Array)), GC_ARRAY, 0}; // flag 0 => node contains all pointers++WORD __GC__Array1[] = {WORDS(sizeof(struct Array)), GC_ARRAY, 1}; // flag 1 => node contains all scalars+++POLY primRefl(BITS32 polytag, POLY in) {+ return in;+}++// String marshalling ----------------------------------------------------------------------------------++LIST getStr(char *p) {+ if (!*p)+ return (LIST)0;+ CONS n0; NEW(CONS, n0, WORDS(sizeof(struct CONS)));+ n0->GCINFO = __GC__CONS;+ CONS n = n0;+ n->a = (POLY)(Int)*p++;+ while (*p) {+ NEW(LIST, n->b, WORDS(sizeof(struct CONS)));+ n = (CONS)n->b;+ n->GCINFO = __GC__CONS;+ n->a = (POLY)(Int)*p++;+ }+ n->b = (LIST)0;+ return (LIST)n0;+}++Int strEq (LIST s1, LIST s2) {+ Char c1, c2;+ while(1) {+ switch ((Int)s1) {+ case 0: + return ((Int)s2==0);+ default: + switch ((Int)s2) {+ case 0:+ return 0;+ default:+ c1 = (Int)((CONS)s1)->a;+ c2 = (Int)((CONS)s2)->a;+ if (c1!=c2) return 0;+ s1 = ((CONS)s1)->b;+ s2 = ((CONS)s2)->b;+ }+ }+ }+}
+ include/timber.h view
@@ -0,0 +1,173 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#ifndef TIMBER_H_+#define TIMBER_H_+#include <math.h>++struct TUP2;+typedef struct TUP2 *TUP2;+struct TUP3;+typedef struct TUP3 *TUP3;+struct TUP4;+typedef struct TUP4 *TUP4;+struct LIST;+typedef struct LIST *LIST;+struct NIL;+typedef struct NIL *NIL;+struct CONS;+typedef struct CONS *CONS;+struct EITHER;+typedef struct EITHER *EITHER;+struct LEFT;+typedef struct LEFT *LEFT;+struct RIGHT;+typedef struct RIGHT *RIGHT;++struct Msg;+typedef struct Msg *Msg;++struct TUP2 {+ WORD *GCINFO;+ POLY a;+ POLY b;+};+extern WORD __GC__TUP2[];++struct TUP3 {+ WORD *GCINFO;+ POLY a;+ POLY b;+ POLY c;+};+extern WORD __GC__TUP3[];++struct TUP4 {+ WORD *GCINFO;+ POLY a;+ POLY b;+ POLY c;+ POLY d;+};+extern WORD __GC__TUP4[];++struct LIST {+ WORD *GCINFO;+};++struct CONS {+ WORD *GCINFO;+ POLY a;+ LIST b;+};+extern WORD __GC__CONS[];++struct EITHER {+ WORD *GCINFO;+ Int Tag;+};++extern WORD __GC__EITHER[];+struct LEFT {+ WORD *GCINFO;+ Int Tag;+ POLY a;+};+extern WORD __GC__LEFT[];++struct RIGHT {+ WORD *GCINFO;+ Int Tag;+ POLY a;+};+extern WORD __GC__RIGHT[];++struct Msg {+ WORD *GCINFO;+ Int (*Code)(Msg);+ AbsTime baseline;+ AbsTime deadline;+ Msg next;+};+extern WORD __GC__Msg[];++struct Array {+ WORD *GCINFO;+ Int size;+ POLY elems[];+};+extern WORD __GC__Array0[];+extern WORD __GC__Array1[];+++typedef struct Array *Array;++struct Timer;+typedef struct Timer *TIMERTYPE;+++struct Timer {+ WORD *GCINFO;+ UNITTYPE (*reset) (TIMERTYPE, Int);+ Time (*sample) (TIMERTYPE, Int);+};++extern WORD __GC__Timer[];+++UNITTYPE ASYNC(Msg, Time, Time);+PID LOCK(PID);+UNITTYPE UNLOCK(PID);+void RAISE(Int);++POLY Raise(BITS32, Int);++Array primListArray(BITS32,LIST);+Array primUniArray(BITS32,Int,POLY);+Array EmptyArray(BITS32,Int);+Array CloneArray(BITS32,Array,Int);+Array primUpdateArray(BITS32,Array,Int,POLY);++Array CYCLIC_BEGIN(Int, Int);+void CYCLIC_UPDATE(Array, Int, ADDR stop);+void CYCLIC_END(Array, ADDR stop);++POLY primRefl(BITS32,POLY);++TIMERTYPE primTIMERTERM(Int x);+UNITTYPE ABORT(BITS32,Msg msg,Ref x);++LIST primShowFloat(Float x);+LIST getStr(char *p) ;+Int strEq (LIST s1, LIST s2) ;+#endif
+ lib/BitOps.t view
@@ -0,0 +1,174 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module BitOps where+++instance intBITS32 :: IntLiteral BITS32 where+ fromInt = primIntToBITS32++instance intBITS16 :: IntLiteral BITS16 where+ fromInt = primIntToBITS16++instance intBITS8 :: IntLiteral BITS8 where+ fromInt = primIntToBITS8++ +default intInt < intBITS8+default intInt < intBITS16+default intInt < intBITS32++typeclass ToInt a where+ toInt :: a -> Int++instance fromBITS32 :: ToInt BITS32 where+ toInt = primBITS32ToInt++instance fromBITS16 :: ToInt BITS16 where+ toInt = primBITS16ToInt++instance fromBITS8 :: ToInt BITS8 where+ toInt = primBITS8ToInt+ ++typeclass BitsOp a where+ band :: a -> a -> a + bor :: a -> a -> a + bxor :: a -> a -> a + binv :: a -> a + bsll :: a -> Int -> a + bsrl :: a -> Int -> a + bsra :: a -> Int -> a + bset :: a -> Int -> a + bclr :: a -> Int -> a + btst :: a -> Int -> Bool ++a .&. b = band a b+a .|. b = bor a b+a .^. b = bxor a b +a .<<. b = bsll a b +a .>>. b = bsrl a b +a .|=. b = bset a b +a .!=. b = bclr a b +a .?. b = btst a b ++instance bitsOpBits32 :: BitsOp BITS32 where+ band a b = primAND32 a b+ bor a b = primOR32 a b+ bxor a b = primEXOR32 a b+ binv a = primNOT32 a+ bsll a i = primSHIFTL32 a i+ bsrl a i = primSHIFTR32 a i+ bsra a i = primSHIFTRA32 a i+ bset a i = primSET32 a i + bclr a i = primCLR32 a i+ btst a i = primTST32 a i++instance bitsOpBits16 :: BitsOp BITS16 where+ band a b = primAND16 a b+ bor a b = primOR16 a b+ bxor a b = primEXOR16 a b+ binv a = primNOT16 a+ bsll a i = primSHIFTL16 a i+ bsrl a i = primSHIFTR16 a i+ bsra a i = primSHIFTRA16 a i+ bset a i = primSET16 a i + bclr a i = primCLR16 a i+ btst a i = primTST16 a i++instance bitsOpBits8 :: BitsOp BITS8 where+ band a b = primAND8 a b+ bor a b = primOR8 a b+ bxor a b = primEXOR8 a b+ binv a = primNOT8 a+ bsll a i = primSHIFTL8 a i+ bsrl a i = primSHIFTR8 a i+ bsra a i = primSHIFTRA8 a i+ bset a i = primSET8 a i + bclr a i = primCLR8 a i+ btst a i = primTST8 a i++ +instance eqBits32 :: Eq BITS32 where+ a == b = primBITS32ToInt a == primBITS32ToInt b+ a /= b = primBITS32ToInt a /= primBITS32ToInt b++instance eqBits16 :: Eq BITS16 where+ a == b = primBITS16ToInt a == primBITS16ToInt b+ a /= b = primBITS16ToInt a /= primBITS16ToInt b++instance eqBits8 :: Eq BITS8 where+ a == b = primBITS8ToInt a == primBITS8ToInt b+ a /= b = primBITS8ToInt a /= primBITS8ToInt b+++showbits :: a -> Int -> String \\ BitsOp a++showbits a 0 = ""+showbits a n = if btst a n1 then '1' : str else '0' : str+ where n1 = n-1+ str = showbits a n1+ +instance showBits32 :: Show BITS32 where + show a = "0b" ++ showbits a 32++instance showBits16 :: Show BITS16 where + show a = "0b" ++ showbits a 16++instance showBits8 :: Show BITS8 where + show a = "0b" ++ showbits a 8+++hex a = if (a <= 9) then + (chr (a + (ord '0'))) + else+ (chr ((a -10) + (ord 'A'))) ++ +showh :: BITS32 -> Int -> String +showh a 0 = ""+showh a n = ( hex (toInt((a `bsrl` (4 * n1)) `band` 0xF)) ) : str + where n1 = n - 1+ str = showh a n1++typeclass ShowHex a where+ showhex :: a -> String++instance showHBits32 :: ShowHex BITS32 where + showhex a = "0x" ++ showh a 8++instance showHBits16 :: ShowHex BITS16 where + showhex a = "0x" ++ showh (fromInt(toInt a)) 4++instance showHBits8 :: ShowHex BITS8 where + showhex a = "0x" ++ showh (fromInt(toInt a)) 2
+ lib/Data.Functional.List.t view
@@ -0,0 +1,117 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module List where++delete :: a -> [a] -> [a] \\ Eq a+delete = deleteBy (==)++deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy eq x [] = []+deleteBy eq x (y:ys)= if x `eq` y then ys else y:deleteBy eq x ys+++(\\) :: [a] -> [a] -> [a] \\ Eq a+(\\) = foldl (flip delete)++elemBy, notElemBy :: (a -> a -> Bool) -> a -> [a] -> Bool+elemBy eq _ [] = False+elemBy eq x (y:ys) = x `eq` y || elemBy eq x ys++notElemBy eq x xs = not (elemBy eq x xs)++lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b+lookupBy eq key [] = Nothing+lookupBy eq key ((x,y):xys)+ | key `eq` x = Just y+ | otherwise = lookupBy eq key xys++partition :: (a -> Bool) -> [a] -> ([a],[a])+partition p = foldr select ([],[])+ where select x (ts,fs) | p x = (x:ts,fs)+ | otherwise = (ts,x:fs)++nub :: [a] -> [a] \\ Eq a+nub = nubBy (==)++nubBy :: (a -> a -> Bool) -> [a] -> [a]+nubBy eq [] = []+nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs)++sort :: [a] -> [a] \\ Ord a+sort [] = []+sort (x : xs) = sort small ++ x : sort big+ where (small,big) = partition (\y -> y <= x) xs++span, break :: (a -> Bool) -> [a] -> ([a],[a])+span p [] = ([],[])+span p (x:xs)+ | p x = let (ys,zs) = span p xs in (x:ys,zs)+ | otherwise = ([],x:xs)++break p = span (\x -> not (p x))++lines :: String -> [String]+lines [] = []+lines s = let (l,s') = break ('\n'==) s+ in l : case s' of + [] -> []+ (_:s'') -> lines s''++words :: String -> [String]+words s = case dropWhile isSpace s of+ [] -> []+ s' -> w : words s''+ where (w,s'') = acc s' []+ acc [] w = (reverse w,[])+ acc (c:cs) w+ |isSpace c = (reverse w,cs)+ |otherwise = acc cs (c:w) + +isSpace c = elem c " \t\n"++unlines :: [String] -> String+unlines ls = concat (map (\l -> l ++ "\n") ls)++unwords :: [String] -> String+unwords [] = []+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws++foldr1 f [x] = x+foldr1 f (x:xs) = f x (foldr1 f xs)++sum :: [a] -> a \\ IntLiteral a, Num a+sum = foldl (+) 0++null [] = True+null _ = False
+ lib/Data.Objects.Dictionary.t view
@@ -0,0 +1,104 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Dictionary where++ struct Dictionary a b where+ insert :: a -> b -> Request ()+ lookup :: a -> Request (Maybe b)++ listDict :: Class (Dictionary a b) \\ Eq a+ listDict = class+ dict := []+ + insert a b = request+ dict := insL a b dict++ lookup a = request+ result Prelude.lookup a dict++ result Dictionary {..}+++ treeDict :: Class (Dictionary a b) \\ Ord a+ treeDict = class+ dict := Nil+ + insert a b = request+ dict := insT a b dict++ lookup a = request+ result look a dict++ result Dictionary {..}+++ hashDict :: (a -> Int -> Int) -> Class (Dictionary a b) ->+ Int -> Class (Dictionary a b)+ hashDict hash dictC n = class++ ds = new seqC dictC n+ dict = array ds+ + insert a b = (dict!(hash a n)).insert a b++ lookup a = (dict!(hash a n)).lookup a+ + result Dictionary {..}++private+ + insL a b [] = [(a,b)]+ insL a b ((x,y) : xs) + | a == x = (a,b) : xs+ | otherwise = (x,y) : insL a b xs++ data Tree a = Nil | Node (Tree a) a (Tree a)++ insT a b Nil = Node Nil (a,b) Nil+ insT a b (Node l (x,y) r) + | a == x = Node l (a,b) r+ | a < x = Node (insT a b l) (x,y) r+ | a > x = Node l (x,y) (insT a b r)++ look a Nil = Nothing+ look a (Node l (x,y) r) + | a == x = Just y+ | a < x = look a l+ | a > x = look a r++ seqC c 0 = class result []+ seqC c n = class+ x = new c+ xs = new seqC c (n-1)+ result (x:xs)
+ lib/Data.Objects.Stack.t view
@@ -0,0 +1,58 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Stack where++struct Stack a where + push :: a -> Action+ pop :: Action+ top :: Request a+ size :: Request Int++stk = class+ xs := []+ + push x = action+ xs := x : xs++ pop = action+ xs := tail xs+ + top = request+ result (head xs)++ size = request+ result (length xs)++ result Stack{..}+
+ lib/POSIX.t view
@@ -0,0 +1,86 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module POSIX where+ +type RootType = Env -> Class Prog++type Prog = Action++struct Env where+ exit :: Int -> Request ()+ argv :: Array String+ stdin :: RFile+ stdout :: WFile+ openR :: String -> Request (Maybe RFile)+ openW :: String -> Request (Maybe WFile)+ startTime :: Time+ inet :: Internet++struct Closable where+ close :: Request ()++struct File < Closable where+ seek :: Int -> Request Int+ +struct RFile < File where+ read :: Request String+ installR :: (String -> Action) -> Request ()+ +struct WFile < File where+ write :: String -> Request Int+ installW :: Action -> Request ()++data Host = Host String+data Port = Port Int++struct Internet where+ tcp :: Sockets++struct Socket < Closable where+ remoteHost :: Host+ remotePort :: Port+ inFile :: RFile+ outFile :: WFile++struct Connection < Closable where + established :: Action+ neterror :: String -> Action++struct Sockets where+ connect :: Host -> Port -> (Socket -> Class Connection) -> Request ()+ listen :: Port -> (Socket -> Class Connection) -> Request Closable++instance showHost :: Show Host+showHost = struct+ show (Host nm) = nm
+ lib/Prelude.t view
@@ -0,0 +1,553 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Prelude where++-- IntLiteral ----------------------------------------------++typeclass IntLiteral a where+ fromInt :: Int -> a++instance intInt :: IntLiteral Int where+ fromInt n = n+ +instance intFloat ::IntLiteral Float where+ fromInt = primIntToFloat++default intInt < intFloat++-- Num ----------------------------------------------------- ++typeclass Num a where+ (+),(-),(*) :: a -> a -> a+ negate :: a -> a++instance numInt :: Num Int where+ (+) = primIntPlus+ (-) = primIntMinus+ (*) = primIntTimes+ negate = primIntNeg++instance numFloat :: Num Float where+ (+) = primFloatPlus+ (-) = primFloatMinus+ (*) = primFloatTimes+ negate = primFloatNeg++instance numTime :: Num Time where+ (+) = primTimePlus+ (-) = primTimeMinus+ _ * _ = raise 1+ negate _ = sec 0++-- Eq ------------------------------------------------------++typeclass Eq a where+ (==),(/=) :: a -> a -> Bool++instance eqInt :: Eq Int where+ (==) = primIntEQ+ (/=) = primIntNE++instance eqFloat :: Eq Float where+ (==) = primFloatEQ+ (/=) = primFloatNE++instance eqTime :: Eq Time where+ (==) = primTimeEQ+ (/=) = primTimeNE++instance eqPID :: Eq PID where+ (==) = primPidEQ+ (/=) = primPidNE++instance eqChar :: Eq Char where+ a == b = ord a == ord b+ a /= b = ord a /= ord b++instance eqUnit :: Eq () where+ _ == _ = True+ _ /= _ = False++instance eqList :: Eq [a] \\ Eq a where+ [] == [] = True+ a : as == b : bs = a == b && as == bs+ _ == _ = False+ xs /= ys = not ( xs == ys)++instance eqEither :: Eq (Either a b) \\ Eq a, Eq b where+ Left x == Left y = x == y+ Right x == Right y = x == y+ _ == _ = False+ x /= y = not (x == y)++instance eqPair :: Eq (a,b) \\ Eq a, Eq b where+ (a,b) == (c,d) = a==c && b==d+ x /= y = not (x==y)++-- Ord -----------------------------------------------------++typeclass Ord a < Eq a where+ (<),(<=),(>),(>=) :: a -> a -> Bool++instance ordInt :: Ord Int = Ord {..}+ where Eq {..} = eqInt+ (<) = primIntLT+ (<=) = primIntLE+ (>) = primIntGT+ (>=) = primIntGE++instance ordFloat :: Ord Float = Ord {..}+ where Eq {..} = eqFloat+ (<) = primFloatLT+ (<=) = primFloatLE+ (>) = primFloatGT+ (>=) = primFloatGE++instance ordChar :: Ord Char = struct+ a < b = ord a < ord b+ a <= b = ord a <= ord b+ a > b = ord a > ord b+ a >= b = ord a >= ord b+ (==) = eqChar.(==)+ (/=) = eqChar.(/=)++instance ordTime :: Ord Time = Ord {..}+ where Eq {..} = eqTime+ (<) = primTimeLT+ (<=) = primTimeLE+ (>) = primTimeGT+ (>=) = primTimeGE++instance ordUnit :: Ord () = Ord{..}+ where Eq{..} = eqUnit+ _ < _ = False+ _ <= _ = True+ _ > _ = False+ _ >= _ = True+ +-- Show ----------------------------------------------------+ +typeclass Show a where+ show :: a -> String++instance showInt :: Show Int where+ show 0 = "0"+ show n+ |n < 0 = '-' : show (negate n)+ | otherwise = reverse (digs n)+ where dig n = chr (n + ord '0')+ digs n+ | n < 10 = [dig n]+ | otherwise = dig (n `mod` 10) : digs (n `div` 10)+ +instance showFloat :: Show Float where+ show = primShowFloat++instance showBool :: Show Bool where+ show False = "False"+ show True = "True"++instance showChar :: Show Char where+ show c = [c]++instance showMaybe :: Show (Maybe a) \\ Show a where+ show Nothing = "Nothing"+ show (Just x) = "Just (" ++ show x ++ ")"++instance showString :: Show String where+ show s = '"' : s ++ "\""++instance showList :: Show [a] \\ Show a where+ show [] = "[]"+ show (x : xs) = '[' : show x ++ concat (map (\x -> ',' : show x) xs) ++ "]"++instance showTuple :: Show (a,b) \\ Show a, Show b where+ show (a,b) = "("++show a++","++show b++")"++instance showUnit :: Show () where+ show () = "()"++-- Parse ---------------------------------------------------++typeclass Parse a where+ parse :: String -> Either String a++instance parseInt :: Parse Int where+ parse str = p (strip str)+ where p('-':cs) = case q (strip (reverse cs)) of+ Left err -> Left err+ Right n -> Right (-n)+ p cs = q (strip (reverse cs))+ q cs+ | all isDigit cs = Right (r cs)+ | otherwise = Left "parseInt: no Parse"+ r (c:cs) = ord c - ord '0' + 10*r cs+ r [] = 0+ strip cs = dropWhile (== ' ') cs+ isDigit c = c >= '0' && c <= '9'++-- Enum ----------------------------------------------------++typeclass Enum a where+ fromEnum :: a -> Int+ toEnum :: Int -> a++instance enumInt :: Enum Int where+ fromEnum n = n+ toEnum n = n++instance enumChar :: Enum Char where+ fromEnum = primCharToInt+ toEnum = primIntToChar++instance enumUnit :: Enum () where+ fromEnum () = 0+ toEnum 0 = ()++instance enumEither :: Enum (Either () a) \\ Enum a where+ fromEnum (Left ()) = 0+ fromEnum (Right a) = 1 + fromEnum a+ toEnum 0 = Left ()+ toEnum n = Right (toEnum (n-1))++-- Functor, Monad and friends ------------------------------++typeclass Functor m where+ ($^) :: (a -> b) -> m a -> m b++typeclass Applicative m < Functor m where+ ($*) :: m (a -> b) -> m a -> m b+ return :: a -> m a++typeclass Monad m < Applicative m where+ (>>=) :: m a -> (a -> m b) -> m b++typeclass MPlus m where+ mempty :: m a+ mappend :: m a -> m a -> m a++instance functorMaybe :: Functor Maybe where+ f $^ Nothing = Nothing+ f $^ Just a = Just (f a)++instance applicativeMaybe :: Applicative Maybe = Applicative {..}+ where Functor {..} = functorMaybe+ Just f $* Just a = Just (f a)+ _ $* _ = Nothing++instance monadMaybe :: Monad Maybe = Monad {..}+ where Applicative {..} = applicativeMaybe+ Just a >>= f = f a+ Nothing >>= _ = Nothing++instance mPlusMaybe :: MPlus Maybe where+ mempty = Nothing+ Just a `mappend` _ = Just a+ Nothing `mappend` a = a++instance functorArray :: Functor Array where+ f $^ a = array [f (a!i) | i <- [0..size a-1]]+++(>>) :: m a -> m b -> m b \\ Monad m+ma >> mb = ma >>= \_ -> mb++join :: m (m a) -> m a \\ Monad m+join m = m >>= id++-- Prelude support for forall statement --------------------++forallList f [] = do result ()+forallList f (x : xs) = do f x+ forallList f xs++forallSeq :: (a -> Cmd b c) -> a -> a -> Cmd b () \\ Enum a+forallSeq f a b = fS (fromEnum a) (fromEnum b)+ where fS ai bi+ | ai>bi = do result ()+ | otherwise = do f (toEnum ai)+ fS (ai+1) bi++forallSeq1 :: (a -> Cmd b c) -> a -> a -> a -> Cmd b () \\ Enum a+forallSeq1 f a b c = fE ai (bi-ai) ci+ where ai = fromEnum a+ bi = fromEnum b+ ci = fromEnum c+ fE ai bi ci + | (if bi > 0 then ai > ci else ai < ci) = do result ()+ | otherwise = do f (toEnum ai)+ fE (ai+bi) bi ci++-- Prelude support for arithmetic sequences ----------------++enumFromTo :: a -> a -> [a] \\ Enum a+enumFromTo a b = map toEnum (fromToInt (fromEnum a) 1 (fromEnum b))++enumFromThenTo a b c = map toEnum (fromToInt ai (bi-ai) ci)+ where ai = fromEnum a+ bi = fromEnum b+ ci = fromEnum c++fromToInt :: Int -> Int -> Int -> [Int]+fromToInt m s n+ | s > 0 = up m n+ | otherwise = down m n+ where up m n+ | m > n = []+ | otherwise = m : up (m+s) n+ down m n+ | m < n = []+ | otherwise = m : down (m+s) n++-- Maybe ---------------------------------------------------++data Maybe a = Just a | Nothing++isNothing :: Maybe a -> Bool+isNothing Nothing = True+isNothing (Just _) = False++isJust :: Maybe a -> Bool+isJust Nothing = False+isJust (Just _) = True++-- Either --------------------------------------------------++isLeft (Left _) = True+isLeft _ = False++isRight (Right _) = True+isRight _ = False++fromRight (Right x) = x++fromLeft (Left x) = x++-- String --------------------------------------------------++type String = [Char]++-- Tuples --------------------------------------------------++fst :: (a,b) -> a+fst (x,_) = x++snd :: (a,b) -> b+snd (_,x) = x++-- List functions ------------------------------------------++head :: [a] -> a+head (x : _) = x++tail :: [a] -> [a]+tail (_ : xs) = xs++init :: [a] -> [a]+init [x] = []+init (x : xs) = x : init xs++last :: [a] -> a+last [x] = x+last (x : xs) = last xs++(++) :: [a] -> [a] -> [a]+[] ++ ys = ys+(x:xs) ++ ys = x : xs ++ ys++length :: [a] -> Int+length [] = 0+length (_ : xs) = 1 + length xs++reverse :: [a] -> [a]+reverse xs = rev xs []+ where rev [] ys = ys+ rev (x : xs) ys+ = rev xs (x : ys)++map :: (a -> b) -> [a] -> [b]+map f [] = []+map f (x : xs) = f x : map f xs++filter :: (a -> Bool) -> [a] -> [a]+filter p [] = []+filter p (x : xs) + | p x = x : filter p xs+ | otherwise = filter p xs+++foldr :: ( a -> b -> b) -> b -> [a] -> b+foldr f u [] = u+foldr f u (x : xs) = f x (foldr f u xs)++foldl :: (a -> b -> a) -> a -> [b] -> a+foldl f u [] = u +foldl f u (x : xs) = foldl f (f u x) xs++concat = foldr (++) []++zip (x:xs) (y:ys) = (x,y) : zip xs ys+zip _ _ = []++elem :: a -> [a] -> Bool \\ Eq a+elem x [] = False+elem x (y : ys) = x == y || elem x ys++lookup :: a -> [(a,b)] -> Maybe b \\ Eq a+lookup x [] = Nothing+lookup x ((a,b) : xs) + | x == a = Just b+ | otherwise = lookup x xs++replicate :: Int -> a -> [a]+replicate n x+ | n < 0 = []+ | otherwise = x : replicate (n-1) x++take, drop :: Int -> [a] -> [a]+take 0 xs = []+take n [] = []+take n (x : xs) + | n > 0 = x : take (n-1) xs++drop 0 xs = xs+drop n [] = []+drop n (x : xs)+ | n > 0 = drop (n-1) xs+ +takeWhile p [] = []+takeWhile p (x:xs)+ | p x = x : takeWhile p xs+ | otherwise = []++dropWhile p [] = []+dropWhile p (x:xs)+ | p x = dropWhile p xs+ | otherwise = x:xs++all p [] = True+all p (x : xs) = p x && all p xs++any p [] = False+any p (x : xs) = p x || any p xs++-- Combinators ---------------------------------------------++($) :: (a -> b) -> a -> b+f $ a = f a++const :: a -> b -> a+const a _ = a++id :: a -> a+id a = a++flip :: (a -> b -> c) -> b -> a -> c+flip f x y = f y x++curry :: ((a,b) -> c) -> a -> b -> c +curry f x y = f (x,y)++uncurry :: (a -> b -> c) -> (a,b) -> c+uncurry f (x,y) = f x y++f @ g = \x -> f (g x)++-- Boolean and numeric functions ---------------------------++not :: Bool -> Bool+not True = False+not False = True++otherwise :: Bool+otherwise = True++ord :: Char -> Int+ord = primCharToInt++chr :: Int -> Char+chr = primIntToChar++a ^ 0 = 1+a ^ n + | even n = (a * a) ^ (n `div` 2)+ | otherwise = a * (a * a) ^ (n `div` 2)++div, mod :: Int -> Int -> Int+div = primIntDiv+mod = primIntMod++(/) :: Float -> Float -> Float+(/) = primFloatDiv++even, odd :: Int -> Bool+even x = x `mod` 2 == 0+odd x = x `mod` 2 == 1++gcd :: Int -> Int -> Int+gcd x y = gcd' (abs x) (abs y)+ where gcd' a 0+ | a > 0 = a+ gcd' a b = gcd' b (a `mod` b)++abs x = case x < 0 of+ True -> -x+ False -> x+++max, min :: a -> a -> a \\ Ord a+max x y+ | x >= y = x+ | otherwise = y++min x y+ | x <= y = x+ | otherwise = y++floor = primFloatToInt++round x = floor (x + 0.5)++-- Command sequencing --------------------------------------++sequence [] = do result []+sequence (x : xs) = do a <- x+ as <- sequence xs+ result a : as++mapM f [] = do result []+mapM f (x : xs) = do a <- f x+ as <- mapM f xs+ result a : as+
+ lib/RandomGenerator.t view
@@ -0,0 +1,60 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module RandomGenerator where++struct Generator a where+ next :: Request a+ +-- Lehmer/Schrage random number generator. Simple and not too bad.+-- baseGen generates integers in the range [1..m-1] on 32 bit machines.+-- The n-th number produced is (seed * a^n) mod m but with calculations organised to avoid overflow.+-- 7^5 is a primitive root of the prime m, so this generator has period m - 1.++baseGen :: Int -> Class (Generator Int)+baseGen 0 = raise 1+baseGen seed = class+ a = 16807 -- = 7^5+ m = 2147483647 -- = 2^31 - 1+ q = 127773 -- = m `div` a+ r = 2836 -- = m `mod` a++ state := seed+ + next = request+ tmp = a * (state `mod` q) - r * (state `div` q)+ state := if tmp > 0 then tmp else tmp + m+ result state++ result Generator{..}+
+ rtsPOSIX/Makefile.in view
@@ -0,0 +1,42 @@+prefix = @prefix@+CC = @CC@+CFLAGS = @CFLAGS@+INSTALL = @INSTALL@++TIMBERC = @TIMBERC@+TIMBERLIBS = Prelude.t $(filter-out Prelude.t,$(notdir $(wildcard ../lib/*.t)))+OBJS = $(TIMBERLIBS:.t=.o)++DEST = libTimber.a++all: + @printf "Run make install to install and build this RTS.\n\n"+ @printf "Run make $(DEST) to build this RTS in-place.\n"+ @printf "Notice that building in-place requires the RTS to reside in\n"+ @printf "an installed timberc tree.\n\n"+++$(DEST): $(OBJS) rts.o+ ar rc $(DEST) $(OBJS) rts.o++$(OBJS): %.o: ../lib/%.t ../include/timber.h+ $(TIMBERC) --target POSIX --api -c $<++rts.o: rts.c cyclic.c gc.c env.c env.h timer.c rts.h ../include/timber.h ../include/timber.c ../include/float.c+ $(CC) $(CFLAGS) -Wall -O2 -fno-strict-aliasing -g -I../include -I../lib -I. -c rts.c++install: + $(INSTALL) -d $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) timberc.cfg $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) rts.h $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) rts.c $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) cyclic.c $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) config.h $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) gc.c $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) env.c $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) env.h $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) timer.c $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) main.c $(DESTDIR)$(prefix)/rtsPOSIX+ $(INSTALL) Makefile $(DESTDIR)$(prefix)/rtsPOSIX+ cd $(DESTDIR)$(prefix)/rtsPOSIX && make $(DEST) +
+ rtsPOSIX/config.guess view
@@ -0,0 +1,1526 @@+#! /bin/sh+# Attempt to guess a canonical system name.+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,+# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008+# Free Software Foundation, Inc.++timestamp='2008-01-23'++# This file is free software; you can redistribute it and/or modify it+# under the terms of the GNU General Public License as published by+# the Free Software Foundation; either version 2 of the License, or+# (at your option) any later version.+#+# This program is distributed in the hope that it will be useful, but+# WITHOUT ANY WARRANTY; without even the implied warranty of+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+# General Public License for more details.+#+# You should have received a copy of the GNU General Public License+# along with this program; if not, write to the Free Software+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA+# 02110-1301, USA.+#+# As a special exception to the GNU General Public License, if you+# distribute this file as part of a program that contains a+# configuration script generated by Autoconf, you may include it under+# the same distribution terms that you use for the rest of that program.+++# Originally written by Per Bothner <per@bothner.com>.+# Please send patches to <config-patches@gnu.org>. Submit a context+# diff and a properly formatted ChangeLog entry.+#+# This script attempts to guess a canonical system name similar to+# config.sub. If it succeeds, it prints the system name on stdout, and+# exits with 0. Otherwise, it exits with 1.+#+# The plan is that this can be called by configure scripts if you+# don't specify an explicit build system type.++me=`echo "$0" | sed -e 's,.*/,,'`++usage="\+Usage: $0 [OPTION]++Output the configuration name of the system \`$me' is run on.++Operation modes:+ -h, --help print this help, then exit+ -t, --time-stamp print date of last modification, then exit+ -v, --version print version number, then exit++Report bugs and patches to <config-patches@gnu.org>."++version="\+GNU config.guess ($timestamp)++Originally written by Per Bothner.+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,+2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.++This is free software; see the source for copying conditions. There is NO+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."++help="+Try \`$me --help' for more information."++# Parse command line+while test $# -gt 0 ; do+ case $1 in+ --time-stamp | --time* | -t )+ echo "$timestamp" ; exit ;;+ --version | -v )+ echo "$version" ; exit ;;+ --help | --h* | -h )+ echo "$usage"; exit ;;+ -- ) # Stop option processing+ shift; break ;;+ - ) # Use stdin as input.+ break ;;+ -* )+ echo "$me: invalid option $1$help" >&2+ exit 1 ;;+ * )+ break ;;+ esac+done++if test $# != 0; then+ echo "$me: too many arguments$help" >&2+ exit 1+fi++trap 'exit 1' 1 2 15++# CC_FOR_BUILD -- compiler used by this script. Note that the use of a+# compiler to aid in system detection is discouraged as it requires+# temporary files to be created and, as you can see below, it is a+# headache to deal with in a portable fashion.++# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still+# use `HOST_CC' if defined, but it is deprecated.++# Portable tmp directory creation inspired by the Autoconf team.++set_cc_for_build='+trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;+trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;+: ${TMPDIR=/tmp} ;+ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||+ { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;+dummy=$tmp/dummy ;+tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;+case $CC_FOR_BUILD,$HOST_CC,$CC in+ ,,) echo "int x;" > $dummy.c ;+ for c in cc gcc c89 c99 ; do+ if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then+ CC_FOR_BUILD="$c"; break ;+ fi ;+ done ;+ if test x"$CC_FOR_BUILD" = x ; then+ CC_FOR_BUILD=no_compiler_found ;+ fi+ ;;+ ,,*) CC_FOR_BUILD=$CC ;;+ ,*,*) CC_FOR_BUILD=$HOST_CC ;;+esac ; set_cc_for_build= ;'++# This is needed to find uname on a Pyramid OSx when run in the BSD universe.+# (ghazi@noc.rutgers.edu 1994-08-24)+if (test -f /.attbin/uname) >/dev/null 2>&1 ; then+ PATH=$PATH:/.attbin ; export PATH+fi++UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown+UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown+UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown+UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown++# Note: order is significant - the case branches are not exclusive.++case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in+ *:NetBSD:*:*)+ # NetBSD (nbsd) targets should (where applicable) match one or+ # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*,+ # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently+ # switched to ELF, *-*-netbsd* would select the old+ # object file format. This provides both forward+ # compatibility and a consistent mechanism for selecting the+ # object file format.+ #+ # Note: NetBSD doesn't particularly care about the vendor+ # portion of the name. We always set it to "unknown".+ sysctl="sysctl -n hw.machine_arch"+ UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \+ /usr/sbin/$sysctl 2>/dev/null || echo unknown)`+ case "${UNAME_MACHINE_ARCH}" in+ armeb) machine=armeb-unknown ;;+ arm*) machine=arm-unknown ;;+ sh3el) machine=shl-unknown ;;+ sh3eb) machine=sh-unknown ;;+ sh5el) machine=sh5le-unknown ;;+ *) machine=${UNAME_MACHINE_ARCH}-unknown ;;+ esac+ # The Operating System including object format, if it has switched+ # to ELF recently, or will in the future.+ case "${UNAME_MACHINE_ARCH}" in+ arm*|i386|m68k|ns32k|sh3*|sparc|vax)+ eval $set_cc_for_build+ if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \+ | grep __ELF__ >/dev/null+ then+ # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).+ # Return netbsd for either. FIX?+ os=netbsd+ else+ os=netbsdelf+ fi+ ;;+ *)+ os=netbsd+ ;;+ esac+ # The OS release+ # Debian GNU/NetBSD machines have a different userland, and+ # thus, need a distinct triplet. However, they do not need+ # kernel version information, so it can be replaced with a+ # suitable tag, in the style of linux-gnu.+ case "${UNAME_VERSION}" in+ Debian*)+ release='-gnu'+ ;;+ *)+ release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`+ ;;+ esac+ # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:+ # contains redundant information, the shorter form:+ # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.+ echo "${machine}-${os}${release}"+ exit ;;+ *:OpenBSD:*:*)+ UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`+ echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}+ exit ;;+ *:ekkoBSD:*:*)+ echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}+ exit ;;+ *:SolidBSD:*:*)+ echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}+ exit ;;+ macppc:MirBSD:*:*)+ echo powerpc-unknown-mirbsd${UNAME_RELEASE}+ exit ;;+ *:MirBSD:*:*)+ echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}+ exit ;;+ alpha:OSF1:*:*)+ case $UNAME_RELEASE in+ *4.0)+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`+ ;;+ *5.*)+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`+ ;;+ esac+ # According to Compaq, /usr/sbin/psrinfo has been available on+ # OSF/1 and Tru64 systems produced since 1995. I hope that+ # covers most systems running today. This code pipes the CPU+ # types through head -n 1, so we only detect the type of CPU 0.+ ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1`+ case "$ALPHA_CPU_TYPE" in+ "EV4 (21064)")+ UNAME_MACHINE="alpha" ;;+ "EV4.5 (21064)")+ UNAME_MACHINE="alpha" ;;+ "LCA4 (21066/21068)")+ UNAME_MACHINE="alpha" ;;+ "EV5 (21164)")+ UNAME_MACHINE="alphaev5" ;;+ "EV5.6 (21164A)")+ UNAME_MACHINE="alphaev56" ;;+ "EV5.6 (21164PC)")+ UNAME_MACHINE="alphapca56" ;;+ "EV5.7 (21164PC)")+ UNAME_MACHINE="alphapca57" ;;+ "EV6 (21264)")+ UNAME_MACHINE="alphaev6" ;;+ "EV6.7 (21264A)")+ UNAME_MACHINE="alphaev67" ;;+ "EV6.8CB (21264C)")+ UNAME_MACHINE="alphaev68" ;;+ "EV6.8AL (21264B)")+ UNAME_MACHINE="alphaev68" ;;+ "EV6.8CX (21264D)")+ UNAME_MACHINE="alphaev68" ;;+ "EV6.9A (21264/EV69A)")+ UNAME_MACHINE="alphaev69" ;;+ "EV7 (21364)")+ UNAME_MACHINE="alphaev7" ;;+ "EV7.9 (21364A)")+ UNAME_MACHINE="alphaev79" ;;+ esac+ # A Pn.n version is a patched version.+ # A Vn.n version is a released version.+ # A Tn.n version is a released field test version.+ # A Xn.n version is an unreleased experimental baselevel.+ # 1.2 uses "1.2" for uname -r.+ echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`+ exit ;;+ Alpha\ *:Windows_NT*:*)+ # How do we know it's Interix rather than the generic POSIX subsystem?+ # Should we change UNAME_MACHINE based on the output of uname instead+ # of the specific Alpha model?+ echo alpha-pc-interix+ exit ;;+ 21064:Windows_NT:50:3)+ echo alpha-dec-winnt3.5+ exit ;;+ Amiga*:UNIX_System_V:4.0:*)+ echo m68k-unknown-sysv4+ exit ;;+ *:[Aa]miga[Oo][Ss]:*:*)+ echo ${UNAME_MACHINE}-unknown-amigaos+ exit ;;+ *:[Mm]orph[Oo][Ss]:*:*)+ echo ${UNAME_MACHINE}-unknown-morphos+ exit ;;+ *:OS/390:*:*)+ echo i370-ibm-openedition+ exit ;;+ *:z/VM:*:*)+ echo s390-ibm-zvmoe+ exit ;;+ *:OS400:*:*)+ echo powerpc-ibm-os400+ exit ;;+ arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)+ echo arm-acorn-riscix${UNAME_RELEASE}+ exit ;;+ arm:riscos:*:*|arm:RISCOS:*:*)+ echo arm-unknown-riscos+ exit ;;+ SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)+ echo hppa1.1-hitachi-hiuxmpp+ exit ;;+ Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)+ # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.+ if test "`(/bin/universe) 2>/dev/null`" = att ; then+ echo pyramid-pyramid-sysv3+ else+ echo pyramid-pyramid-bsd+ fi+ exit ;;+ NILE*:*:*:dcosx)+ echo pyramid-pyramid-svr4+ exit ;;+ DRS?6000:unix:4.0:6*)+ echo sparc-icl-nx6+ exit ;;+ DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)+ case `/usr/bin/uname -p` in+ sparc) echo sparc-icl-nx7; exit ;;+ esac ;;+ sun4H:SunOS:5.*:*)+ echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+ exit ;;+ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)+ echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+ exit ;;+ i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)+ echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+ exit ;;+ sun4*:SunOS:6*:*)+ # According to config.sub, this is the proper way to canonicalize+ # SunOS6. Hard to guess exactly what SunOS6 will be like, but+ # it's likely to be more like Solaris than SunOS4.+ echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+ exit ;;+ sun4*:SunOS:*:*)+ case "`/usr/bin/arch -k`" in+ Series*|S4*)+ UNAME_RELEASE=`uname -v`+ ;;+ esac+ # Japanese Language versions have a version number like `4.1.3-JL'.+ echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`+ exit ;;+ sun3*:SunOS:*:*)+ echo m68k-sun-sunos${UNAME_RELEASE}+ exit ;;+ sun*:*:4.2BSD:*)+ UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`+ test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3+ case "`/bin/arch`" in+ sun3)+ echo m68k-sun-sunos${UNAME_RELEASE}+ ;;+ sun4)+ echo sparc-sun-sunos${UNAME_RELEASE}+ ;;+ esac+ exit ;;+ aushp:SunOS:*:*)+ echo sparc-auspex-sunos${UNAME_RELEASE}+ exit ;;+ # The situation for MiNT is a little confusing. The machine name+ # can be virtually everything (everything which is not+ # "atarist" or "atariste" at least should have a processor+ # > m68000). The system name ranges from "MiNT" over "FreeMiNT"+ # to the lowercase version "mint" (or "freemint"). Finally+ # the system name "TOS" denotes a system which is actually not+ # MiNT. But MiNT is downward compatible to TOS, so this should+ # be no problem.+ atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)+ echo m68k-atari-mint${UNAME_RELEASE}+ exit ;;+ atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)+ echo m68k-atari-mint${UNAME_RELEASE}+ exit ;;+ *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)+ echo m68k-atari-mint${UNAME_RELEASE}+ exit ;;+ milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)+ echo m68k-milan-mint${UNAME_RELEASE}+ exit ;;+ hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)+ echo m68k-hades-mint${UNAME_RELEASE}+ exit ;;+ *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)+ echo m68k-unknown-mint${UNAME_RELEASE}+ exit ;;+ m68k:machten:*:*)+ echo m68k-apple-machten${UNAME_RELEASE}+ exit ;;+ powerpc:machten:*:*)+ echo powerpc-apple-machten${UNAME_RELEASE}+ exit ;;+ RISC*:Mach:*:*)+ echo mips-dec-mach_bsd4.3+ exit ;;+ RISC*:ULTRIX:*:*)+ echo mips-dec-ultrix${UNAME_RELEASE}+ exit ;;+ VAX*:ULTRIX*:*:*)+ echo vax-dec-ultrix${UNAME_RELEASE}+ exit ;;+ 2020:CLIX:*:* | 2430:CLIX:*:*)+ echo clipper-intergraph-clix${UNAME_RELEASE}+ exit ;;+ mips:*:*:UMIPS | mips:*:*:RISCos)+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c+#ifdef __cplusplus+#include <stdio.h> /* for printf() prototype */+ int main (int argc, char *argv[]) {+#else+ int main (argc, argv) int argc; char *argv[]; {+#endif+ #if defined (host_mips) && defined (MIPSEB)+ #if defined (SYSTYPE_SYSV)+ printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);+ #endif+ #if defined (SYSTYPE_SVR4)+ printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);+ #endif+ #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)+ printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);+ #endif+ #endif+ exit (-1);+ }+EOF+ $CC_FOR_BUILD -o $dummy $dummy.c &&+ dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&+ SYSTEM_NAME=`$dummy $dummyarg` &&+ { echo "$SYSTEM_NAME"; exit; }+ echo mips-mips-riscos${UNAME_RELEASE}+ exit ;;+ Motorola:PowerMAX_OS:*:*)+ echo powerpc-motorola-powermax+ exit ;;+ Motorola:*:4.3:PL8-*)+ echo powerpc-harris-powermax+ exit ;;+ Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)+ echo powerpc-harris-powermax+ exit ;;+ Night_Hawk:Power_UNIX:*:*)+ echo powerpc-harris-powerunix+ exit ;;+ m88k:CX/UX:7*:*)+ echo m88k-harris-cxux7+ exit ;;+ m88k:*:4*:R4*)+ echo m88k-motorola-sysv4+ exit ;;+ m88k:*:3*:R3*)+ echo m88k-motorola-sysv3+ exit ;;+ AViiON:dgux:*:*)+ # DG/UX returns AViiON for all architectures+ UNAME_PROCESSOR=`/usr/bin/uname -p`+ if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]+ then+ if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \+ [ ${TARGET_BINARY_INTERFACE}x = x ]+ then+ echo m88k-dg-dgux${UNAME_RELEASE}+ else+ echo m88k-dg-dguxbcs${UNAME_RELEASE}+ fi+ else+ echo i586-dg-dgux${UNAME_RELEASE}+ fi+ exit ;;+ M88*:DolphinOS:*:*) # DolphinOS (SVR3)+ echo m88k-dolphin-sysv3+ exit ;;+ M88*:*:R3*:*)+ # Delta 88k system running SVR3+ echo m88k-motorola-sysv3+ exit ;;+ XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)+ echo m88k-tektronix-sysv3+ exit ;;+ Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)+ echo m68k-tektronix-bsd+ exit ;;+ *:IRIX*:*:*)+ echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`+ exit ;;+ ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.+ echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id+ exit ;; # Note that: echo "'`uname -s`'" gives 'AIX '+ i*86:AIX:*:*)+ echo i386-ibm-aix+ exit ;;+ ia64:AIX:*:*)+ if [ -x /usr/bin/oslevel ] ; then+ IBM_REV=`/usr/bin/oslevel`+ else+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}+ fi+ echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}+ exit ;;+ *:AIX:2:3)+ if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c+ #include <sys/systemcfg.h>++ main()+ {+ if (!__power_pc())+ exit(1);+ puts("powerpc-ibm-aix3.2.5");+ exit(0);+ }+EOF+ if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`+ then+ echo "$SYSTEM_NAME"+ else+ echo rs6000-ibm-aix3.2.5+ fi+ elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then+ echo rs6000-ibm-aix3.2.4+ else+ echo rs6000-ibm-aix3.2+ fi+ exit ;;+ *:AIX:*:[456])+ IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`+ if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then+ IBM_ARCH=rs6000+ else+ IBM_ARCH=powerpc+ fi+ if [ -x /usr/bin/oslevel ] ; then+ IBM_REV=`/usr/bin/oslevel`+ else+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}+ fi+ echo ${IBM_ARCH}-ibm-aix${IBM_REV}+ exit ;;+ *:AIX:*:*)+ echo rs6000-ibm-aix+ exit ;;+ ibmrt:4.4BSD:*|romp-ibm:BSD:*)+ echo romp-ibm-bsd4.4+ exit ;;+ ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and+ echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to+ exit ;; # report: romp-ibm BSD 4.3+ *:BOSX:*:*)+ echo rs6000-bull-bosx+ exit ;;+ DPX/2?00:B.O.S.:*:*)+ echo m68k-bull-sysv3+ exit ;;+ 9000/[34]??:4.3bsd:1.*:*)+ echo m68k-hp-bsd+ exit ;;+ hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)+ echo m68k-hp-bsd4.4+ exit ;;+ 9000/[34678]??:HP-UX:*:*)+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`+ case "${UNAME_MACHINE}" in+ 9000/31? ) HP_ARCH=m68000 ;;+ 9000/[34]?? ) HP_ARCH=m68k ;;+ 9000/[678][0-9][0-9])+ if [ -x /usr/bin/getconf ]; then+ sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`+ sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`+ case "${sc_cpu_version}" in+ 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0+ 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1+ 532) # CPU_PA_RISC2_0+ case "${sc_kernel_bits}" in+ 32) HP_ARCH="hppa2.0n" ;;+ 64) HP_ARCH="hppa2.0w" ;;+ '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20+ esac ;;+ esac+ fi+ if [ "${HP_ARCH}" = "" ]; then+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c++ #define _HPUX_SOURCE+ #include <stdlib.h>+ #include <unistd.h>++ int main ()+ {+ #if defined(_SC_KERNEL_BITS)+ long bits = sysconf(_SC_KERNEL_BITS);+ #endif+ long cpu = sysconf (_SC_CPU_VERSION);++ switch (cpu)+ {+ case CPU_PA_RISC1_0: puts ("hppa1.0"); break;+ case CPU_PA_RISC1_1: puts ("hppa1.1"); break;+ case CPU_PA_RISC2_0:+ #if defined(_SC_KERNEL_BITS)+ switch (bits)+ {+ case 64: puts ("hppa2.0w"); break;+ case 32: puts ("hppa2.0n"); break;+ default: puts ("hppa2.0"); break;+ } break;+ #else /* !defined(_SC_KERNEL_BITS) */+ puts ("hppa2.0"); break;+ #endif+ default: puts ("hppa1.0"); break;+ }+ exit (0);+ }+EOF+ (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`+ test -z "$HP_ARCH" && HP_ARCH=hppa+ fi ;;+ esac+ if [ ${HP_ARCH} = "hppa2.0w" ]+ then+ eval $set_cc_for_build++ # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating+ # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler+ # generating 64-bit code. GNU and HP use different nomenclature:+ #+ # $ CC_FOR_BUILD=cc ./config.guess+ # => hppa2.0w-hp-hpux11.23+ # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess+ # => hppa64-hp-hpux11.23++ if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |+ grep __LP64__ >/dev/null+ then+ HP_ARCH="hppa2.0w"+ else+ HP_ARCH="hppa64"+ fi+ fi+ echo ${HP_ARCH}-hp-hpux${HPUX_REV}+ exit ;;+ ia64:HP-UX:*:*)+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`+ echo ia64-hp-hpux${HPUX_REV}+ exit ;;+ 3050*:HI-UX:*:*)+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c+ #include <unistd.h>+ int+ main ()+ {+ long cpu = sysconf (_SC_CPU_VERSION);+ /* The order matters, because CPU_IS_HP_MC68K erroneously returns+ true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct+ results, however. */+ if (CPU_IS_PA_RISC (cpu))+ {+ switch (cpu)+ {+ case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;+ case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;+ case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;+ default: puts ("hppa-hitachi-hiuxwe2"); break;+ }+ }+ else if (CPU_IS_HP_MC68K (cpu))+ puts ("m68k-hitachi-hiuxwe2");+ else puts ("unknown-hitachi-hiuxwe2");+ exit (0);+ }+EOF+ $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&+ { echo "$SYSTEM_NAME"; exit; }+ echo unknown-hitachi-hiuxwe2+ exit ;;+ 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )+ echo hppa1.1-hp-bsd+ exit ;;+ 9000/8??:4.3bsd:*:*)+ echo hppa1.0-hp-bsd+ exit ;;+ *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)+ echo hppa1.0-hp-mpeix+ exit ;;+ hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )+ echo hppa1.1-hp-osf+ exit ;;+ hp8??:OSF1:*:*)+ echo hppa1.0-hp-osf+ exit ;;+ i*86:OSF1:*:*)+ if [ -x /usr/sbin/sysversion ] ; then+ echo ${UNAME_MACHINE}-unknown-osf1mk+ else+ echo ${UNAME_MACHINE}-unknown-osf1+ fi+ exit ;;+ parisc*:Lites*:*:*)+ echo hppa1.1-hp-lites+ exit ;;+ C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)+ echo c1-convex-bsd+ exit ;;+ C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)+ if getsysinfo -f scalar_acc+ then echo c32-convex-bsd+ else echo c2-convex-bsd+ fi+ exit ;;+ C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)+ echo c34-convex-bsd+ exit ;;+ C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)+ echo c38-convex-bsd+ exit ;;+ C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)+ echo c4-convex-bsd+ exit ;;+ CRAY*Y-MP:*:*:*)+ echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+ exit ;;+ CRAY*[A-Z]90:*:*:*)+ echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \+ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \+ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \+ -e 's/\.[^.]*$/.X/'+ exit ;;+ CRAY*TS:*:*:*)+ echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+ exit ;;+ CRAY*T3E:*:*:*)+ echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+ exit ;;+ CRAY*SV1:*:*:*)+ echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+ exit ;;+ *:UNICOS/mp:*:*)+ echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+ exit ;;+ F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)+ FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`+ FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`+ echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"+ exit ;;+ 5000:UNIX_System_V:4.*:*)+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`+ FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`+ echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"+ exit ;;+ i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)+ echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}+ exit ;;+ sparc*:BSD/OS:*:*)+ echo sparc-unknown-bsdi${UNAME_RELEASE}+ exit ;;+ *:BSD/OS:*:*)+ echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}+ exit ;;+ *:FreeBSD:*:*)+ case ${UNAME_MACHINE} in+ pc98)+ echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+ amd64)+ echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+ *)+ echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+ esac+ exit ;;+ i*:CYGWIN*:*)+ echo ${UNAME_MACHINE}-pc-cygwin+ exit ;;+ *:MINGW*:*)+ echo ${UNAME_MACHINE}-pc-mingw32+ exit ;;+ i*:windows32*:*)+ # uname -m includes "-pc" on this system.+ echo ${UNAME_MACHINE}-mingw32+ exit ;;+ i*:PW*:*)+ echo ${UNAME_MACHINE}-pc-pw32+ exit ;;+ *:Interix*:[3456]*)+ case ${UNAME_MACHINE} in+ x86)+ echo i586-pc-interix${UNAME_RELEASE}+ exit ;;+ EM64T | authenticamd)+ echo x86_64-unknown-interix${UNAME_RELEASE}+ exit ;;+ IA64)+ echo ia64-unknown-interix${UNAME_RELEASE}+ exit ;;+ esac ;;+ [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)+ echo i${UNAME_MACHINE}-pc-mks+ exit ;;+ i*:Windows_NT*:* | Pentium*:Windows_NT*:*)+ # How do we know it's Interix rather than the generic POSIX subsystem?+ # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we+ # UNAME_MACHINE based on the output of uname instead of i386?+ echo i586-pc-interix+ exit ;;+ i*:UWIN*:*)+ echo ${UNAME_MACHINE}-pc-uwin+ exit ;;+ amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)+ echo x86_64-unknown-cygwin+ exit ;;+ p*:CYGWIN*:*)+ echo powerpcle-unknown-cygwin+ exit ;;+ prep*:SunOS:5.*:*)+ echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+ exit ;;+ *:GNU:*:*)+ # the GNU system+ echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`+ exit ;;+ *:GNU/*:*:*)+ # other systems with GNU libc and userland+ echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu+ exit ;;+ i*86:Minix:*:*)+ echo ${UNAME_MACHINE}-pc-minix+ exit ;;+ arm*:Linux:*:*)+ eval $set_cc_for_build+ if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \+ | grep -q __ARM_EABI__+ then+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ else+ echo ${UNAME_MACHINE}-unknown-linux-gnueabi+ fi+ exit ;;+ avr32*:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ cris:Linux:*:*)+ echo cris-axis-linux-gnu+ exit ;;+ crisv32:Linux:*:*)+ echo crisv32-axis-linux-gnu+ exit ;;+ frv:Linux:*:*)+ echo frv-unknown-linux-gnu+ exit ;;+ ia64:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ m32r*:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ m68*:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ mips:Linux:*:*)+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c+ #undef CPU+ #undef mips+ #undef mipsel+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)+ CPU=mipsel+ #else+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)+ CPU=mips+ #else+ CPU=+ #endif+ #endif+EOF+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '+ /^CPU/{+ s: ::g+ p+ }'`"+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }+ ;;+ mips64:Linux:*:*)+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c+ #undef CPU+ #undef mips64+ #undef mips64el+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)+ CPU=mips64el+ #else+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)+ CPU=mips64+ #else+ CPU=+ #endif+ #endif+EOF+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '+ /^CPU/{+ s: ::g+ p+ }'`"+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }+ ;;+ or32:Linux:*:*)+ echo or32-unknown-linux-gnu+ exit ;;+ ppc:Linux:*:*)+ echo powerpc-unknown-linux-gnu+ exit ;;+ ppc64:Linux:*:*)+ echo powerpc64-unknown-linux-gnu+ exit ;;+ alpha:Linux:*:*)+ case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in+ EV5) UNAME_MACHINE=alphaev5 ;;+ EV56) UNAME_MACHINE=alphaev56 ;;+ PCA56) UNAME_MACHINE=alphapca56 ;;+ PCA57) UNAME_MACHINE=alphapca56 ;;+ EV6) UNAME_MACHINE=alphaev6 ;;+ EV67) UNAME_MACHINE=alphaev67 ;;+ EV68*) UNAME_MACHINE=alphaev68 ;;+ esac+ objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null+ if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi+ echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}+ exit ;;+ parisc:Linux:*:* | hppa:Linux:*:*)+ # Look for CPU level+ case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in+ PA7*) echo hppa1.1-unknown-linux-gnu ;;+ PA8*) echo hppa2.0-unknown-linux-gnu ;;+ *) echo hppa-unknown-linux-gnu ;;+ esac+ exit ;;+ parisc64:Linux:*:* | hppa64:Linux:*:*)+ echo hppa64-unknown-linux-gnu+ exit ;;+ s390:Linux:*:* | s390x:Linux:*:*)+ echo ${UNAME_MACHINE}-ibm-linux+ exit ;;+ sh64*:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ sh*:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ sparc:Linux:*:* | sparc64:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ vax:Linux:*:*)+ echo ${UNAME_MACHINE}-dec-linux-gnu+ exit ;;+ x86_64:Linux:*:*)+ echo x86_64-unknown-linux-gnu+ exit ;;+ xtensa*:Linux:*:*)+ echo ${UNAME_MACHINE}-unknown-linux-gnu+ exit ;;+ i*86:Linux:*:*)+ # The BFD linker knows what the default object file format is, so+ # first see if it will tell us. cd to the root directory to prevent+ # problems with other programs or directories called `ld' in the path.+ # Set LC_ALL=C to ensure ld outputs messages in English.+ ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \+ | sed -ne '/supported targets:/!d+ s/[ ][ ]*/ /g+ s/.*supported targets: *//+ s/ .*//+ p'`+ case "$ld_supported_targets" in+ elf32-i386)+ TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"+ ;;+ a.out-i386-linux)+ echo "${UNAME_MACHINE}-pc-linux-gnuaout"+ exit ;;+ coff-i386)+ echo "${UNAME_MACHINE}-pc-linux-gnucoff"+ exit ;;+ "")+ # Either a pre-BFD a.out linker (linux-gnuoldld) or+ # one that does not give us useful --help.+ echo "${UNAME_MACHINE}-pc-linux-gnuoldld"+ exit ;;+ esac+ # Determine whether the default compiler is a.out or elf+ eval $set_cc_for_build+ sed 's/^ //' << EOF >$dummy.c+ #include <features.h>+ #ifdef __ELF__+ # ifdef __GLIBC__+ # if __GLIBC__ >= 2+ LIBC=gnu+ # else+ LIBC=gnulibc1+ # endif+ # else+ LIBC=gnulibc1+ # endif+ #else+ #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC)+ LIBC=gnu+ #else+ LIBC=gnuaout+ #endif+ #endif+ #ifdef __dietlibc__+ LIBC=dietlibc+ #endif+EOF+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '+ /^LIBC/{+ s: ::g+ p+ }'`"+ test x"${LIBC}" != x && {+ echo "${UNAME_MACHINE}-pc-linux-${LIBC}"+ exit+ }+ test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; }+ ;;+ i*86:DYNIX/ptx:4*:*)+ # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.+ # earlier versions are messed up and put the nodename in both+ # sysname and nodename.+ echo i386-sequent-sysv4+ exit ;;+ i*86:UNIX_SV:4.2MP:2.*)+ # Unixware is an offshoot of SVR4, but it has its own version+ # number series starting with 2...+ # I am not positive that other SVR4 systems won't match this,+ # I just have to hope. -- rms.+ # Use sysv4.2uw... so that sysv4* matches it.+ echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}+ exit ;;+ i*86:OS/2:*:*)+ # If we were able to find `uname', then EMX Unix compatibility+ # is probably installed.+ echo ${UNAME_MACHINE}-pc-os2-emx+ exit ;;+ i*86:XTS-300:*:STOP)+ echo ${UNAME_MACHINE}-unknown-stop+ exit ;;+ i*86:atheos:*:*)+ echo ${UNAME_MACHINE}-unknown-atheos+ exit ;;+ i*86:syllable:*:*)+ echo ${UNAME_MACHINE}-pc-syllable+ exit ;;+ i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)+ echo i386-unknown-lynxos${UNAME_RELEASE}+ exit ;;+ i*86:*DOS:*:*)+ echo ${UNAME_MACHINE}-pc-msdosdjgpp+ exit ;;+ i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)+ UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`+ if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then+ echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}+ else+ echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}+ fi+ exit ;;+ i*86:*:5:[678]*)+ # UnixWare 7.x, OpenUNIX and OpenServer 6.+ case `/bin/uname -X | grep "^Machine"` in+ *486*) UNAME_MACHINE=i486 ;;+ *Pentium) UNAME_MACHINE=i586 ;;+ *Pent*|*Celeron) UNAME_MACHINE=i686 ;;+ esac+ echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}+ exit ;;+ i*86:*:3.2:*)+ if test -f /usr/options/cb.name; then+ UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`+ echo ${UNAME_MACHINE}-pc-isc$UNAME_REL+ elif /bin/uname -X 2>/dev/null >/dev/null ; then+ UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')`+ (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486+ (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \+ && UNAME_MACHINE=i586+ (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \+ && UNAME_MACHINE=i686+ (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \+ && UNAME_MACHINE=i686+ echo ${UNAME_MACHINE}-pc-sco$UNAME_REL+ else+ echo ${UNAME_MACHINE}-pc-sysv32+ fi+ exit ;;+ pc:*:*:*)+ # Left here for compatibility:+ # uname -m prints for DJGPP always 'pc', but it prints nothing about+ # the processor, so we play safe by assuming i386.+ echo i386-pc-msdosdjgpp+ exit ;;+ Intel:Mach:3*:*)+ echo i386-pc-mach3+ exit ;;+ paragon:*:*:*)+ echo i860-intel-osf1+ exit ;;+ i860:*:4.*:*) # i860-SVR4+ if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then+ echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4+ else # Add other i860-SVR4 vendors below as they are discovered.+ echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4+ fi+ exit ;;+ mini*:CTIX:SYS*5:*)+ # "miniframe"+ echo m68010-convergent-sysv+ exit ;;+ mc68k:UNIX:SYSTEM5:3.51m)+ echo m68k-convergent-sysv+ exit ;;+ M680?0:D-NIX:5.3:*)+ echo m68k-diab-dnix+ exit ;;+ M68*:*:R3V[5678]*:*)+ test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;+ 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)+ OS_REL=''+ test -r /etc/.relid \+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \+ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \+ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;+ 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \+ && { echo i486-ncr-sysv4; exit; } ;;+ m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)+ echo m68k-unknown-lynxos${UNAME_RELEASE}+ exit ;;+ mc68030:UNIX_System_V:4.*:*)+ echo m68k-atari-sysv4+ exit ;;+ TSUNAMI:LynxOS:2.*:*)+ echo sparc-unknown-lynxos${UNAME_RELEASE}+ exit ;;+ rs6000:LynxOS:2.*:*)+ echo rs6000-unknown-lynxos${UNAME_RELEASE}+ exit ;;+ PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)+ echo powerpc-unknown-lynxos${UNAME_RELEASE}+ exit ;;+ SM[BE]S:UNIX_SV:*:*)+ echo mips-dde-sysv${UNAME_RELEASE}+ exit ;;+ RM*:ReliantUNIX-*:*:*)+ echo mips-sni-sysv4+ exit ;;+ RM*:SINIX-*:*:*)+ echo mips-sni-sysv4+ exit ;;+ *:SINIX-*:*:*)+ if uname -p 2>/dev/null >/dev/null ; then+ UNAME_MACHINE=`(uname -p) 2>/dev/null`+ echo ${UNAME_MACHINE}-sni-sysv4+ else+ echo ns32k-sni-sysv+ fi+ exit ;;+ PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort+ # says <Richard.M.Bartel@ccMail.Census.GOV>+ echo i586-unisys-sysv4+ exit ;;+ *:UNIX_System_V:4*:FTX*)+ # From Gerald Hewes <hewes@openmarket.com>.+ # How about differentiating between stratus architectures? -djm+ echo hppa1.1-stratus-sysv4+ exit ;;+ *:*:*:FTX*)+ # From seanf@swdc.stratus.com.+ echo i860-stratus-sysv4+ exit ;;+ i*86:VOS:*:*)+ # From Paul.Green@stratus.com.+ echo ${UNAME_MACHINE}-stratus-vos+ exit ;;+ *:VOS:*:*)+ # From Paul.Green@stratus.com.+ echo hppa1.1-stratus-vos+ exit ;;+ mc68*:A/UX:*:*)+ echo m68k-apple-aux${UNAME_RELEASE}+ exit ;;+ news*:NEWS-OS:6*:*)+ echo mips-sony-newsos6+ exit ;;+ R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)+ if [ -d /usr/nec ]; then+ echo mips-nec-sysv${UNAME_RELEASE}+ else+ echo mips-unknown-sysv${UNAME_RELEASE}+ fi+ exit ;;+ BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.+ echo powerpc-be-beos+ exit ;;+ BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.+ echo powerpc-apple-beos+ exit ;;+ BePC:BeOS:*:*) # BeOS running on Intel PC compatible.+ echo i586-pc-beos+ exit ;;+ SX-4:SUPER-UX:*:*)+ echo sx4-nec-superux${UNAME_RELEASE}+ exit ;;+ SX-5:SUPER-UX:*:*)+ echo sx5-nec-superux${UNAME_RELEASE}+ exit ;;+ SX-6:SUPER-UX:*:*)+ echo sx6-nec-superux${UNAME_RELEASE}+ exit ;;+ SX-7:SUPER-UX:*:*)+ echo sx7-nec-superux${UNAME_RELEASE}+ exit ;;+ SX-8:SUPER-UX:*:*)+ echo sx8-nec-superux${UNAME_RELEASE}+ exit ;;+ SX-8R:SUPER-UX:*:*)+ echo sx8r-nec-superux${UNAME_RELEASE}+ exit ;;+ Power*:Rhapsody:*:*)+ echo powerpc-apple-rhapsody${UNAME_RELEASE}+ exit ;;+ *:Rhapsody:*:*)+ echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}+ exit ;;+ *:Darwin:*:*)+ UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown+ case $UNAME_PROCESSOR in+ unknown) UNAME_PROCESSOR=powerpc ;;+ esac+ echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}+ exit ;;+ *:procnto*:*:* | *:QNX:[0123456789]*:*)+ UNAME_PROCESSOR=`uname -p`+ if test "$UNAME_PROCESSOR" = "x86"; then+ UNAME_PROCESSOR=i386+ UNAME_MACHINE=pc+ fi+ echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}+ exit ;;+ *:QNX:*:4*)+ echo i386-pc-qnx+ exit ;;+ NSE-?:NONSTOP_KERNEL:*:*)+ echo nse-tandem-nsk${UNAME_RELEASE}+ exit ;;+ NSR-?:NONSTOP_KERNEL:*:*)+ echo nsr-tandem-nsk${UNAME_RELEASE}+ exit ;;+ *:NonStop-UX:*:*)+ echo mips-compaq-nonstopux+ exit ;;+ BS2000:POSIX*:*:*)+ echo bs2000-siemens-sysv+ exit ;;+ DS/*:UNIX_System_V:*:*)+ echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}+ exit ;;+ *:Plan9:*:*)+ # "uname -m" is not consistent, so use $cputype instead. 386+ # is converted to i386 for consistency with other x86+ # operating systems.+ if test "$cputype" = "386"; then+ UNAME_MACHINE=i386+ else+ UNAME_MACHINE="$cputype"+ fi+ echo ${UNAME_MACHINE}-unknown-plan9+ exit ;;+ *:TOPS-10:*:*)+ echo pdp10-unknown-tops10+ exit ;;+ *:TENEX:*:*)+ echo pdp10-unknown-tenex+ exit ;;+ KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)+ echo pdp10-dec-tops20+ exit ;;+ XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)+ echo pdp10-xkl-tops20+ exit ;;+ *:TOPS-20:*:*)+ echo pdp10-unknown-tops20+ exit ;;+ *:ITS:*:*)+ echo pdp10-unknown-its+ exit ;;+ SEI:*:*:SEIUX)+ echo mips-sei-seiux${UNAME_RELEASE}+ exit ;;+ *:DragonFly:*:*)+ echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`+ exit ;;+ *:*VMS:*:*)+ UNAME_MACHINE=`(uname -p) 2>/dev/null`+ case "${UNAME_MACHINE}" in+ A*) echo alpha-dec-vms ; exit ;;+ I*) echo ia64-dec-vms ; exit ;;+ V*) echo vax-dec-vms ; exit ;;+ esac ;;+ *:XENIX:*:SysV)+ echo i386-pc-xenix+ exit ;;+ i*86:skyos:*:*)+ echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'+ exit ;;+ i*86:rdos:*:*)+ echo ${UNAME_MACHINE}-pc-rdos+ exit ;;+esac++#echo '(No uname command or uname output not recognized.)' 1>&2+#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2++eval $set_cc_for_build+cat >$dummy.c <<EOF+#ifdef _SEQUENT_+# include <sys/types.h>+# include <sys/utsname.h>+#endif+main ()+{+#if defined (sony)+#if defined (MIPSEB)+ /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,+ I don't know.... */+ printf ("mips-sony-bsd\n"); exit (0);+#else+#include <sys/param.h>+ printf ("m68k-sony-newsos%s\n",+#ifdef NEWSOS4+ "4"+#else+ ""+#endif+ ); exit (0);+#endif+#endif++#if defined (__arm) && defined (__acorn) && defined (__unix)+ printf ("arm-acorn-riscix\n"); exit (0);+#endif++#if defined (hp300) && !defined (hpux)+ printf ("m68k-hp-bsd\n"); exit (0);+#endif++#if defined (NeXT)+#if !defined (__ARCHITECTURE__)+#define __ARCHITECTURE__ "m68k"+#endif+ int version;+ version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;+ if (version < 4)+ printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);+ else+ printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);+ exit (0);+#endif++#if defined (MULTIMAX) || defined (n16)+#if defined (UMAXV)+ printf ("ns32k-encore-sysv\n"); exit (0);+#else+#if defined (CMU)+ printf ("ns32k-encore-mach\n"); exit (0);+#else+ printf ("ns32k-encore-bsd\n"); exit (0);+#endif+#endif+#endif++#if defined (__386BSD__)+ printf ("i386-pc-bsd\n"); exit (0);+#endif++#if defined (sequent)+#if defined (i386)+ printf ("i386-sequent-dynix\n"); exit (0);+#endif+#if defined (ns32000)+ printf ("ns32k-sequent-dynix\n"); exit (0);+#endif+#endif++#if defined (_SEQUENT_)+ struct utsname un;++ uname(&un);++ if (strncmp(un.version, "V2", 2) == 0) {+ printf ("i386-sequent-ptx2\n"); exit (0);+ }+ if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */+ printf ("i386-sequent-ptx1\n"); exit (0);+ }+ printf ("i386-sequent-ptx\n"); exit (0);++#endif++#if defined (vax)+# if !defined (ultrix)+# include <sys/param.h>+# if defined (BSD)+# if BSD == 43+ printf ("vax-dec-bsd4.3\n"); exit (0);+# else+# if BSD == 199006+ printf ("vax-dec-bsd4.3reno\n"); exit (0);+# else+ printf ("vax-dec-bsd\n"); exit (0);+# endif+# endif+# else+ printf ("vax-dec-bsd\n"); exit (0);+# endif+# else+ printf ("vax-dec-ultrix\n"); exit (0);+# endif+#endif++#if defined (alliant) && defined (i860)+ printf ("i860-alliant-bsd\n"); exit (0);+#endif++ exit (1);+}+EOF++$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&+ { echo "$SYSTEM_NAME"; exit; }++# Apollos put the system type in the environment.++test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }++# Convex versions that predate uname can use getsysinfo(1)++if [ -x /usr/convex/getsysinfo ]+then+ case `getsysinfo -f cpu_type` in+ c1*)+ echo c1-convex-bsd+ exit ;;+ c2*)+ if getsysinfo -f scalar_acc+ then echo c32-convex-bsd+ else echo c2-convex-bsd+ fi+ exit ;;+ c34*)+ echo c34-convex-bsd+ exit ;;+ c38*)+ echo c38-convex-bsd+ exit ;;+ c4*)+ echo c4-convex-bsd+ exit ;;+ esac+fi++cat >&2 <<EOF+$0: unable to guess system type++This script, last modified $timestamp, has failed to recognize+the operating system you are using. It is advised that you+download the most up to date version of the config scripts from++ http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD+and+ http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD++If the version you run ($0) is already up to date, please+send the following data and any information you think might be+pertinent to <config-patches@gnu.org> in order to provide the needed+information to handle your system.++config.guess timestamp = $timestamp++uname -m = `(uname -m) 2>/dev/null || echo unknown`+uname -r = `(uname -r) 2>/dev/null || echo unknown`+uname -s = `(uname -s) 2>/dev/null || echo unknown`+uname -v = `(uname -v) 2>/dev/null || echo unknown`++/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null`+/bin/uname -X = `(/bin/uname -X) 2>/dev/null`++hostinfo = `(hostinfo) 2>/dev/null`+/bin/universe = `(/bin/universe) 2>/dev/null`+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null`+/bin/arch = `(/bin/arch) 2>/dev/null`+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null`+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`++UNAME_MACHINE = ${UNAME_MACHINE}+UNAME_RELEASE = ${UNAME_RELEASE}+UNAME_SYSTEM = ${UNAME_SYSTEM}+UNAME_VERSION = ${UNAME_VERSION}+EOF++exit 1++# Local variables:+# eval: (add-hook 'write-file-hooks 'time-stamp)+# time-stamp-start: "timestamp='"+# time-stamp-format: "%:y-%02m-%02d"+# time-stamp-end: "'"+# End:
+ rtsPOSIX/config.h.in view
@@ -0,0 +1,69 @@+/* Define to 1 if you have the `gettimeofday' function. */+#undef HAVE_GETTIMEOFDAY++/* Define to 1 if you have the <inttypes.h> header file. */+#undef HAVE_INTTYPES_H++/* Define to 1 if your system has a GNU libc compatible `malloc' function, and+ to 0 otherwise. */+#undef HAVE_MALLOC++/* Define to 1 if you have the <memory.h> header file. */+#undef HAVE_MEMORY_H++/* Define to 1 if you have the <stdint.h> header file. */+#undef HAVE_STDINT_H++/* Define to 1 if you have the <stdlib.h> header file. */+#undef HAVE_STDLIB_H++/* Define to 1 if you have the <strings.h> header file. */+#undef HAVE_STRINGS_H++/* Define to 1 if you have the <string.h> header file. */+#undef HAVE_STRING_H++/* Define to 1 if you have the <sys/stat.h> header file. */+#undef HAVE_SYS_STAT_H++/* Define to 1 if you have the <sys/time.h> header file. */+#undef HAVE_SYS_TIME_H++/* Define to 1 if you have the <sys/types.h> header file. */+#undef HAVE_SYS_TYPES_H++/* Define to 1 if you have the <termios.h> header file. */+#undef HAVE_TERMIOS_H++/* Define to 1 if you have the <unistd.h> header file. */+#undef HAVE_UNISTD_H++/* Define to the address where bug reports for this package should be sent. */+#undef PACKAGE_BUGREPORT++/* Define to the full name of this package. */+#undef PACKAGE_NAME++/* Define to the full name and version of this package. */+#undef PACKAGE_STRING++/* Define to the one symbol short name of this package. */+#undef PACKAGE_TARNAME++/* Define to the version of this package. */+#undef PACKAGE_VERSION++/* Define to 1 if you have the ANSI C header files. */+#undef STDC_HEADERS++/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */+#undef TIME_WITH_SYS_TIME++/* Define to rpl_malloc if the replacement function should be used. */+#undef malloc++/* Define if we have atomic ops */+#undef HAVE_BUILTIN_ATOMIC++/* Define if we have atomic ops on OSX */+#undef HAVE_OSX_ATOMICS
+ rtsPOSIX/config.sub view
@@ -0,0 +1,1658 @@+#! /bin/sh+# Configuration validation subroutine script.+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,+# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008+# Free Software Foundation, Inc.++timestamp='2008-01-16'++# This file is (in principle) common to ALL GNU software.+# The presence of a machine in this file suggests that SOME GNU software+# can handle that machine. It does not imply ALL GNU software can.+#+# This file is free software; you can redistribute it and/or modify+# it under the terms of the GNU General Public License as published by+# the Free Software Foundation; either version 2 of the License, or+# (at your option) any later version.+#+# This program is distributed in the hope that it will be useful,+# but WITHOUT ANY WARRANTY; without even the implied warranty of+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+# GNU General Public License for more details.+#+# You should have received a copy of the GNU General Public License+# along with this program; if not, write to the Free Software+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA+# 02110-1301, USA.+#+# As a special exception to the GNU General Public License, if you+# distribute this file as part of a program that contains a+# configuration script generated by Autoconf, you may include it under+# the same distribution terms that you use for the rest of that program.+++# Please send patches to <config-patches@gnu.org>. Submit a context+# diff and a properly formatted ChangeLog entry.+#+# Configuration subroutine to validate and canonicalize a configuration type.+# Supply the specified configuration type as an argument.+# If it is invalid, we print an error message on stderr and exit with code 1.+# Otherwise, we print the canonical config type on stdout and succeed.++# This file is supposed to be the same for all GNU packages+# and recognize all the CPU types, system types and aliases+# that are meaningful with *any* GNU software.+# Each package is responsible for reporting which valid configurations+# it does not support. The user should be able to distinguish+# a failure to support a valid configuration from a meaningless+# configuration.++# The goal of this file is to map all the various variations of a given+# machine specification into a single specification in the form:+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM+# or in some cases, the newer four-part form:+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM+# It is wrong to echo any other type of specification.++me=`echo "$0" | sed -e 's,.*/,,'`++usage="\+Usage: $0 [OPTION] CPU-MFR-OPSYS+ $0 [OPTION] ALIAS++Canonicalize a configuration name.++Operation modes:+ -h, --help print this help, then exit+ -t, --time-stamp print date of last modification, then exit+ -v, --version print version number, then exit++Report bugs and patches to <config-patches@gnu.org>."++version="\+GNU config.sub ($timestamp)++Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,+2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.++This is free software; see the source for copying conditions. There is NO+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."++help="+Try \`$me --help' for more information."++# Parse command line+while test $# -gt 0 ; do+ case $1 in+ --time-stamp | --time* | -t )+ echo "$timestamp" ; exit ;;+ --version | -v )+ echo "$version" ; exit ;;+ --help | --h* | -h )+ echo "$usage"; exit ;;+ -- ) # Stop option processing+ shift; break ;;+ - ) # Use stdin as input.+ break ;;+ -* )+ echo "$me: invalid option $1$help"+ exit 1 ;;++ *local*)+ # First pass through any local machine types.+ echo $1+ exit ;;++ * )+ break ;;+ esac+done++case $# in+ 0) echo "$me: missing argument$help" >&2+ exit 1;;+ 1) ;;+ *) echo "$me: too many arguments$help" >&2+ exit 1;;+esac++# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).+# Here we must recognize all the valid KERNEL-OS combinations.+maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`+case $maybe_os in+ nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \+ uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \+ storm-chaos* | os2-emx* | rtmk-nova*)+ os=-$maybe_os+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`+ ;;+ *)+ basic_machine=`echo $1 | sed 's/-[^-]*$//'`+ if [ $basic_machine != $1 ]+ then os=`echo $1 | sed 's/.*-/-/'`+ else os=; fi+ ;;+esac++### Let's recognize common machines as not being operating systems so+### that things like config.sub decstation-3100 work. We also+### recognize some manufacturers as not being operating systems, so we+### can provide default operating systems below.+case $os in+ -sun*os*)+ # Prevent following clause from handling this invalid input.+ ;;+ -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \+ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \+ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \+ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\+ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \+ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \+ -apple | -axis | -knuth | -cray)+ os=+ basic_machine=$1+ ;;+ -sim | -cisco | -oki | -wec | -winbond)+ os=+ basic_machine=$1+ ;;+ -scout)+ ;;+ -wrs)+ os=-vxworks+ basic_machine=$1+ ;;+ -chorusos*)+ os=-chorusos+ basic_machine=$1+ ;;+ -chorusrdb)+ os=-chorusrdb+ basic_machine=$1+ ;;+ -hiux*)+ os=-hiuxwe2+ ;;+ -sco6)+ os=-sco5v6+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -sco5)+ os=-sco3.2v5+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -sco4)+ os=-sco3.2v4+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -sco3.2.[4-9]*)+ os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -sco3.2v[4-9]*)+ # Don't forget version if it is 3.2v4 or newer.+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -sco5v6*)+ # Don't forget version if it is 3.2v4 or newer.+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -sco*)+ os=-sco3.2v2+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -udk*)+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -isc)+ os=-isc2.2+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -clix*)+ basic_machine=clipper-intergraph+ ;;+ -isc*)+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+ ;;+ -lynx*)+ os=-lynxos+ ;;+ -ptx*)+ basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`+ ;;+ -windowsnt*)+ os=`echo $os | sed -e 's/windowsnt/winnt/'`+ ;;+ -psos*)+ os=-psos+ ;;+ -mint | -mint[0-9]*)+ basic_machine=m68k-atari+ os=-mint+ ;;+esac++# Decode aliases for certain CPU-COMPANY combinations.+case $basic_machine in+ # Recognize the basic CPU types without company name.+ # Some are omitted here because they have special meanings below.+ 1750a | 580 \+ | a29k \+ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \+ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \+ | am33_2.0 \+ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \+ | bfin \+ | c4x | clipper \+ | d10v | d30v | dlx | dsp16xx \+ | fido | fr30 | frv \+ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \+ | i370 | i860 | i960 | ia64 \+ | ip2k | iq2000 \+ | m32c | m32r | m32rle | m68000 | m68k | m88k \+ | maxq | mb | microblaze | mcore | mep \+ | mips | mipsbe | mipseb | mipsel | mipsle \+ | mips16 \+ | mips64 | mips64el \+ | mips64vr | mips64vrel \+ | mips64orion | mips64orionel \+ | mips64vr4100 | mips64vr4100el \+ | mips64vr4300 | mips64vr4300el \+ | mips64vr5000 | mips64vr5000el \+ | mips64vr5900 | mips64vr5900el \+ | mipsisa32 | mipsisa32el \+ | mipsisa32r2 | mipsisa32r2el \+ | mipsisa64 | mipsisa64el \+ | mipsisa64r2 | mipsisa64r2el \+ | mipsisa64sb1 | mipsisa64sb1el \+ | mipsisa64sr71k | mipsisa64sr71kel \+ | mipstx39 | mipstx39el \+ | mn10200 | mn10300 \+ | mt \+ | msp430 \+ | nios | nios2 \+ | ns16k | ns32k \+ | or32 \+ | pdp10 | pdp11 | pj | pjl \+ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \+ | pyramid \+ | score \+ | sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \+ | sh64 | sh64le \+ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \+ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \+ | spu | strongarm \+ | tahoe | thumb | tic4x | tic80 | tron \+ | v850 | v850e \+ | we32k \+ | x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \+ | z8k)+ basic_machine=$basic_machine-unknown+ ;;+ m6811 | m68hc11 | m6812 | m68hc12)+ # Motorola 68HC11/12.+ basic_machine=$basic_machine-unknown+ os=-none+ ;;+ m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)+ ;;+ ms1)+ basic_machine=mt-unknown+ ;;++ # We use `pc' rather than `unknown'+ # because (1) that's what they normally are, and+ # (2) the word "unknown" tends to confuse beginning users.+ i*86 | x86_64)+ basic_machine=$basic_machine-pc+ ;;+ # Object if more than one company name word.+ *-*-*)+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2+ exit 1+ ;;+ # Recognize the basic CPU types with company name.+ 580-* \+ | a29k-* \+ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \+ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \+ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \+ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \+ | avr-* | avr32-* \+ | bfin-* | bs2000-* \+ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \+ | clipper-* | craynv-* | cydra-* \+ | d10v-* | d30v-* | dlx-* \+ | elxsi-* \+ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \+ | h8300-* | h8500-* \+ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \+ | i*86-* | i860-* | i960-* | ia64-* \+ | ip2k-* | iq2000-* \+ | m32c-* | m32r-* | m32rle-* \+ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \+ | m88110-* | m88k-* | maxq-* | mcore-* \+ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \+ | mips16-* \+ | mips64-* | mips64el-* \+ | mips64vr-* | mips64vrel-* \+ | mips64orion-* | mips64orionel-* \+ | mips64vr4100-* | mips64vr4100el-* \+ | mips64vr4300-* | mips64vr4300el-* \+ | mips64vr5000-* | mips64vr5000el-* \+ | mips64vr5900-* | mips64vr5900el-* \+ | mipsisa32-* | mipsisa32el-* \+ | mipsisa32r2-* | mipsisa32r2el-* \+ | mipsisa64-* | mipsisa64el-* \+ | mipsisa64r2-* | mipsisa64r2el-* \+ | mipsisa64sb1-* | mipsisa64sb1el-* \+ | mipsisa64sr71k-* | mipsisa64sr71kel-* \+ | mipstx39-* | mipstx39el-* \+ | mmix-* \+ | mt-* \+ | msp430-* \+ | nios-* | nios2-* \+ | none-* | np1-* | ns16k-* | ns32k-* \+ | orion-* \+ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \+ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \+ | pyramid-* \+ | romp-* | rs6000-* \+ | sh-* | sh[1234]-* | sh[24]a-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \+ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \+ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \+ | sparclite-* \+ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \+ | tahoe-* | thumb-* \+ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \+ | tron-* \+ | v850-* | v850e-* | vax-* \+ | we32k-* \+ | x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \+ | xstormy16-* | xtensa*-* \+ | ymp-* \+ | z8k-*)+ ;;+ # Recognize the basic CPU types without company name, with glob match.+ xtensa*)+ basic_machine=$basic_machine-unknown+ ;;+ # Recognize the various machine names and aliases which stand+ # for a CPU type and a company and sometimes even an OS.+ 386bsd)+ basic_machine=i386-unknown+ os=-bsd+ ;;+ 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)+ basic_machine=m68000-att+ ;;+ 3b*)+ basic_machine=we32k-att+ ;;+ a29khif)+ basic_machine=a29k-amd+ os=-udi+ ;;+ abacus)+ basic_machine=abacus-unknown+ ;;+ adobe68k)+ basic_machine=m68010-adobe+ os=-scout+ ;;+ alliant | fx80)+ basic_machine=fx80-alliant+ ;;+ altos | altos3068)+ basic_machine=m68k-altos+ ;;+ am29k)+ basic_machine=a29k-none+ os=-bsd+ ;;+ amd64)+ basic_machine=x86_64-pc+ ;;+ amd64-*)+ basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ amdahl)+ basic_machine=580-amdahl+ os=-sysv+ ;;+ amiga | amiga-*)+ basic_machine=m68k-unknown+ ;;+ amigaos | amigados)+ basic_machine=m68k-unknown+ os=-amigaos+ ;;+ amigaunix | amix)+ basic_machine=m68k-unknown+ os=-sysv4+ ;;+ apollo68)+ basic_machine=m68k-apollo+ os=-sysv+ ;;+ apollo68bsd)+ basic_machine=m68k-apollo+ os=-bsd+ ;;+ aux)+ basic_machine=m68k-apple+ os=-aux+ ;;+ balance)+ basic_machine=ns32k-sequent+ os=-dynix+ ;;+ blackfin)+ basic_machine=bfin-unknown+ os=-linux+ ;;+ blackfin-*)+ basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'`+ os=-linux+ ;;+ c90)+ basic_machine=c90-cray+ os=-unicos+ ;;+ convex-c1)+ basic_machine=c1-convex+ os=-bsd+ ;;+ convex-c2)+ basic_machine=c2-convex+ os=-bsd+ ;;+ convex-c32)+ basic_machine=c32-convex+ os=-bsd+ ;;+ convex-c34)+ basic_machine=c34-convex+ os=-bsd+ ;;+ convex-c38)+ basic_machine=c38-convex+ os=-bsd+ ;;+ cray | j90)+ basic_machine=j90-cray+ os=-unicos+ ;;+ craynv)+ basic_machine=craynv-cray+ os=-unicosmp+ ;;+ cr16)+ basic_machine=cr16-unknown+ os=-elf+ ;;+ crds | unos)+ basic_machine=m68k-crds+ ;;+ crisv32 | crisv32-* | etraxfs*)+ basic_machine=crisv32-axis+ ;;+ cris | cris-* | etrax*)+ basic_machine=cris-axis+ ;;+ crx)+ basic_machine=crx-unknown+ os=-elf+ ;;+ da30 | da30-*)+ basic_machine=m68k-da30+ ;;+ decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)+ basic_machine=mips-dec+ ;;+ decsystem10* | dec10*)+ basic_machine=pdp10-dec+ os=-tops10+ ;;+ decsystem20* | dec20*)+ basic_machine=pdp10-dec+ os=-tops20+ ;;+ delta | 3300 | motorola-3300 | motorola-delta \+ | 3300-motorola | delta-motorola)+ basic_machine=m68k-motorola+ ;;+ delta88)+ basic_machine=m88k-motorola+ os=-sysv3+ ;;+ djgpp)+ basic_machine=i586-pc+ os=-msdosdjgpp+ ;;+ dpx20 | dpx20-*)+ basic_machine=rs6000-bull+ os=-bosx+ ;;+ dpx2* | dpx2*-bull)+ basic_machine=m68k-bull+ os=-sysv3+ ;;+ ebmon29k)+ basic_machine=a29k-amd+ os=-ebmon+ ;;+ elxsi)+ basic_machine=elxsi-elxsi+ os=-bsd+ ;;+ encore | umax | mmax)+ basic_machine=ns32k-encore+ ;;+ es1800 | OSE68k | ose68k | ose | OSE)+ basic_machine=m68k-ericsson+ os=-ose+ ;;+ fx2800)+ basic_machine=i860-alliant+ ;;+ genix)+ basic_machine=ns32k-ns+ ;;+ gmicro)+ basic_machine=tron-gmicro+ os=-sysv+ ;;+ go32)+ basic_machine=i386-pc+ os=-go32+ ;;+ h3050r* | hiux*)+ basic_machine=hppa1.1-hitachi+ os=-hiuxwe2+ ;;+ h8300hms)+ basic_machine=h8300-hitachi+ os=-hms+ ;;+ h8300xray)+ basic_machine=h8300-hitachi+ os=-xray+ ;;+ h8500hms)+ basic_machine=h8500-hitachi+ os=-hms+ ;;+ harris)+ basic_machine=m88k-harris+ os=-sysv3+ ;;+ hp300-*)+ basic_machine=m68k-hp+ ;;+ hp300bsd)+ basic_machine=m68k-hp+ os=-bsd+ ;;+ hp300hpux)+ basic_machine=m68k-hp+ os=-hpux+ ;;+ hp3k9[0-9][0-9] | hp9[0-9][0-9])+ basic_machine=hppa1.0-hp+ ;;+ hp9k2[0-9][0-9] | hp9k31[0-9])+ basic_machine=m68000-hp+ ;;+ hp9k3[2-9][0-9])+ basic_machine=m68k-hp+ ;;+ hp9k6[0-9][0-9] | hp6[0-9][0-9])+ basic_machine=hppa1.0-hp+ ;;+ hp9k7[0-79][0-9] | hp7[0-79][0-9])+ basic_machine=hppa1.1-hp+ ;;+ hp9k78[0-9] | hp78[0-9])+ # FIXME: really hppa2.0-hp+ basic_machine=hppa1.1-hp+ ;;+ hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)+ # FIXME: really hppa2.0-hp+ basic_machine=hppa1.1-hp+ ;;+ hp9k8[0-9][13679] | hp8[0-9][13679])+ basic_machine=hppa1.1-hp+ ;;+ hp9k8[0-9][0-9] | hp8[0-9][0-9])+ basic_machine=hppa1.0-hp+ ;;+ hppa-next)+ os=-nextstep3+ ;;+ hppaosf)+ basic_machine=hppa1.1-hp+ os=-osf+ ;;+ hppro)+ basic_machine=hppa1.1-hp+ os=-proelf+ ;;+ i370-ibm* | ibm*)+ basic_machine=i370-ibm+ ;;+# I'm not sure what "Sysv32" means. Should this be sysv3.2?+ i*86v32)+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+ os=-sysv32+ ;;+ i*86v4*)+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+ os=-sysv4+ ;;+ i*86v)+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+ os=-sysv+ ;;+ i*86sol2)+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+ os=-solaris2+ ;;+ i386mach)+ basic_machine=i386-mach+ os=-mach+ ;;+ i386-vsta | vsta)+ basic_machine=i386-unknown+ os=-vsta+ ;;+ iris | iris4d)+ basic_machine=mips-sgi+ case $os in+ -irix*)+ ;;+ *)+ os=-irix4+ ;;+ esac+ ;;+ isi68 | isi)+ basic_machine=m68k-isi+ os=-sysv+ ;;+ m68knommu)+ basic_machine=m68k-unknown+ os=-linux+ ;;+ m68knommu-*)+ basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'`+ os=-linux+ ;;+ m88k-omron*)+ basic_machine=m88k-omron+ ;;+ magnum | m3230)+ basic_machine=mips-mips+ os=-sysv+ ;;+ merlin)+ basic_machine=ns32k-utek+ os=-sysv+ ;;+ mingw32)+ basic_machine=i386-pc+ os=-mingw32+ ;;+ mingw32ce)+ basic_machine=arm-unknown+ os=-mingw32ce+ ;;+ miniframe)+ basic_machine=m68000-convergent+ ;;+ *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)+ basic_machine=m68k-atari+ os=-mint+ ;;+ mips3*-*)+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`+ ;;+ mips3*)+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown+ ;;+ monitor)+ basic_machine=m68k-rom68k+ os=-coff+ ;;+ morphos)+ basic_machine=powerpc-unknown+ os=-morphos+ ;;+ msdos)+ basic_machine=i386-pc+ os=-msdos+ ;;+ ms1-*)+ basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`+ ;;+ mvs)+ basic_machine=i370-ibm+ os=-mvs+ ;;+ ncr3000)+ basic_machine=i486-ncr+ os=-sysv4+ ;;+ netbsd386)+ basic_machine=i386-unknown+ os=-netbsd+ ;;+ netwinder)+ basic_machine=armv4l-rebel+ os=-linux+ ;;+ news | news700 | news800 | news900)+ basic_machine=m68k-sony+ os=-newsos+ ;;+ news1000)+ basic_machine=m68030-sony+ os=-newsos+ ;;+ news-3600 | risc-news)+ basic_machine=mips-sony+ os=-newsos+ ;;+ necv70)+ basic_machine=v70-nec+ os=-sysv+ ;;+ next | m*-next )+ basic_machine=m68k-next+ case $os in+ -nextstep* )+ ;;+ -ns2*)+ os=-nextstep2+ ;;+ *)+ os=-nextstep3+ ;;+ esac+ ;;+ nh3000)+ basic_machine=m68k-harris+ os=-cxux+ ;;+ nh[45]000)+ basic_machine=m88k-harris+ os=-cxux+ ;;+ nindy960)+ basic_machine=i960-intel+ os=-nindy+ ;;+ mon960)+ basic_machine=i960-intel+ os=-mon960+ ;;+ nonstopux)+ basic_machine=mips-compaq+ os=-nonstopux+ ;;+ np1)+ basic_machine=np1-gould+ ;;+ nsr-tandem)+ basic_machine=nsr-tandem+ ;;+ op50n-* | op60c-*)+ basic_machine=hppa1.1-oki+ os=-proelf+ ;;+ openrisc | openrisc-*)+ basic_machine=or32-unknown+ ;;+ os400)+ basic_machine=powerpc-ibm+ os=-os400+ ;;+ OSE68000 | ose68000)+ basic_machine=m68000-ericsson+ os=-ose+ ;;+ os68k)+ basic_machine=m68k-none+ os=-os68k+ ;;+ pa-hitachi)+ basic_machine=hppa1.1-hitachi+ os=-hiuxwe2+ ;;+ paragon)+ basic_machine=i860-intel+ os=-osf+ ;;+ parisc)+ basic_machine=hppa-unknown+ os=-linux+ ;;+ parisc-*)+ basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'`+ os=-linux+ ;;+ pbd)+ basic_machine=sparc-tti+ ;;+ pbb)+ basic_machine=m68k-tti+ ;;+ pc532 | pc532-*)+ basic_machine=ns32k-pc532+ ;;+ pc98)+ basic_machine=i386-pc+ ;;+ pc98-*)+ basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ pentium | p5 | k5 | k6 | nexgen | viac3)+ basic_machine=i586-pc+ ;;+ pentiumpro | p6 | 6x86 | athlon | athlon_*)+ basic_machine=i686-pc+ ;;+ pentiumii | pentium2 | pentiumiii | pentium3)+ basic_machine=i686-pc+ ;;+ pentium4)+ basic_machine=i786-pc+ ;;+ pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)+ basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ pentiumpro-* | p6-* | 6x86-* | athlon-*)+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ pentium4-*)+ basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ pn)+ basic_machine=pn-gould+ ;;+ power) basic_machine=power-ibm+ ;;+ ppc) basic_machine=powerpc-unknown+ ;;+ ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ ppcle | powerpclittle | ppc-le | powerpc-little)+ basic_machine=powerpcle-unknown+ ;;+ ppcle-* | powerpclittle-*)+ basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ ppc64) basic_machine=powerpc64-unknown+ ;;+ ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ ppc64le | powerpc64little | ppc64-le | powerpc64-little)+ basic_machine=powerpc64le-unknown+ ;;+ ppc64le-* | powerpc64little-*)+ basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`+ ;;+ ps2)+ basic_machine=i386-ibm+ ;;+ pw32)+ basic_machine=i586-unknown+ os=-pw32+ ;;+ rdos)+ basic_machine=i386-pc+ os=-rdos+ ;;+ rom68k)+ basic_machine=m68k-rom68k+ os=-coff+ ;;+ rm[46]00)+ basic_machine=mips-siemens+ ;;+ rtpc | rtpc-*)+ basic_machine=romp-ibm+ ;;+ s390 | s390-*)+ basic_machine=s390-ibm+ ;;+ s390x | s390x-*)+ basic_machine=s390x-ibm+ ;;+ sa29200)+ basic_machine=a29k-amd+ os=-udi+ ;;+ sb1)+ basic_machine=mipsisa64sb1-unknown+ ;;+ sb1el)+ basic_machine=mipsisa64sb1el-unknown+ ;;+ sde)+ basic_machine=mipsisa32-sde+ os=-elf+ ;;+ sei)+ basic_machine=mips-sei+ os=-seiux+ ;;+ sequent)+ basic_machine=i386-sequent+ ;;+ sh)+ basic_machine=sh-hitachi+ os=-hms+ ;;+ sh5el)+ basic_machine=sh5le-unknown+ ;;+ sh64)+ basic_machine=sh64-unknown+ ;;+ sparclite-wrs | simso-wrs)+ basic_machine=sparclite-wrs+ os=-vxworks+ ;;+ sps7)+ basic_machine=m68k-bull+ os=-sysv2+ ;;+ spur)+ basic_machine=spur-unknown+ ;;+ st2000)+ basic_machine=m68k-tandem+ ;;+ stratus)+ basic_machine=i860-stratus+ os=-sysv4+ ;;+ sun2)+ basic_machine=m68000-sun+ ;;+ sun2os3)+ basic_machine=m68000-sun+ os=-sunos3+ ;;+ sun2os4)+ basic_machine=m68000-sun+ os=-sunos4+ ;;+ sun3os3)+ basic_machine=m68k-sun+ os=-sunos3+ ;;+ sun3os4)+ basic_machine=m68k-sun+ os=-sunos4+ ;;+ sun4os3)+ basic_machine=sparc-sun+ os=-sunos3+ ;;+ sun4os4)+ basic_machine=sparc-sun+ os=-sunos4+ ;;+ sun4sol2)+ basic_machine=sparc-sun+ os=-solaris2+ ;;+ sun3 | sun3-*)+ basic_machine=m68k-sun+ ;;+ sun4)+ basic_machine=sparc-sun+ ;;+ sun386 | sun386i | roadrunner)+ basic_machine=i386-sun+ ;;+ sv1)+ basic_machine=sv1-cray+ os=-unicos+ ;;+ symmetry)+ basic_machine=i386-sequent+ os=-dynix+ ;;+ t3e)+ basic_machine=alphaev5-cray+ os=-unicos+ ;;+ t90)+ basic_machine=t90-cray+ os=-unicos+ ;;+ tic54x | c54x*)+ basic_machine=tic54x-unknown+ os=-coff+ ;;+ tic55x | c55x*)+ basic_machine=tic55x-unknown+ os=-coff+ ;;+ tic6x | c6x*)+ basic_machine=tic6x-unknown+ os=-coff+ ;;+ tile*)+ basic_machine=tile-unknown+ os=-linux-gnu+ ;;+ tx39)+ basic_machine=mipstx39-unknown+ ;;+ tx39el)+ basic_machine=mipstx39el-unknown+ ;;+ toad1)+ basic_machine=pdp10-xkl+ os=-tops20+ ;;+ tower | tower-32)+ basic_machine=m68k-ncr+ ;;+ tpf)+ basic_machine=s390x-ibm+ os=-tpf+ ;;+ udi29k)+ basic_machine=a29k-amd+ os=-udi+ ;;+ ultra3)+ basic_machine=a29k-nyu+ os=-sym1+ ;;+ v810 | necv810)+ basic_machine=v810-nec+ os=-none+ ;;+ vaxv)+ basic_machine=vax-dec+ os=-sysv+ ;;+ vms)+ basic_machine=vax-dec+ os=-vms+ ;;+ vpp*|vx|vx-*)+ basic_machine=f301-fujitsu+ ;;+ vxworks960)+ basic_machine=i960-wrs+ os=-vxworks+ ;;+ vxworks68)+ basic_machine=m68k-wrs+ os=-vxworks+ ;;+ vxworks29k)+ basic_machine=a29k-wrs+ os=-vxworks+ ;;+ w65*)+ basic_machine=w65-wdc+ os=-none+ ;;+ w89k-*)+ basic_machine=hppa1.1-winbond+ os=-proelf+ ;;+ xbox)+ basic_machine=i686-pc+ os=-mingw32+ ;;+ xps | xps100)+ basic_machine=xps100-honeywell+ ;;+ ymp)+ basic_machine=ymp-cray+ os=-unicos+ ;;+ z8k-*-coff)+ basic_machine=z8k-unknown+ os=-sim+ ;;+ none)+ basic_machine=none-none+ os=-none+ ;;++# Here we handle the default manufacturer of certain CPU types. It is in+# some cases the only manufacturer, in others, it is the most popular.+ w89k)+ basic_machine=hppa1.1-winbond+ ;;+ op50n)+ basic_machine=hppa1.1-oki+ ;;+ op60c)+ basic_machine=hppa1.1-oki+ ;;+ romp)+ basic_machine=romp-ibm+ ;;+ mmix)+ basic_machine=mmix-knuth+ ;;+ rs6000)+ basic_machine=rs6000-ibm+ ;;+ vax)+ basic_machine=vax-dec+ ;;+ pdp10)+ # there are many clones, so DEC is not a safe bet+ basic_machine=pdp10-unknown+ ;;+ pdp11)+ basic_machine=pdp11-dec+ ;;+ we32k)+ basic_machine=we32k-att+ ;;+ sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele)+ basic_machine=sh-unknown+ ;;+ sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)+ basic_machine=sparc-sun+ ;;+ cydra)+ basic_machine=cydra-cydrome+ ;;+ orion)+ basic_machine=orion-highlevel+ ;;+ orion105)+ basic_machine=clipper-highlevel+ ;;+ mac | mpw | mac-mpw)+ basic_machine=m68k-apple+ ;;+ pmac | pmac-mpw)+ basic_machine=powerpc-apple+ ;;+ *-unknown)+ # Make sure to match an already-canonicalized machine name.+ ;;+ *)+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2+ exit 1+ ;;+esac++# Here we canonicalize certain aliases for manufacturers.+case $basic_machine in+ *-digital*)+ basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`+ ;;+ *-commodore*)+ basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`+ ;;+ *)+ ;;+esac++# Decode manufacturer-specific aliases for certain operating systems.++if [ x"$os" != x"" ]+then+case $os in+ # First match some system type aliases+ # that might get confused with valid system types.+ # -solaris* is a basic system type, with this one exception.+ -solaris1 | -solaris1.*)+ os=`echo $os | sed -e 's|solaris1|sunos4|'`+ ;;+ -solaris)+ os=-solaris2+ ;;+ -svr4*)+ os=-sysv4+ ;;+ -unixware*)+ os=-sysv4.2uw+ ;;+ -gnu/linux*)+ os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`+ ;;+ # First accept the basic system types.+ # The portable systems comes first.+ # Each alternative MUST END IN A *, to match a version number.+ # -sysv* is not here because it comes later, after sysvr4.+ -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \+ | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\+ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \+ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \+ | -aos* \+ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \+ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \+ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \+ | -openbsd* | -solidbsd* \+ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \+ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \+ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \+ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \+ | -chorusos* | -chorusrdb* \+ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \+ | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \+ | -uxpv* | -beos* | -mpeix* | -udk* \+ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \+ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \+ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \+ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \+ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \+ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \+ | -skyos* | -haiku* | -rdos* | -toppers* | -drops*)+ # Remember, each alternative MUST END IN *, to match a version number.+ ;;+ -qnx*)+ case $basic_machine in+ x86-* | i*86-*)+ ;;+ *)+ os=-nto$os+ ;;+ esac+ ;;+ -nto-qnx*)+ ;;+ -nto*)+ os=`echo $os | sed -e 's|nto|nto-qnx|'`+ ;;+ -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \+ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \+ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)+ ;;+ -mac*)+ os=`echo $os | sed -e 's|mac|macos|'`+ ;;+ -linux-dietlibc)+ os=-linux-dietlibc+ ;;+ -linux*)+ os=`echo $os | sed -e 's|linux|linux-gnu|'`+ ;;+ -sunos5*)+ os=`echo $os | sed -e 's|sunos5|solaris2|'`+ ;;+ -sunos6*)+ os=`echo $os | sed -e 's|sunos6|solaris3|'`+ ;;+ -opened*)+ os=-openedition+ ;;+ -os400*)+ os=-os400+ ;;+ -wince*)+ os=-wince+ ;;+ -osfrose*)+ os=-osfrose+ ;;+ -osf*)+ os=-osf+ ;;+ -utek*)+ os=-bsd+ ;;+ -dynix*)+ os=-bsd+ ;;+ -acis*)+ os=-aos+ ;;+ -atheos*)+ os=-atheos+ ;;+ -syllable*)+ os=-syllable+ ;;+ -386bsd)+ os=-bsd+ ;;+ -ctix* | -uts*)+ os=-sysv+ ;;+ -nova*)+ os=-rtmk-nova+ ;;+ -ns2 )+ os=-nextstep2+ ;;+ -nsk*)+ os=-nsk+ ;;+ # Preserve the version number of sinix5.+ -sinix5.*)+ os=`echo $os | sed -e 's|sinix|sysv|'`+ ;;+ -sinix*)+ os=-sysv4+ ;;+ -tpf*)+ os=-tpf+ ;;+ -triton*)+ os=-sysv3+ ;;+ -oss*)+ os=-sysv3+ ;;+ -svr4)+ os=-sysv4+ ;;+ -svr3)+ os=-sysv3+ ;;+ -sysvr4)+ os=-sysv4+ ;;+ # This must come after -sysvr4.+ -sysv*)+ ;;+ -ose*)+ os=-ose+ ;;+ -es1800*)+ os=-ose+ ;;+ -xenix)+ os=-xenix+ ;;+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)+ os=-mint+ ;;+ -aros*)+ os=-aros+ ;;+ -kaos*)+ os=-kaos+ ;;+ -zvmoe)+ os=-zvmoe+ ;;+ -none)+ ;;+ *)+ # Get rid of the `-' at the beginning of $os.+ os=`echo $os | sed 's/[^-]*-//'`+ echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2+ exit 1+ ;;+esac+else++# Here we handle the default operating systems that come with various machines.+# The value should be what the vendor currently ships out the door with their+# machine or put another way, the most popular os provided with the machine.++# Note that if you're going to try to match "-MANUFACTURER" here (say,+# "-sun"), then you have to tell the case statement up towards the top+# that MANUFACTURER isn't an operating system. Otherwise, code above+# will signal an error saying that MANUFACTURER isn't an operating+# system, and we'll never get to this point.++case $basic_machine in+ score-*)+ os=-elf+ ;;+ spu-*)+ os=-elf+ ;;+ *-acorn)+ os=-riscix1.2+ ;;+ arm*-rebel)+ os=-linux+ ;;+ arm*-semi)+ os=-aout+ ;;+ c4x-* | tic4x-*)+ os=-coff+ ;;+ # This must come before the *-dec entry.+ pdp10-*)+ os=-tops20+ ;;+ pdp11-*)+ os=-none+ ;;+ *-dec | vax-*)+ os=-ultrix4.2+ ;;+ m68*-apollo)+ os=-domain+ ;;+ i386-sun)+ os=-sunos4.0.2+ ;;+ m68000-sun)+ os=-sunos3+ # This also exists in the configure program, but was not the+ # default.+ # os=-sunos4+ ;;+ m68*-cisco)+ os=-aout+ ;;+ mep-*)+ os=-elf+ ;;+ mips*-cisco)+ os=-elf+ ;;+ mips*-*)+ os=-elf+ ;;+ or32-*)+ os=-coff+ ;;+ *-tti) # must be before sparc entry or we get the wrong os.+ os=-sysv3+ ;;+ sparc-* | *-sun)+ os=-sunos4.1.1+ ;;+ *-be)+ os=-beos+ ;;+ *-haiku)+ os=-haiku+ ;;+ *-ibm)+ os=-aix+ ;;+ *-knuth)+ os=-mmixware+ ;;+ *-wec)+ os=-proelf+ ;;+ *-winbond)+ os=-proelf+ ;;+ *-oki)+ os=-proelf+ ;;+ *-hp)+ os=-hpux+ ;;+ *-hitachi)+ os=-hiux+ ;;+ i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)+ os=-sysv+ ;;+ *-cbm)+ os=-amigaos+ ;;+ *-dg)+ os=-dgux+ ;;+ *-dolphin)+ os=-sysv3+ ;;+ m68k-ccur)+ os=-rtu+ ;;+ m88k-omron*)+ os=-luna+ ;;+ *-next )+ os=-nextstep+ ;;+ *-sequent)+ os=-ptx+ ;;+ *-crds)+ os=-unos+ ;;+ *-ns)+ os=-genix+ ;;+ i370-*)+ os=-mvs+ ;;+ *-next)+ os=-nextstep3+ ;;+ *-gould)+ os=-sysv+ ;;+ *-highlevel)+ os=-bsd+ ;;+ *-encore)+ os=-bsd+ ;;+ *-sgi)+ os=-irix+ ;;+ *-siemens)+ os=-sysv4+ ;;+ *-masscomp)+ os=-rtu+ ;;+ f30[01]-fujitsu | f700-fujitsu)+ os=-uxpv+ ;;+ *-rom68k)+ os=-coff+ ;;+ *-*bug)+ os=-coff+ ;;+ *-apple)+ os=-macos+ ;;+ *-atari*)+ os=-mint+ ;;+ *)+ os=-none+ ;;+esac+fi++# Here we handle the case where we know the os, and the CPU type, but not the+# manufacturer. We pick the logical manufacturer.+vendor=unknown+case $basic_machine in+ *-unknown)+ case $os in+ -riscix*)+ vendor=acorn+ ;;+ -sunos*)+ vendor=sun+ ;;+ -aix*)+ vendor=ibm+ ;;+ -beos*)+ vendor=be+ ;;+ -hpux*)+ vendor=hp+ ;;+ -mpeix*)+ vendor=hp+ ;;+ -hiux*)+ vendor=hitachi+ ;;+ -unos*)+ vendor=crds+ ;;+ -dgux*)+ vendor=dg+ ;;+ -luna*)+ vendor=omron+ ;;+ -genix*)+ vendor=ns+ ;;+ -mvs* | -opened*)+ vendor=ibm+ ;;+ -os400*)+ vendor=ibm+ ;;+ -ptx*)+ vendor=sequent+ ;;+ -tpf*)+ vendor=ibm+ ;;+ -vxsim* | -vxworks* | -windiss*)+ vendor=wrs+ ;;+ -aux*)+ vendor=apple+ ;;+ -hms*)+ vendor=hitachi+ ;;+ -mpw* | -macos*)+ vendor=apple+ ;;+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)+ vendor=atari+ ;;+ -vos*)+ vendor=stratus+ ;;+ esac+ basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`+ ;;+esac++echo $basic_machine$os+exit++# Local variables:+# eval: (add-hook 'write-file-hooks 'time-stamp)+# time-stamp-start: "timestamp='"+# time-stamp-format: "%:y-%02m-%02d"+# time-stamp-end: "'"+# End:
+ rtsPOSIX/configure view
@@ -0,0 +1,6122 @@+#! /bin/sh+# Guess values for system-dependent variables and create Makefiles.+# Generated by GNU Autoconf 2.61 for rtsPOSIX 0.9.9.+#+# Report bugs to <nordland@csee.ltu.se>.+#+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,+# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.+# This configure script is free software; the Free Software Foundation+# gives unlimited permission to copy, distribute and modify it.+## --------------------- ##+## M4sh Initialization. ##+## --------------------- ##++# Be more Bourne compatible+DUALCASE=1; export DUALCASE # for MKS sh+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+ emulate sh+ NULLCMD=:+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '${1+"$@"}'='"$@"'+ setopt NO_GLOB_SUBST+else+ case `(set -o) 2>/dev/null` in+ *posix*) set -o posix ;;+esac++fi+++++# PATH needs CR+# Avoid depending upon Character Ranges.+as_cr_letters='abcdefghijklmnopqrstuvwxyz'+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'+as_cr_Letters=$as_cr_letters$as_cr_LETTERS+as_cr_digits='0123456789'+as_cr_alnum=$as_cr_Letters$as_cr_digits++# The user is always right.+if test "${PATH_SEPARATOR+set}" != set; then+ echo "#! /bin/sh" >conf$$.sh+ echo "exit 0" >>conf$$.sh+ chmod +x conf$$.sh+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then+ PATH_SEPARATOR=';'+ else+ PATH_SEPARATOR=:+ fi+ rm -f conf$$.sh+fi++# Support unset when possible.+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then+ as_unset=unset+else+ as_unset=false+fi+++# IFS+# We need space, tab and new line, in precisely that order. Quoting is+# there to prevent editors from complaining about space-tab.+# (If _AS_PATH_WALK were called with IFS unset, it would disable word+# splitting by setting IFS to empty value.)+as_nl='+'+IFS=" "" $as_nl"++# Find who we are. Look in the path if we contain no directory separator.+case $0 in+ *[\\/]* ) as_myself=$0 ;;+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break+done+IFS=$as_save_IFS++ ;;+esac+# We did not find ourselves, most probably we were run as `sh COMMAND'+# in which case we are not to be found in the path.+if test "x$as_myself" = x; then+ as_myself=$0+fi+if test ! -f "$as_myself"; then+ echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2+ { (exit 1); exit 1; }+fi++# Work around bugs in pre-3.0 UWIN ksh.+for as_var in ENV MAIL MAILPATH+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+done+PS1='$ '+PS2='> '+PS4='+ '++# NLS nuisances.+for as_var in \+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \+ LC_TELEPHONE LC_TIME+do+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then+ eval $as_var=C; export $as_var+ else+ ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+ fi+done++# Required to use basename.+if expr a : '\(a\)' >/dev/null 2>&1 &&+ test "X`expr 00001 : '.*\(...\)'`" = X001; then+ as_expr=expr+else+ as_expr=false+fi++if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then+ as_basename=basename+else+ as_basename=false+fi+++# Name of the executable.+as_me=`$as_basename -- "$0" ||+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \+ X"$0" : 'X\(//\)$' \| \+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||+echo X/"$0" |+ sed '/^.*\/\([^/][^/]*\)\/*$/{+ s//\1/+ q+ }+ /^X\/\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\/\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`++# CDPATH.+$as_unset CDPATH+++if test "x$CONFIG_SHELL" = x; then+ if (eval ":") 2>/dev/null; then+ as_have_required=yes+else+ as_have_required=no+fi++ if test $as_have_required = yes && (eval ":+(as_func_return () {+ (exit \$1)+}+as_func_success () {+ as_func_return 0+}+as_func_failure () {+ as_func_return 1+}+as_func_ret_success () {+ return 0+}+as_func_ret_failure () {+ return 1+}++exitcode=0+if as_func_success; then+ :+else+ exitcode=1+ echo as_func_success failed.+fi++if as_func_failure; then+ exitcode=1+ echo as_func_failure succeeded.+fi++if as_func_ret_success; then+ :+else+ exitcode=1+ echo as_func_ret_success failed.+fi++if as_func_ret_failure; then+ exitcode=1+ echo as_func_ret_failure succeeded.+fi++if ( set x; as_func_ret_success y && test x = \"\$1\" ); then+ :+else+ exitcode=1+ echo positional parameters were not saved.+fi++test \$exitcode = 0) || { (exit 1); exit 1; }++(+ as_lineno_1=\$LINENO+ as_lineno_2=\$LINENO+ test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&+ test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }+") 2> /dev/null; then+ :+else+ as_candidate_shells=+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ case $as_dir in+ /*)+ for as_base in sh bash ksh sh5; do+ as_candidate_shells="$as_candidate_shells $as_dir/$as_base"+ done;;+ esac+done+IFS=$as_save_IFS+++ for as_shell in $as_candidate_shells $SHELL; do+ # Try only shells that exist, to save several forks.+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&+ { ("$as_shell") 2> /dev/null <<\_ASEOF+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+ emulate sh+ NULLCMD=:+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '${1+"$@"}'='"$@"'+ setopt NO_GLOB_SUBST+else+ case `(set -o) 2>/dev/null` in+ *posix*) set -o posix ;;+esac++fi+++:+_ASEOF+}; then+ CONFIG_SHELL=$as_shell+ as_have_required=yes+ if { "$as_shell" 2> /dev/null <<\_ASEOF+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+ emulate sh+ NULLCMD=:+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '${1+"$@"}'='"$@"'+ setopt NO_GLOB_SUBST+else+ case `(set -o) 2>/dev/null` in+ *posix*) set -o posix ;;+esac++fi+++:+(as_func_return () {+ (exit $1)+}+as_func_success () {+ as_func_return 0+}+as_func_failure () {+ as_func_return 1+}+as_func_ret_success () {+ return 0+}+as_func_ret_failure () {+ return 1+}++exitcode=0+if as_func_success; then+ :+else+ exitcode=1+ echo as_func_success failed.+fi++if as_func_failure; then+ exitcode=1+ echo as_func_failure succeeded.+fi++if as_func_ret_success; then+ :+else+ exitcode=1+ echo as_func_ret_success failed.+fi++if as_func_ret_failure; then+ exitcode=1+ echo as_func_ret_failure succeeded.+fi++if ( set x; as_func_ret_success y && test x = "$1" ); then+ :+else+ exitcode=1+ echo positional parameters were not saved.+fi++test $exitcode = 0) || { (exit 1); exit 1; }++(+ as_lineno_1=$LINENO+ as_lineno_2=$LINENO+ test "x$as_lineno_1" != "x$as_lineno_2" &&+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }++_ASEOF+}; then+ break+fi++fi++ done++ if test "x$CONFIG_SHELL" != x; then+ for as_var in BASH_ENV ENV+ do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+ done+ export CONFIG_SHELL+ exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}+fi+++ if test $as_have_required = no; then+ echo This script requires a shell more modern than all the+ echo shells that I found on your system. Please install a+ echo modern shell, or manually run the script under such a+ echo shell if you do have one.+ { (exit 1); exit 1; }+fi+++fi++fi++++(eval "as_func_return () {+ (exit \$1)+}+as_func_success () {+ as_func_return 0+}+as_func_failure () {+ as_func_return 1+}+as_func_ret_success () {+ return 0+}+as_func_ret_failure () {+ return 1+}++exitcode=0+if as_func_success; then+ :+else+ exitcode=1+ echo as_func_success failed.+fi++if as_func_failure; then+ exitcode=1+ echo as_func_failure succeeded.+fi++if as_func_ret_success; then+ :+else+ exitcode=1+ echo as_func_ret_success failed.+fi++if as_func_ret_failure; then+ exitcode=1+ echo as_func_ret_failure succeeded.+fi++if ( set x; as_func_ret_success y && test x = \"\$1\" ); then+ :+else+ exitcode=1+ echo positional parameters were not saved.+fi++test \$exitcode = 0") || {+ echo No shell found that supports shell functions.+ echo Please tell autoconf@gnu.org about your system,+ echo including any error possibly output before this+ echo message+}++++ as_lineno_1=$LINENO+ as_lineno_2=$LINENO+ test "x$as_lineno_1" != "x$as_lineno_2" &&+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {++ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO+ # uniformly replaced by the line number. The first 'sed' inserts a+ # line-number line after each line using $LINENO; the second 'sed'+ # does the real work. The second script uses 'N' to pair each+ # line-number line with the line containing $LINENO, and appends+ # trailing '-' during substitution so that $LINENO is not a special+ # case at line end.+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the+ # scripts with optimization help from Paolo Bonzini. Blame Lee+ # E. McMahon (1931-1989) for sed's syntax. :-)+ sed -n '+ p+ /[$]LINENO/=+ ' <$as_myself |+ sed '+ s/[$]LINENO.*/&-/+ t lineno+ b+ :lineno+ N+ :loop+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/+ t loop+ s/-\n.*//+ ' >$as_me.lineno &&+ chmod +x "$as_me.lineno" ||+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2+ { (exit 1); exit 1; }; }++ # Don't try to exec as it changes $[0], causing all sort of problems+ # (the dirname of $[0] is not the place where we might find the+ # original and so on. Autoconf is especially sensitive to this).+ . "./$as_me.lineno"+ # Exit status is that of the last command.+ exit+}+++if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then+ as_dirname=dirname+else+ as_dirname=false+fi++ECHO_C= ECHO_N= ECHO_T=+case `echo -n x` in+-n*)+ case `echo 'x\c'` in+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.+ *) ECHO_C='\c';;+ esac;;+*)+ ECHO_N='-n';;+esac++if expr a : '\(a\)' >/dev/null 2>&1 &&+ test "X`expr 00001 : '.*\(...\)'`" = X001; then+ as_expr=expr+else+ as_expr=false+fi++rm -f conf$$ conf$$.exe conf$$.file+if test -d conf$$.dir; then+ rm -f conf$$.dir/conf$$.file+else+ rm -f conf$$.dir+ mkdir conf$$.dir+fi+echo >conf$$.file+if ln -s conf$$.file conf$$ 2>/dev/null; then+ as_ln_s='ln -s'+ # ... but there are two gotchas:+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.+ # In both cases, we have to default to `cp -p'.+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||+ as_ln_s='cp -p'+elif ln conf$$.file conf$$ 2>/dev/null; then+ as_ln_s=ln+else+ as_ln_s='cp -p'+fi+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file+rmdir conf$$.dir 2>/dev/null++if mkdir -p . 2>/dev/null; then+ as_mkdir_p=:+else+ test -d ./-p && rmdir ./-p+ as_mkdir_p=false+fi++if test -x / >/dev/null 2>&1; then+ as_test_x='test -x'+else+ if ls -dL / >/dev/null 2>&1; then+ as_ls_L_option=L+ else+ as_ls_L_option=+ fi+ as_test_x='+ eval sh -c '\''+ if test -d "$1"; then+ test -d "$1/.";+ else+ case $1 in+ -*)set "./$1";;+ esac;+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in+ ???[sx]*):;;*)false;;esac;fi+ '\'' sh+ '+fi+as_executable_p=$as_test_x++# Sed expression to map a string onto a valid CPP name.+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"++# Sed expression to map a string onto a valid variable name.+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"++++exec 7<&0 </dev/null 6>&1++# Name of the host.+# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,+# so uname gets run too.+ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`++#+# Initializations.+#+ac_default_prefix=/usr/local+ac_clean_files=+ac_config_libobj_dir=.+LIBOBJS=+cross_compiling=no+subdirs=+MFLAGS=+MAKEFLAGS=+SHELL=${CONFIG_SHELL-/bin/sh}++# Identity of this package.+PACKAGE_NAME='rtsPOSIX'+PACKAGE_TARNAME='rtsposix'+PACKAGE_VERSION='0.9.9'+PACKAGE_STRING='rtsPOSIX 0.9.9'+PACKAGE_BUGREPORT='nordland@csee.ltu.se'++ac_unique_file="main.c"+# Factoring default headers for most tests.+ac_includes_default="\+#include <stdio.h>+#ifdef HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#ifdef HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif+#ifdef STDC_HEADERS+# include <stdlib.h>+# include <stddef.h>+#else+# ifdef HAVE_STDLIB_H+# include <stdlib.h>+# endif+#endif+#ifdef HAVE_STRING_H+# if !defined STDC_HEADERS && defined HAVE_MEMORY_H+# include <memory.h>+# endif+# include <string.h>+#endif+#ifdef HAVE_STRINGS_H+# include <strings.h>+#endif+#ifdef HAVE_INTTYPES_H+# include <inttypes.h>+#endif+#ifdef HAVE_STDINT_H+# include <stdint.h>+#endif+#ifdef HAVE_UNISTD_H+# include <unistd.h>+#endif"++ac_subst_vars='SHELL+PATH_SEPARATOR+PACKAGE_NAME+PACKAGE_TARNAME+PACKAGE_VERSION+PACKAGE_STRING+PACKAGE_BUGREPORT+exec_prefix+prefix+program_transform_name+bindir+sbindir+libexecdir+datarootdir+datadir+sysconfdir+sharedstatedir+localstatedir+includedir+oldincludedir+docdir+infodir+htmldir+dvidir+pdfdir+psdir+libdir+localedir+mandir+DEFS+ECHO_C+ECHO_N+ECHO_T+LIBS+build_alias+host_alias+target_alias+CC+CFLAGS+LDFLAGS+CPPFLAGS+ac_ct_CC+EXEEXT+OBJEXT+INSTALL_PROGRAM+INSTALL_SCRIPT+INSTALL_DATA+build+build_cpu+build_vendor+build_os+host+host_cpu+host_vendor+host_os+acx_pthread_config+PTHREAD_CC+PTHREAD_LIBS+PTHREAD_CFLAGS+TIMBERC+CPP+GREP+EGREP+LIBOBJS+SRC+DEST+LTLIBOBJS'+ac_subst_files=''+ ac_precious_vars='build_alias+host_alias+target_alias+CC+CFLAGS+LDFLAGS+LIBS+CPPFLAGS+CPP'+++# Initialize some variables set by options.+ac_init_help=+ac_init_version=false+# The variables have the same names as the options, with+# dashes changed to underlines.+cache_file=/dev/null+exec_prefix=NONE+no_create=+no_recursion=+prefix=NONE+program_prefix=NONE+program_suffix=NONE+program_transform_name=s,x,x,+silent=+site=+srcdir=+verbose=+x_includes=NONE+x_libraries=NONE++# Installation directory options.+# These are left unexpanded so users can "make install exec_prefix=/foo"+# and all the variables that are supposed to be based on exec_prefix+# by default will actually change.+# Use braces instead of parens because sh, perl, etc. also accept them.+# (The list follows the same order as the GNU Coding Standards.)+bindir='${exec_prefix}/bin'+sbindir='${exec_prefix}/sbin'+libexecdir='${exec_prefix}/libexec'+datarootdir='${prefix}/share'+datadir='${datarootdir}'+sysconfdir='${prefix}/etc'+sharedstatedir='${prefix}/com'+localstatedir='${prefix}/var'+includedir='${prefix}/include'+oldincludedir='/usr/include'+docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'+infodir='${datarootdir}/info'+htmldir='${docdir}'+dvidir='${docdir}'+pdfdir='${docdir}'+psdir='${docdir}'+libdir='${exec_prefix}/lib'+localedir='${datarootdir}/locale'+mandir='${datarootdir}/man'++ac_prev=+ac_dashdash=+for ac_option+do+ # If the previous option needs an argument, assign it.+ if test -n "$ac_prev"; then+ eval $ac_prev=\$ac_option+ ac_prev=+ continue+ fi++ case $ac_option in+ *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;+ *) ac_optarg=yes ;;+ esac++ # Accept the important Cygnus configure options, so we can diagnose typos.++ case $ac_dashdash$ac_option in+ --)+ ac_dashdash=yes ;;++ -bindir | --bindir | --bindi | --bind | --bin | --bi)+ ac_prev=bindir ;;+ -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)+ bindir=$ac_optarg ;;++ -build | --build | --buil | --bui | --bu)+ ac_prev=build_alias ;;+ -build=* | --build=* | --buil=* | --bui=* | --bu=*)+ build_alias=$ac_optarg ;;++ -cache-file | --cache-file | --cache-fil | --cache-fi \+ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)+ ac_prev=cache_file ;;+ -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \+ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)+ cache_file=$ac_optarg ;;++ --config-cache | -C)+ cache_file=config.cache ;;++ -datadir | --datadir | --datadi | --datad)+ ac_prev=datadir ;;+ -datadir=* | --datadir=* | --datadi=* | --datad=*)+ datadir=$ac_optarg ;;++ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \+ | --dataroo | --dataro | --datar)+ ac_prev=datarootdir ;;+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)+ datarootdir=$ac_optarg ;;++ -disable-* | --disable-*)+ ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2+ { (exit 1); exit 1; }; }+ ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`+ eval enable_$ac_feature=no ;;++ -docdir | --docdir | --docdi | --doc | --do)+ ac_prev=docdir ;;+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)+ docdir=$ac_optarg ;;++ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)+ ac_prev=dvidir ;;+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)+ dvidir=$ac_optarg ;;++ -enable-* | --enable-*)+ ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2+ { (exit 1); exit 1; }; }+ ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`+ eval enable_$ac_feature=\$ac_optarg ;;++ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \+ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \+ | --exec | --exe | --ex)+ ac_prev=exec_prefix ;;+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \+ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \+ | --exec=* | --exe=* | --ex=*)+ exec_prefix=$ac_optarg ;;++ -gas | --gas | --ga | --g)+ # Obsolete; use --with-gas.+ with_gas=yes ;;++ -help | --help | --hel | --he | -h)+ ac_init_help=long ;;+ -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)+ ac_init_help=recursive ;;+ -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)+ ac_init_help=short ;;++ -host | --host | --hos | --ho)+ ac_prev=host_alias ;;+ -host=* | --host=* | --hos=* | --ho=*)+ host_alias=$ac_optarg ;;++ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)+ ac_prev=htmldir ;;+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \+ | --ht=*)+ htmldir=$ac_optarg ;;++ -includedir | --includedir | --includedi | --included | --include \+ | --includ | --inclu | --incl | --inc)+ ac_prev=includedir ;;+ -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \+ | --includ=* | --inclu=* | --incl=* | --inc=*)+ includedir=$ac_optarg ;;++ -infodir | --infodir | --infodi | --infod | --info | --inf)+ ac_prev=infodir ;;+ -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)+ infodir=$ac_optarg ;;++ -libdir | --libdir | --libdi | --libd)+ ac_prev=libdir ;;+ -libdir=* | --libdir=* | --libdi=* | --libd=*)+ libdir=$ac_optarg ;;++ -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \+ | --libexe | --libex | --libe)+ ac_prev=libexecdir ;;+ -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \+ | --libexe=* | --libex=* | --libe=*)+ libexecdir=$ac_optarg ;;++ -localedir | --localedir | --localedi | --localed | --locale)+ ac_prev=localedir ;;+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)+ localedir=$ac_optarg ;;++ -localstatedir | --localstatedir | --localstatedi | --localstated \+ | --localstate | --localstat | --localsta | --localst | --locals)+ ac_prev=localstatedir ;;+ -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)+ localstatedir=$ac_optarg ;;++ -mandir | --mandir | --mandi | --mand | --man | --ma | --m)+ ac_prev=mandir ;;+ -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)+ mandir=$ac_optarg ;;++ -nfp | --nfp | --nf)+ # Obsolete; use --without-fp.+ with_fp=no ;;++ -no-create | --no-create | --no-creat | --no-crea | --no-cre \+ | --no-cr | --no-c | -n)+ no_create=yes ;;++ -no-recursion | --no-recursion | --no-recursio | --no-recursi \+ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)+ no_recursion=yes ;;++ -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \+ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \+ | --oldin | --oldi | --old | --ol | --o)+ ac_prev=oldincludedir ;;+ -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \+ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \+ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)+ oldincludedir=$ac_optarg ;;++ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)+ ac_prev=prefix ;;+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)+ prefix=$ac_optarg ;;++ -program-prefix | --program-prefix | --program-prefi | --program-pref \+ | --program-pre | --program-pr | --program-p)+ ac_prev=program_prefix ;;+ -program-prefix=* | --program-prefix=* | --program-prefi=* \+ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)+ program_prefix=$ac_optarg ;;++ -program-suffix | --program-suffix | --program-suffi | --program-suff \+ | --program-suf | --program-su | --program-s)+ ac_prev=program_suffix ;;+ -program-suffix=* | --program-suffix=* | --program-suffi=* \+ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)+ program_suffix=$ac_optarg ;;++ -program-transform-name | --program-transform-name \+ | --program-transform-nam | --program-transform-na \+ | --program-transform-n | --program-transform- \+ | --program-transform | --program-transfor \+ | --program-transfo | --program-transf \+ | --program-trans | --program-tran \+ | --progr-tra | --program-tr | --program-t)+ ac_prev=program_transform_name ;;+ -program-transform-name=* | --program-transform-name=* \+ | --program-transform-nam=* | --program-transform-na=* \+ | --program-transform-n=* | --program-transform-=* \+ | --program-transform=* | --program-transfor=* \+ | --program-transfo=* | --program-transf=* \+ | --program-trans=* | --program-tran=* \+ | --progr-tra=* | --program-tr=* | --program-t=*)+ program_transform_name=$ac_optarg ;;++ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)+ ac_prev=pdfdir ;;+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)+ pdfdir=$ac_optarg ;;++ -psdir | --psdir | --psdi | --psd | --ps)+ ac_prev=psdir ;;+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)+ psdir=$ac_optarg ;;++ -q | -quiet | --quiet | --quie | --qui | --qu | --q \+ | -silent | --silent | --silen | --sile | --sil)+ silent=yes ;;++ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)+ ac_prev=sbindir ;;+ -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \+ | --sbi=* | --sb=*)+ sbindir=$ac_optarg ;;++ -sharedstatedir | --sharedstatedir | --sharedstatedi \+ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \+ | --sharedst | --shareds | --shared | --share | --shar \+ | --sha | --sh)+ ac_prev=sharedstatedir ;;+ -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \+ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \+ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \+ | --sha=* | --sh=*)+ sharedstatedir=$ac_optarg ;;++ -site | --site | --sit)+ ac_prev=site ;;+ -site=* | --site=* | --sit=*)+ site=$ac_optarg ;;++ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)+ ac_prev=srcdir ;;+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)+ srcdir=$ac_optarg ;;++ -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \+ | --syscon | --sysco | --sysc | --sys | --sy)+ ac_prev=sysconfdir ;;+ -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \+ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)+ sysconfdir=$ac_optarg ;;++ -target | --target | --targe | --targ | --tar | --ta | --t)+ ac_prev=target_alias ;;+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)+ target_alias=$ac_optarg ;;++ -v | -verbose | --verbose | --verbos | --verbo | --verb)+ verbose=yes ;;++ -version | --version | --versio | --versi | --vers | -V)+ ac_init_version=: ;;++ -with-* | --with-*)+ ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&+ { echo "$as_me: error: invalid package name: $ac_package" >&2+ { (exit 1); exit 1; }; }+ ac_package=`echo $ac_package | sed 's/[-.]/_/g'`+ eval with_$ac_package=\$ac_optarg ;;++ -without-* | --without-*)+ ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&+ { echo "$as_me: error: invalid package name: $ac_package" >&2+ { (exit 1); exit 1; }; }+ ac_package=`echo $ac_package | sed 's/[-.]/_/g'`+ eval with_$ac_package=no ;;++ --x)+ # Obsolete; use --with-x.+ with_x=yes ;;++ -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \+ | --x-incl | --x-inc | --x-in | --x-i)+ ac_prev=x_includes ;;+ -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \+ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)+ x_includes=$ac_optarg ;;++ -x-libraries | --x-libraries | --x-librarie | --x-librari \+ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)+ ac_prev=x_libraries ;;+ -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \+ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)+ x_libraries=$ac_optarg ;;++ -*) { echo "$as_me: error: unrecognized option: $ac_option+Try \`$0 --help' for more information." >&2+ { (exit 1); exit 1; }; }+ ;;++ *=*)+ ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`+ # Reject names that are not valid shell variable names.+ expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&+ { echo "$as_me: error: invalid variable name: $ac_envvar" >&2+ { (exit 1); exit 1; }; }+ eval $ac_envvar=\$ac_optarg+ export $ac_envvar ;;++ *)+ # FIXME: should be removed in autoconf 3.0.+ echo "$as_me: WARNING: you should use --build, --host, --target" >&2+ expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&+ echo "$as_me: WARNING: invalid host type: $ac_option" >&2+ : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}+ ;;++ esac+done++if test -n "$ac_prev"; then+ ac_option=--`echo $ac_prev | sed 's/_/-/g'`+ { echo "$as_me: error: missing argument to $ac_option" >&2+ { (exit 1); exit 1; }; }+fi++# Be sure to have absolute directory names.+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \+ datadir sysconfdir sharedstatedir localstatedir includedir \+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \+ libdir localedir mandir+do+ eval ac_val=\$$ac_var+ case $ac_val in+ [\\/$]* | ?:[\\/]* ) continue;;+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;+ esac+ { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2+ { (exit 1); exit 1; }; }+done++# There might be people who depend on the old broken behavior: `$host'+# used to hold the argument of --host etc.+# FIXME: To remove some day.+build=$build_alias+host=$host_alias+target=$target_alias++# FIXME: To remove some day.+if test "x$host_alias" != x; then+ if test "x$build_alias" = x; then+ cross_compiling=maybe+ echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.+ If a cross compiler is detected then cross compile mode will be used." >&2+ elif test "x$build_alias" != "x$host_alias"; then+ cross_compiling=yes+ fi+fi++ac_tool_prefix=+test -n "$host_alias" && ac_tool_prefix=$host_alias-++test "$silent" = yes && exec 6>/dev/null+++ac_pwd=`pwd` && test -n "$ac_pwd" &&+ac_ls_di=`ls -di .` &&+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||+ { echo "$as_me: error: Working directory cannot be determined" >&2+ { (exit 1); exit 1; }; }+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||+ { echo "$as_me: error: pwd does not report name of working directory" >&2+ { (exit 1); exit 1; }; }+++# Find the source files, if location was not specified.+if test -z "$srcdir"; then+ ac_srcdir_defaulted=yes+ # Try the directory containing this script, then the parent directory.+ ac_confdir=`$as_dirname -- "$0" ||+$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$0" : 'X\(//\)[^/]' \| \+ X"$0" : 'X\(//\)$' \| \+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||+echo X"$0" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ srcdir=$ac_confdir+ if test ! -r "$srcdir/$ac_unique_file"; then+ srcdir=..+ fi+else+ ac_srcdir_defaulted=no+fi+if test ! -r "$srcdir/$ac_unique_file"; then+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."+ { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2+ { (exit 1); exit 1; }; }+fi+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"+ac_abs_confdir=`(+ cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2+ { (exit 1); exit 1; }; }+ pwd)`+# When building in place, set srcdir=.+if test "$ac_abs_confdir" = "$ac_pwd"; then+ srcdir=.+fi+# Remove unnecessary trailing slashes from srcdir.+# Double slashes in file names in object file debugging info+# mess up M-x gdb in Emacs.+case $srcdir in+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;+esac+for ac_var in $ac_precious_vars; do+ eval ac_env_${ac_var}_set=\${${ac_var}+set}+ eval ac_env_${ac_var}_value=\$${ac_var}+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}+ eval ac_cv_env_${ac_var}_value=\$${ac_var}+done++#+# Report the --help message.+#+if test "$ac_init_help" = "long"; then+ # Omit some internal or obsolete options to make the list less imposing.+ # This message is too long to be a string in the A/UX 3.1 sh.+ cat <<_ACEOF+\`configure' configures rtsPOSIX 0.9.9 to adapt to many kinds of systems.++Usage: $0 [OPTION]... [VAR=VALUE]...++To assign environment variables (e.g., CC, CFLAGS...), specify them as+VAR=VALUE. See below for descriptions of some of the useful variables.++Defaults for the options are specified in brackets.++Configuration:+ -h, --help display this help and exit+ --help=short display options specific to this package+ --help=recursive display the short help of all the included packages+ -V, --version display version information and exit+ -q, --quiet, --silent do not print \`checking...' messages+ --cache-file=FILE cache test results in FILE [disabled]+ -C, --config-cache alias for \`--cache-file=config.cache'+ -n, --no-create do not create output files+ --srcdir=DIR find the sources in DIR [configure dir or \`..']++Installation directories:+ --prefix=PREFIX install architecture-independent files in PREFIX+ [$ac_default_prefix]+ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX+ [PREFIX]++By default, \`make install' will install all the files in+\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify+an installation prefix other than \`$ac_default_prefix' using \`--prefix',+for instance \`--prefix=\$HOME'.++For better control, use the options below.++Fine tuning of the installation directories:+ --bindir=DIR user executables [EPREFIX/bin]+ --sbindir=DIR system admin executables [EPREFIX/sbin]+ --libexecdir=DIR program executables [EPREFIX/libexec]+ --sysconfdir=DIR read-only single-machine data [PREFIX/etc]+ --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]+ --localstatedir=DIR modifiable single-machine data [PREFIX/var]+ --libdir=DIR object code libraries [EPREFIX/lib]+ --includedir=DIR C header files [PREFIX/include]+ --oldincludedir=DIR C header files for non-gcc [/usr/include]+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]+ --infodir=DIR info documentation [DATAROOTDIR/info]+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]+ --mandir=DIR man documentation [DATAROOTDIR/man]+ --docdir=DIR documentation root [DATAROOTDIR/doc/rtsposix]+ --htmldir=DIR html documentation [DOCDIR]+ --dvidir=DIR dvi documentation [DOCDIR]+ --pdfdir=DIR pdf documentation [DOCDIR]+ --psdir=DIR ps documentation [DOCDIR]+_ACEOF++ cat <<\_ACEOF++System types:+ --build=BUILD configure for building on BUILD [guessed]+ --host=HOST cross-compile to build programs to run on HOST [BUILD]+_ACEOF+fi++if test -n "$ac_init_help"; then+ case $ac_init_help in+ short | recursive ) echo "Configuration of rtsPOSIX 0.9.9:";;+ esac+ cat <<\_ACEOF++Optional Packages:+ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]+ --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)+ --with-timberc=DIR Path to timberc++Some influential environment variables:+ CC C compiler command+ CFLAGS C compiler flags+ LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a+ nonstandard directory <lib dir>+ LIBS libraries to pass to the linker, e.g. -l<library>+ CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I<include dir> if+ you have headers in a nonstandard directory <include dir>+ CPP C preprocessor++Use these variables to override the choices made by `configure' or to help+it to find libraries and programs with nonstandard names/locations.++Report bugs to <nordland@csee.ltu.se>.+_ACEOF+ac_status=$?+fi++if test "$ac_init_help" = "recursive"; then+ # If there are subdirs, report their specific --help.+ for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue+ test -d "$ac_dir" || continue+ ac_builddir=.++case "$ac_dir" in+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;+*)+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`+ # A ".." for each directory in $ac_dir_suffix.+ ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`+ case $ac_top_builddir_sub in+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;+ esac ;;+esac+ac_abs_top_builddir=$ac_pwd+ac_abs_builddir=$ac_pwd$ac_dir_suffix+# for backward compatibility:+ac_top_builddir=$ac_top_build_prefix++case $srcdir in+ .) # We are building in place.+ ac_srcdir=.+ ac_top_srcdir=$ac_top_builddir_sub+ ac_abs_top_srcdir=$ac_pwd ;;+ [\\/]* | ?:[\\/]* ) # Absolute name.+ ac_srcdir=$srcdir$ac_dir_suffix;+ ac_top_srcdir=$srcdir+ ac_abs_top_srcdir=$srcdir ;;+ *) # Relative name.+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix+ ac_top_srcdir=$ac_top_build_prefix$srcdir+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;+esac+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix++ cd "$ac_dir" || { ac_status=$?; continue; }+ # Check for guested configure.+ if test -f "$ac_srcdir/configure.gnu"; then+ echo &&+ $SHELL "$ac_srcdir/configure.gnu" --help=recursive+ elif test -f "$ac_srcdir/configure"; then+ echo &&+ $SHELL "$ac_srcdir/configure" --help=recursive+ else+ echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2+ fi || ac_status=$?+ cd "$ac_pwd" || { ac_status=$?; break; }+ done+fi++test -n "$ac_init_help" && exit $ac_status+if $ac_init_version; then+ cat <<\_ACEOF+rtsPOSIX configure 0.9.9+generated by GNU Autoconf 2.61++Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,+2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.+This configure script is free software; the Free Software Foundation+gives unlimited permission to copy, distribute and modify it.+_ACEOF+ exit+fi+cat >config.log <<_ACEOF+This file contains any messages produced by compilers while+running configure, to aid debugging if configure makes a mistake.++It was created by rtsPOSIX $as_me 0.9.9, which was+generated by GNU Autoconf 2.61. Invocation command line was++ $ $0 $@++_ACEOF+exec 5>>config.log+{+cat <<_ASUNAME+## --------- ##+## Platform. ##+## --------- ##++hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`+uname -m = `(uname -m) 2>/dev/null || echo unknown`+uname -r = `(uname -r) 2>/dev/null || echo unknown`+uname -s = `(uname -s) 2>/dev/null || echo unknown`+uname -v = `(uname -v) 2>/dev/null || echo unknown`++/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`+/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`++/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`+/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`+/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`+/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`++_ASUNAME++as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ echo "PATH: $as_dir"+done+IFS=$as_save_IFS++} >&5++cat >&5 <<_ACEOF+++## ----------- ##+## Core tests. ##+## ----------- ##++_ACEOF+++# Keep a trace of the command line.+# Strip out --no-create and --no-recursion so they do not pile up.+# Strip out --silent because we don't want to record it for future runs.+# Also quote any args containing shell meta-characters.+# Make two passes to allow for proper duplicate-argument suppression.+ac_configure_args=+ac_configure_args0=+ac_configure_args1=+ac_must_keep_next=false+for ac_pass in 1 2+do+ for ac_arg+ do+ case $ac_arg in+ -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \+ | -silent | --silent | --silen | --sile | --sil)+ continue ;;+ *\'*)+ ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;+ esac+ case $ac_pass in+ 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;+ 2)+ ac_configure_args1="$ac_configure_args1 '$ac_arg'"+ if test $ac_must_keep_next = true; then+ ac_must_keep_next=false # Got value, back to normal.+ else+ case $ac_arg in+ *=* | --config-cache | -C | -disable-* | --disable-* \+ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \+ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \+ | -with-* | --with-* | -without-* | --without-* | --x)+ case "$ac_configure_args0 " in+ "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;+ esac+ ;;+ -* ) ac_must_keep_next=true ;;+ esac+ fi+ ac_configure_args="$ac_configure_args '$ac_arg'"+ ;;+ esac+ done+done+$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }+$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; }++# When interrupted or exit'd, cleanup temporary files, and complete+# config.log. We remove comments because anyway the quotes in there+# would cause problems or look ugly.+# WARNING: Use '\'' to represent an apostrophe within the trap.+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.+trap 'exit_status=$?+ # Save into config.log some information that might help in debugging.+ {+ echo++ cat <<\_ASBOX+## ---------------- ##+## Cache variables. ##+## ---------------- ##+_ASBOX+ echo+ # The following way of writing the cache mishandles newlines in values,+(+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do+ eval ac_val=\$$ac_var+ case $ac_val in #(+ *${as_nl}*)+ case $ac_var in #(+ *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;+ esac+ case $ac_var in #(+ _ | IFS | as_nl) ;; #(+ *) $as_unset $ac_var ;;+ esac ;;+ esac+ done+ (set) 2>&1 |+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(+ *${as_nl}ac_space=\ *)+ sed -n \+ "s/'\''/'\''\\\\'\'''\''/g;+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"+ ;; #(+ *)+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"+ ;;+ esac |+ sort+)+ echo++ cat <<\_ASBOX+## ----------------- ##+## Output variables. ##+## ----------------- ##+_ASBOX+ echo+ for ac_var in $ac_subst_vars+ do+ eval ac_val=\$$ac_var+ case $ac_val in+ *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;+ esac+ echo "$ac_var='\''$ac_val'\''"+ done | sort+ echo++ if test -n "$ac_subst_files"; then+ cat <<\_ASBOX+## ------------------- ##+## File substitutions. ##+## ------------------- ##+_ASBOX+ echo+ for ac_var in $ac_subst_files+ do+ eval ac_val=\$$ac_var+ case $ac_val in+ *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;+ esac+ echo "$ac_var='\''$ac_val'\''"+ done | sort+ echo+ fi++ if test -s confdefs.h; then+ cat <<\_ASBOX+## ----------- ##+## confdefs.h. ##+## ----------- ##+_ASBOX+ echo+ cat confdefs.h+ echo+ fi+ test "$ac_signal" != 0 &&+ echo "$as_me: caught signal $ac_signal"+ echo "$as_me: exit $exit_status"+ } >&5+ rm -f core *.core core.conftest.* &&+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&+ exit $exit_status+' 0+for ac_signal in 1 2 13 15; do+ trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal+done+ac_signal=0++# confdefs.h avoids OS command line length limits that DEFS can exceed.+rm -f -r conftest* confdefs.h++# Predefined preprocessor variables.++cat >>confdefs.h <<_ACEOF+#define PACKAGE_NAME "$PACKAGE_NAME"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_VERSION "$PACKAGE_VERSION"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_STRING "$PACKAGE_STRING"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"+_ACEOF+++# Let the site file select an alternate cache file if it wants to.+# Prefer explicitly selected file to automatically selected ones.+if test -n "$CONFIG_SITE"; then+ set x "$CONFIG_SITE"+elif test "x$prefix" != xNONE; then+ set x "$prefix/share/config.site" "$prefix/etc/config.site"+else+ set x "$ac_default_prefix/share/config.site" \+ "$ac_default_prefix/etc/config.site"+fi+shift+for ac_site_file+do+ if test -r "$ac_site_file"; then+ { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5+echo "$as_me: loading site script $ac_site_file" >&6;}+ sed 's/^/| /' "$ac_site_file" >&5+ . "$ac_site_file"+ fi+done++if test -r "$cache_file"; then+ # Some versions of bash will fail to source /dev/null (special+ # files actually), so we avoid doing that.+ if test -f "$cache_file"; then+ { echo "$as_me:$LINENO: loading cache $cache_file" >&5+echo "$as_me: loading cache $cache_file" >&6;}+ case $cache_file in+ [\\/]* | ?:[\\/]* ) . "$cache_file";;+ *) . "./$cache_file";;+ esac+ fi+else+ { echo "$as_me:$LINENO: creating cache $cache_file" >&5+echo "$as_me: creating cache $cache_file" >&6;}+ >$cache_file+fi++# Check that the precious variables saved in the cache have kept the same+# value.+ac_cache_corrupted=false+for ac_var in $ac_precious_vars; do+ eval ac_old_set=\$ac_cv_env_${ac_var}_set+ eval ac_new_set=\$ac_env_${ac_var}_set+ eval ac_old_val=\$ac_cv_env_${ac_var}_value+ eval ac_new_val=\$ac_env_${ac_var}_value+ case $ac_old_set,$ac_new_set in+ set,)+ { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5+echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}+ ac_cache_corrupted=: ;;+ ,set)+ { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5+echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}+ ac_cache_corrupted=: ;;+ ,);;+ *)+ if test "x$ac_old_val" != "x$ac_new_val"; then+ { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5+echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}+ { echo "$as_me:$LINENO: former value: $ac_old_val" >&5+echo "$as_me: former value: $ac_old_val" >&2;}+ { echo "$as_me:$LINENO: current value: $ac_new_val" >&5+echo "$as_me: current value: $ac_new_val" >&2;}+ ac_cache_corrupted=:+ fi;;+ esac+ # Pass precious variables to config.status.+ if test "$ac_new_set" = set; then+ case $ac_new_val in+ *\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;+ *) ac_arg=$ac_var=$ac_new_val ;;+ esac+ case " $ac_configure_args " in+ *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.+ *) ac_configure_args="$ac_configure_args '$ac_arg'" ;;+ esac+ fi+done+if $ac_cache_corrupted; then+ { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5+echo "$as_me: error: changes in the environment can compromise the build" >&2;}+ { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5+echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}+ { (exit 1); exit 1; }; }+fi++++++++++++++++++++++++++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu++++ac_config_headers="$ac_config_headers config.h"+++# Checks for programs.+ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu+if test -n "$ac_tool_prefix"; then+ # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.+set dummy ${ac_tool_prefix}gcc; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_CC="${ac_tool_prefix}gcc"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++fi+if test -z "$ac_cv_prog_CC"; then+ ac_ct_CC=$CC+ # Extract the first word of "gcc", so it can be a program name with args.+set dummy gcc; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$ac_ct_CC"; then+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_ac_ct_CC="gcc"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+ac_ct_CC=$ac_cv_prog_ac_ct_CC+if test -n "$ac_ct_CC"; then+ { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5+echo "${ECHO_T}$ac_ct_CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi++ if test "x$ac_ct_CC" = x; then+ CC=""+ else+ case $cross_compiling:$ac_tool_warned in+yes:)+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet. If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&5+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet. If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&2;}+ac_tool_warned=yes ;;+esac+ CC=$ac_ct_CC+ fi+else+ CC="$ac_cv_prog_CC"+fi++if test -z "$CC"; then+ if test -n "$ac_tool_prefix"; then+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.+set dummy ${ac_tool_prefix}cc; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_CC="${ac_tool_prefix}cc"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ fi+fi+if test -z "$CC"; then+ # Extract the first word of "cc", so it can be a program name with args.+set dummy cc; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+ ac_prog_rejected=no+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then+ ac_prog_rejected=yes+ continue+ fi+ ac_cv_prog_CC="cc"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++if test $ac_prog_rejected = yes; then+ # We found a bogon in the path, so make sure we never use it.+ set dummy $ac_cv_prog_CC+ shift+ if test $# != 0; then+ # We chose a different compiler from the bogus one.+ # However, it has the same basename, so the bogon will be chosen+ # first if we set CC to just the basename; use the full file name.+ shift+ ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"+ fi+fi+fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++fi+if test -z "$CC"; then+ if test -n "$ac_tool_prefix"; then+ for ac_prog in cl.exe+ do+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.+set dummy $ac_tool_prefix$ac_prog; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_CC="$ac_tool_prefix$ac_prog"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ test -n "$CC" && break+ done+fi+if test -z "$CC"; then+ ac_ct_CC=$CC+ for ac_prog in cl.exe+do+ # Extract the first word of "$ac_prog", so it can be a program name with args.+set dummy $ac_prog; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$ac_ct_CC"; then+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_ac_ct_CC="$ac_prog"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+ac_ct_CC=$ac_cv_prog_ac_ct_CC+if test -n "$ac_ct_CC"; then+ { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5+echo "${ECHO_T}$ac_ct_CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ test -n "$ac_ct_CC" && break+done++ if test "x$ac_ct_CC" = x; then+ CC=""+ else+ case $cross_compiling:$ac_tool_warned in+yes:)+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet. If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&5+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet. If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&2;}+ac_tool_warned=yes ;;+esac+ CC=$ac_ct_CC+ fi+fi++fi+++test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH+See \`config.log' for more details." >&5+echo "$as_me: error: no acceptable C compiler found in \$PATH+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }++# Provide some information about the compiler.+echo "$as_me:$LINENO: checking for C compiler version" >&5+ac_compiler=`set X $ac_compile; echo $2`+{ (ac_try="$ac_compiler --version >&5"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compiler --version >&5") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }+{ (ac_try="$ac_compiler -v >&5"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compiler -v >&5") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }+{ (ac_try="$ac_compiler -V >&5"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compiler -V >&5") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }++cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+ac_clean_files_save=$ac_clean_files+ac_clean_files="$ac_clean_files a.out a.exe b.out"+# Try to create an executable without -o first, disregard a.out.+# It will help us diagnose broken compilers, and finding out an intuition+# of exeext.+{ echo "$as_me:$LINENO: checking for C compiler default output file name" >&5+echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6; }+ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`+#+# List of possible output files, starting from the most likely.+# The algorithm is not robust to junk in `.', hence go to wildcards (a.*)+# only as a last resort. b.out is created by i960 compilers.+ac_files='a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out'+#+# The IRIX 6 linker writes into existing files which may not be+# executable, retaining their permissions. Remove them first so a+# subsequent execution test works.+ac_rmfiles=+for ac_file in $ac_files+do+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;;+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;+ esac+done+rm -f $ac_rmfiles++if { (ac_try="$ac_link_default"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link_default") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }; then+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'+# in a Makefile. We should not override ac_cv_exeext if it was cached,+# so that the user can short-circuit this test for compilers unknown to+# Autoconf.+for ac_file in $ac_files ''+do+ test -f "$ac_file" || continue+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj )+ ;;+ [ab].out )+ # We found the default executable, but exeext='' is most+ # certainly right.+ break;;+ *.* )+ if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no;+ then :; else+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`+ fi+ # We set ac_cv_exeext here because the later test for it is not+ # safe: cross compilers may not add the suffix if given an `-o'+ # argument, so we may need to know it at that point already.+ # Even if this section looks crufty: it has the advantage of+ # actually working.+ break;;+ * )+ break;;+ esac+done+test "$ac_cv_exeext" = no && ac_cv_exeext=++else+ ac_file=''+fi++{ echo "$as_me:$LINENO: result: $ac_file" >&5+echo "${ECHO_T}$ac_file" >&6; }+if test -z "$ac_file"; then+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++{ { echo "$as_me:$LINENO: error: C compiler cannot create executables+See \`config.log' for more details." >&5+echo "$as_me: error: C compiler cannot create executables+See \`config.log' for more details." >&2;}+ { (exit 77); exit 77; }; }+fi++ac_exeext=$ac_cv_exeext++# Check that the compiler produces executables we can run. If not, either+# the compiler is broken, or we cross compile.+{ echo "$as_me:$LINENO: checking whether the C compiler works" >&5+echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6; }+# FIXME: These cross compiler hacks should be removed for Autoconf 3.0+# If not cross compiling, check that we can run a simple program.+if test "$cross_compiling" != yes; then+ if { ac_try='./$ac_file'+ { (case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_try") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }; }; then+ cross_compiling=no+ else+ if test "$cross_compiling" = maybe; then+ cross_compiling=yes+ else+ { { echo "$as_me:$LINENO: error: cannot run C compiled programs.+If you meant to cross compile, use \`--host'.+See \`config.log' for more details." >&5+echo "$as_me: error: cannot run C compiled programs.+If you meant to cross compile, use \`--host'.+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }+ fi+ fi+fi+{ echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }++rm -f a.out a.exe conftest$ac_cv_exeext b.out+ac_clean_files=$ac_clean_files_save+# Check that the compiler produces executables we can run. If not, either+# the compiler is broken, or we cross compile.+{ echo "$as_me:$LINENO: checking whether we are cross compiling" >&5+echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6; }+{ echo "$as_me:$LINENO: result: $cross_compiling" >&5+echo "${ECHO_T}$cross_compiling" >&6; }++{ echo "$as_me:$LINENO: checking for suffix of executables" >&5+echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6; }+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }; then+ # If both `conftest.exe' and `conftest' are `present' (well, observable)+# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will+# work properly (i.e., refer to `conftest.exe'), while it won't with+# `rm'.+for ac_file in conftest.exe conftest conftest.*; do+ test -f "$ac_file" || continue+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;;+ *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`+ break;;+ * ) break;;+ esac+done+else+ { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link+See \`config.log' for more details." >&5+echo "$as_me: error: cannot compute suffix of executables: cannot compile and link+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }+fi++rm -f conftest$ac_cv_exeext+{ echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5+echo "${ECHO_T}$ac_cv_exeext" >&6; }++rm -f conftest.$ac_ext+EXEEXT=$ac_cv_exeext+ac_exeext=$EXEEXT+{ echo "$as_me:$LINENO: checking for suffix of object files" >&5+echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6; }+if test "${ac_cv_objext+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+rm -f conftest.o conftest.obj+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }; then+ for ac_file in conftest.o conftest.obj conftest.*; do+ test -f "$ac_file" || continue;+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf ) ;;+ *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`+ break;;+ esac+done+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile+See \`config.log' for more details." >&5+echo "$as_me: error: cannot compute suffix of object files: cannot compile+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }+fi++rm -f conftest.$ac_cv_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_objext" >&5+echo "${ECHO_T}$ac_cv_objext" >&6; }+OBJEXT=$ac_cv_objext+ac_objext=$OBJEXT+{ echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5+echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6; }+if test "${ac_cv_c_compiler_gnu+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{+#ifndef __GNUC__+ choke me+#endif++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_compiler_gnu=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_compiler_gnu=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+ac_cv_c_compiler_gnu=$ac_compiler_gnu++fi+{ echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5+echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6; }+GCC=`test $ac_compiler_gnu = yes && echo yes`+ac_test_CFLAGS=${CFLAGS+set}+ac_save_CFLAGS=$CFLAGS+{ echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5+echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6; }+if test "${ac_cv_prog_cc_g+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ ac_save_c_werror_flag=$ac_c_werror_flag+ ac_c_werror_flag=yes+ ac_cv_prog_cc_g=no+ CFLAGS="-g"+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_cv_prog_cc_g=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ CFLAGS=""+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ :+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_c_werror_flag=$ac_save_c_werror_flag+ CFLAGS="-g"+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_cv_prog_cc_g=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+ ac_c_werror_flag=$ac_save_c_werror_flag+fi+{ echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5+echo "${ECHO_T}$ac_cv_prog_cc_g" >&6; }+if test "$ac_test_CFLAGS" = set; then+ CFLAGS=$ac_save_CFLAGS+elif test $ac_cv_prog_cc_g = yes; then+ if test "$GCC" = yes; then+ CFLAGS="-g -O2"+ else+ CFLAGS="-g"+ fi+else+ if test "$GCC" = yes; then+ CFLAGS="-O2"+ else+ CFLAGS=+ fi+fi+{ echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5+echo $ECHO_N "checking for $CC option to accept ISO C89... $ECHO_C" >&6; }+if test "${ac_cv_prog_cc_c89+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ ac_cv_prog_cc_c89=no+ac_save_CC=$CC+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <stdarg.h>+#include <stdio.h>+#include <sys/types.h>+#include <sys/stat.h>+/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */+struct buf { int x; };+FILE * (*rcsopen) (struct buf *, struct stat *, int);+static char *e (p, i)+ char **p;+ int i;+{+ return p[i];+}+static char *f (char * (*g) (char **, int), char **p, ...)+{+ char *s;+ va_list v;+ va_start (v,p);+ s = g (p, va_arg (v,int));+ va_end (v);+ return s;+}++/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has+ function prototypes and stuff, but not '\xHH' hex character constants.+ These don't provoke an error unfortunately, instead are silently treated+ as 'x'. The following induces an error, until -std is added to get+ proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an+ array size at least. It's necessary to write '\x00'==0 to get something+ that's true only with -std. */+int osf4_cc_array ['\x00' == 0 ? 1 : -1];++/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters+ inside strings and character constants. */+#define FOO(x) 'x'+int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1];++int test (int i, double x);+struct s1 {int (*f) (int a);};+struct s2 {int (*f) (double a);};+int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);+int argc;+char **argv;+int+main ()+{+return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];+ ;+ return 0;+}+_ACEOF+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"+do+ CC="$ac_save_CC $ac_arg"+ rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_cv_prog_cc_c89=$ac_arg+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext+ test "x$ac_cv_prog_cc_c89" != "xno" && break+done+rm -f conftest.$ac_ext+CC=$ac_save_CC++fi+# AC_CACHE_VAL+case "x$ac_cv_prog_cc_c89" in+ x)+ { echo "$as_me:$LINENO: result: none needed" >&5+echo "${ECHO_T}none needed" >&6; } ;;+ xno)+ { echo "$as_me:$LINENO: result: unsupported" >&5+echo "${ECHO_T}unsupported" >&6; } ;;+ *)+ CC="$CC $ac_cv_prog_cc_c89"+ { echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5+echo "${ECHO_T}$ac_cv_prog_cc_c89" >&6; } ;;+esac+++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu++ac_aux_dir=+for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do+ if test -f "$ac_dir/install-sh"; then+ ac_aux_dir=$ac_dir+ ac_install_sh="$ac_aux_dir/install-sh -c"+ break+ elif test -f "$ac_dir/install.sh"; then+ ac_aux_dir=$ac_dir+ ac_install_sh="$ac_aux_dir/install.sh -c"+ break+ elif test -f "$ac_dir/shtool"; then+ ac_aux_dir=$ac_dir+ ac_install_sh="$ac_aux_dir/shtool install -c"+ break+ fi+done+if test -z "$ac_aux_dir"; then+ { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5+echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;}+ { (exit 1); exit 1; }; }+fi++# These three variables are undocumented and unsupported,+# and are intended to be withdrawn in a future Autoconf release.+# They can cause serious problems if a builder's source tree is in a directory+# whose full name contains unusual characters.+ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var.+ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var.+ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var.+++# Find a good install program. We prefer a C program (faster),+# so one script is as good as another. But avoid the broken or+# incompatible versions:+# SysV /etc/install, /usr/sbin/install+# SunOS /usr/etc/install+# IRIX /sbin/install+# AIX /bin/install+# AmigaOS /C/install, which installs bootblocks on floppy discs+# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag+# AFS /usr/afsws/bin/install, which mishandles nonexistent args+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"+# OS/2's system install, which has a completely different semantic+# ./install, which can be erroneously created by make from ./install.sh.+{ echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5+echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6; }+if test -z "$INSTALL"; then+if test "${ac_cv_path_install+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ # Account for people who put trailing slashes in PATH elements.+case $as_dir/ in+ ./ | .// | /cC/* | \+ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \+ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \+ /usr/ucb/* ) ;;+ *)+ # OSF1 and SCO ODT 3.0 have their own names for install.+ # Don't use installbsd from OSF since it installs stuff as root+ # by default.+ for ac_prog in ginstall scoinst install; do+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then+ if test $ac_prog = install &&+ grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then+ # AIX install. It has an incompatible calling convention.+ :+ elif test $ac_prog = install &&+ grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then+ # program-specific install script used by HP pwplus--don't use.+ :+ else+ ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c"+ break 3+ fi+ fi+ done+ done+ ;;+esac+done+IFS=$as_save_IFS+++fi+ if test "${ac_cv_path_install+set}" = set; then+ INSTALL=$ac_cv_path_install+ else+ # As a last resort, use the slow shell script. Don't cache a+ # value for INSTALL within a source directory, because that will+ # break other packages using the cache if that directory is+ # removed, or if the value is a relative name.+ INSTALL=$ac_install_sh+ fi+fi+{ echo "$as_me:$LINENO: result: $INSTALL" >&5+echo "${ECHO_T}$INSTALL" >&6; }++# Use test -z because SunOS4 sh mishandles braces in ${var-val}.+# It thinks the first close brace ends the variable substitution.+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'++test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}'++test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'+++# Force building 32-bit applications since we're not 64-bit clean.+#+# GCC accepts -m32 on most architectures that might have a corresponding+# 64-bit architecture, for example sparc and MIPS.++old_CFLAGS="$CFLAGS"+CFLAGS="$CFLAGS -m32"++cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{+return 1;++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ :+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ CFLAGS="$old_CFLAGS"++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++# Checks for libraries.++# Look for pthreads.+# Make sure we can run config.sub.+$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||+ { { echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5+echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;}+ { (exit 1); exit 1; }; }++{ echo "$as_me:$LINENO: checking build system type" >&5+echo $ECHO_N "checking build system type... $ECHO_C" >&6; }+if test "${ac_cv_build+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ ac_build_alias=$build_alias+test "x$ac_build_alias" = x &&+ ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"`+test "x$ac_build_alias" = x &&+ { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5+echo "$as_me: error: cannot guess build type; you must specify one" >&2;}+ { (exit 1); exit 1; }; }+ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;}+ { (exit 1); exit 1; }; }++fi+{ echo "$as_me:$LINENO: result: $ac_cv_build" >&5+echo "${ECHO_T}$ac_cv_build" >&6; }+case $ac_cv_build in+*-*-*) ;;+*) { { echo "$as_me:$LINENO: error: invalid value of canonical build" >&5+echo "$as_me: error: invalid value of canonical build" >&2;}+ { (exit 1); exit 1; }; };;+esac+build=$ac_cv_build+ac_save_IFS=$IFS; IFS='-'+set x $ac_cv_build+shift+build_cpu=$1+build_vendor=$2+shift; shift+# Remember, the first character of IFS is used to create $*,+# except with old shells:+build_os=$*+IFS=$ac_save_IFS+case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac+++{ echo "$as_me:$LINENO: checking host system type" >&5+echo $ECHO_N "checking host system type... $ECHO_C" >&6; }+if test "${ac_cv_host+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test "x$host_alias" = x; then+ ac_cv_host=$ac_cv_build+else+ ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` ||+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;}+ { (exit 1); exit 1; }; }+fi++fi+{ echo "$as_me:$LINENO: result: $ac_cv_host" >&5+echo "${ECHO_T}$ac_cv_host" >&6; }+case $ac_cv_host in+*-*-*) ;;+*) { { echo "$as_me:$LINENO: error: invalid value of canonical host" >&5+echo "$as_me: error: invalid value of canonical host" >&2;}+ { (exit 1); exit 1; }; };;+esac+host=$ac_cv_host+ac_save_IFS=$IFS; IFS='-'+set x $ac_cv_host+shift+host_cpu=$1+host_vendor=$2+shift; shift+# Remember, the first character of IFS is used to create $*,+# except with old shells:+host_os=$*+IFS=$ac_save_IFS+case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac++++++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu++acx_pthread_ok=no++# We used to check for pthread.h first, but this fails if pthread.h+# requires special compiler flags (e.g. on True64 or Sequent).+# It gets checked for in the link test anyway.++# First of all, check if the user has set any of the PTHREAD_LIBS,+# etcetera environment variables, and if threads linking works using+# them:+if test x"$PTHREAD_LIBS$PTHREAD_CFLAGS" != x; then+ save_CFLAGS="$CFLAGS"+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"+ save_LIBS="$LIBS"+ LIBS="$PTHREAD_LIBS $LIBS"+ { echo "$as_me:$LINENO: checking for pthread_join in LIBS=$PTHREAD_LIBS with CFLAGS=$PTHREAD_CFLAGS" >&5+echo $ECHO_N "checking for pthread_join in LIBS=$PTHREAD_LIBS with CFLAGS=$PTHREAD_CFLAGS... $ECHO_C" >&6; }+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++/* Override any GCC internal prototype to avoid an error.+ Use char because int might match the return type of a GCC+ builtin and then its argument prototype would still apply. */+#ifdef __cplusplus+extern "C"+#endif+char pthread_join ();+int+main ()+{+return pthread_join ();+ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext &&+ $as_test_x conftest$ac_exeext; then+ acx_pthread_ok=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+ conftest$ac_exeext conftest.$ac_ext+ { echo "$as_me:$LINENO: result: $acx_pthread_ok" >&5+echo "${ECHO_T}$acx_pthread_ok" >&6; }+ if test x"$acx_pthread_ok" = xno; then+ PTHREAD_LIBS=""+ PTHREAD_CFLAGS=""+ fi+ LIBS="$save_LIBS"+ CFLAGS="$save_CFLAGS"+fi++# We must check for the threads library under a number of different+# names; the ordering is very important because some systems+# (e.g. DEC) have both -lpthread and -lpthreads, where one of the+# libraries is broken (non-POSIX).++# Create a list of thread flags to try. Items starting with a "-" are+# C compiler flags, and other items are library names, except for "none"+# which indicates that we try without any flags at all, and "pthread-config"+# which is a program returning the flags for the Pth emulation library.++acx_pthread_flags="pthreads none -Kthread -kthread lthread -pthread -pthreads -mthreads pthread --thread-safe -mt pthread-config"++# The ordering *is* (sometimes) important. Some notes on the+# individual items follow:++# pthreads: AIX (must check this before -lpthread)+# none: in case threads are in libc; should be tried before -Kthread and+# other compiler flags to prevent continual compiler warnings+# -Kthread: Sequent (threads in libc, but -Kthread needed for pthread.h)+# -kthread: FreeBSD kernel threads (preferred to -pthread since SMP-able)+# lthread: LinuxThreads port on FreeBSD (also preferred to -pthread)+# -pthread: Linux/gcc (kernel threads), BSD/gcc (userland threads)+# -pthreads: Solaris/gcc+# -mthreads: Mingw32/gcc, Lynx/gcc+# -mt: Sun Workshop C (may only link SunOS threads [-lthread], but it+# doesn't hurt to check since this sometimes defines pthreads too;+# also defines -D_REENTRANT)+# ... -mt is also the pthreads flag for HP/aCC+# pthread: Linux, etcetera+# --thread-safe: KAI C+++# pthread-config: use pthread-config program (for GNU Pth library)++case "${host_cpu}-${host_os}" in+ *solaris*)++ # On Solaris (at least, for some versions), libc contains stubbed+ # (non-functional) versions of the pthreads routines, so link-based+ # tests will erroneously succeed. (We need to link with -pthreads/-mt/+ # -lpthread.) (The stubs are missing pthread_cleanup_push, or rather+ # a function called by this macro, so we could check for that, but+ # who knows whether they'll stub that too in a future libc.) So,+ # we'll just look for -pthreads and -lpthread first:++ acx_pthread_flags="-pthreads pthread -mt -pthread $acx_pthread_flags"+ ;;+esac++if test x"$acx_pthread_ok" = xno; then+for flag in $acx_pthread_flags; do++ case $flag in+ none)+ { echo "$as_me:$LINENO: checking whether pthreads work without any flags" >&5+echo $ECHO_N "checking whether pthreads work without any flags... $ECHO_C" >&6; }+ ;;++ -*)+ { echo "$as_me:$LINENO: checking whether pthreads work with $flag" >&5+echo $ECHO_N "checking whether pthreads work with $flag... $ECHO_C" >&6; }+ PTHREAD_CFLAGS="$flag"+ ;;++ pthread-config)+ # Extract the first word of "pthread-config", so it can be a program name with args.+set dummy pthread-config; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_acx_pthread_config+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$acx_pthread_config"; then+ ac_cv_prog_acx_pthread_config="$acx_pthread_config" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_acx_pthread_config="yes"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++ test -z "$ac_cv_prog_acx_pthread_config" && ac_cv_prog_acx_pthread_config="no"+fi+fi+acx_pthread_config=$ac_cv_prog_acx_pthread_config+if test -n "$acx_pthread_config"; then+ { echo "$as_me:$LINENO: result: $acx_pthread_config" >&5+echo "${ECHO_T}$acx_pthread_config" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ if test x"$acx_pthread_config" = xno; then continue; fi+ PTHREAD_CFLAGS="`pthread-config --cflags`"+ PTHREAD_LIBS="`pthread-config --ldflags` `pthread-config --libs`"+ ;;++ *)+ { echo "$as_me:$LINENO: checking for the pthreads library -l$flag" >&5+echo $ECHO_N "checking for the pthreads library -l$flag... $ECHO_C" >&6; }+ PTHREAD_LIBS="-l$flag"+ ;;+ esac++ save_LIBS="$LIBS"+ save_CFLAGS="$CFLAGS"+ LIBS="$PTHREAD_LIBS $LIBS"+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"++ # Check for various functions. We must include pthread.h,+ # since some functions may be macros. (On the Sequent, we+ # need a special flag -Kthread to make this header compile.)+ # We check for pthread_join because it is in -lpthread on IRIX+ # while pthread_create is in libc. We check for pthread_attr_init+ # due to DEC craziness with -lpthreads. We check for+ # pthread_cleanup_push because it is one of the few pthread+ # functions on Solaris that doesn't have a non-functional libc stub.+ # We try pthread_create on general principles.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <pthread.h>+int+main ()+{+pthread_t th; pthread_join(th, 0);+ pthread_attr_init(0); pthread_cleanup_push(0, 0);+ pthread_create(0,0,0,0); pthread_cleanup_pop(0);+ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext &&+ $as_test_x conftest$ac_exeext; then+ acx_pthread_ok=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+ conftest$ac_exeext conftest.$ac_ext++ LIBS="$save_LIBS"+ CFLAGS="$save_CFLAGS"++ { echo "$as_me:$LINENO: result: $acx_pthread_ok" >&5+echo "${ECHO_T}$acx_pthread_ok" >&6; }+ if test "x$acx_pthread_ok" = xyes; then+ break;+ fi++ PTHREAD_LIBS=""+ PTHREAD_CFLAGS=""+done+fi++# Various other checks:+if test "x$acx_pthread_ok" = xyes; then+ save_LIBS="$LIBS"+ LIBS="$PTHREAD_LIBS $LIBS"+ save_CFLAGS="$CFLAGS"+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"++ # Detect AIX lossage: JOINABLE attribute is called UNDETACHED.+ { echo "$as_me:$LINENO: checking for joinable pthread attribute" >&5+echo $ECHO_N "checking for joinable pthread attribute... $ECHO_C" >&6; }+ attr_name=unknown+ for attr in PTHREAD_CREATE_JOINABLE PTHREAD_CREATE_UNDETACHED; do+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <pthread.h>+int+main ()+{+int attr=$attr; return attr;+ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext &&+ $as_test_x conftest$ac_exeext; then+ attr_name=$attr; break+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+ conftest$ac_exeext conftest.$ac_ext+ done+ { echo "$as_me:$LINENO: result: $attr_name" >&5+echo "${ECHO_T}$attr_name" >&6; }+ if test "$attr_name" != PTHREAD_CREATE_JOINABLE; then++cat >>confdefs.h <<_ACEOF+#define PTHREAD_CREATE_JOINABLE $attr_name+_ACEOF++ fi++ { echo "$as_me:$LINENO: checking if more special flags are required for pthreads" >&5+echo $ECHO_N "checking if more special flags are required for pthreads... $ECHO_C" >&6; }+ flag=no+ case "${host_cpu}-${host_os}" in+ *-aix* | *-freebsd* | *-darwin*) flag="-D_THREAD_SAFE";;+ *solaris* | *-osf* | *-hpux*) flag="-D_REENTRANT";;+ esac+ { echo "$as_me:$LINENO: result: ${flag}" >&5+echo "${ECHO_T}${flag}" >&6; }+ if test "x$flag" != xno; then+ PTHREAD_CFLAGS="$flag $PTHREAD_CFLAGS"+ fi++ LIBS="$save_LIBS"+ CFLAGS="$save_CFLAGS"++ # More AIX lossage: must compile with xlc_r or cc_r+ if test x"$GCC" != xyes; then+ for ac_prog in xlc_r cc_r+do+ # Extract the first word of "$ac_prog", so it can be a program name with args.+set dummy $ac_prog; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_PTHREAD_CC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$PTHREAD_CC"; then+ ac_cv_prog_PTHREAD_CC="$PTHREAD_CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_PTHREAD_CC="$ac_prog"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+PTHREAD_CC=$ac_cv_prog_PTHREAD_CC+if test -n "$PTHREAD_CC"; then+ { echo "$as_me:$LINENO: result: $PTHREAD_CC" >&5+echo "${ECHO_T}$PTHREAD_CC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ test -n "$PTHREAD_CC" && break+done+test -n "$PTHREAD_CC" || PTHREAD_CC="${CC}"++ else+ PTHREAD_CC=$CC+ fi+else+ PTHREAD_CC="$CC"+fi++++++# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND:+if test x"$acx_pthread_ok" = xyes; then++cat >>confdefs.h <<\_ACEOF+#define HAVE_PTHREAD 1+_ACEOF++ :+else+ acx_pthread_ok=no++fi+ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu++++if test "$THREAD_SUPPORT" = "no"; then+ { { echo "$as_me:$LINENO: error: Cannot enable threads on this platform." >&5+echo "$as_me: error: Cannot enable threads on this platform." >&2;}+ { (exit 1); exit 1; }; }+fi++CC="$PTHREAD_CC"+CFLAGS="$CFLAGS $PTHREAD_CFLAGS"+LIBS="$PTHREAD_LIBS $LIBS"++# Make sure that pthread realtime-threads extension is available. This is+# not the default behaviour on most GNU/Linux dists. If it turns out that+# the realtime-threads extension is not available we add -D_GNU_SOURCE=1+# as this should enable all extensions on most GNU/Linux dists. For more+# information please see <features.h>.+{ echo "$as_me:$LINENO: checking pthread realtime-threads extension" >&5+echo $ECHO_N "checking pthread realtime-threads extension... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <pthread.h>+int+main ()+{+pthread_mutexattr_setprotocol(NULL, PTHREAD_PRIO_INHERIT);++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ need_gnu_source=no+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ need_gnu_source=yes++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++if test "x$need_gnu_source" = "xyes"; then+ CFLAGS="$CFLAGS -D_GNU_SOURCE=1"+fi++# Finalize the checking for pthread realtime-threads extension. This may+# still fail if -D_GNU_SOURCE=1 does not enable the realtime-threads+# extension. I this is the case then we are either running this on a+# system without the realtime-threads extension or we need to perform some+# other kind of black magic to enable it. If you know of any such platform+# then please feel free to send a patch.+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <pthread.h>+int+main ()+{+pthread_mutexattr_setprotocol(NULL, PTHREAD_PRIO_INHERIT);++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ { { echo "$as_me:$LINENO: error: no+See \`config.log' for more details." >&5+echo "$as_me: error: no+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+++# Check whether --with-timberc was given.+if test "${with_timberc+set}" = set; then+ withval=$with_timberc; with_timberc=$withval++fi+++if test "x$with_timberc" = "x"; then+ for ac_prog in timberc+do+ # Extract the first word of "$ac_prog", so it can be a program name with args.+set dummy $ac_prog; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_TIMBERC+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$TIMBERC"; then+ ac_cv_prog_TIMBERC="$TIMBERC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_TIMBERC="$ac_prog"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+TIMBERC=$ac_cv_prog_TIMBERC+if test -n "$TIMBERC"; then+ { echo "$as_me:$LINENO: result: $TIMBERC" >&5+echo "${ECHO_T}$TIMBERC" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ test -n "$TIMBERC" && break+done++else+ TIMBERC="$with_timberc"+fi++if test "x$TIMBERC" = "x"; then+ { { echo "$as_me:$LINENO: error: Timberc not found." >&5+echo "$as_me: error: Timberc not found." >&2;}+ { (exit 1); exit 1; }; }+fi++# Checks for header files.+ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu+{ echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5+echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6; }+# On Suns, sometimes $CPP names a directory.+if test -n "$CPP" && test -d "$CPP"; then+ CPP=+fi+if test -z "$CPP"; then+ if test "${ac_cv_prog_CPP+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ # Double quotes because CPP needs to be expanded+ for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"+ do+ ac_preproc_ok=false+for ac_c_preproc_warn_flag in '' yes+do+ # Use a header file that comes with gcc, so configuring glibc+ # with a fresh cross-compiler works.+ # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+ # <limits.h> exists even on freestanding compilers.+ # On the NeXT, cc -E runs the code through the compiler's parser,+ # not just through cpp. "Syntax error" is here to catch this case.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif+ Syntax error+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ :+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ # Broken: fails on valid input.+continue+fi++rm -f conftest.err conftest.$ac_ext++ # OK, works on sane cases. Now check whether nonexistent headers+ # can be detected and how.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <ac_nonexistent.h>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ # Broken: success on invalid input.+continue+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ # Passes both tests.+ac_preproc_ok=:+break+fi++rm -f conftest.err conftest.$ac_ext++done+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.+rm -f conftest.err conftest.$ac_ext+if $ac_preproc_ok; then+ break+fi++ done+ ac_cv_prog_CPP=$CPP++fi+ CPP=$ac_cv_prog_CPP+else+ ac_cv_prog_CPP=$CPP+fi+{ echo "$as_me:$LINENO: result: $CPP" >&5+echo "${ECHO_T}$CPP" >&6; }+ac_preproc_ok=false+for ac_c_preproc_warn_flag in '' yes+do+ # Use a header file that comes with gcc, so configuring glibc+ # with a fresh cross-compiler works.+ # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+ # <limits.h> exists even on freestanding compilers.+ # On the NeXT, cc -E runs the code through the compiler's parser,+ # not just through cpp. "Syntax error" is here to catch this case.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif+ Syntax error+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ :+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ # Broken: fails on valid input.+continue+fi++rm -f conftest.err conftest.$ac_ext++ # OK, works on sane cases. Now check whether nonexistent headers+ # can be detected and how.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <ac_nonexistent.h>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ # Broken: success on invalid input.+continue+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ # Passes both tests.+ac_preproc_ok=:+break+fi++rm -f conftest.err conftest.$ac_ext++done+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.+rm -f conftest.err conftest.$ac_ext+if $ac_preproc_ok; then+ :+else+ { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check+See \`config.log' for more details." >&5+echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }+fi++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu+++{ echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5+echo $ECHO_N "checking for grep that handles long lines and -e... $ECHO_C" >&6; }+if test "${ac_cv_path_GREP+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ # Extract the first word of "grep ggrep" to use in msg output+if test -z "$GREP"; then+set dummy grep ggrep; ac_prog_name=$2+if test "${ac_cv_path_GREP+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ ac_path_GREP_found=false+# Loop through the user's path and test for each of PROGNAME-LIST+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_prog in grep ggrep; do+ for ac_exec_ext in '' $ac_executable_extensions; do+ ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext"+ { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue+ # Check for GNU ac_path_GREP and select it if it is found.+ # Check for GNU $ac_path_GREP+case `"$ac_path_GREP" --version 2>&1` in+*GNU*)+ ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;+*)+ ac_count=0+ echo $ECHO_N "0123456789$ECHO_C" >"conftest.in"+ while :+ do+ cat "conftest.in" "conftest.in" >"conftest.tmp"+ mv "conftest.tmp" "conftest.in"+ cp "conftest.in" "conftest.nl"+ echo 'GREP' >> "conftest.nl"+ "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break+ ac_count=`expr $ac_count + 1`+ if test $ac_count -gt ${ac_path_GREP_max-0}; then+ # Best one so far, save it but keep looking for a better one+ ac_cv_path_GREP="$ac_path_GREP"+ ac_path_GREP_max=$ac_count+ fi+ # 10*(2^10) chars as input seems more than enough+ test $ac_count -gt 10 && break+ done+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;+esac+++ $ac_path_GREP_found && break 3+ done+done++done+IFS=$as_save_IFS+++fi++GREP="$ac_cv_path_GREP"+if test -z "$GREP"; then+ { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5+echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;}+ { (exit 1); exit 1; }; }+fi++else+ ac_cv_path_GREP=$GREP+fi+++fi+{ echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5+echo "${ECHO_T}$ac_cv_path_GREP" >&6; }+ GREP="$ac_cv_path_GREP"+++{ echo "$as_me:$LINENO: checking for egrep" >&5+echo $ECHO_N "checking for egrep... $ECHO_C" >&6; }+if test "${ac_cv_path_EGREP+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if echo a | $GREP -E '(a|b)' >/dev/null 2>&1+ then ac_cv_path_EGREP="$GREP -E"+ else+ # Extract the first word of "egrep" to use in msg output+if test -z "$EGREP"; then+set dummy egrep; ac_prog_name=$2+if test "${ac_cv_path_EGREP+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ ac_path_EGREP_found=false+# Loop through the user's path and test for each of PROGNAME-LIST+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_prog in egrep; do+ for ac_exec_ext in '' $ac_executable_extensions; do+ ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext"+ { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue+ # Check for GNU ac_path_EGREP and select it if it is found.+ # Check for GNU $ac_path_EGREP+case `"$ac_path_EGREP" --version 2>&1` in+*GNU*)+ ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;+*)+ ac_count=0+ echo $ECHO_N "0123456789$ECHO_C" >"conftest.in"+ while :+ do+ cat "conftest.in" "conftest.in" >"conftest.tmp"+ mv "conftest.tmp" "conftest.in"+ cp "conftest.in" "conftest.nl"+ echo 'EGREP' >> "conftest.nl"+ "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break+ ac_count=`expr $ac_count + 1`+ if test $ac_count -gt ${ac_path_EGREP_max-0}; then+ # Best one so far, save it but keep looking for a better one+ ac_cv_path_EGREP="$ac_path_EGREP"+ ac_path_EGREP_max=$ac_count+ fi+ # 10*(2^10) chars as input seems more than enough+ test $ac_count -gt 10 && break+ done+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;+esac+++ $ac_path_EGREP_found && break 3+ done+done++done+IFS=$as_save_IFS+++fi++EGREP="$ac_cv_path_EGREP"+if test -z "$EGREP"; then+ { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5+echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;}+ { (exit 1); exit 1; }; }+fi++else+ ac_cv_path_EGREP=$EGREP+fi+++ fi+fi+{ echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5+echo "${ECHO_T}$ac_cv_path_EGREP" >&6; }+ EGREP="$ac_cv_path_EGREP"+++{ echo "$as_me:$LINENO: checking for ANSI C header files" >&5+echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6; }+if test "${ac_cv_header_stdc+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <stdlib.h>+#include <stdarg.h>+#include <string.h>+#include <float.h>++int+main ()+{++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_cv_header_stdc=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_cv_header_stdc=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++if test $ac_cv_header_stdc = yes; then+ # SunOS 4.x string.h does not declare mem*, contrary to ANSI.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <string.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+ $EGREP "memchr" >/dev/null 2>&1; then+ :+else+ ac_cv_header_stdc=no+fi+rm -f conftest*++fi++if test $ac_cv_header_stdc = yes; then+ # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <stdlib.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+ $EGREP "free" >/dev/null 2>&1; then+ :+else+ ac_cv_header_stdc=no+fi+rm -f conftest*++fi++if test $ac_cv_header_stdc = yes; then+ # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.+ if test "$cross_compiling" = yes; then+ :+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <ctype.h>+#include <stdlib.h>+#if ((' ' & 0x0FF) == 0x020)+# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')+# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))+#else+# define ISLOWER(c) \+ (('a' <= (c) && (c) <= 'i') \+ || ('j' <= (c) && (c) <= 'r') \+ || ('s' <= (c) && (c) <= 'z'))+# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))+#endif++#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))+int+main ()+{+ int i;+ for (i = 0; i < 256; i++)+ if (XOR (islower (i), ISLOWER (i))+ || toupper (i) != TOUPPER (i))+ return 2;+ return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+ { (case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_try") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }; }; then+ :+else+ echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+ac_cv_header_stdc=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++fi+fi+{ echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5+echo "${ECHO_T}$ac_cv_header_stdc" >&6; }+if test $ac_cv_header_stdc = yes; then++cat >>confdefs.h <<\_ACEOF+#define STDC_HEADERS 1+_ACEOF++fi++# On IRIX 5.3, sys/types and inttypes.h are conflicting.++++++++++for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \+ inttypes.h stdint.h unistd.h+do+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+$ac_includes_default++#include <$ac_header>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ eval "$as_ac_Header=yes"+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ eval "$as_ac_Header=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+ { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_Header'}'` = yes; then+ cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1+_ACEOF++fi++done++++++for ac_header in stdlib.h sys/time.h termios.h+do+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ { echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+ { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+else+ # Is the header compilable?+{ echo "$as_me:$LINENO: checking $ac_header usability" >&5+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+$ac_includes_default+#include <$ac_header>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_header_compiler=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_header_compiler=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5+echo "${ECHO_T}$ac_header_compiler" >&6; }++# Is the header present?+{ echo "$as_me:$LINENO: checking $ac_header presence" >&5+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <$ac_header>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ ac_header_preproc=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_header_preproc=no+fi++rm -f conftest.err conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5+echo "${ECHO_T}$ac_header_preproc" >&6; }++# So? What about this header?+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in+ yes:no: )+ { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}+ ac_header_preproc=yes+ ;;+ no:yes:* )+ { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5+echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5+echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5+echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5+echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}+ ( cat <<\_ASBOX+## ----------------------------------- ##+## Report this to nordland@csee.ltu.se ##+## ----------------------------------- ##+_ASBOX+ ) | sed "s/^/$as_me: WARNING: /" >&2+ ;;+esac+{ echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ eval "$as_ac_Header=\$ac_header_preproc"+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+ { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }++fi+if test `eval echo '${'$as_ac_Header'}'` = yes; then+ cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1+_ACEOF++fi++done+++if test "${ac_cv_header_libkern_OSAtomic_h+set}" = set; then+ { echo "$as_me:$LINENO: checking for libkern/OSAtomic.h" >&5+echo $ECHO_N "checking for libkern/OSAtomic.h... $ECHO_C" >&6; }+if test "${ac_cv_header_libkern_OSAtomic_h+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+fi+{ echo "$as_me:$LINENO: result: $ac_cv_header_libkern_OSAtomic_h" >&5+echo "${ECHO_T}$ac_cv_header_libkern_OSAtomic_h" >&6; }+else+ # Is the header compilable?+{ echo "$as_me:$LINENO: checking libkern/OSAtomic.h usability" >&5+echo $ECHO_N "checking libkern/OSAtomic.h usability... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+$ac_includes_default+#include <libkern/OSAtomic.h>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_header_compiler=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_header_compiler=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5+echo "${ECHO_T}$ac_header_compiler" >&6; }++# Is the header present?+{ echo "$as_me:$LINENO: checking libkern/OSAtomic.h presence" >&5+echo $ECHO_N "checking libkern/OSAtomic.h presence... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <libkern/OSAtomic.h>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ ac_header_preproc=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_header_preproc=no+fi++rm -f conftest.err conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5+echo "${ECHO_T}$ac_header_preproc" >&6; }++# So? What about this header?+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in+ yes:no: )+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: accepted by the compiler, rejected by the preprocessor!" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: accepted by the compiler, rejected by the preprocessor!" >&2;}+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: proceeding with the compiler's result" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: proceeding with the compiler's result" >&2;}+ ac_header_preproc=yes+ ;;+ no:yes:* )+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: present but cannot be compiled" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: present but cannot be compiled" >&2;}+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: check for missing prerequisite headers?" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: check for missing prerequisite headers?" >&2;}+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: see the Autoconf documentation" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: see the Autoconf documentation" >&2;}+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: section \"Present But Cannot Be Compiled\"" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: section \"Present But Cannot Be Compiled\"" >&2;}+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: proceeding with the preprocessor's result" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: proceeding with the preprocessor's result" >&2;}+ { echo "$as_me:$LINENO: WARNING: libkern/OSAtomic.h: in the future, the compiler will take precedence" >&5+echo "$as_me: WARNING: libkern/OSAtomic.h: in the future, the compiler will take precedence" >&2;}+ ( cat <<\_ASBOX+## ----------------------------------- ##+## Report this to nordland@csee.ltu.se ##+## ----------------------------------- ##+_ASBOX+ ) | sed "s/^/$as_me: WARNING: /" >&2+ ;;+esac+{ echo "$as_me:$LINENO: checking for libkern/OSAtomic.h" >&5+echo $ECHO_N "checking for libkern/OSAtomic.h... $ECHO_C" >&6; }+if test "${ac_cv_header_libkern_OSAtomic_h+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ ac_cv_header_libkern_OSAtomic_h=$ac_header_preproc+fi+{ echo "$as_me:$LINENO: result: $ac_cv_header_libkern_OSAtomic_h" >&5+echo "${ECHO_T}$ac_cv_header_libkern_OSAtomic_h" >&6; }++fi+if test $ac_cv_header_libkern_OSAtomic_h = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_OSX_ATOMICS 1+_ACEOF++fi++++# Check the <sys/stat.h> header for XSI extensions. This should already be+# enable by -D_GNU_SOURCE=1, if it's supported.+# NOTE:+# While it might be possible for the compiler to optimize away the int xsi+# statement I'm not up for the challenge of writing something that is+# _impossible_ for the compiler to optimize away.+{ echo "$as_me:$LINENO: checking sys/stat.h header for XSI extensions" >&5+echo $ECHO_N "checking sys/stat.h header for XSI extensions... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <sys/stat.h>+int+main ()+{+mode_t mode_xsi = S_IWUSR|S_IRUSR|S_IRGRP|S_IROTH;++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ { { echo "$as_me:$LINENO: error: no+See \`config.log' for more details." >&5+echo "$as_me: error: no+See \`config.log' for more details." >&2;}+ { (exit 1); exit 1; }; }++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++# Does this compiler have built-in functions for atomic memory access?+{ echo "$as_me:$LINENO: checking if gcc supports __sync_bool_compare_and_swap" >&5+echo $ECHO_N "checking if gcc supports __sync_bool_compare_and_swap... $ECHO_C" >&6; }++cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ int variable = 1;+ return (__sync_bool_compare_and_swap(&variable, 1, 2)+ && __sync_add_and_fetch(&variable, 1)) ? 1 : 0;++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext &&+ $as_test_x conftest$ac_exeext; then++ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }++cat >>confdefs.h <<\_ACEOF+#define HAVE_BUILTIN_ATOMIC 1+_ACEOF+++else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++ # Retry with -march set for x86.+ old_CFLAGS="$CFLAGS"+ CFLAGS="$CFLAGS -march=i686"+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */++int+main ()+{++ int variable = 1;+ return (__sync_bool_compare_and_swap(&variable, 1, 2)+ && __sync_add_and_fetch(&variable, 1)) ? 1 : 0;++ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext &&+ $as_test_x conftest$ac_exeext; then++ { echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }++cat >>confdefs.h <<\_ACEOF+#define HAVE_BUILTIN_ATOMIC 1+_ACEOF+++else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+ CFLAGS="$old_CFLAGS"++fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+ conftest$ac_exeext conftest.$ac_ext++fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+ conftest$ac_exeext conftest.$ac_ext++# Checks for typedefs, structures, and compiler characteristics.+{ echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5+echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6; }+if test "${ac_cv_header_time+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <sys/types.h>+#include <sys/time.h>+#include <time.h>++int+main ()+{+if ((struct tm *) 0)+return 0;+ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_cv_header_time=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_cv_header_time=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5+echo "${ECHO_T}$ac_cv_header_time" >&6; }+if test $ac_cv_header_time = yes; then++cat >>confdefs.h <<\_ACEOF+#define TIME_WITH_SYS_TIME 1+_ACEOF++fi+++# Look for the timber compiler++# Checks for library functions.++for ac_header in stdlib.h+do+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ { echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+ { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+else+ # Is the header compilable?+{ echo "$as_me:$LINENO: checking $ac_header usability" >&5+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+$ac_includes_default+#include <$ac_header>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_compile") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then+ ac_header_compiler=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_header_compiler=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5+echo "${ECHO_T}$ac_header_compiler" >&6; }++# Is the header present?+{ echo "$as_me:$LINENO: checking $ac_header presence" >&5+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#include <$ac_header>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } >/dev/null && {+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+ test ! -s conftest.err+ }; then+ ac_header_preproc=yes+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_header_preproc=no+fi++rm -f conftest.err conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5+echo "${ECHO_T}$ac_header_preproc" >&6; }++# So? What about this header?+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in+ yes:no: )+ { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}+ ac_header_preproc=yes+ ;;+ no:yes:* )+ { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5+echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5+echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5+echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}+ { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5+echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}+ ( cat <<\_ASBOX+## ----------------------------------- ##+## Report this to nordland@csee.ltu.se ##+## ----------------------------------- ##+_ASBOX+ ) | sed "s/^/$as_me: WARNING: /" >&2+ ;;+esac+{ echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ eval "$as_ac_Header=\$ac_header_preproc"+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+ { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }++fi+if test `eval echo '${'$as_ac_Header'}'` = yes; then+ cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1+_ACEOF++fi++done++{ echo "$as_me:$LINENO: checking for GNU libc compatible malloc" >&5+echo $ECHO_N "checking for GNU libc compatible malloc... $ECHO_C" >&6; }+if test "${ac_cv_func_malloc_0_nonnull+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test "$cross_compiling" = yes; then+ ac_cv_func_malloc_0_nonnull=no+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+#if defined STDC_HEADERS || defined HAVE_STDLIB_H+# include <stdlib.h>+#else+char *malloc ();+#endif++int+main ()+{+return ! malloc (0);+ ;+ return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+ { (case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_try") 2>&5+ ac_status=$?+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); }; }; then+ ac_cv_func_malloc_0_nonnull=yes+else+ echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+ac_cv_func_malloc_0_nonnull=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++fi+{ echo "$as_me:$LINENO: result: $ac_cv_func_malloc_0_nonnull" >&5+echo "${ECHO_T}$ac_cv_func_malloc_0_nonnull" >&6; }+if test $ac_cv_func_malloc_0_nonnull = yes; then++cat >>confdefs.h <<\_ACEOF+#define HAVE_MALLOC 1+_ACEOF++else+ cat >>confdefs.h <<\_ACEOF+#define HAVE_MALLOC 0+_ACEOF++ case " $LIBOBJS " in+ *" malloc.$ac_objext "* ) ;;+ *) LIBOBJS="$LIBOBJS malloc.$ac_objext"+ ;;+esac+++cat >>confdefs.h <<\_ACEOF+#define malloc rpl_malloc+_ACEOF++fi+++++for ac_func in gettimeofday+do+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_func" >&5+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h. */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h. */+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.+ For example, HP-UX 11i <limits.h> declares gettimeofday. */+#define $ac_func innocuous_$ac_func++/* System header to define __stub macros and hopefully few prototypes,+ which can conflict with char $ac_func (); below.+ Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+ <limits.h> exists even on freestanding compilers. */++#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif++#undef $ac_func++/* Override any GCC internal prototype to avoid an error.+ Use char because int might match the return type of a GCC+ builtin and then its argument prototype would still apply. */+#ifdef __cplusplus+extern "C"+#endif+char $ac_func ();+/* The GNU C library defines this for functions which it implements+ to always fail with ENOSYS. Some functions are actually named+ something starting with __ and the normal name is an alias. */+#if defined __stub_$ac_func || defined __stub___$ac_func+choke me+#endif++int+main ()+{+return $ac_func ();+ ;+ return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+ (eval "$ac_link") 2>conftest.er1+ ac_status=$?+ grep -v '^ *+' conftest.er1 >conftest.err+ rm -f conftest.er1+ cat conftest.err >&5+ echo "$as_me:$LINENO: \$? = $ac_status" >&5+ (exit $ac_status); } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext &&+ $as_test_x conftest$ac_exeext; then+ eval "$as_ac_var=yes"+else+ echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ eval "$as_ac_var=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+ conftest$ac_exeext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_var'}'`+ { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_var'}'` = yes; then+ cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1+_ACEOF++fi+done+++++++++++ac_config_files="$ac_config_files Makefile timberc.cfg"++cat >confcache <<\_ACEOF+# This file is a shell script that caches the results of configure+# tests run on this system so they can be shared between configure+# scripts and configure runs, see configure's option --config-cache.+# It is not useful on other systems. If it contains results you don't+# want to keep, you may remove or edit it.+#+# config.status only pays attention to the cache file if you give it+# the --recheck option to rerun configure.+#+# `ac_cv_env_foo' variables (set or unset) will be overridden when+# loading this file, other *unset* `ac_cv_foo' will be assigned the+# following values.++_ACEOF++# The following way of writing the cache mishandles newlines in values,+# but we know of no workaround that is simple, portable, and efficient.+# So, we kill variables containing newlines.+# Ultrix sh set writes to stderr and can't be redirected directly,+# and sets the high bit in the cache file unless we assign to the vars.+(+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do+ eval ac_val=\$$ac_var+ case $ac_val in #(+ *${as_nl}*)+ case $ac_var in #(+ *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;+ esac+ case $ac_var in #(+ _ | IFS | as_nl) ;; #(+ *) $as_unset $ac_var ;;+ esac ;;+ esac+ done++ (set) 2>&1 |+ case $as_nl`(ac_space=' '; set) 2>&1` in #(+ *${as_nl}ac_space=\ *)+ # `set' does not quote correctly, so add quotes (double-quote+ # substitution turns \\\\ into \\, and sed turns \\ into \).+ sed -n \+ "s/'/'\\\\''/g;+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"+ ;; #(+ *)+ # `set' quotes correctly as required by POSIX, so do not add quotes.+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"+ ;;+ esac |+ sort+) |+ sed '+ /^ac_cv_env_/b end+ t clear+ :clear+ s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/+ t end+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/+ :end' >>confcache+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else+ if test -w "$cache_file"; then+ test "x$cache_file" != "x/dev/null" &&+ { echo "$as_me:$LINENO: updating cache $cache_file" >&5+echo "$as_me: updating cache $cache_file" >&6;}+ cat confcache >$cache_file+ else+ { echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5+echo "$as_me: not updating unwritable cache $cache_file" >&6;}+ fi+fi+rm -f confcache++test "x$prefix" = xNONE && prefix=$ac_default_prefix+# Let make expand exec_prefix.+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'++DEFS=-DHAVE_CONFIG_H++ac_libobjs=+ac_ltlibobjs=+for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue+ # 1. Remove the extension, and $U if already installed.+ ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'+ ac_i=`echo "$ac_i" | sed "$ac_script"`+ # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR+ # will be set to the directory where LIBOBJS objects are built.+ ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"+ ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'+done+LIBOBJS=$ac_libobjs++LTLIBOBJS=$ac_ltlibobjs++++: ${CONFIG_STATUS=./config.status}+ac_clean_files_save=$ac_clean_files+ac_clean_files="$ac_clean_files $CONFIG_STATUS"+{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5+echo "$as_me: creating $CONFIG_STATUS" >&6;}+cat >$CONFIG_STATUS <<_ACEOF+#! $SHELL+# Generated by $as_me.+# Run this file to recreate the current configuration.+# Compiler output produced by configure, useful for debugging+# configure, is in config.log if it exists.++debug=false+ac_cs_recheck=false+ac_cs_silent=false+SHELL=\${CONFIG_SHELL-$SHELL}+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+## --------------------- ##+## M4sh Initialization. ##+## --------------------- ##++# Be more Bourne compatible+DUALCASE=1; export DUALCASE # for MKS sh+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+ emulate sh+ NULLCMD=:+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '${1+"$@"}'='"$@"'+ setopt NO_GLOB_SUBST+else+ case `(set -o) 2>/dev/null` in+ *posix*) set -o posix ;;+esac++fi+++++# PATH needs CR+# Avoid depending upon Character Ranges.+as_cr_letters='abcdefghijklmnopqrstuvwxyz'+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'+as_cr_Letters=$as_cr_letters$as_cr_LETTERS+as_cr_digits='0123456789'+as_cr_alnum=$as_cr_Letters$as_cr_digits++# The user is always right.+if test "${PATH_SEPARATOR+set}" != set; then+ echo "#! /bin/sh" >conf$$.sh+ echo "exit 0" >>conf$$.sh+ chmod +x conf$$.sh+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then+ PATH_SEPARATOR=';'+ else+ PATH_SEPARATOR=:+ fi+ rm -f conf$$.sh+fi++# Support unset when possible.+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then+ as_unset=unset+else+ as_unset=false+fi+++# IFS+# We need space, tab and new line, in precisely that order. Quoting is+# there to prevent editors from complaining about space-tab.+# (If _AS_PATH_WALK were called with IFS unset, it would disable word+# splitting by setting IFS to empty value.)+as_nl='+'+IFS=" "" $as_nl"++# Find who we are. Look in the path if we contain no directory separator.+case $0 in+ *[\\/]* ) as_myself=$0 ;;+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break+done+IFS=$as_save_IFS++ ;;+esac+# We did not find ourselves, most probably we were run as `sh COMMAND'+# in which case we are not to be found in the path.+if test "x$as_myself" = x; then+ as_myself=$0+fi+if test ! -f "$as_myself"; then+ echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2+ { (exit 1); exit 1; }+fi++# Work around bugs in pre-3.0 UWIN ksh.+for as_var in ENV MAIL MAILPATH+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+done+PS1='$ '+PS2='> '+PS4='+ '++# NLS nuisances.+for as_var in \+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \+ LC_TELEPHONE LC_TIME+do+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then+ eval $as_var=C; export $as_var+ else+ ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+ fi+done++# Required to use basename.+if expr a : '\(a\)' >/dev/null 2>&1 &&+ test "X`expr 00001 : '.*\(...\)'`" = X001; then+ as_expr=expr+else+ as_expr=false+fi++if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then+ as_basename=basename+else+ as_basename=false+fi+++# Name of the executable.+as_me=`$as_basename -- "$0" ||+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \+ X"$0" : 'X\(//\)$' \| \+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||+echo X/"$0" |+ sed '/^.*\/\([^/][^/]*\)\/*$/{+ s//\1/+ q+ }+ /^X\/\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\/\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`++# CDPATH.+$as_unset CDPATH++++ as_lineno_1=$LINENO+ as_lineno_2=$LINENO+ test "x$as_lineno_1" != "x$as_lineno_2" &&+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {++ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO+ # uniformly replaced by the line number. The first 'sed' inserts a+ # line-number line after each line using $LINENO; the second 'sed'+ # does the real work. The second script uses 'N' to pair each+ # line-number line with the line containing $LINENO, and appends+ # trailing '-' during substitution so that $LINENO is not a special+ # case at line end.+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the+ # scripts with optimization help from Paolo Bonzini. Blame Lee+ # E. McMahon (1931-1989) for sed's syntax. :-)+ sed -n '+ p+ /[$]LINENO/=+ ' <$as_myself |+ sed '+ s/[$]LINENO.*/&-/+ t lineno+ b+ :lineno+ N+ :loop+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/+ t loop+ s/-\n.*//+ ' >$as_me.lineno &&+ chmod +x "$as_me.lineno" ||+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2+ { (exit 1); exit 1; }; }++ # Don't try to exec as it changes $[0], causing all sort of problems+ # (the dirname of $[0] is not the place where we might find the+ # original and so on. Autoconf is especially sensitive to this).+ . "./$as_me.lineno"+ # Exit status is that of the last command.+ exit+}+++if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then+ as_dirname=dirname+else+ as_dirname=false+fi++ECHO_C= ECHO_N= ECHO_T=+case `echo -n x` in+-n*)+ case `echo 'x\c'` in+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.+ *) ECHO_C='\c';;+ esac;;+*)+ ECHO_N='-n';;+esac++if expr a : '\(a\)' >/dev/null 2>&1 &&+ test "X`expr 00001 : '.*\(...\)'`" = X001; then+ as_expr=expr+else+ as_expr=false+fi++rm -f conf$$ conf$$.exe conf$$.file+if test -d conf$$.dir; then+ rm -f conf$$.dir/conf$$.file+else+ rm -f conf$$.dir+ mkdir conf$$.dir+fi+echo >conf$$.file+if ln -s conf$$.file conf$$ 2>/dev/null; then+ as_ln_s='ln -s'+ # ... but there are two gotchas:+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.+ # In both cases, we have to default to `cp -p'.+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||+ as_ln_s='cp -p'+elif ln conf$$.file conf$$ 2>/dev/null; then+ as_ln_s=ln+else+ as_ln_s='cp -p'+fi+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file+rmdir conf$$.dir 2>/dev/null++if mkdir -p . 2>/dev/null; then+ as_mkdir_p=:+else+ test -d ./-p && rmdir ./-p+ as_mkdir_p=false+fi++if test -x / >/dev/null 2>&1; then+ as_test_x='test -x'+else+ if ls -dL / >/dev/null 2>&1; then+ as_ls_L_option=L+ else+ as_ls_L_option=+ fi+ as_test_x='+ eval sh -c '\''+ if test -d "$1"; then+ test -d "$1/.";+ else+ case $1 in+ -*)set "./$1";;+ esac;+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in+ ???[sx]*):;;*)false;;esac;fi+ '\'' sh+ '+fi+as_executable_p=$as_test_x++# Sed expression to map a string onto a valid CPP name.+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"++# Sed expression to map a string onto a valid variable name.+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"+++exec 6>&1++# Save the log message, to keep $[0] and so on meaningful, and to+# report actual input values of CONFIG_FILES etc. instead of their+# values after options handling.+ac_log="+This file was extended by rtsPOSIX $as_me 0.9.9, which was+generated by GNU Autoconf 2.61. Invocation command line was++ CONFIG_FILES = $CONFIG_FILES+ CONFIG_HEADERS = $CONFIG_HEADERS+ CONFIG_LINKS = $CONFIG_LINKS+ CONFIG_COMMANDS = $CONFIG_COMMANDS+ $ $0 $@++on `(hostname || uname -n) 2>/dev/null | sed 1q`+"++_ACEOF++cat >>$CONFIG_STATUS <<_ACEOF+# Files that config.status was made for.+config_files="$ac_config_files"+config_headers="$ac_config_headers"++_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+ac_cs_usage="\+\`$as_me' instantiates files from templates according to the+current configuration.++Usage: $0 [OPTIONS] [FILE]...++ -h, --help print this help, then exit+ -V, --version print version number and configuration settings, then exit+ -q, --quiet do not print progress messages+ -d, --debug don't remove temporary files+ --recheck update $as_me by reconfiguring in the same conditions+ --file=FILE[:TEMPLATE]+ instantiate the configuration file FILE+ --header=FILE[:TEMPLATE]+ instantiate the configuration header FILE++Configuration files:+$config_files++Configuration headers:+$config_headers++Report bugs to <bug-autoconf@gnu.org>."++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+ac_cs_version="\\+rtsPOSIX config.status 0.9.9+configured by $0, generated by GNU Autoconf 2.61,+ with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"++Copyright (C) 2006 Free Software Foundation, Inc.+This config.status script is free software; the Free Software Foundation+gives unlimited permission to copy, distribute and modify it."++ac_pwd='$ac_pwd'+srcdir='$srcdir'+INSTALL='$INSTALL'+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+# If no file are specified by the user, then we need to provide default+# value. By we need to know if files were specified by the user.+ac_need_defaults=:+while test $# != 0+do+ case $1 in+ --*=*)+ ac_option=`expr "X$1" : 'X\([^=]*\)='`+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`+ ac_shift=:+ ;;+ *)+ ac_option=$1+ ac_optarg=$2+ ac_shift=shift+ ;;+ esac++ case $ac_option in+ # Handling of the options.+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)+ ac_cs_recheck=: ;;+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )+ echo "$ac_cs_version"; exit ;;+ --debug | --debu | --deb | --de | --d | -d )+ debug=: ;;+ --file | --fil | --fi | --f )+ $ac_shift+ CONFIG_FILES="$CONFIG_FILES $ac_optarg"+ ac_need_defaults=false;;+ --header | --heade | --head | --hea )+ $ac_shift+ CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg"+ ac_need_defaults=false;;+ --he | --h)+ # Conflict between --help and --header+ { echo "$as_me: error: ambiguous option: $1+Try \`$0 --help' for more information." >&2+ { (exit 1); exit 1; }; };;+ --help | --hel | -h )+ echo "$ac_cs_usage"; exit ;;+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \+ | -silent | --silent | --silen | --sile | --sil | --si | --s)+ ac_cs_silent=: ;;++ # This is an error.+ -*) { echo "$as_me: error: unrecognized option: $1+Try \`$0 --help' for more information." >&2+ { (exit 1); exit 1; }; } ;;++ *) ac_config_targets="$ac_config_targets $1"+ ac_need_defaults=false ;;++ esac+ shift+done++ac_configure_extra_args=++if $ac_cs_silent; then+ exec 6>/dev/null+ ac_configure_extra_args="$ac_configure_extra_args --silent"+fi++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+if \$ac_cs_recheck; then+ echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6+ CONFIG_SHELL=$SHELL+ export CONFIG_SHELL+ exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion+fi++_ACEOF+cat >>$CONFIG_STATUS <<\_ACEOF+exec 5>>config.log+{+ echo+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX+## Running $as_me. ##+_ASBOX+ echo "$ac_log"+} >&5++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF++# Handling of arguments.+for ac_config_target in $ac_config_targets+do+ case $ac_config_target in+ "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;;+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;+ "timberc.cfg") CONFIG_FILES="$CONFIG_FILES timberc.cfg" ;;++ *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5+echo "$as_me: error: invalid argument: $ac_config_target" >&2;}+ { (exit 1); exit 1; }; };;+ esac+done+++# If the user did not use the arguments to specify the items to instantiate,+# then the envvar interface is used. Set only those that are not.+# We use the long form for the default assignment because of an extremely+# bizarre bug on SunOS 4.1.3.+if $ac_need_defaults; then+ test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files+ test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers+fi++# Have a temporary directory for convenience. Make it in the build tree+# simply because there is no reason against having it here, and in addition,+# creating and moving files from /tmp can sometimes cause problems.+# Hook for its removal unless debugging.+# Note that there is a small window in which the directory will not be cleaned:+# after its creation but before its name has been assigned to `$tmp'.+$debug ||+{+ tmp=+ trap 'exit_status=$?+ { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status+' 0+ trap '{ (exit 1); exit 1; }' 1 2 13 15+}+# Create a (secure) tmp directory for tmp files.++{+ tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&+ test -n "$tmp" && test -d "$tmp"+} ||+{+ tmp=./conf$$-$RANDOM+ (umask 077 && mkdir "$tmp")+} ||+{+ echo "$me: cannot create a temporary directory in ." >&2+ { (exit 1); exit 1; }+}++#+# Set up the sed scripts for CONFIG_FILES section.+#++# No need to generate the scripts if there are no CONFIG_FILES.+# This happens for instance when ./config.status config.h+if test -n "$CONFIG_FILES"; then++_ACEOF++++ac_delim='%!_!# '+for ac_last_try in false false false false false :; do+ cat >conf$$subs.sed <<_ACEOF+SHELL!$SHELL$ac_delim+PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim+PACKAGE_NAME!$PACKAGE_NAME$ac_delim+PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim+PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim+PACKAGE_STRING!$PACKAGE_STRING$ac_delim+PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim+exec_prefix!$exec_prefix$ac_delim+prefix!$prefix$ac_delim+program_transform_name!$program_transform_name$ac_delim+bindir!$bindir$ac_delim+sbindir!$sbindir$ac_delim+libexecdir!$libexecdir$ac_delim+datarootdir!$datarootdir$ac_delim+datadir!$datadir$ac_delim+sysconfdir!$sysconfdir$ac_delim+sharedstatedir!$sharedstatedir$ac_delim+localstatedir!$localstatedir$ac_delim+includedir!$includedir$ac_delim+oldincludedir!$oldincludedir$ac_delim+docdir!$docdir$ac_delim+infodir!$infodir$ac_delim+htmldir!$htmldir$ac_delim+dvidir!$dvidir$ac_delim+pdfdir!$pdfdir$ac_delim+psdir!$psdir$ac_delim+libdir!$libdir$ac_delim+localedir!$localedir$ac_delim+mandir!$mandir$ac_delim+DEFS!$DEFS$ac_delim+ECHO_C!$ECHO_C$ac_delim+ECHO_N!$ECHO_N$ac_delim+ECHO_T!$ECHO_T$ac_delim+LIBS!$LIBS$ac_delim+build_alias!$build_alias$ac_delim+host_alias!$host_alias$ac_delim+target_alias!$target_alias$ac_delim+CC!$CC$ac_delim+CFLAGS!$CFLAGS$ac_delim+LDFLAGS!$LDFLAGS$ac_delim+CPPFLAGS!$CPPFLAGS$ac_delim+ac_ct_CC!$ac_ct_CC$ac_delim+EXEEXT!$EXEEXT$ac_delim+OBJEXT!$OBJEXT$ac_delim+INSTALL_PROGRAM!$INSTALL_PROGRAM$ac_delim+INSTALL_SCRIPT!$INSTALL_SCRIPT$ac_delim+INSTALL_DATA!$INSTALL_DATA$ac_delim+build!$build$ac_delim+build_cpu!$build_cpu$ac_delim+build_vendor!$build_vendor$ac_delim+build_os!$build_os$ac_delim+host!$host$ac_delim+host_cpu!$host_cpu$ac_delim+host_vendor!$host_vendor$ac_delim+host_os!$host_os$ac_delim+acx_pthread_config!$acx_pthread_config$ac_delim+PTHREAD_CC!$PTHREAD_CC$ac_delim+PTHREAD_LIBS!$PTHREAD_LIBS$ac_delim+PTHREAD_CFLAGS!$PTHREAD_CFLAGS$ac_delim+TIMBERC!$TIMBERC$ac_delim+CPP!$CPP$ac_delim+GREP!$GREP$ac_delim+EGREP!$EGREP$ac_delim+LIBOBJS!$LIBOBJS$ac_delim+SRC!$SRC$ac_delim+DEST!$DEST$ac_delim+LTLIBOBJS!$LTLIBOBJS$ac_delim+_ACEOF++ if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 67; then+ break+ elif $ac_last_try; then+ { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5+echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}+ { (exit 1); exit 1; }; }+ else+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "+ fi+done++ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`+if test -n "$ac_eof"; then+ ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`+ ac_eof=`expr $ac_eof + 1`+fi++cat >>$CONFIG_STATUS <<_ACEOF+cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end+_ACEOF+sed '+s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g+s/^/s,@/; s/!/@,|#_!!_#|/+:n+t n+s/'"$ac_delim"'$/,g/; t+s/$/\\/; p+N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n+' >>$CONFIG_STATUS <conf$$subs.sed+rm -f conf$$subs.sed+cat >>$CONFIG_STATUS <<_ACEOF+:end+s/|#_!!_#|//g+CEOF$ac_eof+_ACEOF+++# VPATH may cause trouble with some makes, so we remove $(srcdir),+# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and+# trailing colons and then remove the whole line if VPATH becomes empty+# (actually we leave an empty line to preserve line numbers).+if test "x$srcdir" = x.; then+ ac_vpsub='/^[ ]*VPATH[ ]*=/{+s/:*\$(srcdir):*/:/+s/:*\${srcdir}:*/:/+s/:*@srcdir@:*/:/+s/^\([^=]*=[ ]*\):*/\1/+s/:*$//+s/^[^=]*=[ ]*$//+}'+fi++cat >>$CONFIG_STATUS <<\_ACEOF+fi # test -n "$CONFIG_FILES"+++for ac_tag in :F $CONFIG_FILES :H $CONFIG_HEADERS+do+ case $ac_tag in+ :[FHLC]) ac_mode=$ac_tag; continue;;+ esac+ case $ac_mode$ac_tag in+ :[FHL]*:*);;+ :L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5+echo "$as_me: error: Invalid tag $ac_tag." >&2;}+ { (exit 1); exit 1; }; };;+ :[FH]-) ac_tag=-:-;;+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;+ esac+ ac_save_IFS=$IFS+ IFS=:+ set x $ac_tag+ IFS=$ac_save_IFS+ shift+ ac_file=$1+ shift++ case $ac_mode in+ :L) ac_source=$1;;+ :[FH])+ ac_file_inputs=+ for ac_f+ do+ case $ac_f in+ -) ac_f="$tmp/stdin";;+ *) # Look for the file first in the build tree, then in the source tree+ # (if the path is not absolute). The absolute path cannot be DOS-style,+ # because $ac_f cannot contain `:'.+ test -f "$ac_f" ||+ case $ac_f in+ [\\/$]*) false;;+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;+ esac ||+ { { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5+echo "$as_me: error: cannot find input file: $ac_f" >&2;}+ { (exit 1); exit 1; }; };;+ esac+ ac_file_inputs="$ac_file_inputs $ac_f"+ done++ # Let's still pretend it is `configure' which instantiates (i.e., don't+ # use $as_me), people would be surprised to read:+ # /* config.h. Generated by config.status. */+ configure_input="Generated from "`IFS=:+ echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."+ if test x"$ac_file" != x-; then+ configure_input="$ac_file. $configure_input"+ { echo "$as_me:$LINENO: creating $ac_file" >&5+echo "$as_me: creating $ac_file" >&6;}+ fi++ case $ac_tag in+ *:-:* | *:-) cat >"$tmp/stdin";;+ esac+ ;;+ esac++ ac_dir=`$as_dirname -- "$ac_file" ||+$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$ac_file" : 'X\(//\)[^/]' \| \+ X"$ac_file" : 'X\(//\)$' \| \+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||+echo X"$ac_file" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ { as_dir="$ac_dir"+ case $as_dir in #(+ -*) as_dir=./$as_dir;;+ esac+ test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {+ as_dirs=+ while :; do+ case $as_dir in #(+ *\'*) as_qdir=`echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #(+ *) as_qdir=$as_dir;;+ esac+ as_dirs="'$as_qdir' $as_dirs"+ as_dir=`$as_dirname -- "$as_dir" ||+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$as_dir" : 'X\(//\)[^/]' \| \+ X"$as_dir" : 'X\(//\)$' \| \+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||+echo X"$as_dir" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ test -d "$as_dir" && break+ done+ test -z "$as_dirs" || eval "mkdir $as_dirs"+ } || test -d "$as_dir" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5+echo "$as_me: error: cannot create directory $as_dir" >&2;}+ { (exit 1); exit 1; }; }; }+ ac_builddir=.++case "$ac_dir" in+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;+*)+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`+ # A ".." for each directory in $ac_dir_suffix.+ ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`+ case $ac_top_builddir_sub in+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;+ esac ;;+esac+ac_abs_top_builddir=$ac_pwd+ac_abs_builddir=$ac_pwd$ac_dir_suffix+# for backward compatibility:+ac_top_builddir=$ac_top_build_prefix++case $srcdir in+ .) # We are building in place.+ ac_srcdir=.+ ac_top_srcdir=$ac_top_builddir_sub+ ac_abs_top_srcdir=$ac_pwd ;;+ [\\/]* | ?:[\\/]* ) # Absolute name.+ ac_srcdir=$srcdir$ac_dir_suffix;+ ac_top_srcdir=$srcdir+ ac_abs_top_srcdir=$srcdir ;;+ *) # Relative name.+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix+ ac_top_srcdir=$ac_top_build_prefix$srcdir+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;+esac+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix+++ case $ac_mode in+ :F)+ #+ # CONFIG_FILE+ #++ case $INSTALL in+ [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;;+ *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;;+ esac+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+# If the template does not know about datarootdir, expand it.+# FIXME: This hack should be removed a few years after 2.60.+ac_datarootdir_hack=; ac_datarootdir_seen=++case `sed -n '/datarootdir/ {+ p+ q+}+/@datadir@/p+/@docdir@/p+/@infodir@/p+/@localedir@/p+/@mandir@/p+' $ac_file_inputs` in+*datarootdir*) ac_datarootdir_seen=yes;;+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)+ { echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5+echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}+_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+ ac_datarootdir_hack='+ s&@datadir@&$datadir&g+ s&@docdir@&$docdir&g+ s&@infodir@&$infodir&g+ s&@localedir@&$localedir&g+ s&@mandir@&$mandir&g+ s&\\\${datarootdir}&$datarootdir&g' ;;+esac+_ACEOF++# Neutralize VPATH when `$srcdir' = `.'.+# Shell code in configure.ac might set extrasub.+# FIXME: do we really want to maintain this feature?+cat >>$CONFIG_STATUS <<_ACEOF+ sed "$ac_vpsub+$extrasub+_ACEOF+cat >>$CONFIG_STATUS <<\_ACEOF+:t+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b+s&@configure_input@&$configure_input&;t t+s&@top_builddir@&$ac_top_builddir_sub&;t t+s&@srcdir@&$ac_srcdir&;t t+s&@abs_srcdir@&$ac_abs_srcdir&;t t+s&@top_srcdir@&$ac_top_srcdir&;t t+s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t+s&@builddir@&$ac_builddir&;t t+s&@abs_builddir@&$ac_abs_builddir&;t t+s&@abs_top_builddir@&$ac_abs_top_builddir&;t t+s&@INSTALL@&$ac_INSTALL&;t t+$ac_datarootdir_hack+" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out++test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&+ { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&+ { echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'+which seems to be undefined. Please make sure it is defined." >&5+echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'+which seems to be undefined. Please make sure it is defined." >&2;}++ rm -f "$tmp/stdin"+ case $ac_file in+ -) cat "$tmp/out"; rm -f "$tmp/out";;+ *) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;+ esac+ ;;+ :H)+ #+ # CONFIG_HEADER+ #+_ACEOF++# Transform confdefs.h into a sed script `conftest.defines', that+# substitutes the proper values into config.h.in to produce config.h.+rm -f conftest.defines conftest.tail+# First, append a space to every undef/define line, to ease matching.+echo 's/$/ /' >conftest.defines+# Then, protect against being on the right side of a sed subst, or in+# an unquoted here document, in config.status. If some macros were+# called several times there might be several #defines for the same+# symbol, which is useless. But do not sort them, since the last+# AC_DEFINE must be honored.+ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]*+# These sed commands are passed to sed as "A NAME B PARAMS C VALUE D", where+# NAME is the cpp macro being defined, VALUE is the value it is being given.+# PARAMS is the parameter list in the macro definition--in most cases, it's+# just an empty string.+ac_dA='s,^\\([ #]*\\)[^ ]*\\([ ]*'+ac_dB='\\)[ (].*,\\1define\\2'+ac_dC=' '+ac_dD=' ,'++uniq confdefs.h |+ sed -n '+ t rset+ :rset+ s/^[ ]*#[ ]*define[ ][ ]*//+ t ok+ d+ :ok+ s/[\\&,]/\\&/g+ s/^\('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/ '"$ac_dA"'\1'"$ac_dB"'\2'"${ac_dC}"'\3'"$ac_dD"'/p+ s/^\('"$ac_word_re"'\)[ ]*\(.*\)/'"$ac_dA"'\1'"$ac_dB$ac_dC"'\2'"$ac_dD"'/p+ ' >>conftest.defines++# Remove the space that was appended to ease matching.+# Then replace #undef with comments. This is necessary, for+# example, in the case of _POSIX_SOURCE, which is predefined and required+# on some systems where configure will not decide to define it.+# (The regexp can be short, since the line contains either #define or #undef.)+echo 's/ $//+s,^[ #]*u.*,/* & */,' >>conftest.defines++# Break up conftest.defines:+ac_max_sed_lines=50++# First sed command is: sed -f defines.sed $ac_file_inputs >"$tmp/out1"+# Second one is: sed -f defines.sed "$tmp/out1" >"$tmp/out2"+# Third one will be: sed -f defines.sed "$tmp/out2" >"$tmp/out1"+# et cetera.+ac_in='$ac_file_inputs'+ac_out='"$tmp/out1"'+ac_nxt='"$tmp/out2"'++while :+do+ # Write a here document:+ cat >>$CONFIG_STATUS <<_ACEOF+ # First, check the format of the line:+ cat >"\$tmp/defines.sed" <<\\CEOF+/^[ ]*#[ ]*undef[ ][ ]*$ac_word_re[ ]*\$/b def+/^[ ]*#[ ]*define[ ][ ]*$ac_word_re[( ]/b def+b+:def+_ACEOF+ sed ${ac_max_sed_lines}q conftest.defines >>$CONFIG_STATUS+ echo 'CEOF+ sed -f "$tmp/defines.sed"' "$ac_in >$ac_out" >>$CONFIG_STATUS+ ac_in=$ac_out; ac_out=$ac_nxt; ac_nxt=$ac_in+ sed 1,${ac_max_sed_lines}d conftest.defines >conftest.tail+ grep . conftest.tail >/dev/null || break+ rm -f conftest.defines+ mv conftest.tail conftest.defines+done+rm -f conftest.defines conftest.tail++echo "ac_result=$ac_in" >>$CONFIG_STATUS+cat >>$CONFIG_STATUS <<\_ACEOF+ if test x"$ac_file" != x-; then+ echo "/* $configure_input */" >"$tmp/config.h"+ cat "$ac_result" >>"$tmp/config.h"+ if diff $ac_file "$tmp/config.h" >/dev/null 2>&1; then+ { echo "$as_me:$LINENO: $ac_file is unchanged" >&5+echo "$as_me: $ac_file is unchanged" >&6;}+ else+ rm -f $ac_file+ mv "$tmp/config.h" $ac_file+ fi+ else+ echo "/* $configure_input */"+ cat "$ac_result"+ fi+ rm -f "$tmp/out12"+ ;;+++ esac++done # for ac_tag+++{ (exit 0); exit 0; }+_ACEOF+chmod +x $CONFIG_STATUS+ac_clean_files=$ac_clean_files_save+++# configure is writing to config.log, and then calls config.status.+# config.status does its own redirection, appending to config.log.+# Unfortunately, on DOS this fails, as config.log is still kept open+# by configure, so config.status won't be able to write to it; its+# output is simply discarded. So we exec the FD to /dev/null,+# effectively closing config.log, so it can be properly (re)opened and+# appended to by config.status. When coming back to configure, we+# need to make the FD available again.+if test "$no_create" != yes; then+ ac_cs_success=:+ ac_config_status_args=+ test "$silent" = yes &&+ ac_config_status_args="$ac_config_status_args --quiet"+ exec 5>/dev/null+ $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false+ exec 5>>config.log+ # Use ||, not &&, to avoid exiting from the if with $? = 1, which+ # would make configure fail if this is the last instruction.+ $ac_cs_success || { (exit 1); exit 1; }+fi+
+ rtsPOSIX/cyclic.c view
@@ -0,0 +1,144 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.+++#define BIT0(val) (((WORD)(val)) & 0x01)+#define CLR0(val) ((WORD)(val) & (~0x01))+#define TOGGLE0(val) ((WORD)(val) ^ 0x01)++#define ISPLACEHOLDER(obj) (BIT0(obj) && ((int)(obj) < 0))+#define INDEXOF(obj) (((-(int)(obj)) >> 1) - current->placeholders)+#define PLACEHOLDER(index) (-((((index) + current->placeholders) << 1) | 0x01))++#define CURRENT_CYCLE(obj,roots) !INSIDE(heapchain,obj,(ADDR)roots)++#define SUBST(obj,off,roots,lim) { ADDR obj1 = (ADDR)obj[off]; \+ if (ISPLACEHOLDER(obj1)) { \+ int index = INDEXOF(obj1); \+ if (index >= 0 && index < (lim)) \+ obj[off] = (WORD)roots->elems[index]; \+ } \+ }++ADDR substObj(ADDR obj, Array roots, int limit, Thread current) {+ ADDR info = IND0(obj);+ if (!info) // if gcinfo is null we have reached the end of a heap segment+ return (ADDR)obj[1]; // pointer to first object of next segment is found in subsequent slot+ switch (GC_TYPE(info)) {+ case GC_STD: {+ WORD size = STATIC_SIZE(info), i = 2, offset = info[i];+ while (offset) {+ SUBST(obj,offset,roots,limit);+ offset = info[++i];+ }+ return obj + size;+ }+ case GC_ARRAY: {+ WORD size = STATIC_SIZE(info) + obj[1], offset = 2; // find size of dynamic part in second slot of obj, add static size+ if (info[2])+ return obj + size; // return immediately if array contains only scalars+ while (offset<size) {+ SUBST(obj,offset,roots,limit);+ offset++;+ }+ return obj + size;+ }+ case GC_TUPLE: {+ WORD width = obj[1], offset = 1 + POLYTAGS(width), i = 1, j, tags;+ while (width > 32) {+ for (j = 0, tags = obj[i++]; j < 32; j++, offset++, tags = tags >> 1)+ if (!(tags & 1))+ SUBST(obj,offset,roots,limit);+ width -= 32;+ }+ for (tags = obj[i]; width > 0; width--, offset++, tags = tags >> 1) + if (!(tags & 1))+ SUBST(obj,offset,roots,limit);+ return obj + STATIC_SIZE(info) + width + POLYTAGS(width);+ }+ case GC_BIG: {+ WORD size = STATIC_SIZE(info), i = 2, offset = info[i];+ while (offset) { // subst all statically known pointer fields+ SUBST(obj,offset,roots,limit);+ offset = info[++i];+ }+ offset = info[++i];+ while (offset) { // subst dynamically identified pointers+ WORD tagword = info[++i];+ WORD bitno = info[++i];+ if ((tagword & (1 << bitno)) == 0)+ SUBST(obj,offset,roots,limit);+ offset = info[++i];+ }+ return obj + size;+ }+ case GC_MUT: {+ return substObj(obj + STATIC_SIZE(info), roots, limit, current);+ }+ }+ return (ADDR)0; // Not reached+}++void subst(Array roots, int limit, ADDR stop, Thread current) {+ ADDR p = (ADDR)roots + STATIC_SIZE(roots->GCINFO) + roots->size;+ int i;+ for (i = 0; i < limit; i++)+ if (ISPLACEHOLDER(roots->elems[i])) + RAISE(2);+ while (p != stop)+ p = substObj(p, roots, limit, current);+}++Array CYCLIC_BEGIN(Int n, Int updates) {+ Thread current = CURRENT();+ Array roots = EmptyArray(0,n);+ int i;+ for (i = 0; i < n; i++)+ roots->elems[i] = (POLY)PLACEHOLDER(i);+ current->placeholders += n;+ return roots;+}++void CYCLIC_UPDATE(Array roots, Int limit, ADDR stop) {+ Thread current = CURRENT();+ current->placeholders -= roots->size;+ subst(roots, limit, stop, current);+ current->placeholders += roots->size;+}++void CYCLIC_END(Array roots, ADDR stop) {+ Thread current = CURRENT();+ current->placeholders -= roots->size;+ subst(roots, roots->size, stop, current);+}+
+ rtsPOSIX/env.c view
@@ -0,0 +1,618 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#include <fcntl.h>+#include <pthread.h>+#include <unistd.h>+#include <sys/socket.h>+#include <netinet/in.h>+#include <netdb.h>+#include <arpa/inet.h>+#include <errno.h>+#include "POSIX.h"+#include "env.h"++#define SIGSELECT SIGUSR1++#define ADD_RDTABLE(desc,act) {rdTable[desc] = act; FD_SET(desc,&readUsed); }+#define ADD_WRTABLE(desc,act) {wrTable[desc] = act; FD_SET(desc,&writeUsed); }++#define CLR_RDTABLE(desc) {rdTable[desc] = NULL; FD_CLR(desc, &readUsed);}+#define CLR_WRTABLE(desc) {wrTable[desc] = NULL; FD_CLR(desc, &writeUsed);}++// --------- Socket data stored in global array sockTable, indexed by descriptor -------------------------------------------------++struct SockData {+ WORD *GCINFO;+ struct sockaddr_in addr; // address of remote peer+ SOCKHANDLER handler; +};++WORD __GC__SockData[] = { WORDS(sizeof(struct SockData)), GC_STD, WORDS(offsetof(struct SockData,handler)), 0 };++typedef struct SockData *SockData;+++// -------- Global variables ---------------------------------------------------++/*++ Bit n in readUsed is set iff+ - we have used installR to install a callback for the RFile with descriptor n; the callback is rdTable[n] OR+ - n is a (server) socket, we have called listen and are waiting for clients to connect; handler is sockTable[i] OR+ - n is a socket with an established connection; deliver method of the Destination is rdTable[i] and sockTable[i] contains+ SockData (needed for future closing message).++ Bit n in writeUsed is set iff+ - we have used installW to install a callback for the WFile with descriptor n; the callback is wrTable[i] OR+ - n is a (client) socket, we have called connect and are waiting for connection with server to be established; sockTable[i]+ contains SockData from which we can construct the handler when connection is set up.++ In all other cases, bits are cleared and array entries are NULL.++ eventLoop runs the indefinite loop that repetitively blocks on select; each change to the above data strucures is + reported to the calling thread through a SIGSELECT signal, so that select parameters can be adapted accordingly.++ maxDesc is an upper bound on the highest descriptor in use; updated when opening, but currently not decreased on closing.++*/+++fd_set readUsed, writeUsed;++HANDLER rdTable[FD_SETSIZE] ;+ACTION wrTable[FD_SETSIZE] ;+SockData sockTable[FD_SETSIZE];++int envRootsDirty;++struct Msg msg0 = { NULL, 0, { 0, 0 }, { INF, 0 }, NULL };++struct Thread thread0 = { NULL, &msg0, 0, };++pthread_mutex_t envmut;++int maxDesc = 2;++ACTION prog = NULL; // Must be set by main()+++//---------- Utilities ---------------------------------------------------------++Host_POSIX mkHost(struct sockaddr_in addr) {+ _Host_POSIX host; NEW(_Host_POSIX, host, WORDS(sizeof(struct _Host_POSIX)));+ host->GCINFO = __GC___Host_POSIX;+ host->a = getStr(inet_ntoa(addr.sin_addr));+ return (Host_POSIX)host;+}++Port_POSIX mkPort (struct sockaddr_in addr) {+ _Port_POSIX port; NEW(_Port_POSIX, port, WORDS(sizeof(struct _Port_POSIX)));+ port->GCINFO = __GC___Port_POSIX;+ port->a = ntohs(addr.sin_port); + return (Port_POSIX)port;+}++void netError(Int sock,char *message);++// -------- Closable -----------------------------------------------------------++struct DescClosable {+ WORD *GCINFO;+ UNITTYPE (*close_POSIX) (Closable_POSIX, Int);+// Msg (*close_POSIX) (Closable_POSIX, Time, Time);+ int descriptor;+// DescState self;+};+ +WORD __GC__DescClosable[] = { WORDS(sizeof(struct DescClosable)), GC_STD, 0 };++typedef struct DescClosable *DescClosable;++struct CloseMsg;+typedef struct CloseMsg *CloseMsg;++struct CloseMsg {+ WORD *GCINFO;+ UNITTYPE (*Code)(CloseMsg);+ AbsTime baseline;+ AbsTime deadline;+ Msg next;+ int descriptor;+// DescState self;+};++WORD __GC__CloseMsg[] = { WORDS(sizeof(struct CloseMsg)), GC_STD, 0 }; // Field "next" is custom handled by the GC+++UNITTYPE close_fun (Closable_POSIX this, Int dummy) {+ DISABLE(envmut);+ int desc = ((DescClosable)this)->descriptor;+ close(desc);+ CLR_RDTABLE(desc);+ CLR_WRTABLE(desc);+ sockTable[desc] = NULL;+ pthread_kill(thread0.id, SIGSELECT);+ ENABLE(envmut);+ return (UNITTYPE)0;+}++Closable_POSIX new_Closable (int desc) {+ DescClosable res;+ NEW(DescClosable, res, WORDS(sizeof(struct DescClosable)));+ res->GCINFO = __GC__DescClosable;+ res->close_POSIX = close_fun;+ res->descriptor = desc;+ return (Closable_POSIX)res;+}++// -------- File ---------------------------------------------------------------++Int seek_fun (File_POSIX this, Int off, Int dummy) {+ DISABLE(envmut);+ Int res, mode;+ if (off >= 0) + mode = SEEK_SET;+ else {+ mode = SEEK_END;+ off++;+ }+ res = lseek(((DescClosable)this->FILE2CLOSABLE)->descriptor,off,mode);+ ENABLE(envmut);+ return res;+}++File_POSIX new_File (int desc) {+ File_POSIX res; NEW(File_POSIX, res, WORDS(sizeof(struct File_POSIX)));+ res->GCINFO = __GC__File_POSIX;+ res->FILE2CLOSABLE = new_Closable(desc);+ res->seek_POSIX = seek_fun;+ return res;+}++// --------- RFile -------------------------------------------------------------++LIST read_descr (int descr) {+ char buf[1024];+ LIST xs = (LIST)0;+ LIST xslast = (LIST)0;+ LIST res = (LIST)0;+ LIST reslast = (LIST)0;+ int r;+ while (1) {+ xs = (LIST)0;+ xslast = (LIST)0;+ r = read(descr, buf, 1023);+ if (r <= 0) {+ if (reslast != (LIST)0) ((CONS)reslast)->b = (LIST)0;+ return res;+ }+ while (r) {+ CONS n; NEW(CONS, n, WORDS(sizeof(struct CONS)));+ if (xslast==(LIST)0) xslast = (LIST)n;+ n->GCINFO = __GC__CONS+5; // POLY instance is a scalar+ n->a = (POLY)(Int)buf[--r];+ n->b = xs;+ xs = (LIST)n;+ }+ if (res==(LIST)0) + res = xs; + else + ((CONS)reslast)->b = xs;+ reslast = xslast;+ }+}+++LIST read_fun (RFile_POSIX this, Int dummy) {+ return read_descr(((DescClosable)this->RFILE2FILE->FILE2CLOSABLE)->descriptor);+}++UNITTYPE installR_fun (RFile_POSIX this, HANDLER hand, Int dummy) {+ DISABLE(envmut);+ Int desc = ((DescClosable)this->RFILE2FILE->FILE2CLOSABLE)->descriptor;+ ADD_RDTABLE(desc,hand);+ maxDesc = desc > maxDesc ? desc : maxDesc; + pthread_kill(thread0.id, SIGSELECT);+ ENABLE(envmut);+ return (UNITTYPE)0;+}++RFile_POSIX new_RFile(int desc) {+ RFile_POSIX rf; NEW(RFile_POSIX, rf, sizeof(struct RFile_POSIX));+ rf->GCINFO = __GC__RFile_POSIX;+ rf->RFILE2FILE = new_File(desc);+ rf->read_POSIX = read_fun;+ rf->installR_POSIX = installR_fun;+ return rf;+}++// ----------- WFile -----------------------------------------------------------++int write_fun (WFile_POSIX this, LIST xs, Int dummy) {+ char buf[1024];+ int res = 0;+ while (xs) {+ int len = 0;+ while (xs && len < 1024) {+ buf[len++] = (Char)(Int)((CONS)xs)->a;+ xs = ((CONS)xs)->b;+ }+ if (len<1024) buf[len] = 0;+ int r = write(((DescClosable)this->WFILE2FILE->FILE2CLOSABLE)->descriptor, buf, len);+ if (r < 0) return res;+ res += r;+ }+ return res;+}++UNITTYPE installW_fun (WFile_POSIX this, ACTION act, Int dummy) {+ DISABLE(envmut);+ Int desc = ((DescClosable)this->WFILE2FILE->FILE2CLOSABLE)->descriptor;+ ADD_WRTABLE(desc,act);+ envRootsDirty = 1;+ maxDesc = desc > maxDesc ? desc : maxDesc; + pthread_kill(thread0.id, SIGSELECT);+ ENABLE(envmut);+ return (UNITTYPE)0;+}++WFile_POSIX new_WFile(int desc) {+ WFile_POSIX wf; NEW(WFile_POSIX, wf, sizeof(struct WFile_POSIX));+ wf->GCINFO = __GC__WFile_POSIX;+ wf->WFILE2FILE = new_File(desc);+ wf->write_POSIX = write_fun;+ wf->installW_POSIX = installW_fun;+ return wf;+}++// ------------ Env ------------------------------------------------------------++UNITTYPE exit_fun (Env_POSIX this, Int n, Int dummy) {+ DISABLE(envmut);+ DISABLE(rts);+ exit(n);+}++Maybe_Prelude open_fun (LIST path, int oflag) {+ char buf[1024];+ int len = 0;+ while (path && len < 1024) {+ buf[len++] = (Char)(Int)((CONS)path)->a;+ path = ((CONS)path)->b;+ }+ buf[len] = 0;+ int descr = open(buf,oflag,S_IWUSR|S_IRUSR|S_IRGRP|S_IROTH);+ if (descr < 0) return (Maybe_Prelude)0;+ _Just_Prelude res; NEW(_Just_Prelude, res, WORDS(sizeof(struct _Just_Prelude)));+ res->GCINFO = __GC___Just_Prelude+0; // POLY instance is a pointer+ res->a = (POLY)new_File(descr);+ return (Maybe_Prelude)res;+}+++Maybe_Prelude openR_fun (Env_POSIX this, LIST path, Int dummy) {+ DISABLE(envmut);+ Maybe_Prelude f = open_fun(path,O_RDONLY);+ if (f) {+ RFile_POSIX rf; NEW(RFile_POSIX, rf, WORDS(sizeof(struct RFile_POSIX)));+ rf->GCINFO = __GC__RFile_POSIX;+ rf->RFILE2FILE = (File_POSIX)((_Just_Prelude)f)->a;+ rf->read_POSIX = read_fun;+ rf->installR_POSIX = installR_fun;+ ((_Just_Prelude)f)->a = (POLY)rf;+ }+ ENABLE(envmut);+ return f;+}++Maybe_Prelude openW_fun (Env_POSIX this, LIST path, Int dummy) {+ DISABLE(envmut);+ Maybe_Prelude f = open_fun(path,O_WRONLY | O_CREAT | O_TRUNC);+ if (f) {+ WFile_POSIX wf; NEW(WFile_POSIX, wf, WORDS(sizeof(struct WFile_POSIX)));+ wf->GCINFO = __GC__WFile_POSIX;+ wf->WFILE2FILE = (File_POSIX)((_Just_Prelude)f)->a;+ wf->write_POSIX = write_fun;+ wf->installW_POSIX = installW_fun;+ ((_Just_Prelude)f)->a = (POLY)wf;+ }+ ENABLE(envmut);+ return f;+} ++// ---------- Sockets ----------------------------------------------------------++Socket_POSIX new_Socket (Int sock) {+ Socket_POSIX res;+ NEW (Socket_POSIX, res, WORDS(sizeof(struct Socket_POSIX)));+ res->GCINFO = __GC__Socket_POSIX;+ res->SOCK2CLOSABLE = new_Closable(sock);+ res->inFile_POSIX = new_RFile(sock);+ res->outFile_POSIX = new_WFile(sock); + struct sockaddr_in addr = sockTable[sock]->addr;+ res->remoteHost_POSIX = mkHost(addr);+ res->remotePort_POSIX = mkPort(addr);+ return res;+}+++Int new_socket (SOCKHANDLER handler) {+ SockData d; + int sock = socket(PF_INET,SOCK_STREAM,0);+ fcntl(sock,F_SETFL,O_NONBLOCK);+ maxDesc = sock > maxDesc ? sock : maxDesc; + NEW(SockData,d,WORDS(sizeof(struct SockData)));+ d->GCINFO =__GC__SockData;+ d->handler = handler;+ sockTable[sock] = d;+ envRootsDirty = 1;+ return sock;+} ++void netError (Int sock, char *message) {+ SOCKHANDLER handler = sockTable[sock]->handler;+ Connection_POSIX conn = (Connection_POSIX)handler->Code(handler,(POLY)new_Socket(sock),(POLY)0);+ //ADD_RDTABLE(sock,mkHandler(conn));+ envRootsDirty = 1;+ conn->neterror_POSIX(conn,getStr(message),Inherit,Inherit);+}++void setupConnection (Int sock) {+ SOCKHANDLER handler = sockTable[sock]->handler;+ Connection_POSIX conn = (Connection_POSIX)handler->Code(handler,(POLY)new_Socket(sock),(POLY)0);+ //ADD_RDTABLE(sock,mkHandler(conn));+ envRootsDirty = 1;+ conn->established_POSIX(conn,Inherit,Inherit);+}++int mkAddr (Int sock, Host_POSIX host, struct in_addr *addr) {+ LIST h = ((_Host_POSIX)host)->a;+ char buf[1024];+ int len = 0;+ Int hostid;+ struct hostent *ent;+ while (h && len < 1024) {+ buf[len++] = (Char)(Int)((CONS)h)->a;+ h = ((CONS)h)->b;+ }+ buf[len] = 0;+ // We assume gethostbyname will not block...+ ent = gethostbyname(buf);+ if(ent==NULL) {+ netError(sock,"Name lookup error");+ return -1;+ }+ else {+ memcpy(&hostid, ent->h_addr_list[0], sizeof hostid);+ addr->s_addr = hostid;+ return 0;+ }+}++UNITTYPE connect_fun (Sockets_POSIX this, Host_POSIX host, Port_POSIX port, SOCKHANDLER handler, Int dummy) {+ DISABLE(envmut);+ struct sockaddr_in addr;+ struct in_addr iaddr;+ int sock = new_socket(handler);+ if (mkAddr(sock, host, &iaddr) == 0) {+ addr.sin_addr = iaddr;+ addr.sin_port = htons(((_Port_POSIX)port)->a);+ addr.sin_family = AF_INET;+ sockTable[sock]->addr = addr;+ if (connect(sock,(struct sockaddr *)&addr,sizeof(struct sockaddr)) < 0) {// couldn't connect immediately, + if (errno==EINPROGRESS) // so check if attempt continues asynchronously.+ FD_SET(sock,&writeUsed);+ else+ netError(sock,"Connect failed");+ }+ else {+ setupConnection(sock);+ }+ pthread_kill(thread0.id, SIGSELECT);+ }+ ENABLE(envmut);+ return (UNITTYPE)0;+}+++Closable_POSIX listen_fun (Sockets_POSIX this, Port_POSIX port, SOCKHANDLER handler, Int dummy) {+ DISABLE(envmut);+ struct sockaddr_in addr;+ int sock = new_socket(handler);+ addr.sin_addr.s_addr = INADDR_ANY;+ addr.sin_port = htons(((_Port_POSIX)port)->a);+ addr.sin_family = AF_INET;+ if (bind(sock,(struct sockaddr *)&addr,sizeof(struct sockaddr)) < 0)+ perror("bind failed");+ listen(sock,5);+ FD_SET(sock,&readUsed);+ pthread_kill(thread0.id, SIGSELECT);+ ENABLE(envmut);+ return new_Closable(sock);+}++// ---------- Global env object ------------------------------------------------++// Note: all the following structs lie outside the garbage collected heap, and are therefore marked with a gcinfo = 0.++struct DescClosable stdin_cl = { 0, close_fun, 0 };+struct DescClosable stdout_cl = { 0, close_fun, 1 };++struct File_POSIX stdin_file = { 0, (Closable_POSIX)&stdin_cl, seek_fun };+struct File_POSIX stdout_file = { 0, (Closable_POSIX)&stdout_cl, seek_fun };++struct RFile_POSIX stdin_rfile = { 0, &stdin_file, read_fun, installR_fun };+struct WFile_POSIX stdout_wfile = { 0, &stdout_file, write_fun, installW_fun };++struct Sockets_POSIX tcp = { 0, connect_fun, listen_fun };++struct Internet_POSIX inet = { 0, &tcp };++struct Time startTime;++struct Env_POSIX env_struct = { 0, exit_fun, NULL, &stdin_rfile, &stdout_wfile,+ openR_fun, openW_fun, &startTime, &inet };++Env_POSIX env = &env_struct;+++// ------- Copying for gc -----------------------------------------------++void scanEnvRoots (void) {+ envRootsDirty = 0;+ int i;+ prog = (ACTION)copy((ADDR)prog);+ i = 0;+ DISABLE(envmut);+ while (i<maxDesc+1) {+ if (rdTable[i]) rdTable[i] = (HANDLER)copy((ADDR)rdTable[i]);+ if (wrTable[i]) wrTable[i] = (ACTION)copy((ADDR)wrTable[i]);+ if (sockTable[i]) sockTable[i] = (SockData)copy((ADDR)sockTable[i]);+ i++;+ ENABLE(envmut);+ DISABLE(envmut);+ }+ ENABLE(envmut);+}++// --------- Event loop ----------------------------------------------++void kill_handler () {+ return;+}++void eventLoop (void) {+ sigset_t one_sig;+ sigemptyset(&one_sig);+ sigaddset(&one_sig, SIGSELECT);+ pthread_sigmask(SIG_UNBLOCK, &one_sig, NULL);++ DISABLE(envmut);+ fd_set readFds, writeFds;+ int i;+ while(1) {+ readFds = readUsed;+ writeFds = writeUsed;+ ENABLE(envmut);+ int r = select(maxDesc+1, &readFds, &writeFds, NULL, NULL);+ DISABLE(envmut);+ if (r >= 0) {+ TIMERGET(msg0.baseline);+ for(i=0; i<maxDesc+1; i++) {+ if (FD_ISSET(i, &readFds)) {+ if (rdTable[i]) {+ LIST inp = read_descr(i);+ if (inp) {+ rdTable[i]->Code(rdTable[i],(POLY)inp,(POLY)Inherit,(POLY)Inherit);+ }+ else if (sockTable[i]) { //we got a close message from peer on connected socket+ SOCKHANDLER handler = sockTable[i]->handler;+ Connection_POSIX conn = (Connection_POSIX)handler->Code(handler,(POLY)new_Socket(i),(POLY)0);+ Closable_POSIX cl = conn->CONN2CLOSABLE;+ cl->close_POSIX(cl,0);+ close(i);+ CLR_RDTABLE(i);+ sockTable[i] = NULL;+ }+ } else if (sockTable[i]) { //listening socket received a connect request; we will accept+ socklen_t len = sizeof(struct sockaddr);+ struct sockaddr_in addr;+ Int sock = accept(i,(struct sockaddr *)&addr,&len);+ fcntl(sock,F_SETFL,O_NONBLOCK);+ NEW(SockData,sockTable[sock],WORDS(sizeof(struct SockData)));+ sockTable[sock]->handler = sockTable[i]->handler;+ sockTable[sock]->addr = addr;+ maxDesc = sock > maxDesc ? sock : maxDesc;+ setupConnection(sock);+ }+ }+ if (FD_ISSET(i, &writeFds)) {+ if (wrTable[i]) {+ wrTable[i]->Code(wrTable[i],(POLY)Inherit,(POLY)Inherit);+ } else if (sockTable[i]) { //delayed connection has been accepted or has failed+ int opt;+ socklen_t len = sizeof(int);+ FD_CLR(i,&writeUsed);+ if (getsockopt(i,SOL_SOCKET,SO_ERROR, (void *)&opt, &len) < 0)+ perror("getsockopt failed");+ if (opt) {+ netError(i,"Connection failed");+ } else {+ setupConnection(i);+ }+ }+ }+ }+ }+ }+}++// --------- Initialization ----------------------------------------------------++void envInit (int argc, char **argv) {+ Int i;+ + pthread_setspecific(current_key, &thread0);+ pthread_mutex_init(&envmut, &glob_mutexattr);+ + FD_ZERO(&readUsed);+ FD_ZERO(&writeUsed);+ + struct sigaction act;+ act.sa_flags = 0;+ sigemptyset( &act.sa_mask );+ act.sa_handler = kill_handler;+ sigaction( SIGSELECT, &act, NULL );+ + Array arr; NEW(Array,arr,WORDS(sizeof(struct Array))+argc);+ arr->GCINFO = __GC__Array0;+ arr->size = argc;+ for (i=0; i<argc; i++)+ arr->elems[i] = (POLY)getStr(argv[i]);+ env->argv_POSIX = arr;+ + struct timeval now;+ if (gettimeofday(&now,NULL) < 0)+ perror("gettimeofday failed");+ startTime.sec = now.tv_sec;+ startTime.usec = now.tv_usec;++ fcntl(0, F_SETFL, O_NONBLOCK);+ fcntl(1, F_SETFL, O_NONBLOCK);++ TIMERGET(msg0.baseline);++ thread0.msg = &msg0;+ thread0.id = pthread_self();+ }
+ rtsPOSIX/env.h view
@@ -0,0 +1,46 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#ifndef ENV_H_+#define ENV_H_++#define SOCKHANDLER CLOS2_Prelude // CLOS_Peer_POSIX_Int_Connection_POSIX__POSIX+#define HANDLER CLOS3_POSIX // CLOS_LIST_Time_Time_Msg__POSIX+#define ACTION CLOS2_Prelude // CLOS_Time_Time_Msg__POSIX+#define FILE2CLOSABLE l_File_POSIX_Closable_POSIX_POSIX+#define RFILE2FILE l_RFile_POSIX_File_POSIX_POSIX+#define WFILE2FILE l_WFile_POSIX_File_POSIX_POSIX+#define CONN2CLOSABLE l_Connection_POSIX_Closable_POSIX_POSIX+#define SOCK2CLOSABLE l_Socket_POSIX_Closable_POSIX_POSIX+#define __GC__HANDLER __GC__CLOS3_POSIX // __GC__CLOS_LIST_Time_Time_Msg__POSIX+#endif
+ rtsPOSIX/gc.c view
@@ -0,0 +1,373 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#include <stdlib.h>+#if defined(__APPLE__)+#include <mach-o/getsect.h>+#endif++#define NEW2(addr,words,info) { ADDR top,stop; \+ do { addr = hp2; stop = lim2; top = ODD((addr)+(words)); \+ } while (ISODD(addr) || !CAS(addr,top,&hp2)); \+ if (top>=stop) addr = force2(words,addr,info); else { addr[0] = (WORD)(info); hp2 = EVEN(top); } }++#define ODD(addr) (ADDR)((WORD)(addr) | 1)+#define EVEN(addr) (ADDR)((WORD)(addr) & ~1)+#define ISODD(addr) ((WORD)(addr) & 1)++#define IND0(obj) (ADDR)((ADDR)obj)[0]+#define GC_PROLOGUE(obj) { if (ISFORWARD(IND0(obj))) obj = (PID)IND0(obj); } // read barrier+#define GC_EPILOGUE(obj) { if (ISBLACK((ADDR)obj)) { ADDR a; NEW2(a,1,(ADDR)obj); } } // write barrier++#define GC_STD 0+#define GC_ARRAY 1+#define GC_TUPLE 2+#define GC_BIG 3+#define GC_MUT 4++#define POLYTAGS(width) (((width)+31) % 32)++#define GC_TYPE(info) (info[1])+#define STATIC_SIZE(info) (info[0])++#define allocwords(size) (ADDR)malloc(BYTES(size))+#define HEAPSIZE 0x100000 // 0x100000 words = 0x400000 bytes = 4194304 bytes = 4 Mb = 1024 pages = 0x400 pages+#define STARTGC() (WORD)hp >= 7 * (((WORD)lim)/8)++#define ISWHITE(a) INSIDE(heapchain,a,hp)+#define ISBLACK(a) hp2 && INSIDE(heapchain2,a,scanp)+#define ISFORWARD(a) ((ADDR)(a) > edata)++#define INSIDE(base,a,lim) (base[0] ? inside(base,a,lim) : (base <= (a) && (a) < lim))++int inside(ADDR base, ADDR a, ADDR lim) {+ if (base <= a && a < base+HEAPSIZE)+ return 1;+ base = (ADDR)base[0];+ return INSIDE(base,a,lim);+}++WORD pagesize; // obtained from OS, measured in words+ADDR base, lim, hp; // start, end, and current pos of latest "fromspace" (normal space)+ADDR base2, lim2, hp2; // start, end and current pos of latest "tospace" (only used during gc)+ADDR scanbase, scanp; // start and current pos of currently scanned segment (only used during gc)+ADDR heapchain, heapchain2; // anchor for the chain of all fromspaces, ditto for the tospaces+ADDR edata; // end of static data+ADDR staticHeap; // heap (chain) containing only statically allocated nodes (no copy)++char emergency = 0; // flag signalling heap overflow during gc++void scanEnvRoots(void);+void scanTimerQ(void);+extern int envRootsDirty;+extern int timerQdirty;+++void initheap() {+ base = allocwords(HEAPSIZE);+ if (!base)+ panic("Cannot allocate initial heap");+ base[0] = 0; // first word in a heap is the "next" link+ hp = base + 1;+ lim = base + HEAPSIZE - 1; // leave room for a one word node at the end+ heapchain = base;+ // printf("# Fresh heap: base=%x lim=%x (hp=%x)\n", (int)base, (int)lim, (int)hp);+}++void pruneStaticHeap() {+ ADDR lim0 = hp;+ ADDR base0 = realloc(base, BYTES(hp - base)); // Let current heap shrink to its current size+ if (base0 != base)+ panic("Cannot shrink static heap to current size");+ staticHeap = heapchain; // Remember the static chain (for debugging only)++ base0 = staticHeap; // Scan through all nodes allocated so far+ ADDR obj = base0 + 1;+ while (obj != lim0) {+ ADDR info = IND0(obj);+ if (info) {+ obj[0] = 0; // Mark as static+ WORD size = STATIC_SIZE(info);+ switch (GC_TYPE(info)) {+ case GC_ARRAY: size += obj[1]; break;+ case GC_TUPLE: size += obj[1] + POLYTAGS(obj[1]);+ }+ obj = obj + size;+ } else {+ base0 = (ADDR)base0[0]; // End of one static segment reached, move to next+ obj = base0 + 1;+ }+ }++ initheap(); // Create fresh heap for dynamic data+}++ADDR force(WORD size, ADDR last) { // Overflow in fromspace+ ADDR a;+ if (size > HEAPSIZE-3) panic("Excessive heap block requested");++ DISABLE(rts);+ // printf("# force: base=%x lim=%x (hp=%x)\n", (int)base, (int)lim, (int)hp);+ if (base <= last && last < lim) { // only extend if we were first to reach critical section+ a = allocwords(HEAPSIZE);+ if (!a) panic("Cannot allocate more memory");++ base[0] = (WORD)a; // add link to new heap in first word of previous heap+ a[0] = 0; // null terminate chain of heaps+ base = a;+ lim = a + HEAPSIZE - 1; // leave room for two words at the end+ hp = a + 1;++ last[0] = 0; // mark the end of a heap segment (nulled gcinfo)+ last[1] = (WORD)hp;+ // printf("# new: base=%x lim=%x (hp=%x)\n", (int)base, (int)lim, (int)hp);+ }+ ENABLE(rts);++ NEW(ADDR,a,size);+ return a;+}++ADDR force2(WORD size, ADDR last, ADDR info) { // Overflow in tospace+ ADDR a;+ if (size > HEAPSIZE-3) panic("Excessive heap block requested");+ + DISABLE(rts);+ if (base2 <= last && last < lim2) { // only extend if we were first to reach critical section+ a = allocwords(HEAPSIZE);+ if (!a) panic("Cannot allocate more memory");++ base2[0] = (WORD)a; // add link to new heap in first word of previous heap+ a[0] = 0; // null terminate chain of heaps+ base2 = a;+ lim2 = a + HEAPSIZE - 2; // leave room for two words at the end+ hp2 = a + 1;++ last[0] = 0; // mark the end of a heap segment (nulled gcinfo)+ last[1] = (WORD)hp2;+ }+ ENABLE(rts);++ NEW2(a,size,info);+ return a;+}++ADDR copystateful(ADDR obj, ADDR info) {+ WORD i = STATIC_SIZE(info);+ ADDR dest, datainfo = IND0(obj+i); // actual mutable struct follows right after the Ref struct+ WORD size = i + STATIC_SIZE(datainfo); // dataobj must be a GC_STD or a GC_BIG+ NEW2(dest,size,info);+ DISABLE(((Ref)obj)->mut);+ for ( ; i < size; i++)+ dest[i] = obj[i];+ INITREF((Ref)dest);+ obj[0] = (WORD)dest;+ if (info[2]) {+ // object has mutable arrays... !!!!!!!!+ }+ ENABLE(((Ref)obj)->mut);+ return dest;+}++ADDR copy(ADDR obj) {+ if (!ISWHITE(obj)) // don't copy if obj is a tospace address or a low range constant+ return obj;+ ADDR dest, info = IND0(obj);+ if (!info) // don't copy if obj is in static heap+ return obj;+ if (ISFORWARD(info)) // gcinfo should point to static data;+ return info; // if not, we have a forward ptr+ WORD i, size = STATIC_SIZE(info);+ switch (GC_TYPE(info)) { + case GC_ARRAY: size += obj[1]; break;+ case GC_TUPLE: size += obj[1] + POLYTAGS(obj[1]); break;+ case GC_MUT: return copystateful(obj,info);+ default: break;+ }+ NEW2(dest,size,info); // allocate in tospace and initialize with gcinfo+ for (i=0; i<size; i++)+ dest[i] = obj[i];+ obj[0] = (WORD)dest; // mark fromspace object as forwarded+ return dest;+}+++ADDR scan(ADDR obj) {+ ADDR info = IND0(obj);+ if (!info) // if gcinfo is null we have reached the end of a tospace segment+ return (ADDR)0; + if (ISFORWARD(info)) { // gcinfo should point to static data;+ scan(info); // if not, we have a write barrier (rescan request)+ return obj + 1;+ }+ switch (GC_TYPE(info)) {+ case GC_STD: {+ WORD size = STATIC_SIZE(info), i = 2, offset = info[i];+ while (offset) {+ obj[offset] = (WORD)copy((ADDR)obj[offset]);+ offset = info[++i];+ }+ return obj + size;+ }+ case GC_ARRAY: {+ WORD size = STATIC_SIZE(info) + obj[1], offset = 2; // find size of dynamic part in second slot of obj, add static size+ if (info[2])+ return obj + size; // return immediately if array contains only scalars+ while (offset<size) {+ obj[offset] = (WORD)copy((ADDR)obj[offset]);+ offset++;+ }+ return obj + size;+ }+ case GC_TUPLE: {+ WORD width = obj[1], offset = 1 + POLYTAGS(width), i = 1, j, tags;+ while (width > 32) {+ for (j = 0, tags = obj[i++]; j < 32; j++, offset++, tags = tags >> 1)+ if (!(tags & 1))+ obj[offset] = (WORD)copy((ADDR)obj[offset]);+ width -= 32;+ }+ for (tags = obj[i]; width > 0; width--, offset++, tags = tags >> 1) + if (!(tags & 1))+ obj[offset] = (WORD)copy((ADDR)obj[offset]);+ return obj + STATIC_SIZE(info) + width + POLYTAGS(width);+ }+ case GC_BIG: {+ WORD size = STATIC_SIZE(info), i = 2, offset = info[i];+ while (offset) { // scan all statically known pointer fields+ obj[offset] = (WORD)copy((ADDR)obj[offset]);+ offset = info[++i];+ }+ offset = info[++i];+ while (offset) { // scan dynamically identified pointers+ WORD tagword = info[++i];+ WORD bitno = info[++i];+ if ((tagword & (1 << bitno)) == 0)+ obj[offset] = (WORD)copy((ADDR)obj[offset]);+ offset = info[++i];+ }+ return obj + size;+ }+ case GC_MUT: {+ return scan(obj + STATIC_SIZE(info));+ }+ }+ return (ADDR)0; // Not reached+}++void gc() {+ heapchain2 = (ADDR)allocwords(HEAPSIZE); // allocate tospace (initial segment)+ base2 = heapchain2;+ base2[0] = 0;+ lim2 = base2 + HEAPSIZE - 1; // leave room for a one wor node at the end+ hp2 = base2 + 1;+ scanp = hp2;+ scanbase = base2;+ ENABLE(rts);+ + envRootsDirty = 1;+ timerQdirty = 1;++ while (1) {+ if (envRootsDirty)+ scanEnvRoots();+ if (timerQdirty)+ scanTimerQ();++ while (1) {+ while (ISODD(hp2)); // spin while a mutator is allocating a write barrier+ if (scanp == hp2)+ break; // break loop when we seem to be done+ scanp = scan(scanp);+ if (!scanp) { // nulled scanp: end of currently scanned segment+ scanbase = (ADDR)scanbase[0];+ scanp = scanbase + 1;+ }+ }++ DISABLE(rts);+ if ((scanp == hp2) && (envRootsDirty+timerQdirty+nactive == 0)) // still done and everybody else is asleep?+ break; // Continue with exclusive rts access+ ENABLE(rts);+ }+ + do { base = heapchain;+ heapchain = (ADDR)base[0];+ free(base);+ } while (heapchain);++ heapchain = heapchain2;+ base = base2;+ lim = lim2;+ hp = hp2;+ // printf("!!!Heap switched: base=%x lim=%x (hp=%x)\n", (int)base, (int)lim, (int)hp);++ base2 = lim2 = hp2 = (ADDR)0;+ scanbase = scanp = (ADDR)0;+ heapchain2 = (ADDR)0;+}++void *garbageCollector(void *arg) {+ Thread current = (Thread)arg;+ pthread_setspecific(current_key, current);+ struct sched_param param;+ param.sched_priority = current->prio;+ pthread_setschedparam(current->id, SCHED_RR, ¶m);+ DISABLE(rts);+ while (1) {+ pthread_cond_wait(¤t->trigger, &rts);+ // printf("# Starting GC\n");+ gc();+ }+}++Thread gcThread;++void gcStart(void) {+ pthread_cond_signal(&gcThread->trigger);+}++void gcInit() {+#if defined(__APPLE__)+ edata = (ADDR)get_edata();+#endif+#if defined(__linux__)+ extern int _end[];+ edata = (ADDR)_end;+#endif+ pagesize = sysconf(_SC_PAGESIZE) / sizeof(WORD);+ base2 = lim2 = hp2 = (ADDR)0; // no active tospace+ initheap(); // Allocate base (= heapchain)+ gcThread = newThread(NULL, prio_min, garbageCollector, pagesize);+}+
+ rtsPOSIX/install-sh view
@@ -0,0 +1,294 @@+#!/bin/sh+#+# install - install a program, script, or datafile+#+# This originates from X11R5 (mit/util/scripts/install.sh), which was+# later released in X11R6 (xc/config/util/install.sh) with the+# following copyright and license.+#+# Copyright (C) 1994 X Consortium+#+# Permission is hereby granted, free of charge, to any person obtaining a copy+# of this software and associated documentation files (the "Software"), to+# deal in the Software without restriction, including without limitation the+# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or+# sell copies of the Software, and to permit persons to whom the Software is+# furnished to do so, subject to the following conditions:+#+# The above copyright notice and this permission notice shall be included in+# all copies or substantial portions of the Software.+#+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN+# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-+# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+#+# Except as contained in this notice, the name of the X Consortium shall not+# be used in advertising or otherwise to promote the sale, use or other deal-+# ings in this Software without prior written authorization from the X Consor-+# tium.+#+#+# FSF changes to this file are in the public domain.+#+# Calling this script install-sh is preferred over install.sh, to prevent+# `make' implicit rules from creating a file called install from it+# when there is no Makefile.+#+# This script is compatible with the BSD install script, but was written+# from scratch. It can only install one file at a time, a restriction+# shared with many OS's install programs.+++# set DOITPROG to echo to test this script++# Don't use :- since 4.3BSD and earlier shells don't like it.+doit="${DOITPROG-}"+++# put in absolute paths if you don't have them in your path; or use env. vars.++mvprog="${MVPROG-mv}"+cpprog="${CPPROG-cp}"+chmodprog="${CHMODPROG-chmod}"+chownprog="${CHOWNPROG-chown}"+chgrpprog="${CHGRPPROG-chgrp}"+stripprog="${STRIPPROG-strip}"+rmprog="${RMPROG-rm}"+mkdirprog="${MKDIRPROG-mkdir}"++transformbasename=""+transform_arg=""+instcmd="$mvprog"+chmodcmd="$chmodprog 0755"+chowncmd=""+chgrpcmd=""+stripcmd=""+rmcmd="$rmprog -f"+mvcmd="$mvprog"+src=""+dst=""+dir_arg=""++while [ x"$1" != x ]; do+ case $1 in+ -c) instcmd=$cpprog+ shift+ continue;;++ -d) dir_arg=true+ shift+ continue;;++ -m) chmodcmd="$chmodprog $2"+ shift+ shift+ continue;;++ -o) chowncmd="$chownprog $2"+ shift+ shift+ continue;;++ -g) chgrpcmd="$chgrpprog $2"+ shift+ shift+ continue;;++ -s) stripcmd=$stripprog+ shift+ continue;;++ -t=*) transformarg=`echo $1 | sed 's/-t=//'`+ shift+ continue;;++ -b=*) transformbasename=`echo $1 | sed 's/-b=//'`+ shift+ continue;;++ *) if [ x"$src" = x ]+ then+ src=$1+ else+ # this colon is to work around a 386BSD /bin/sh bug+ :+ dst=$1+ fi+ shift+ continue;;+ esac+done++if [ x"$src" = x ]+then+ echo "$0: no input file specified" >&2+ exit 1+else+ :+fi++if [ x"$dir_arg" != x ]; then+ dst=$src+ src=""++ if [ -d "$dst" ]; then+ instcmd=:+ chmodcmd=""+ else+ instcmd=$mkdirprog+ fi+else++# Waiting for this to be detected by the "$instcmd $src $dsttmp" command+# might cause directories to be created, which would be especially bad+# if $src (and thus $dsttmp) contains '*'.++ if [ -f "$src" ] || [ -d "$src" ]+ then+ :+ else+ echo "$0: $src does not exist" >&2+ exit 1+ fi++ if [ x"$dst" = x ]+ then+ echo "$0: no destination specified" >&2+ exit 1+ else+ :+ fi++# If destination is a directory, append the input filename; if your system+# does not like double slashes in filenames, you may need to add some logic++ if [ -d "$dst" ]+ then+ dst=$dst/`basename "$src"`+ else+ :+ fi+fi++## this sed command emulates the dirname command+dstdir=`echo "$dst" | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`++# Make sure that the destination directory exists.+# this part is taken from Noah Friedman's mkinstalldirs script++# Skip lots of stat calls in the usual case.+if [ ! -d "$dstdir" ]; then+defaultIFS='+ '+IFS="${IFS-$defaultIFS}"++oIFS=$IFS+# Some sh's can't handle IFS=/ for some reason.+IFS='%'+set - `echo "$dstdir" | sed -e 's@/@%@g' -e 's@^%@/@'`+IFS=$oIFS++pathcomp=''++while [ $# -ne 0 ] ; do+ pathcomp=$pathcomp$1+ shift++ if [ ! -d "$pathcomp" ] ;+ then+ $mkdirprog "$pathcomp"+ else+ :+ fi++ pathcomp=$pathcomp/+done+fi++if [ x"$dir_arg" != x ]+then+ $doit $instcmd "$dst" &&++ if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dst"; else : ; fi &&+ if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dst"; else : ; fi &&+ if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dst"; else : ; fi &&+ if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dst"; else : ; fi+else++# If we're going to rename the final executable, determine the name now.++ if [ x"$transformarg" = x ]+ then+ dstfile=`basename "$dst"`+ else+ dstfile=`basename "$dst" $transformbasename |+ sed $transformarg`$transformbasename+ fi++# don't allow the sed command to completely eliminate the filename++ if [ x"$dstfile" = x ]+ then+ dstfile=`basename "$dst"`+ else+ :+ fi++# Make a couple of temp file names in the proper directory.++ dsttmp=$dstdir/#inst.$$#+ rmtmp=$dstdir/#rm.$$#++# Trap to clean up temp files at exit.++ trap 'status=$?; rm -f "$dsttmp" "$rmtmp" && exit $status' 0+ trap '(exit $?); exit' 1 2 13 15++# Move or copy the file name to the temp name++ $doit $instcmd "$src" "$dsttmp" &&++# and set any options; do chmod last to preserve setuid bits++# If any of these fail, we abort the whole thing. If we want to+# ignore errors from any of these, just make sure not to ignore+# errors from the above "$doit $instcmd $src $dsttmp" command.++ if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; else :;fi &&+ if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; else :;fi &&+ if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; else :;fi &&+ if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; else :;fi &&++# Now remove or move aside any old file at destination location. We try this+# two ways since rm can't unlink itself on some systems and the destination+# file might be busy for other reasons. In this case, the final cleanup+# might fail but the new file should still install successfully.++{+ if [ -f "$dstdir/$dstfile" ]+ then+ $doit $rmcmd -f "$dstdir/$dstfile" 2>/dev/null ||+ $doit $mvcmd -f "$dstdir/$dstfile" "$rmtmp" 2>/dev/null ||+ {+ echo "$0: cannot unlink or rename $dstdir/$dstfile" >&2+ (exit 1); exit+ }+ else+ :+ fi+} &&++# Now rename the file to the real destination.++ $doit $mvcmd "$dsttmp" "$dstdir/$dstfile"++fi &&++# The final little trick to "correctly" pass the exit status to the exit trap.++{+ (exit 0); exit+}
+ rtsPOSIX/main.c view
@@ -0,0 +1,52 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#include "rts.h"+#include "timber.h"+#include "POSIX.h"+#include "env.h"++void ROOTINIT(void);+ACTION ROOT(Env_POSIX, POLY);++extern ACTION prog;+extern Env_POSIX env;++int main(int argc, char **argv) {+ init_rts(argc, argv);+ ROOTINIT();+ pruneStaticHeap();+ prog = ROOT(env, (POLY)0);+ prog->Code(prog,(POLY)Inherit,(POLY)Inherit);+ eventLoop();+}
+ rtsPOSIX/rts.c view
@@ -0,0 +1,500 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#include <stdlib.h>+#include <stdio.h>+#include <unistd.h>+#include <sys/types.h>+#include <sys/mman.h>+#include <signal.h>+#include <sys/time.h>+#include <string.h>+#include "rts.h"+#include "timber.h"+++#define MAXTHREADS 8++#define SLEEP() sigsuspend(&enabled_mask)+#define DISABLE(mutex) pthread_mutex_lock(&mutex)+#define ENABLE(mutex) pthread_mutex_unlock(&mutex)+++#define TDELTA 1+#define TIMERGET(x) gettimeofday(&x, NULL)+#define TIMERSET(x,now) { struct itimerval t; \+ t.it_value = (x); \+ SUB(t.it_value, now); \+ t.it_interval.tv_sec = 0; \+ t.it_interval.tv_usec = 0; \+ setitimer( ITIMER_REAL, &t, NULL); \+ }++#define LESS(a,b) ( ((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec)) )+#define LESSEQ(a,b) ( ((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec <= (b).tv_usec)) )+#define ADD(a,t) { (a).tv_usec += (t->usec); \+ if ((a).tv_usec >= 1000000) { \+ (a).tv_usec -= 1000000; \+ (a).tv_sec += 1; \+ } \+ (a).tv_sec += (t->sec); \+ }+#define SUB(a,b) { (a).tv_usec -= (b).tv_usec; \+ if ((a).tv_usec < 0) { \+ (a).tv_usec += 1000000; \+ (a).tv_sec -= 1; \+ } \+ (a).tv_sec -= (b).tv_sec; \+ }++#define INF 0x7fffffff+++// Thread management --------------------------------------------------------------------------------++struct Thread;+typedef struct Thread *Thread;++struct Thread {+ Thread next; // for use in linked lists+ Msg msg; // message under execution+ int prio;+ pthread_t id;+ int index;+ pthread_cond_t trigger;+ int placeholders; // for use during cyclic data construction+};++Msg msgQ = NULL;+Msg timerQ = NULL;++Thread runQ = NULL;+Thread sleepQ = NULL;++int nactive = 0;+int nthreads = 0;++struct Thread threads[MAXTHREADS];++pthread_mutex_t rts;++pthread_mutexattr_t glob_mutexattr;+pthread_mutexattr_t obj_mutexattr;++sigset_t all_sigs;++pthread_key_t current_key;++int prio_min, prio_max;++#define NCORES 2+#define PRIO(t) (t ? t->prio : )+++Thread newThread(Msg m, int prio, void *(*fun)(void *), int stacksize) {+ Thread t = NULL;+ if (nthreads < MAXTHREADS) {+ t = &threads[nthreads++];+ t->msg = m;+ t->prio = prio;+ t->placeholders = 0;+ t->index = nthreads;+ pthread_attr_t attr;+ pthread_attr_init(&attr);+ pthread_attr_setinheritsched(&attr, PTHREAD_EXPLICIT_SCHED);+ if (stacksize > 0)+ pthread_attr_setstacksize(&attr, BYTES(stacksize));+ pthread_cond_init(&t->trigger, NULL);+ pthread_create(&t->id, &attr, fun, t);+ }+ return t;+}++++// Last resort -----------------------------------------------------------------------------------++void panic(char *str) {+ DISABLE(rts);+ fprintf(stderr, "Timber RTS panic: %s. Quitting...\n", str);+ exit(1);+}+++// Memory management --------------------------------------------------------------------------------++#include "gc.c"+++// Cyclic data handling -----------------------------------------------------------------------------++#include "cyclic.c"+++// GCINFO definitions for the built-in types -----------------------------------------------------++#include "timber.c"+++// Queue management ------------------------------------------------------------------------------++void enqueueByDeadline(Msg p, Msg *queue) {+ Msg prev = NULL, q = *queue;+ while (q && LESS(q->deadline, p->deadline)) {+ prev = q;+ q = q->next;+ }+ p->next = q;+ if (prev == NULL)+ *queue = p;+ else+ prev->next = p;+}++void enqueueByBaseline(Msg p, Msg *queue) {+ Msg prev = NULL, q = *queue;+ while (q && LESS(q->baseline, p->baseline)) {+ prev = q;+ q = q->next;+ }+ p->next = q;+ if (prev == NULL)+ *queue = p;+ else+ prev->next = p;+}++Msg dequeue(Msg *queue) {+ Msg m = *queue;+ if (m)+ *queue = m->next;+ else+ panic("Empty queue");+ return m;+}++UNITTYPE ABORT(BITS32 polytag, Msg m, Ref dummy){+ m->Code = NULL;+ ADDR info;+ do {+ info = IND0((ADDR)m);+ if (ISFORWARD(info))+ ((Msg)info)->Code = NULL;+ } while (info != IND0((ADDR)m));+ return (UNITTYPE)0;+}++++// Thread management ------------------------------------------------------------------------++int midPrio(Thread prev, Thread next) {+ int left = (prev ? prev->prio : prio_max-1);+ int right = (next ? next->prio : prio_min+1);+ return right + ((left - right) / 2);+}+++void *run(void*);++Thread getThread(Msg m, int prio) {+ Thread t = sleepQ;+ if (t) {+ struct sched_param param;+ param.sched_priority = prio;+ sleepQ = t->next;+ t->msg = m;+ pthread_setschedparam(t->id, SCHED_RR, ¶m);+ pthread_cond_signal(&t->trigger);+ } else+ t = newThread(m, prio, run, 0);+ return t;+}++int activate(Msg m) {+ int count = 0;+ Thread prev = NULL, t = runQ;+ AbsTime dl = m->deadline;+ while (count < NCORES && t && LESS(t->msg->deadline, dl)) {+ count++;+ prev = t;+ t = t->next;+ }+ if (count >= NCORES)+ return 0;+ Thread new = getThread(m, midPrio(prev,t));+ if (new == NULL)+ return 0;+ new->next = t;+ if (prev == NULL)+ runQ = new;+ else+ prev->next = new;+ nactive++;+ // fprintf(stderr, "Worker thread %d activated (%d)\n", (int)new, nactive);+ return 1;+}++void deactivate(Thread t) {+ if (t == runQ)+ runQ = runQ->next;+ else {+ Thread prev = runQ, q = runQ->next;+ while (q != t) {+ prev = q;+ q = q->next;+ }+ prev->next = q->next;+ }+ t->next = sleepQ;+ sleepQ = t;+ nactive--;+ // fprintf(stderr, "Worker thread %d deactivated (%d)\n", (int)t, nactive);+}++void *run(void *arg) {+ Thread current = (Thread)arg;+ pthread_setspecific(current_key, current);+ struct sched_param param;+ param.sched_priority = current->prio;+ pthread_setschedparam(current->id, SCHED_RR, ¶m);+ // fprintf(stderr, "Worker thread %d started\n", (int)current);+ DISABLE(rts);+ while (1) {+ Msg this = current->msg;++ ENABLE(rts);+ Int (*code)(Msg) = this->Code;+ if (code)+ code(this);+ DISABLE(rts);++ deactivate(current);+ while (msgQ && !(msgQ->Code))+ msgQ = msgQ->next;+ if (msgQ) {+ activate(msgQ);+ msgQ = msgQ->next;+ } else {+ pthread_cond_wait(¤t->trigger, &rts);+ }+ if (STARTGC())+ gcStart();+ }+}+++// Major primitives ---------------------------------------------------------------------++UNITTYPE ASYNC( Msg m, Time bl, Time dl ) {+ DISABLE(rts);++ AbsTime now;+ TIMERGET(now);+ Thread current = CURRENT();+ // fprintf(stderr, "Working thread %d in ASYNC\n", (int)current);+ m->baseline = current->msg->baseline;+ switch ((Int)bl) {+ case INHERIT: break;+ case TIME_INFINITY:+ m->baseline.tv_sec = INF;+ m->baseline.tv_usec = 0;+ break;+ default:+ ADD(m->baseline, bl);+ if (LESS(m->baseline, now))+ m->baseline = now;+ }+ switch((Int)dl) {+ case INHERIT: + m->deadline = current->msg->deadline;+ break;+ case TIME_INFINITY:+ m->deadline.tv_sec = INF;+ m->deadline.tv_usec = 0;+ break;+ default:+ m->deadline = m->baseline;+ ADD(m->deadline, dl);+ }+ + if (LESS(now, m->baseline)) { // TIMERQ_PROLOGUE();+ enqueueByBaseline(m, &timerQ);+ timerQdirty = 1;+ if (timerQ == m)+ TIMERSET(m->baseline, now); // TIMERQ_EPILOGUE();+ } else if (!activate(m))+ enqueueByDeadline(m, &msgQ);++ ENABLE(rts);+ return (UNITTYPE)0;+}+++void INITREF( Ref obj ) {+ obj->GCINFO = __GC__Ref;+ pthread_mutex_init(&obj->mut, &obj_mutexattr);+ obj->STATE = (ADDR)STATEOF(obj); // actually unused, but keep it clean+}++PID LOCK( PID to ) {+ Ref r = (Ref)to;+ pthread_mutex_lock(&(r->mut));+ GC_PROLOGUE(to);+ if (to != (PID)r) {+ pthread_mutex_lock(&(((Ref)to)->mut));+ pthread_mutex_unlock(&(r->mut));+ }+ return to;+}++UNITTYPE UNLOCK( PID to ) {+ GC_EPILOGUE(to);+ pthread_mutex_unlock(&(((Ref)to)->mut));+ return (UNITTYPE)0;+}++++// Exception handling ----------------------------------------------------------------------------------++void RAISE(Int err) {+ char buf[100];+ sprintf(buf, "Unhandled exception (%d)", err);+ panic(buf);+}++POLY Raise(BITS32 polyTag, Int err) {+ RAISE(err);+ return NULL;+}+++// Arrays ---------------------------------------------------------------------------------------------++#include "arrays.c"++// Primitive timer class ------------------------------------------------------------------------------++#include "timer.c"++// Environment object ---------------------------------------------------------------------------------++#include "env.c"++// Show Float -----------------------------------------------------------------------------------------++#include "float.c"++// timerQ handling ------------------------------------------------------------------------------------++int timerQdirty;++void *timerHandler(void *arg) {+ Thread current = (Thread)arg;+ struct sched_param param;+ param.sched_priority = current->prio;+ pthread_setschedparam(current->id, SCHED_RR, ¶m);++// pthread_sigmask(SIG_BLOCK, &all_sigs, NULL);+ sigset_t accept;+ sigemptyset(&accept);+ sigaddset(&accept, SIGALRM);+ while (1) {+ int received;+ sigwait(&accept, &received);+ DISABLE(rts);+ AbsTime now;+ TIMERGET(now);+ while (timerQ && LESSEQ(timerQ->baseline, now)) {+ Msg m = dequeue(&timerQ);+ if (m->Code) {+ if (!activate(m))+ enqueueByDeadline(m, &msgQ);+ }+ }+ if (timerQ)+ TIMERSET(timerQ->baseline, now);+ ENABLE(rts);+ }+}++void scanTimerQ() {+ timerQdirty = 0;+ DISABLE(rts);+ if (timerQ) {+ timerQ = (Msg)copy((ADDR)timerQ);+ ENABLE(rts);+ DISABLE(rts);+ Msg m = timerQ, next = m->next;+ while (next) {+ m->next = (Msg)copy((ADDR)next);+ ENABLE(rts);+ DISABLE(rts);+ m = m->next;+ next = m->next;+ }+ }+ ENABLE(rts);+}+++// Initialization -------------------------------------------------------------------------------------++void init_rts(int argc, char **argv) {+ pthread_mutexattr_init(&glob_mutexattr);+ pthread_mutexattr_settype(&glob_mutexattr, PTHREAD_MUTEX_NORMAL);+ pthread_mutexattr_setprotocol(&glob_mutexattr, PTHREAD_PRIO_INHERIT);+ pthread_mutex_init(&rts, &glob_mutexattr);+ + pthread_mutexattr_init(&obj_mutexattr);+ pthread_mutexattr_settype(&obj_mutexattr, PTHREAD_MUTEX_NORMAL);+ pthread_mutexattr_setprotocol(&obj_mutexattr, PTHREAD_PRIO_INHERIT);+ + prio_min = sched_get_priority_min(SCHED_RR);+ prio_max = sched_get_priority_max(SCHED_RR);+ pthread_key_create(¤t_key, NULL);+ sigemptyset(&all_sigs);+ sigaddset(&all_sigs, SIGALRM);+ sigaddset(&all_sigs, SIGSELECT);+ pthread_sigmask(SIG_BLOCK, &all_sigs, NULL);+ + DISABLE(rts);+ + gcInit();+ envInit(argc, argv);+ newThread(NULL, prio_max, timerHandler, pagesize);+ + ENABLE(rts);+}+
+ rtsPOSIX/rts.h view
@@ -0,0 +1,185 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.++#ifndef RTS_H_+#define RTS_H_++#include <stddef.h>+#include <sys/time.h>+//#include <setjmp.h>+#include <pthread.h>++#include "config.h"++typedef int WORD;+typedef WORD *ADDR;++#define Int int+#define Float float+#define Char char+#define Bool char+#define FALSE char // alias for singleton type+#define TRUE char // alias for singleton type+#define UNITTYPE char+#define UNITTERM char // alias for singleton type+#define POLY ADDR+#define PID ADDR+#define BITS8 unsigned char+#define BITS16 unsigned short+#define BITS32 unsigned int+++#define primSHIFTRA8(a,b) ((signed char)(a) >> (b))+#define primSET8(a,b) ((a) | (1 << (b)))+#define primCLR8(a,b) ((a) & ~(1 << (b)))+#define primTST8(a,b) (((a) & (1 << (b))) != 0)++#define primSHIFTRA16(a,b) ((signed short)(a) >> (b))+#define primSET16(a,b) ((a) | (1 << (b)))+#define primCLR16(a,b) ((a) & ~(1 << (b)))+#define primTST16(a,b) (((a) & (1 << (b))) != 0)++#define primSHIFTRA32(a,b) ((signed int)(a) >> (b))+#define primSET32(a,b) ((a) | (1 << (b)))+#define primCLR32(a,b) ((a) & ~(1 << (b)))+#define primTST32(a,b) (((a) & (1 << (b))) != 0)+++union FloatCast {+ float f;+ POLY p;+};++#define POLY2Float(x) ((union FloatCast )(x)).f+#define Float2POLY(x) ((union FloatCast )((float)x)).p++#define ZEROBITS 0+#define ORBITS(a,b) (a) | (b)+#define SETBIT(n) (1 << n)+#define COPYBIT(x,m,n) (((x >> m) & 1) << n)++/*+#define SEC(x) ((x)*1000000)+#define MILLISEC(x) ((x)*1000)+#define MICROSEC(x) (x)+*/++struct Msg;++typedef struct Ref *Ref;+struct Ref {+ WORD *GCINFO;+ pthread_mutex_t mut;+ POLY STATE;+};++#define STATEOF(ref) (((ADDR)(ref))+WORDS(sizeof(struct Ref)))++void INITREF(Ref);++extern WORD __GC__Ref[];++typedef struct timeval AbsTime;++struct Time {+ WORD *GCINFO;+ Int sec;+ Int usec;+};++typedef struct Time *Time;++extern WORD __GG__Time[] ;+++#define WORDS(bytes) (((bytes)+sizeof(WORD)-1)/sizeof(WORD))+#define BYTES(words) ((words)*sizeof(WORD))+++#if defined(HAVE_OSX_ATOMICS)+#include <libkern/OSAtomic.h>+#define CAS(old,new,mem) OSAtomicCompareAndSwap32((WORD)(old),(WORD)(new),(ADDR)(mem))+#else+#if defined(HAVE_BUILTIN_ATOMIC) +#define CAS(old,new,mem) __sync_bool_compare_and_swap((mem),(WORD)(old),(WORD)(new))+#else+#error "Can not define CAS on your architecture."+#endif+#endif++#define NEW(t,addr,words) { ADDR top,stop; \+ do { addr = (t)hp; stop = lim; top = ((ADDR)addr)+(words); } \+ while (!CAS(addr,top,&hp)); \+ if (top>=stop) addr = (t)force((words),(ADDR)addr); }++#define CURRENT() ((Thread)pthread_getspecific(current_key))++/*+#define TMIN(a,b) ((a) < (b) ? (a) : (b) )+#define TPLUS(a,b) ((a) + (b))+#define TMINUS(a,b) ( (a) > (b) ? (a) - (b) : 0 )+*/+++extern ADDR hp, lim;+extern pthread_key_t current_key;++ADDR force(WORD, ADDR);+void pruneStaticHeap();++void init_rts(int, char**);++Time sec(Int c);+Time millisec(Int x);+Time microsec(Int x);+Int secOf(Time t);+Int microsecOf (Time t);++#define Inherit ((Time)0)+#define Infinity ((Time)1)++#define INHERIT 0+#define TIME_INFINITY 1++Time primTimeMin(Time t1, Time t2);+Time primTimePlus(Time t1, Time t2);+Time primTimeMinus(Time t1, Time t2);++Bool primTimeEQ(Time t1, Time t2);+Bool primTimeNE(Time t1, Time t2);+Bool primTimeLT(Time t1, Time t2);+Bool primTimeLE(Time t1, Time t2);+Bool primTimeGT(Time t1, Time t2);+Bool primTimeGE(Time t1, Time t2);++#endif
+ rtsPOSIX/timberc.cfg.in view
@@ -0,0 +1,5 @@+CfgOpts+ { cCompiler = "@CC@ -DPOSIX"+ , compileFlags = " @CFLAGS@ "+ , linkFlags = " @LDFLAGS@ "+ }
+ rtsPOSIX/timer.c view
@@ -0,0 +1,305 @@+// The Timber compiler <timber-lang.org>+// +// Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+// All rights reserved.+// +// Redistribution and use in source and binary forms, with or without+// modification, are permitted provided that the following conditions+// are met:+// +// 1. Redistributions of source code must retain the above copyright+// notice, this list of conditions and the following disclaimer.+// +// 2. Redistributions in binary form must reproduce the above copyright+// notice, this list of conditions and the following disclaimer in the+// documentation and/or other materials provided with the distribution.+// +// 3. Neither the names of the copyright holder and any identified+// contributors, nor the names of their affiliations, may be used to +// endorse or promote products derived from this software without +// specific prior written permission.+// +// THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+// DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+// ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+// OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+// HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+// STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+// POSSIBILITY OF SUCH DAMAGE.+++#include "timber.h"++struct S_Timer {+ WORD *GCINFO;+ AbsTime start;+};++typedef struct S_Timer *S_Timer;++struct T_Timer;+typedef struct T_Timer *T_Timer;++struct T_Timer {+ WORD *GCINFO;+ UNITTYPE (*reset) (T_Timer, Int);+ Time (*sample) (T_Timer, Int);+ Ref self;+};+++static WORD __GC__T_Timer[] = {WORDS(sizeof(struct T_Timer)), GC_STD, WORDS(offsetof(struct T_Timer,self)), 0};+ +static WORD __GC__S_Timer[] = {WORDS(sizeof(struct S_Timer)), GC_STD, 0};++static WORD __GC__Time[] = {WORDS(sizeof(struct Time)), GC_STD, 0};+++Time sec(Int c) {+ Time res;+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->sec = c;+ res->usec = 0;+ return res;+}++Time millisec(Int c) {+ Time res;+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->sec = c / 1000;+ res->usec = 1000 * (c % 1000);+ return res;+}++Time microsec(Int c) {+ Time res;+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->sec = c / 1000000;+ res->usec = c % 1000000;+ return res;+}++Int secOf(Time t) {+ switch ((Int)t) {+ case INHERIT: panic("secOf Inherit");+ case TIME_INFINITY: panic("secOf infinity");+ default: return t->sec;+ }+}++Int microsecOf(Time t) {+ switch ((Int)t) {+ case INHERIT: panic("microsecOf Inherit");+ case TIME_INFINITY: panic("microsecOf infinity");+ default: return t->usec;+ }+}++++Time primTimePlus(Time t1, Time t2) {+ Time res;+ switch ((Int)t1) {+ case INHERIT: return t2;+ case TIME_INFINITY: return Infinity;+ default: + switch ((Int)t2) {+ case INHERIT: return t1;+ case TIME_INFINITY: return Infinity;+ default:+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->usec = t1->usec + t2->usec;+ res->sec = t1->sec + t2->sec;+ if (res->usec >= 1000000) {+ res->usec -= 1000000;+ res->sec += 1;+ }+ return res;+ }+ }+}++Time primTimeMin(Time t1, Time t2) {+ switch ((Int)t1) {+ case INHERIT: + case TIME_INFINITY:return t2;+ default:+ switch ((Int)t2) {+ case INHERIT: + case TIME_INFINITY: return t1;+ default: + if (t1->sec < t2->sec || (t1->sec == t2->sec && t1->usec < t2->usec))+ return t1;+ else+ return t2;+ }+ }+}+++Time primTimeMinus(Time t1, Time t2) {+ Time res;+ switch ((Int)t1) {+ case INHERIT: panic("primTimeMinus Inherit");+ case TIME_INFINITY: + switch((Int) t2) {+ case INHERIT: panic("primTimeMinus Inherit");+ case TIME_INFINITY: panic("infinity - infinity");+ default: return Infinity;+ } + default:+ switch ((Int)t2) {+ case INHERIT: panic("primTimeMinus Inherit");+ case TIME_INFINITY:+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->sec = 0;+ res->usec = 0;+ return res;+ default:+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->usec = t1->usec - t2->usec;+ if (res->usec < 0) {+ res->usec += 1000000;+ t1->sec -= 1;+ }+ res->sec = t1->sec - t2->sec;+ if (res->sec < 0) res->sec = 0;+ return res;+ }+ }+}++Bool primTimeEQ(Time t1, Time t2) {+ switch ((Int)t1) {+ case INHERIT: panic("primTimeEQ Inherit");+ case TIME_INFINITY: switch((Int)t2) {+ case INHERIT: panic("primTimeEQ Inherit");+ case TIME_INFINITY: return 1;+ default:+ return 0;+ }+ default:+ switch ((Int)t2) {+ case INHERIT: panic("primTimeEQ Inherit");+ case TIME_INFINITY: return 0;+ default:+ return (t1->sec == t2->sec && t1->usec == t2->usec);+ }+ }+}++Bool primTimeNE(Time t1, Time t2) {+ switch ((Int)t1) {+ case INHERIT: panic("primTimeNE Inherit");+ case TIME_INFINITY: switch((Int)t2) {+ case INHERIT: panic("primTimeNE Inherit");+ case TIME_INFINITY: return 0;+ default:+ return 1;+ }+ default:+ switch ((Int)t2) {+ case INHERIT: panic("primTimeNE Inherit");+ case TIME_INFINITY: return 1;+ default:+ return (t1->sec != t2->sec || t1->usec != t2->usec);+ }+ }+}++Bool primTimeLT(Time t1, Time t2) {+ switch ((Int)t1) {+ case INHERIT: panic("primTimeLT Inherit");+ case TIME_INFINITY: switch((Int)t2) {+ case INHERIT: panic("primTimeLT Inherit");+ default:+ return 0;+ }+ default:+ switch ((Int)t2) {+ case INHERIT: panic("primTimeLT Inherit");+ case TIME_INFINITY: return 1;+ default:+ return (t1->sec < t2->sec || (t1->sec==t2->sec && t1->usec<t2->usec));+ }+ }+}+Bool primTimeLE(Time t1, Time t2) {+ switch ((Int)t1) {+ case INHERIT: panic("primTime InheritLE");+ case TIME_INFINITY: switch((Int)t2) {+ case INHERIT: panic("primTime InheritLE");+ default:+ return 0;+ }+ default:+ switch ((Int)t2) {+ case INHERIT: panic("primTime InheritLE");+ case TIME_INFINITY: return 1;+ default:+ return (t1->sec < t2->sec || (t1->sec==t2->sec && t1->usec<=t2->usec));+ }+ }+}++Bool primTimeGT(Time t1, Time t2) {+ return primTimeLT(t2,t1);+}++Bool primTimeGE(Time t1, Time t2) {+ return primTimeLE(t2,t1);+}++static UNITTYPE reset_fun(Ref self, Int x) {+ self = (Ref)LOCK((PID)self);+ ((S_Timer)STATEOF(self))->start = CURRENT()->msg->baseline;+ UNLOCK((PID)self);+ return (UNITTYPE)0;+}++static Time sample_fun(Ref self, Int x) {+ self = (Ref)LOCK((PID)self);+ AbsTime now;+ now = CURRENT()->msg->baseline;+ SUB(now,((S_Timer)STATEOF(self))->start);+ UNLOCK((PID)self);+ Time res;+ NEW(Time,res,WORDS(sizeof(struct Time)));+ res->GCINFO = __GC__Time;+ res->sec = now.tv_sec;+ res->usec = now.tv_usec;+ return res;+}++static UNITTYPE reset_sel(T_Timer this,Int x) {+ return reset_fun(this->self,x);+}++static Time sample_sel(T_Timer this, Int x) {+ return sample_fun(this->self,x);+}++TIMERTYPE primTIMERTERM(Int x) {+ Ref self;+ NEW(Ref,self,WORDS(sizeof(struct Ref))+WORDS(sizeof(struct S_Timer)));+ INITREF(self);+ ((S_Timer)STATEOF(self))->GCINFO = __GC__S_Timer;+ ((S_Timer)STATEOF(self))->start = CURRENT()->msg->baseline;+ T_Timer res;+ NEW(T_Timer,res,WORDS(sizeof(struct T_Timer)));+ res->GCINFO = __GC__T_Timer;+ res->reset = reset_sel;+ res->sample = sample_sel;+ res->self = self;+ return (TIMERTYPE)res;+}
+ src/Common.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Common (module Common, module Name, isDigit) where++import PP+import qualified List+import qualified Maybe+import Char+import Name+import Data.Binary+import Debug.Trace++++fromJust = Maybe.fromJust+listToMaybe = Maybe.listToMaybe++fst3 (a,b,c) = a+snd3 (a,b,c) = b+thd3 (a,b,c) = c++dom = map fst++rng = map snd++partition p xs = List.partition p xs++nub xs = List.nub xs++xs \\ ys = filter (`notElem` ys) xs++xs `intersect` ys = xs `List.intersect` ys++xs `union` ys = xs `List.union` ys++disjoint xs ys = xs `intersect` ys == []++overlaps xs ys = not (disjoint xs ys)++intersperse x xs = List.intersperse x xs++duplicates xs = filter (`elem` dups) xs1+ where xs1 = nub xs+ dups = foldl (flip List.delete) xs xs1++rotate n xs = let (xs1,xs2) = splitAt n xs in xs2++xs1++separate [] = ([],[])+separate (Left x : xs) = let (ls,rs) = separate xs in (x:ls,rs)+separate (Right x : xs) = let (ls,rs) = separate xs in (ls,x:rs)++showids vs = concat (intersperse ", " (map show vs))++fmapM f g xs = do ys <- mapM g xs+ return (f ys)++mapFst f xs = [ (f a, b) | (a,b) <- xs ]++mapSnd f xs = [ (a, f b) | (a,b) <- xs ]++zipFilter (f:fs) (x:xs)+ | f = x : zipFilter fs xs+ | otherwise = zipFilter fs xs+zipFilter _ _ = []+ +noDups mess vs+ | not (null dups) = errorIds mess dups+ | otherwise = vs+ where dups = duplicates vs++uncurry3 f (x,y,z) = f x y z+++-- String manipulation -----------------------------------------------------++rmSuffix :: String -> String -> String+rmSuffix suf = reverse . rmPrefix (reverse suf) . reverse++rmPrefix :: String -> String -> String+rmPrefix pre str + | pre `List.isPrefixOf` str = drop (length pre) str+ | otherwise = error $ "rmPrefix: " ++ str ++ " is not a prefix of " ++ show pre++rmDirs :: String -> String+rmDirs = reverse . fst . span (/='/') . reverse ++dropPrefix [] s = (True, s)+dropPrefix (x:xs) (y:ys)+ | x == y = dropPrefix xs ys+dropPrefix xs ys = (False, ys)+++dropDigits xs = drop 0 xs+ where drop n (x:xs)+ | isDigit x = drop (10*n + ord x - ord '0') xs+ drop n xs = (n, xs)++++-- Error reporting ---------------------------------------------------------++errorIds mess ns = error (unlines ((mess++":") : map pos ns))+ where pos n = case loc n of+ Just (r,c) -> rJust 15 (show n) ++ " at line " ++ show r ++ ", column " ++ show c+ Nothing -> rJust 15 (show n) ++ modInfo n+ loc n = location (annot n)+ rJust w str = replicate (w-length str) ' ' ++ str+ modInfo (Name _ _ (Just m) a) = " defined in " ++ m+ modInfo _ = " (unknown position)"+errorTree mess t = error (mess ++ pos ++ (if length (lines str) > 1 then "\n"++str++"\n" else str) )+ where str = render (pr t)+ pos = " ("++ show (posInfo t) ++"): "+ +internalError mess t = errorTree ("**** Internal compiler error ****\n" ++ mess) t++internalError0 mess = error ("**** Internal compiler error ****\n" ++ mess)+++-- PosInfo ---------------------------------------------------------+ ++data PosInfo = Between {start :: (Int,Int), end :: (Int,Int)}+ | Unknown++instance Show PosInfo where+ show (Between (l1,c1) (l2,c2)) + = case l1==l2 of+ True -> case c1 == c2 of+ True -> "close to line "++show l1++", column "++show c1+ False -> "close to line "++show l1++", columns "++show c1++" -- "++show c2+ False -> "close to lines "++show l1++" -- "++show l2+ show Unknown = "at unknown position"++++between (Between s1 e1) (Between s2 e2) + = Between (min s1 s2) (max e1 e2)+between b@(Between _ _) Unknown = b+between Unknown b@(Between _ _) = b+between Unknown Unknown = Unknown ++startPos (Between s _) = Just s+startPos Unknown = Nothing++class HasPos a where+ posInfo :: a -> PosInfo++instance HasPos a => HasPos [a] where+ posInfo xs = foldr between Unknown (map posInfo xs)++instance (HasPos a, HasPos b) => HasPos (a,b) where+ posInfo (a,b) = between (posInfo a) (posInfo b)++instance HasPos a => HasPos (Maybe a) where+ posInfo Nothing = Unknown+ posInfo (Just a) = posInfo a++instance HasPos Bool where+ posInfo _ = Unknown++instance HasPos Name where+ posInfo n = case location (annot n) of+ Just (l,c)+ |l==0 && c==0 -> Unknown -- artificially introduced name+ |otherwise -> Between (l,c) (l,c+len n-1)+ Nothing -> Unknown+ where len(Name s _ _ _) = length s+ len(Prim p _) = length (strRep p)+ len(Tuple n _) = n+2++-- Literals ----------------------------------------------------------------++data Lit = LInt (Maybe (Int,Int)) Integer+ | LRat (Maybe (Int,Int)) Rational+ | LChr (Maybe (Int,Int)) Char+ | LStr (Maybe (Int,Int)) String+-- deriving (Eq)++instance Eq Lit where+ LInt _ m == LInt _ n = m == n+ LRat _ m == LRat _ n = m == n+ LChr _ m == LChr _ n = m == n+ LStr _ m == LStr _ n = m == n+ _ == _ = False++instance Show Lit where+ show (LInt _ i) = "LInt " ++ show i+ show (LRat _ r) = "LRat " ++ show r+ show (LChr _ c) = "LChr " ++ show c+ show (LStr _ s) = "LStr " ++ show s+ +instance Pr Lit where+ pr (LInt p i) = integer i+ pr (LRat _ r) = rational r+ pr (LChr _ c) = litChar c+ pr (LStr _ s) = litString s+++instance HasPos Lit where+ posInfo (LInt (Just (l,c)) i) = Between (l,c) (l,c+length(show i)-1) + posInfo (LRat (Just (l,c)) r) = Between (l,c) (l,c) -- check length of rationals) + posInfo (LChr (Just (l,c)) _) = Between (l,c) (l,c) + posInfo (LStr (Just (l,c)) cs) = Between (l,c) (l,c+length cs+1)+ posInfo _ = Unknown++lInt n = LInt Nothing (toInteger n)+lRat r = LRat Nothing r+lChr c = LChr Nothing c+lStr s = LStr Nothing s++-- Underlying monad ----------------------------------------------------------------------++newtype M s a = M ((Int,[s]) -> Either String ((Int,[s]), a))+++instance Functor (M s) where+ fmap f x = x >>= (return . f)++instance Monad (M s) where+ M m >>= f = M $ \k -> + case m k of + Right (k',a) -> m' k' where M m' = f a+ Left s -> Left s+ return a = M $ \k -> Right (k,a)+ fail s = M $ \k -> Left s++handle (M m) f = M $ \k ->+ case m k of+ Right r -> Right r+ Left s -> m' k where M m' = f s++expose (M m) = M $ \k ->+ case m k of+ Right (k',a) -> Right (k',Right a)+ Left s -> Right (k, Left s)++unexpose (Right a) = return a+unexpose (Left b) = fail b++runM (M m) = case m (1,[]) of + Right (_,x) -> x+ Left s -> error s++newNum = M $ \(n,s) -> Right ((n+1,s), n)++currentNum = M $ \(n,s) -> Right ((n,s), n)++addToStore x = M $ \(n,s) -> Right ((n,x:s), ())++currentStore = M $ \(n,s) -> Right ((n,s), s)++localStore (M m) = M $ \(n0,s0) ->+ case m (n0,[]) of+ Right ((n,s), x) -> Right ((n,s0), x)+ Left s -> Left s++newNameMod m s = do n <- newNum+ return (Name s n m ann)+ where ann = if s `elem` explicitSyms then suppAnnot { explicit = True } else suppAnnot+ suppAnnot = genAnnot { suppressMod = True }++newName s = newNameMod Nothing s++newNames s n = mapM (const (newName s)) [1..n]++newNamesPos s ps = mapM (newNamePos s) ps++newNamePos s p = do n <- newName s+ return (n {annot = genAnnot {location = startPos(posInfo p)}})++renaming vs = mapM f vs+ where f v | tag v == 0 = do n <- newNum+ return (v, v { tag = n })+ | otherwise = return (v, v)+++-- Merging renamings ------------------------------------------------------++-- Here we cannot use equality of names (Eq instance), since two unqualified+-- imported names with the same string will have non-zero tags and hence not be compared+-- for str equality.++-- remove pairs from rn2 that are shadowed by rn1; return also shadowed names+deleteRenamings [] rn2 = (rn2,[])+deleteRenamings ((n,_):rn1) rn2+ | not(isQualified n) = (rn',if b then n:ns else ns)+ | otherwise = (rn,ns)+ where (rn,ns) = deleteRenamings rn1 rn2+ (b,rn') = deleteName n rn+ +deleteName _ [] = (False,[])+deleteName n ((Name s t Nothing a,_):rn) + | str n == s = (True,rn)+deleteName n (p:rn) = let (b,rn') = deleteName n rn+ in (b,p:rn')++-- for merging renaming for locally bound names with ditto for imported names;+-- removes unqualified form of imported name+mergeRenamings1 rn1 rn2 = rn1 ++ rn2' + where (rn2',_) = deleteRenamings rn1 rn2++-- for merging renamings from two imported modules;+-- removes both occurrences when two unqualified names clash+mergeRenamings2 rn1 rn2 = case ns' of+ [] -> rn1' ++ rn2'+ _ -> tr' ("Warning: clash of imported name(s): "++showids ns' ++ "(hence not in scope)\n") (rn1' ++ rn2')+ where (rn2',ns) = deleteRenamings rn1 rn2+ rn1' = deleteNames ns rn1+ ns' = filter (not . isGenerated) ns+ deleteNames [] rn = rn+ deleteNames (n:ns) rn = deleteNames ns (snd (deleteName n rn))++-- Assertions -----------------------------------------------------------------------++assert e msg ns+ | e = return ()+ | otherwise = errorIds msg ns++assert1 e msg ts+ | e = return ()+ | otherwise = errorTree msg ts+++-- Poor man's exception datatype ------------------------------------------------------++encodeError msg ids = msg ++ ": " ++ concat (intersperse " " (map packName ids))++decodeError str+ | msg `elem` encodedMsgs = Just (msg, map unpackName (words rest))+ | otherwise = Nothing+ where (msg,_:rest) = span (/=':') str++encodedMsgs = [circularSubMsg, ambigInstMsg, ambigSubMsg]++circularSubMsg = "Circular subtyping"+ambigInstMsg = "Ambiguous instances"+ambigSubMsg = "Ambiguous subtyping"++assert0 e msg+ | e = return ()+ | otherwise = fail msg+++-- Tracing -----------------------------------------------------------------------------++tr m = trace (m++"\n") (return ())++tr' m e = trace ("\n"++m++"\n") e++trNum str = do n <- currentNum+ tr ("At "++show n++": "++str)++-- Free variables -----------------------------------------------------------------------++class Ids a where+ idents :: a -> [Name]++instance Ids a => Ids [a] where+ idents xs = concatMap idents xs++instance Ids a => Ids (Name,a) where+ idents (v,a) = idents a++tycons x = filter isCon (idents x)++tyvars x = filter isVar (idents x)++evars x = filter isVar (idents x)++svars x = filter isState (idents x)+++vclose vss vs+ | null vss2 = nub vs+ | otherwise = vclose vss1 (concat vss2 ++ vs)+ where (vss1,vss2) = partition (null . intersect vs) vss++++-- Bound variables -----------------------------------------------------------------------++class BVars a where+ bvars :: a -> [Name]+ + bvars _ = []+++-- Mappings -----------------------------------------------------------------------------++infixr 4 @@++type Map a b = [(a,b)]++lookup' assoc x = case lookup x assoc of+ Just e -> e+ Nothing -> internalError "lookup': did not find" x++lookup'' s assoc x = case lookup x assoc of+ Just e -> e+ Nothing -> internalError ("lookup' (" ++ s ++ "): did not find") x++inv assoc = map (\(a,b) -> (b,a)) assoc++delete k [] = []+delete k (x:xs)+ | fst x == k = xs+ | otherwise = x : delete k xs+++delete' ks xs = foldr delete xs ks+++insert k x [] = [(k,x)]+insert k x ((k',x'):assoc)+ | k == k' = (k,x) : assoc+ | otherwise = (k',x') : insert k x assoc+++update k f [] = error "Internal: Common.update"+update k f ((k',x):assoc)+ | k == k' = (k, f x) : assoc+ | otherwise = (k',x) : update k f assoc+++search p [] = Nothing+search p (a:assoc)+ | p a = Just a+ | otherwise = search p assoc+++insertBefore kx ks [] = [kx]+insertBefore kx ks ((k,x'):assoc)+ | k `elem` ks = kx:(k,x'):assoc+ | otherwise = (k,x') : insertBefore kx ks assoc+++++(@@) :: Subst b a b => Map a b -> Map a b -> Map a b+s1 @@ s2 = [(u,subst s1 t) | (u,t) <- s2] ++ s1+++merge :: (Eq a, Eq b) => Map a b -> Map a b -> Maybe (Map a b)+merge [] s' = Just s'+merge ((v,t):s) s' = case lookup v s' of+ Nothing -> merge s ((v,t):s')+ Just t' | t==t' -> merge s s'+ _ -> Nothing++nullSubst = []++a +-> b = [(a,b)]++restrict s vs = filter ((`elem` vs) . fst) s++prune s vs = filter ((`notElem` vs) . fst) s++class Subst a i e where+ subst :: Map i e -> a -> a+++substVars s xs = map (substVar s) xs++substVar s x = case lookup x s of+ Just x' -> x'+ Nothing -> x+++instance Subst a i e => Subst [a] i e where+ subst [] xs = xs+ subst s xs = map (subst s) xs++instance Subst a i e => Subst (Name,a) i e where+ subst s (v,a) = (v, subst s a)++instance Subst a i e => Subst (Maybe a) i e where+ subst s Nothing = Nothing+ subst s (Just a) = Just (subst s a)+++newEnv x ts = do vs <- mapM (const (newName x)) ts+ return (vs `zip` ts)++newEnvPos x ts e = do vs <- mapM (const (newNamePos x e)) ts+ return (vs `zip` ts)++++-- Kinds ---------------------------------------------------------------------------------++data Kind = Star+ | KFun Kind Kind+ | KWild+ | KVar Int+ deriving (Eq,Show)++instance HasPos Kind where+ posInfo _ = Unknown++newtype TVar = TV (Int,Kind)++type KEnv = Map Name Kind++instance Eq TVar where+ TV (n,k) == TV (n',k') = n == n'++instance Show TVar where+ show (TV (n,k)) = show n++instance Pr TVar where+ pr (TV (n,k)) = pr n+++newTV k = do n <- newNum+ return (TV (n,k))++newKVar = do n <- newNum+ return (KVar n)++tvKind (TV (n,k)) = k++kvars Star = []+kvars (KVar n) = [n]+kvars (KFun k1 k2) = kvars k1 ++ kvars k2++kArgs (KFun k k') = k : kArgs k'+kArgs k = []++kFlat k = (kArgs k, kRes k)++kRes (KFun k k') = kRes k'+kRes k = k+++instance Subst Kind Int Kind where+ subst s Star = Star+ subst s k@(KVar n) = case lookup n s of+ Just k' -> k'+ Nothing -> k+ subst s (KFun k1 k2) = KFun (subst s k1) (subst s k2)++instance Subst (Kind,Kind) Int Kind where+ subst s (a,b) = (subst s a, subst s b)++instance Pr (Name,Kind) where+ pr (n,k) = prId n <+> text "::" <+> pr k++instance Pr Kind where+ prn 0 (KFun k1 k2) = prn 1 k1 <+> text "->" <+> prn 0 k2+ prn 0 k = prn 1 k+ prn 1 Star = text "*"+ prn 1 (KVar n) = text ('_':show n)+ prn 1 KWild = text "_"+ prn 1 k = parens (prn 0 k)+++class TVars a where+ tvars :: a -> [TVar]++instance TVars a => TVars [a] where+ tvars xs = concatMap tvars xs++instance TVars a => TVars (Name,a) where+ tvars (v,a) = tvars a+++-- Defaults ------------------------------------------++data Default a = Default Bool Name Name -- First arg is True if declaration is in public part+ | Derive Name a+ deriving (Eq, Show)++instance Pr a => Pr(Default a) where+ pr (Default _ a b) = pr a <+> text "<" <+> pr b+ pr (Derive v t) = pr v <+> text "::" <+> pr t++instance HasPos a => HasPos (Default a) where+ posInfo (Default _ a b) = between (posInfo a) (posInfo b)+ posInfo (Derive v t) = between (posInfo v) (posInfo t)+++-- Binary --------------------------------------------++instance Binary Lit where+ put (LInt _ a) = putWord8 0 >> put a+ put (LRat _ a) = putWord8 1 >> put a+ put (LChr _ a) = putWord8 2 >> put a+ put (LStr _ a) = putWord8 3 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (lInt (a::Integer))+ 1 -> get >>= \a -> return (lRat a)+ 2 -> get >>= \a -> return (lChr a)+ 3 -> get >>= \a -> return (lStr a)+ _ -> fail "no parse"++instance Binary Kind where+ put Star = putWord8 0+ put (KFun a b) = putWord8 1 >> put a >> put b+ put KWild = putWord8 2+ put (KVar a) = putWord8 3 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> return Star+ 1 -> get >>= \a -> get >>= \b -> return (KFun a b)+ 2 -> return KWild+ 3 -> get >>= \a -> return (KVar a)+ _ -> fail "no parse"++instance Binary TVar where+ put (TV a) = put a+ get = get >>= \a -> return (TV a)++instance Binary a => Binary (Default a) where+ put (Default a b c) = putWord8 0 >> put a >> put b >> put c+ put (Derive a b) = putWord8 1 >> put a >> put b+ + get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (Default a b c)+ 1 -> get >>= \a -> get >>= \b -> return (Derive a b)
+ src/Config.hs view
@@ -0,0 +1,326 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++--------------------------------------------------------------------------+--+-- Compiler configuration+--+-- This module contains both what GHC calls "dynamic flags", flags that+-- can change between each compilation, and static flags. Initial idea+-- from GHC, slightly modified to fit our needs.+--+---------------------------------------------------------------------------++module Config (+ -- Our Data from files/flags.+ CfgOpts(..),+ CmdLineOpts(..),+ + -- Read out configuration from file.+ readCfg,++ -- Query about our options from flags.+ cmdLineOpts,+ + -- Configurable paths+ libDir,+ includeDir,+ rtsDir,+ rtsCfg,+ rtsMain,+ + -- Print usage info and exit.+ helpMsg,+ + -- Pass data. XXX Does not belong here?+ Pass(..),+ allPasses,+ + -- Dynamic Exceptions+ TimbercException(..),+ ) where+++import Char+import System.Console.GetOpt+import System ( getArgs, getEnv, getProgName )+import qualified Control.Exception as Exception ( throwIO, Exception )+import Data.Dynamic+++versionString = "The Timber compiler, version 1.0.1"++-- | Contains the configuration for the compiler with the current+-- command line switches.+data CfgOpts = CfgOpts { cCompiler :: FilePath,+ compileFlags :: String,+ linkFlags :: String+ } deriving (Show, Eq, Read)++-- | Command line options.+data CmdLineOpts = CmdLineOpts { isVerbose :: Bool,+ datadir :: FilePath,+ target :: String,+ outfile :: FilePath,+ root :: String,+ make :: String,+ api :: Bool,+ pager :: FilePath,+ shortcut :: Bool,+ stopAtC :: Bool,+ stopAtO :: Bool,+ dumpAfter :: Pass -> Bool,+ stopAfter :: Pass -> Bool+ }+++options :: [OptDescr Flag]+options = [ Option []+ ["help"]+ (NoArg Help)+ "Show this message",+ Option [] + ["version"] + (NoArg Version)+ "Print version information",+ Option [] + ["print-datadir"] + (NoArg PrintDatadir)+ "Print effective datadir path",+ Option ['v'] + ["verbose"] + (NoArg Verbose)+ "Be verbose",+ Option []+ ["datadir"]+ (ReqArg Datadir "DIRECTORY")+ "Path to installed libraries and run-time systems",+ Option []+ ["target"]+ (ReqArg Target "TARGET")+ "Target platform",+ Option ['o'] + ["output"] + (ReqArg Outfile "FILE") + "Name of executable output",+ Option []+ ["root"]+ (ReqArg Root "[MODULE.]NAME")+ "Define root of executable program",+ Option []+ ["make"]+ (ReqArg Make "[MODULE.]NAME")+ "Make program with given root module",+ Option []+ ["api"]+ (NoArg Api)+ "Produce html file with API",+ Option [] + ["pager"] + (ReqArg Pager "PATH")+ "Use command PATH to display .html files",+ Option ['s']+ ["shortcut"]+ (NoArg ShortCut)+ "Try to reuse existing .c, .h and .ti files",+ Option ['C'] + ["stop-at-c"]+ (NoArg StopAtC)+ "Stop compiler after .c file generation",+ Option ['c'] + ["stop-at-o"] + (NoArg StopAtO)+ "Stop compiler after .o file generation"+ ]+ ++ + [ Option []+ ["dump-" ++ map Char.toLower (show pass)]+ (NoArg $ DumpAfter pass)+ ("Dump " ++ show pass ++ " output to stdout")+ | pass <- allPasses + ] + ++ + [ Option []+ ["stop-after-" ++ map Char.toLower (show pass)]+ (NoArg $ StopAfter pass)+ ("Stop compiler after pass " ++ show pass)+ | pass <- allPasses + ]+ +++data Flag = Help+ | Verbose+ | Version+ | PrintDatadir+ | Datadir String+ | Target String+ | Outfile String+ | Root String+ | Make String+ | Api+ | Pager String+ | ShortCut+ | StopAtC+ | StopAtO+ | DumpAfter Pass+ | StopAfter Pass+ deriving (Show,Eq)++data TimbercException+ = CmdLineError String -- User did something wrong with command line options.+ | Panic String -- Unexpected faults in timberc, panic.+ deriving (Eq)++instance Typeable TimbercException where+ typeOf _ = mkTyConApp (mkTyCon "TimbercException") []++-- | Let us show our exceptions as expected.+instance Show TimbercException where+ showsPrec _ (CmdLineError s) = showString s+ showsPrec _ (Panic s) = showString $+ "Panic! Please file a bug report!\n\n" ++ s++instance Exception.Exception TimbercException++cmdLineOpts :: [String] -> IO (CmdLineOpts,[String])+cmdLineOpts args = do pager <- System.getEnv "PAGER" `catch` (\_ -> return "")+ let pagerOpt = if null pager then [] else ["--pager", pager]+ home <- System.getEnv "HOME" `catch` (\_ -> return "")+ cfgFile <- System.getEnv "TIMBERC_CFG" `catch` (\_ -> return (home ++ "/.timberc"))+ cfgOpts <- readFile cfgFile `catch` (\_ -> return "")+ case getOpt Permute options (args ++ words cfgOpts ++ pagerOpt) of+ (flags,n,[]) + | Help `elem` flags -> do + msg <- helpMsg+ Exception.throwIO (CmdLineError msg)+ | Version `elem` flags ->+ Exception.throwIO (CmdLineError versionString)+ | PrintDatadir `elem` flags ->+ Exception.throwIO (CmdLineError (datadir (mkCmdLineOpts flags)))+ | otherwise -> + return (mkCmdLineOpts flags, n)+ (_,_,errs) -> do + msg <- helpMsg+ Exception.throwIO (CmdLineError (concat errs ++ msg))+++helpMsg = do pgm <- getProgName+ return (usageInfo (header pgm) options)+ where header pgm = "Usage: " ++ pgm ++ " [OPTION...] files..."+ +++-- CmdLineOpts is a set of functions that can be queried+-- about the command line options.++mkCmdLineOpts :: [Flag] -> CmdLineOpts+mkCmdLineOpts flags = CmdLineOpts { isVerbose = find Verbose,+ datadir = first ""+ [ dir | (Datadir dir) <- flags ],+ target = first "POSIX"+ [ target | (Target target) <- flags ],+ outfile = first "a.out"+ [ file | (Outfile file) <- flags ],+ root = first "root"+ [ root | (Root root) <- flags ],+ make = first ""+ [ root | Make root <- flags ],+ api = find Api,+ pager = first "less"+ [ p | (Pager p) <- flags ],+ shortcut = find ShortCut,+ stopAtC = find StopAtC,+ stopAtO = find StopAtO,+ dumpAfter = find . DumpAfter,+ stopAfter = find . StopAfter+ }+ where + first def [] = def+ first def (opt:_)= opt+ find opt = first False [ True | flag <- flags, flag == opt ]++++++-- | Reads a configuration file in the format of CfgOpts.+readCfg clo = parseCfg (rtsCfg clo)+++-- | Internal help routine for readCfg.+parseCfg file+ = do+ txt <- catch (readFile file)+ (\e -> Exception.throwIO $ emsg file)+ config <- safeRead file txt+ return config+ where + safeRead :: FilePath -> String -> IO CfgOpts+ safeRead file text =+ let val = case [x | (x,t) <- reads text, ("","") <- lex t] of+ [x] -> x+ [] -> error ("Parse error in " ++ file ++ "\n")+ _ -> error ("File not found: " ++ file ++ "\n")+ in (return $! val)+ emsg f = (CmdLineError $ "Could not open " ++ file)+++-- | The different compiler passes.+-- XXX Should not be in this file.+data Pass = Parser+ | Desugar1+ | Rename+ | Desugar2+ | S2C+ | KCheck+ | TCheck+ | Termred+ | Type2+ | C2K+ | Kindlered+ | LLift+ | Prepare4C+ | K2C+ | Main -- top level 'pass'+ deriving (Show,Eq,Ord,Enum)+ +allPasses :: [Pass]+allPasses = [Parser .. K2C]+++rtsDir clo = datadir clo ++ "/rts" ++ target clo+rtsCfg clo = rtsDir clo ++ "/timberc.cfg"+rtsMain clo = rtsDir clo ++ "/main.c"+libDir clo = datadir clo ++ "/lib"+includeDir clo = datadir clo ++ "/include"
+ src/Core.hs view
@@ -0,0 +1,1151 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Core where++import Common+import PP+import Data.Binary+import Monad+++data Module = Module Name [(Bool,Name)] [Default Scheme] Types [Name] [Binds]+ deriving (Eq,Show)++data Types = Types KEnv Decls+ deriving (Eq,Show)++data Binds = Binds Bool TEnv Eqns+ deriving (Eq,Show)++--type Default = (Bool,Name,Name)++type PEnv = TEnv++type TEnv = Map Name Scheme++type CEnv = Map Name Constr++type Decls = Map Name Decl++type Eqns = Map Name Exp++data Decl = DData [Name] [Scheme] CEnv+ | DRec Bool [Name] [Scheme] TEnv+ | DType [Name] Type+ deriving (Eq,Show)++type PScheme = Scheme++type Pred = Type++data Scheme = Scheme Rho [PScheme] KEnv+ deriving (Eq,Show)++data Constr = Constr [Scheme] [PScheme] KEnv+ deriving (Eq,Show)++data Rho = R Type+ | F [Scheme] Rho+ deriving (Eq,Show)++data Type = TId Name+ | TVar TVar+ | TFun [Type] Type+ | TAp Type Type+ deriving (Eq,Show)++type Alt = (Pat, Exp)++data Pat = PCon Name+ | PLit Lit+ | PWild+ deriving (Eq,Show)++data Exp = ECon Name+ | ESel Exp Name+ | EVar Name+ | ELam TEnv Exp+ | EAp Exp [Exp]+ | ELet Binds Exp+ | ECase Exp [Alt]+ | ERec Name Eqns+ | ELit Lit++ | EAct Exp Exp+ | EReq Exp Exp+ | ETempl Name Type TEnv Cmd+ | EDo Name Type Cmd+ deriving (Eq,Show)++data Cmd = CGen Name Type Exp Cmd+ | CAss Name Exp Cmd+ | CLet Binds Cmd+ | CRet Exp+ | CExp Exp+ deriving (Eq,Show)+++litType (LInt _ i) = TId (prim Int)+litType (LRat _ r) = TId (prim Float)+litType (LChr _ c) = TId (prim Char)+litType (LStr _ s) = TAp (TId (prim LIST)) (TId (prim Char)) --internalError0 "Core.litType LStr"+++isNewAp (EVar (Prim New _)) = True+isNewAp (EAp e _) = isNewAp e+isNewAp (ELet bs e)+ | isEncoding bs = isNewAp e+isNewAp _ = False+++tupleKind n = foldr KFun Star (replicate n Star)+++tupleType n = Scheme (tFun' (map scheme ts) t) [] (vs `zip` repeat Star)+ where vs = take n abcSupply+ ts = map TId vs+ t = tAp (TId (tuple n)) ts+++newTVar k = fmap TVar (newTV k)+++nullCon = Constr [] [] []+++isLitPat (PLit _) = True+isLitPat _ = False++isConPat (PCon _) = True+isConPat _ = False++isLambda (ELam _ _) = True+isLambda _ = False+++arity (ELam te e) = length te+arity e = 0++eLet [] [] e = e+eLet te eq e = ELet (Binds False te eq) e++eLet' [] e = e+eLet' (bs:bss) e = ELet bs (eLet' bss e)++cLet' [] c = c+cLet' (bs:bss) c = CLet bs (cLet' bss c)++eLam [] e = e+eLam te e = ELam te e++eAbs (ELam te e) = (te,e)+eAbs e = ([],e)++eAp e [] = e+eAp e es = EAp e es++eAp1 e1 e2 = EAp e1 [e2]++eAp2 (EAp e es) es' = eAp2 e (es++es')+eAp2 e es = EAp e es++eFlat (EAp e es) = (e, es)+eFlat e = (e,[])++eHead (EAp e e') = eHead e+eHead e = e++nAp n f es = f es1 : es2+ where (es1,es2) = splitAt n es++tAp t ts = foldl TAp t ts++tAp' i vs = tAp (TId i) (map TId vs)++tFun [] rh = rh+tFun scs rh = F scs rh++tFun' scs t = tFun scs (R t)++tFlat t = flat t []+ where flat (TAp t t') ts = flat t (t':ts)+ flat t ts = (t,ts)+++tHead (TAp t t') = tHead t+tHead t = t++tId (TId i) = i++isTVar (TVar _) = True+isTVar _ = False+++a `sub` b = TFun [a] b+++isSub' p = isSub (body p)+++isSub (TFun [l] u) = True+isSub _ = False++isClass' p = isClass (body p)++isClass c = not (isSub c)+++subs (TFun [l] u) = (l,u)+subs t = internalError "subs of" t++subsyms p = (tId (tHead t), tId (tHead t'))+ where (t,t') = subs (body p)++lowersym p = fst (subsyms p)+uppersym p = snd (subsyms p)++headsym = tId . tHead . body++funArgs (F ts rh) = ts+funArgs rh = []+++body (Scheme rh _ _) = body' rh+ where body' (R c) = c+ body' (F _ rh) = body' rh++ctxt (Scheme _ ps _) = ps++quant (Scheme _ _ ke) = ke++scheme t = Scheme (R t) [] []+scheme' t = Scheme t [] []+pscheme p = Scheme (R p) [] []+pscheme' p ps ke = Scheme (R p) ps ke+++splitInsts (Binds r pe eq) = (Binds False pe1 eq1, Binds r pe2 eq2)+ where (pe1,pe2) = partition (isSub' . snd) pe+ (eq1,eq2) = partition ((`elem` dom pe1) . fst) eq+++ksigsOf (Types ke ds) = ke++tdefsOf (Types ke ds) = ds++tsigsOf (Binds _ te es) = te++tsigsOf' = foldr (\bs -> ((tsigsOf bs) ++)) []++eqnsOf (Binds _ te es) = es++isRec (Binds r _ _) = r++catDecls ds1 ds2 = Types (ksigsOf ds1 ++ ksigsOf ds2) (tdefsOf ds1 ++ tdefsOf ds2)++catBinds bs1 bs2 = Binds (isRec bs1 || isRec bs2) (tsigsOf bs1 ++ tsigsOf bs2) (eqnsOf bs1 ++ eqnsOf bs2)++concatBinds = foldr catBinds nullBinds++nullDecls = Types [] []++nullBinds = Binds True [] []++clash (Binds r te es) = not r && dom es `overlaps` evars es+++altPats = map fst+altRhss = map snd++oplus eqs eqs' = filter ((`notElem` vs) . fst) eqs ++ eqs'+ where vs = dom eqs'+++-- One-way matching -----------------------------------------------------+-- Only apply when types are known to match!! ---------------------------+++matchTs [] = nullSubst+matchTs ((t,TVar n):eqs) = matchTs (subst s eqs) @@ s+ where s = n +-> t+matchTs ((TAp t u,TAp t' u'):eqs) = matchTs ((t,t'):(u,u'):eqs)+matchTs ((TId c,TId c'):eqs) = matchTs eqs+matchTs ((TFun ts t,TFun ts' t'):eqs) = matchTs ((t,t') : ts `zip` ts' ++ eqs)+matchTs _ = internalError0 "Core.match"+++-- Equality up to renaming ----------------------------------------------++equalTs [] = True+equalTs ((TVar n, t@(TVar n')):eqs)+ | n == n' = equalTs eqs+ | otherwise = equalTs (subst (n +-> t) eqs)+equalTs ((TAp t u, TAp t' u'):eqs) = equalTs ((t,t'):(u,u'):eqs)+equalTs ((TId c,TId c'):eqs)+ | c == c' = equalTs eqs+equalTs ((TFun ts t,TFun ts' t'):eqs)+ | length ts == length ts' = equalTs ((t,t') : ts `zip` ts' ++ eqs)+equalTs eqs = False+++-- Simple equality check (modulo function type representation) ----------------++sameType sc t0 = case schemeToType sc of+ Just t -> t == t0+ Nothing -> False++schemeToType (Scheme rh [] []) = rhoToType rh+schemeToType _ = Nothing++rhoToType (R t) = return t+rhoToType (F scs rh) = do ts <- mapM schemeToType scs+ t <- rhoToType rh+ return (TFun ts t)+++-- Free variables (Exp) -------------------------------------------------------------++instance Ids Binds where+ idents (Binds rec te eqns)+ | rec = idents eqns \\ dom eqns+ | otherwise = idents eqns++instance Ids Exp where+ idents (EVar v) = [v]+ idents (ESel e l) = idents e+ idents (ELam te e) = idents e \\ dom te+ idents (EAp e es) = idents e ++ idents es+ idents (ELet bs e) = idents bs ++ (idents e \\ bvars bs)+ idents (ECase e alts) = idents e ++ idents alts+ idents (ERec c eqs) = idents eqs+ idents (EAct e e') = idents e ++ idents e'+ idents (EReq e e') = idents e ++ idents e'+ idents (ETempl x t te c) = idents c \\ (x : dom te)+ idents (EDo x t c) = filter (not . isState) (idents c \\ [x])+ idents _ = []++instance Ids Alt where+ idents (p,e) = idents e+++instance Ids Cmd where+ idents (CLet bs c) = idents bs ++ (idents c \\ bvars bs)+ idents (CGen x t e c) = idents e ++ (idents c \\ [x])+ idents (CAss x e c) = idents e ++ idents c+ idents (CRet e) = idents e+ idents (CExp e) = idents e+++-- Substitutions (Exp) --------------------------------------------------------------++-- Note! This substitution algorithm does not alpha convert!+-- Only use when variables are known not to clash++instance Subst Binds Name Exp where+ subst s (Binds r te eqns) = Binds r te (subst s eqns)+ +instance Subst Exp Name Exp where+ subst [] e = e+ subst s (EVar v) = case lookup v s of+ Just e -> e+ Nothing -> EVar v+ subst s (ESel e l) = ESel (subst s e) l+ subst s (ELam te e) = ELam te (subst s e)+ subst s (EAp e es) = EAp (subst s e) (subst s es)+ subst s (ELet bs e) = ELet (subst s bs) (subst s e)+ subst s (ECase e alts) = ECase (subst s e) (subst s alts)+ subst s (ERec c eqs) = ERec c (subst s eqs)+ subst s (EAct e e') = EAct (subst s e) (subst s e')+ subst s (EReq e e') = EReq (subst s e) (subst s e')+ subst s (ETempl x t te c) = ETempl x t te (subst s c)+ subst s (EDo x t c) = EDo x t (subst s c)+ subst s e = e++instance Subst Cmd Name Exp where+ subst s (CLet bs c) = CLet (subst s bs) (subst s c)+ subst s (CAss x e c) = CAss x (subst s e) (subst s c)+ subst s (CGen x t e c) = CGen x t (subst s e) (subst s c)+ subst s (CRet e) = CRet (subst s e)+ subst s (CExp e) = CExp (subst s e)++instance Subst Exp a b => Subst Alt a b where+ subst s (p,rh) = (p, subst s rh)++instance Subst (Exp, Exp) Name Exp where+ subst s (e,e') = (subst s e, subst s e')+++instance Subst Binds TVar Type where+ subst s (Binds r te eqns) = Binds r (subst s te) (subst s eqns)++instance Subst Exp TVar Type where+ subst [] e = e+ subst s (ESel e l) = ESel (subst s e) l+ subst s (ELam te e) = ELam (subst s te) (subst s e)+ subst s (EAp e es) = EAp (subst s e) (subst s es)+ subst s (ELet bs e) = ELet (subst s bs) (subst s e)+ subst s (ECase e alts) = ECase (subst s e) (subst s alts)+ subst s (ERec c eqs) = ERec c (subst s eqs)+ subst s (EAct e e') = EAct (subst s e) (subst s e')+ subst s (EReq e e') = EReq (subst s e) (subst s e')+ subst s (ETempl x t te c) = ETempl x (subst s t) (subst s te) (subst s c)+ subst s (EDo x t c) = EDo x (subst s t) (subst s c)+ subst s e = e++instance Subst Cmd TVar Type where+ subst s (CLet bs c) = CLet (subst s bs) (subst s c)+ subst s (CAss x e c) = CAss x (subst s e) (subst s c)+ subst s (CGen x t e c) = CGen x (subst s t) (subst s e) (subst s c)+ subst s (CRet e) = CRet (subst s e)+ subst s (CExp e) = CExp (subst s e)++++instance Subst Binds Name Type where+ subst s (Binds r te eqns) = Binds r (subst s te) (subst s eqns)++instance Subst Exp Name Type where+ subst [] e = e+ subst s (ESel e l) = ESel (subst s e) l+ subst s (ELam te e) = ELam (subst s te) (subst s e)+ subst s (EAp e es) = EAp (subst s e) (subst s es)+ subst s (ELet bs e) = ELet (subst s bs) (subst s e)+ subst s (ECase e alts) = ECase (subst s e) (subst s alts)+ subst s (ERec c eqs) = ERec c (subst s eqs)+ subst s (EAct e e') = EAct (subst s e) (subst s e')+ subst s (EReq e e') = EReq (subst s e) (subst s e')+ subst s (ETempl x t te c) = ETempl x (subst s t) (subst s te) (subst s c)+ subst s (EDo x t c) = EDo x (subst s t) (subst s c)+ subst s e = e++instance Subst Cmd Name Type where+ subst s (CLet bs c) = CLet (subst s bs) (subst s c)+ subst s (CAss x e c) = CAss x (subst s e) (subst s c)+ subst s (CGen x t e c) = CGen x (subst s t) (subst s e) (subst s c)+ subst s (CRet e) = CRet (subst s e)+ subst s (CExp e) = CExp (subst s e)++instance Subst Scheme Name Name where+ subst s (Scheme rh ps ke) = Scheme (subst s rh) (subst s ps) (map (subKE s) ke)+ where subKE s (n,k) = case lookup n s of+ Just n' -> (n',k)+ Nothing -> (n,k)++instance Subst Rho Name Name where+ subst s (R t) = R (subst s t)+ subst s (F scs rh) = F (subst s scs) (subst s rh)++instance Subst Type Name Name where+ subst s (TId c) = case lookup c s of+ Just c' -> TId c'+ Nothing -> TId c+ subst s (TAp t t') = TAp (subst s t) (subst s t')+ subst s (TFun ts t) = TFun (subst s ts) (subst s t)+ subst s (TVar n) = TVar n+ ++-- Type identifiers ---------------------------------------------------------++instance Ids Decl where+ idents (DData _ bs cs) = idents bs ++ idents cs+ idents (DRec _ _ bs ss) = idents bs ++ idents ss+ idents (DType _ t) = idents t++instance Ids Constr where+ idents (Constr ts ps ke) = idents ts ++ idents ps++instance Ids Type where+ idents (TId c) = [c]+ idents (TVar _) = []+ idents (TAp t t') = idents t ++ idents t'+ idents (TFun ts t) = idents ts ++ idents t++instance Ids Scheme where+ idents (Scheme rh ps ke) = (idents rh ++ idents ps) \\ dom ke+ +instance Ids Rho where+ idents (R t) = idents t+ idents (F scs rh) = idents scs ++ idents rh++instance Subst Type Name Type where+ subst s (TId c) = case lookup c s of+ Just t -> t+ Nothing -> TId c+ subst s (TVar n) = TVar n+ subst s (TAp t t') = TAp (subst s t) (subst s t')+ subst s (TFun ts t) = TFun (subst s ts) (subst s t)++instance Subst Scheme Name Type where+ subst s (Scheme rh ps ke) = Scheme (subst s rh) (subst s ps) ke++instance Subst Rho Name Type where+ subst s (R t) = R (subst s t)+ subst s (F scs rh) = F (subst s scs) (subst s rh)++instance Subst (Type,Type) Name Type where+ subst s (t1,t2) = (subst s t1, subst s t2)+ +instance Subst (Scheme,Scheme) Name Type where+ subst s (s1,s2) = (subst s s1, subst s s2)+ ++-- Type variables --------------------------------------------------------------++instance TVars Type where+ tvars (TId c) = []+ tvars (TVar n) = [n]+ tvars (TAp t t') = tvars t ++ tvars t'+ tvars (TFun ts t) = tvars ts ++ tvars t++instance TVars Scheme where+ tvars (Scheme t ps ke) = tvars t ++ tvars ps++instance TVars Rho where+ tvars (R t) = tvars t+ tvars (F scs rh) = tvars scs ++ tvars rh++instance Subst Type TVar Type where+ subst [] t = t+ subst s (TId c) = TId c+ subst s (TVar n) = case lookup n s of+ Just t -> t+ Nothing -> TVar n+ subst s (TAp t t') = TAp (subst s t) (subst s t')+ subst s (TFun ts t) = TFun (subst s ts) (subst s t)++instance Subst Scheme TVar Type where+ subst [] sc = sc+ subst s sc@(Scheme t ps ke) = Scheme (subst s t) (subst s ps) ke+ ++instance Subst Rho TVar Type where+ subst s (R t) = R (subst s t)+ subst s (F scs rh) = F (subst s scs) (subst s rh)++instance Subst (Type,Type) TVar Type where+ subst s (t,t') = (subst s t, subst s t')+++instance Subst (Scheme,Scheme) TVar Type where+ subst s (sc,sc') = (subst s sc, subst s sc')+ + +-- Kind variables ----------------------------------------------------------------++instance Subst Decl Int Kind where+ subst s (DData vs bs cs) = DData vs (subst s bs) (subst s cs)+ subst s (DRec i vs bs ss) = DRec i vs (subst s bs) (subst s ss)+ subst s (DType vs t) = DType vs (subst s t)++instance Subst Constr Int Kind where+ subst s (Constr ts ps ke) = Constr (subst s ts) (subst s ps) (subst s ke)+ +instance Subst Scheme Int Kind where+ subst s (Scheme rh ps ke) = Scheme (subst s rh) (subst s ps) (subst s ke)++instance Subst Rho Int Kind where+ subst s (R t) = R (subst s t)+ subst s (F scs rh) = F (subst s scs) (subst s rh)++instance Subst Type Int Kind where+ subst s (TAp t t') = TAp (subst s t) (subst s t')+ subst s (TFun ts t) = TFun (subst s ts) (subst s t)+ subst s (TId c) = TId c+ subst s (TVar (TV (n,k))) = TVar (TV (n, subst s k))+ ++-- Alpha conversion -------------------------------------------------------------++class AlphaConv a where+ ac :: Map Name Name -> a -> M x a+++alphaConvert e | mustAc e = ac nullSubst e+ | otherwise = return e++mustAc (ELam te e) = True+mustAc (ELet bs e) = True+mustAc (EDo x tx c) = True+mustAc (ETempl x tx te c) = True+mustAc (EAp e es) = any mustAc (e:es)+mustAc (ESel e l) = mustAc e+mustAc (ERec c eqs) = any mustAc (rng eqs)+mustAc (EReq e1 e2) = any mustAc [e1,e2]+mustAc (EAct e1 e2) = any mustAc [e1,e2]+mustAc (ECase e alts) = any mustAc (e:rng alts)+mustAc e = False+++instance AlphaConv a => AlphaConv [a] where+ ac s xs = mapM (ac s) xs++instance (AlphaConv a, AlphaConv b) => AlphaConv (a,b) where+ ac s (p,e) = liftM2 (,) (ac s p) (ac s e)++instance AlphaConv Name where+ ac s x = case lookup x s of+ Just x' -> return x'+ _ -> return x++instance AlphaConv Binds where+ ac s (Binds r te eqs) = liftM2 (Binds r) (ac s te) (ac s eqs)+ +instance AlphaConv Exp where+ ac s (ELit l) = return (ELit l)+ ac s (EVar x) = liftM EVar (ac s x)+ ac s (ECon k) = return (ECon k)+ ac s (ESel e l) = liftM (`ESel` l) (ac s e)+ ac s (ELam te e) = do s' <- extSubst s (dom te)+ liftM2 ELam (ac s' te) (ac s' e)+ ac s (EAp e es) = liftM2 EAp (ac s e) (mapM (ac s) es)+ ac s (ELet bs e) = do s' <- extSubst s (bvars bs)+ liftM2 ELet (ac s' bs) (ac s' e)+ ac s (ERec c eqs) = liftM (ERec c) (ac s eqs)+ ac s (ECase e alts) = liftM2 ECase (ac s e) (ac s alts)+ ac s (EReq e1 e2) = liftM2 EReq (ac s e1) (ac s e2)+ ac s (EAct e1 e2) = liftM2 EAct (ac s e1) (ac s e2)+ ac s (EDo x tx c) = do s' <- extSubst s [x]+ liftM3 EDo (ac s' x) (ac s' tx) (ac s' c)+ ac s (ETempl x tx te c) = do s' <- extSubst s (x : dom te)+ liftM4 ETempl (ac s' x) (ac s' tx) (ac s' te) (ac s' c)+ +instance AlphaConv Pat where+ ac s p = return p++instance AlphaConv Cmd where+ ac s (CRet e) = liftM CRet (ac s e)+ ac s (CExp e) = liftM CExp (ac s e)+ ac s (CGen x tx e c) = do s' <- extSubst s [x]+ liftM4 CGen (ac s' x) (ac s' tx) (ac s' e) (ac s' c)+ ac s (CAss x e c) = liftM3 CAss (ac s x) (ac s e) (ac s c)+ ac s (CLet bs c) = do s' <- extSubst s (bvars bs)+ liftM2 CLet (ac s' bs) (ac s' c)++instance AlphaConv Type where+ ac s (TId n) = case lookup n s of+ Just n' -> return (TId n')+ _ | isVar n -> newTVar Star -- not quite correct, really need an env to find kind of n+ -- But we're past kind errors anyway when we alphaconvert...+ | otherwise -> return (TId n)+ ac s (TFun t ts) = liftM2 TFun (ac s t) (ac s ts)+ ac s (TAp t u) = liftM2 TAp (ac s t) (ac s u)+ ac s t = return t++instance AlphaConv Rho where+ ac s (R t) = liftM R (ac s t)+ ac s (F ts t) = liftM2 F (ac s ts) (ac s t)++instance AlphaConv Scheme where+ ac s (Scheme t ps ke) = do s' <- extSubst s (dom ke)+ liftM3 Scheme (ac s' t) (ac s' ps) (ac s' ke)+ +instance AlphaConv Kind where+ ac s k = return k+ ++extSubst s xs = do s' <- mapM ext xs+ return (s'++s)+ where ext x = do n <- newNum+ return (x, {-annotGenerated-} x { tag = n })+ ++-- Bound variables --------------------------------------------------------------++instance BVars Binds where+ bvars (Binds r te eqns) = dom eqns++ ++-- System F encodings ============================================================++-- Encode a System F type application term+encodeTApp env [] e = return e+encodeTApp env ts e = do xs <- newNames tappSym (length ts)+ let te = xs `zip` map scheme ts+ eq = xs `zip` map EVar xs+ return (ELet (Binds True te eq) e)++isTAppEncoding (Binds r te _) = r && isTApp (head (dom te))++tAppTypes (Binds _ te _) = map body (rng te)+++-- Encode a System F type abstraction term+encodeTAbs env [] e = return e+encodeTAbs env ke e = do x <- newName tabsSym+ let te = [(x,Scheme (R (TId (prim UNITTYPE))) [] ke)]+ return (ELet (Binds True te [(x,EVar x)]) e)++isTAbsEncoding (Binds r te _) = r && isTAbs (head (dom te))++tAbsVars (Binds _ te _) = dom (quant (head (rng te)))+++isEncoding bs = isTAppEncoding bs || isTAbsEncoding bs+++class Erase a where+ erase :: a -> a++instance Erase a => Erase [a] where+ erase xs = map erase xs++instance Erase a => Erase (Name,a) where+ erase (x,e) = (x, erase e)++instance Erase Exp where+ erase (ESel e l) = ESel (erase e) l+ erase (ELam te e) = ELam (erase te) (erase e)+ erase (EAp e es) = EAp (erase e) (erase es)+ erase (ELet bs e)+ | isEncoding bs = erase e+ | otherwise = ELet (erase bs) (erase e)+ erase (ECase e alts) = ECase (erase e) (erase alts)+ erase (ERec c eqs) = ERec c (erase eqs)+ erase (EAct e e') = EAct (erase e) (erase e')+ erase (EReq e e') = EReq (erase e) (erase e')+ erase (ETempl x t te c) = ETempl x (erase t) (erase te) (erase c)+ erase (EDo x t c) = EDo x (erase t) (erase c)+ erase e = e++instance Erase Alt where+ erase (p,e) = (p, erase e)++instance Erase Binds where+ erase (Binds r te es) = Binds r (erase te) (erase es)+ +instance Erase Cmd where+ erase (CLet bs c) = CLet (erase bs) (erase c)+ erase (CAss x e c) = CAss x (erase e) (erase c)+ erase (CGen x t e c) = CGen x (erase t) (erase e) (erase c)+ erase (CRet e) = CRet (erase e)+ erase (CExp e) = CExp (erase e)+ +instance Erase Type where+ erase (TAp t t') = TAp (erase t) (erase t')+ erase (TFun ts t) = TFun (erase ts) (erase t)+ erase (TId n) = TId n+ erase (TVar _) = TId (prim Int)++instance Erase Rho where+ erase (F ts t) = F (erase ts) (erase t)+ erase (R t) = R (erase t)++instance Erase Scheme where+ erase (Scheme rh ps ke) = Scheme (erase rh) (erase ps) ke+++-- Printing ==================================================================++-- Modules -------------------------------------------------------------------++instance Pr Module where+ pr (Module i ns xs ds is bss) = text "module" <+> prId i <+> text "where"+ $$ prImports ns $$ prDefaults xs $$ pr ds $$ prInstance is $$ vpr bss++prImports [] = empty+prImports (i : is) = prI i $$ prImports is+ where prI(True,n) = text "import" <+> pr n+ prI(False,n) = text "use" <+> pr n++prDefaults [] = empty+prDefaults ns = text "default" <+> hpr ',' ns++prInstance [] = empty+prInstance ns = text "instance" <+> hpr ',' ns++instance Pr (Module,a) where+ pr (m,_) = pr m++-- Type declarations ---------------------------------------------------------++instance Pr Types where+ pr (Types ke ds) = vpr ke $$ vpr ds++instance Pr (Name, Decl) where+ pr (i, DType vs t) = text "type" <+> prId i <+> hsep (map prId vs) + <+> text "=" <+> pr t+ pr (i, DData vs ts cs) = text "data" <+> prId i <+> hsep (map prId vs) + <+> prSubs ts <+> prConstrs cs+ pr (i, DRec isC vs ts ss) = text kwd <+> prId i <+> hsep (map prId vs) + <+> prSups ts <+> prEq ss $$ nest 4 (vpr ss)+ where kwd = if isC then "typeclass " else "struct"++prEq [] = empty+prEq _ = text "where"+++-- Instances ---------------------------------------------------------------++prInsts (Binds r te eqs) = vcat (map prInst te) $$ vpr eqs++prInst (i, p) = text "instance" <+> prId i <+> text "::" <+> prPScheme 0 p+++-- Bindings -----------------------------------------------------------------++instance Pr Binds where+-- pr (Binds True te eqns) = text "rec" $$ vpr te $$ vpr eqns+ pr (Binds _ te eqns) = vpr te $$ vpr eqns+ +instance Pr (Name, Scheme) where+ pr (v, sc) = prId v <+> text "::" <+> pr sc'+ where sc' = subst s sc+ s = map f (tyvars sc)+ f v@(Name s n m a) = (v, Name ('_':s) n m a)+ f v = (v,v)+ +instance Pr (Name, Exp) where+ pr (v, e) = prId v <+> text "=" <+> pr e++instance Pr [(Name, Scheme)] where+ pr ss = vpr ss+ ++prTop te = vcat (map pr' te)+ where pr' (v,sc) = prId v <+> text "::" <+> pr sc+++-- Sub/supertypes -----------------------------------------------------------++prSups [] = empty+prSups ts = char '<' <+> hpr ',' ts++prSubs [] = empty+prSubs ts = char '>' <+> hpr ',' ts++ +-- Constructors ------------------------------------------------------------++prConstrs [] = empty+prConstrs (c:cs) = vcat (char '=' <+> pr c : map ((char '|' <+>) . pr) cs)++instance Pr (Name,Constr) where+ pr (i, Constr ts ps ke) = prId i <+> hsep (map (prn 1) ts) <+> prContext ps ke+++-- Predicates --------------------------------------------------------------++prContext [] [] = empty+prContext ps ke = text "\\\\" <+> preds+ where preds = hsep (punctuate comma (map (prPScheme 1) ps ++ map prKind ke))++prKind (n,Star) = prId n+prKind (n,k) = prId n <+> text "::" <+> pr k++prPScheme 0 (Scheme p ps ke) = prRPred p <+> prContext ps ke+prPScheme 1 (Scheme p [] []) = prRPred p+prPScheme 1 sc = parens (prPScheme 0 sc)++prRPred (F [t1] t2) = prn 1 t1 <+> text "<" <+> prn 1 t2+prRPred (R t) = prPred t++prPred (TFun [t1] t2) = prn 1 t1 <+> text "<" <+> prn 1 t2+prPred t = pr t+++-- Types -----------------------------------------------------------------++instance Pr Scheme where+ prn 0 (Scheme rh ps ke) = prn 0 rh <+> prContext ps ke+ prn 1 (Scheme rh [] []) = prn 1 rh+ prn n sc = parens (prn 0 sc)++instance Pr Rho where+ prn 0 (F scs rh) = hsep (punctuate (text " ->") (map (prn 1) scs ++ [prn 1 rh]))+ prn 0 rh = prn 1 rh+ prn 1 (R t) = prn 1 t+ prn 1 rh = parens (prn 0 rh)+ +instance Pr Type where+ prn 0 (TFun ts t) = hsep (punctuate (text " ->") (map (prn 1) (ts++[t])))+ prn 0 t = prn 1 t+ + prn 1 (TAp (TId (Prim LIST _)) t) = text "[" <> prn 0 t <> text "]"+ prn 1 t@(TAp _ _) = prTAp (tFlat t)+ where prTAp (TId (Tuple n _),ts) = text "(" <> hpr ',' ts <> text ")"+-- prTAp (t,ts) = hang (prn 1 t) 2 (sep (map (prn 2) ts))+ prTAp (t,ts) = prn 1 t <+> sep (map (prn 2) ts)+ prn 1 t = prn 2 t++ prn 2 (TId c) = prId c+-- prn 2 (TVar _) = text "_"+ prn 2 (TVar n) = text "_" <> pr n++ prn 2 t = parens (prn 0 t)+++prMaybeScheme Nothing = empty+prMaybeScheme (Just t) = prn 1 t+++-- Patterns ----------------------------------------------------------------++instance Pr Pat where+ pr (PCon k) = prId k+ pr (PLit l) = pr l+ pr (PWild) = text "_"+ ++-- Expressions -------------------------------------------------------------++prParam (x,Scheme (R (TVar _)) [] [])+ = prId x+prParam (x,sc) = parens (pr (x,sc))++instance Pr Exp where+ prn 0 (ELam te e) = hang (char '\\' <> sep (map prParam te) <+> text "->") 4 (pr e)+ prn 0 (ELet bs e)+ | isTAppEncoding bs = pr e <+> braces (commasep pr (tAppTypes bs))+ | isTAbsEncoding bs = hang (text "/\\" <> sep (map prId (tAbsVars bs)) <+> text "->") 4 (pr e)+-- | isTAppEncoding bs = pr e+-- | isTAbsEncoding bs = pr e+ | otherwise = text "let" $$ nest 4 (pr bs) $$ text "in" <+> pr e+ prn 0 (ECase e alts) = text "case" <+> pr e <+> text "of" $$ + nest 2 (vpr alts)+ prn 0 (EAct e e') = text "action@" <> prn 2 e $$+ nest 4 (pr e')+ prn 0 (EReq e e') = text "request@" <> prn 2 e $$+ nest 4 (pr e')+ prn 0 (ETempl x t te c) = text "class@" <> prId x $$+ nest 4 (vpr te) $$+ nest 4 (pr c)+ prn 0 (EDo x t c) = text "do@" <> prId x <> text "::" <> pr t $$+ nest 4 (pr c)+ prn 0 e = prn 1 e++ prn 1 (EAp e@(ELet bs _) es)+ | isEncoding bs = prn 0 e <+> sep (map (prn 2) es)+ prn 1 (EAp e es) = prn 1 e <+> sep (map (prn 2) es)++ prn 1 e = prn 2 e+ + prn 2 (ECon c) = prId c+ prn 2 (ESel e s) = prn 2 e <> text "." <> prId s+ prn 2 (EVar v) = prId v+ prn 2 (ELit l) = pr l+ prn 2 (ERec c eqs) = prId c <+> text "{" <+> hpr ',' eqs <+> text "}"+ prn 2 e = parens (prn 0 e)++instance Pr Alt where+ pr (p, e) = pr p <+> text "->" $$ nest 4 (pr e)++instance Pr Cmd where+ pr (CLet bs c) = pr bs $$+ pr c+ pr (CAss x e c) = prId x <+> text ":=" <+> pr e $$+ pr c+ pr (CGen x t e c) = prId x <+> {- text "::" <+> pr t <+> -} text "<-" <+> pr e $$+ pr c+ pr (CRet e) = text "result" <+> pr e+ pr (CExp e) = pr e++++-- HasPos --------------------------------------------------++instance HasPos Types where+ posInfo (Types ke ds) = between (posInfo ke) (posInfo ds)++instance HasPos Binds where+ posInfo (Binds _ te es) = posInfo es++instance HasPos Decl where+ posInfo (DData ns ts ce) = foldr1 between [posInfo ns, posInfo ts, posInfo ce]+ posInfo (DRec _ ns ts te) = foldr1 between [posInfo ns, posInfo ts, posInfo te]+ posInfo (DType ns t) = between (posInfo ns) (posInfo t)++instance HasPos Scheme where+ posInfo (Scheme r ps ke) = foldr1 between [posInfo r, posInfo ps, posInfo ke]++instance HasPos Constr where+ posInfo (Constr ts ps ke) = foldr1 between [posInfo ts, posInfo ps, posInfo ke]++instance HasPos Rho where+ posInfo (R t) = posInfo t+ posInfo (F ts r) = between (posInfo ts) (posInfo r)++instance HasPos Type where+ posInfo (TId n) = posInfo n+ posInfo (TVar _) = Unknown+ posInfo (TFun ts t) = posInfo (t : ts)+ posInfo (TAp t t') = between (posInfo t) (posInfo t')++instance HasPos Pat where+ posInfo (PCon n) = posInfo n+ posInfo (PLit l) = posInfo l+ posInfo (PWild) = Unknown++instance HasPos Exp where+ posInfo (ECon n) = posInfo n+ posInfo (ESel e l) = between (posInfo e) (posInfo l)+ posInfo (EVar n) = posInfo n+ posInfo (ELam te e) = between (posInfo (dom te)) (posInfo e)+ posInfo (EAp e es) = foldr1 between (map posInfo (e : es))+ posInfo (ELet bs e) = between (posInfo bs) (posInfo e)+ posInfo (ECase e as) = foldr1 between [posInfo e, posInfo as]+ posInfo (ERec n es) = between (posInfo n) (posInfo es)+ posInfo (ELit l) = posInfo l+ posInfo (EAct e e') = between (posInfo e) (posInfo e')+ posInfo (EReq e e') = between (posInfo e) (posInfo e')+ posInfo (ETempl n t te c) = foldr1 between [posInfo n, posInfo te, posInfo c]+ posInfo (EDo n t c) = foldr1 between [posInfo n, posInfo c]++instance HasPos Cmd where+ posInfo (CGen n t e c) = foldr1 between [posInfo n, posInfo e, posInfo c]+ posInfo (CAss n e c) = foldr1 between [posInfo n, posInfo e, posInfo c]+ posInfo (CLet bs c) = between (posInfo bs) (posInfo c)+ posInfo (CRet e) = posInfo e+ posInfo (CExp e) = posInfo e++ +-- Binary --------------------------------------------------++instance Binary Module where+ put (Module a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get>>= \f -> return (Module a b c d e f)++instance Binary Types where+ put (Types a b) = put a >> put b+ get = get >>= \a -> get >>= \b -> return (Types a b)++instance Binary Binds where+ put (Binds a b c) = put a >> put b >> put c+ get = get >>= \a -> get >>= \b -> get >>= \c -> return (Binds a b c)++instance Binary Decl where+ put (DData a b c) = putWord8 0 >> put a >> put b >> put c+ put (DRec a b c d) = putWord8 1 >> put a >> put b >> put c >> put d+ put (DType a b) = putWord8 2 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (DData a b c)+ 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (DRec a b c d)+ 2 -> get >>= \a -> get >>= \b -> return (DType a b)+ _ -> fail "no parse"++instance Binary Scheme where+ put (Scheme a b c) = put a >> put b >> put c+ get = get >>= \a -> get >>= \b -> get >>= \c -> return (Scheme a b c)++instance Binary Constr where+ put (Constr a b c) = put a >> put b >> put c+ get = get >>= \a -> get >>= \b -> get >>= \c -> return (Constr a b c)++instance Binary Rho where+ put (R a) = putWord8 0 >> put a+ put (F a b) = putWord8 1 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (R a)+ 1 -> get >>= \a -> get >>= \b -> return (F a b)+ _ -> fail "no parse"++instance Binary Type where+ put (TId a) = putWord8 0 >> put a+ put (TVar a) = putWord8 1 >> put a+ put (TFun a b) = putWord8 2 >> put a >> put b+ put (TAp a b) = putWord8 3 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (TId a)+ 1 -> get >>= \a -> return (TVar a)+ 2 -> get >>= \a -> get >>= \b -> return (TFun a b)+ 3 -> get >>= \a -> get >>= \b -> return (TAp a b)+ _ -> fail "no parse"++instance Binary Pat where+ put (PCon a) = putWord8 0 >> put a+ put (PLit a) = putWord8 1 >> put a+ put (PWild) = putWord8 2+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (PCon a)+ 1 -> get >>= \a -> return (PLit a)+ 2 -> return PWild+ _ -> fail "no parse"++instance Binary Exp where+ put (ECon a) = putWord8 0 >> put a+ put (ESel a b) = putWord8 1 >> put a >> put b+ put (EVar a) = putWord8 2 >> put a+ put (ELam a b) = putWord8 3 >> put a >> put b+ put (EAp a b) = putWord8 4 >> put a >> put b+ put (ELet a b) = putWord8 5 >> put a >> put b+ put (ECase a b) = putWord8 6 >> put a >> put b+ put (ERec a b) = putWord8 7 >> put a >> put b+ put (ELit a) = putWord8 8 >> put a+ put (EAct a b) = putWord8 9 >> put a >> put b+ put (EReq a b) = putWord8 10 >> put a >> put b+ put (ETempl a b c d) = putWord8 11 >> put a >> put b >> put c >> put d+ put (EDo a b c) = putWord8 12 >> put a >> put b >> put c+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (ECon a)+ 1 -> get >>= \a -> get >>= \b -> return (ESel a b)+ 2 -> get >>= \a -> return (EVar a)+ 3 -> get >>= \a -> get >>= \b -> return (ELam a b)+ 4 -> get >>= \a -> get >>= \b -> return (EAp a b)+ 5 -> get >>= \a -> get >>= \b -> return (ELet a b)+ 6 -> get >>= \a -> get >>= \b -> return (ECase a b)+ 7 -> get >>= \a -> get >>= \b -> return (ERec a b)+ 8 -> get >>= \a -> return (ELit a)+ 9 -> get >>= \a -> get >>= \b -> return (EAct a b)+ 10 -> get >>= \a -> get >>= \b -> return (EReq a b)+ 11 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (ETempl a b c d)+ 12 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EDo a b c)+ _ -> fail "no parse"++instance Binary Cmd where+ put (CGen a b c d) = putWord8 0 >> put a >> put b >> put c >> put d+ put (CAss a b c) = putWord8 1 >> put a >> put b >> put c+ put (CLet a b) = putWord8 2 >> put a >> put b+ put (CRet a) = putWord8 3 >> put a+ put (CExp a) = putWord8 4 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CGen a b c d)+ 1 -> get >>= \a -> get >>= \b -> get >>= \c -> return (CAss a b c)+ 2 -> get >>= \a -> get >>= \b -> return (CLet a b)+ 3 -> get >>= \a -> return (CRet a)+ 4 -> get >>= \a -> return (CExp a)+ _ -> fail "no parse"
+ src/Core2Kindle.hs view
@@ -0,0 +1,887 @@+{-# LANGUAGE FlexibleInstances, PatternGuards #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Core2Kindle(core2kindle, c2kTEnv) where+{- -}+import Monad+import Common+import Core+import Name+import PP+import qualified Decls+import qualified Env+import qualified Kindle+++-- =========================================================================================+-- Translation of Core modules into back-end Kindle format+-- =========================================================================================++core2kindle e2 e3 m = localStore (cModule e2 e3 m)+++-- =========================================================================================+-- The FType format+-- =========================================================================================+ +-- This datatype is used to distinguish the types of known functions that can be called directly,+-- from those that are anonymous and thus must be translated as closures. Furthermore, the type+-- arguments of FType constructors are supposed to be on a semi-Kindle form, where several primitive+-- type constructors have been replaced by their corresponding Kindle implementations. These types+-- are still expressed using Core.Type syntax during the translation process, though, to facilitate+-- tracking of instantiation of type variables by means of unification.++data Result a = ValR a+ | FunR ([Kindle.Exp] -> a) [Kindle.AType]++instance Show a => Show (Result a) where+ show (ValR a) = "ValR (" ++ show a ++ ")"+ show (FunR f ts) = "FunR _ " ++ show ts++rcomp f (ValR c) = ValR (f c)+rcomp f (FunR g ts) = FunR (f . g) ts+++-- =========================================================================================+-- Translation environment+-- =========================================================================================++data Env = Env { mname :: Maybe String,+ decls :: Kindle.Decls,+ tenv :: Kindle.TEnv,+ selfN :: Maybe Name,+ tArgs :: [Kindle.AType] }+++env0 = Env { mname = Nothing,+ decls = [],+ tenv = [],+ selfN = Nothing,+ tArgs = [] }++setMName m env = env { mname = Just (str m) }++addDecls ds env = env { decls = ds ++ decls env }++addTEnv te env = env { tenv = te ++ tenv env }++addATEnv te env = env { tenv = mapSnd Kindle.ValT te ++ tenv env }++pushSelf x env = env { selfN = Just x }++self env = fromJust (selfN env)++setTArgs env ts = env { tArgs = ts }++findDecl env k+ | isTuple k = Kindle.tupleDecl k+ | otherwise = lookup' (decls env) k+ ++-- Look up a closure type (a Kindle.Struct) in the current store, extending the store if necessary+findClosureType env [] ts t = do ds <- currentStore+ -- tr ("Looking for (1) " ++ render (pr (name0 "closure", Kindle.FunT [] ts t)))+ case Kindle.findStruct s0 ds of+ Just n -> return (Kindle.TCon n (t:ts))+ Nothing -> do+ n <- newNameMod (mname env) (closureSym ++ show a)+ addToStore (n, s0)+ return (Kindle.TCon n (t:ts))+ where s0 = Kindle.Struct vs0 [(prim Code, Kindle.FunT [] (tail ts0) (head ts0))] Kindle.Top+ vs0 = take (a + 1) abcSupply+ ts0 = map Kindle.tVar vs0+ a = length ts+findClosureType env vs ts t = do ds <- currentStore+ -- tr ("Looking for (2) " ++ render (pr (name0 "closure", Kindle.FunT vs ts t)))+ case Kindle.findStruct s0 ds of+ Just n -> return (Kindle.TCon n ts0)+ Nothing -> do+ n <- newNameMod (mname env) closureSym+ addToStore (n, s0)+ return (Kindle.TCon n ts0)+ where s0 = Kindle.Struct vs0 [(prim Code, Kindle.FunT vs ts t)] Kindle.Top+ vs0 = nub (Kindle.typevars (t:ts) \\ vs)+ ts0 = map Kindle.tVar vs0+++openClosureType (Kindle.TCon n ts)+ | isClosure n = do ds <- currentStore+ let Kindle.Struct vs te _ = lookup' ds n+ Kindle.FunT [] ts' t' = lookup' te (prim Code)+ s = vs `zip` ts+ return (subst s ts', subst s t')+openClosureType t = internalError "Core2Kindle.openClosureType" t+++splitClosureType env 0 t0 = return ([], t0)+splitClosureType env n t0 = do (ts,t) <- openClosureType t0+ let n' = n - length ts+ if n' >= 0 then do+ (tss,t1) <- splitClosureType env n' t+ return (ts:tss, t1)+ else + return ([], t0)+ + +-- =========================================================================================+-- Translation entry point+-- =========================================================================================++-- Translate a Core.Module into a Kindle.Module+cModule e2 e3 (Module m ns xs ds ws bss)+ = do mapM_ addToStore (filter (isClosure . fst) e3)+ te0 <- tenvImp env e2+ ds1 <- cDecls env ds+ bs <- cBindsList (addTEnv te0 (addDecls ds1 env)) bss+ ds2 <- currentStore+ let (dsQ,dsNQ) = partition (isQualified . fst) (reverse ds2)+ dsThis = ds1 ++ filter (isQual m . fst) dsQ+ ds3 = dsThis ++ dsNQ+ --let fromCurrent n = not (isQualified n)|| isQual m n+ -- ds3 = ds1++reverse (filter (fromCurrent . fst) ds2)+ return (Kindle.Module m (map snd ns) ds3 bs,dsThis)+ where env = addDecls e3 (setMName m (addTEnv Kindle.primTEnv (addDecls Kindle.primDecls env0)))++-- Compute the imported type environment+tenvImp env (_,ds,ws,bs) = cTEnv env (tsigsOf bs)+++-- =========================================================================================+-- Translating Core type declarations into Kindle.Decls+-- =========================================================================================++cDecls env (Types ke ds) = do dss <- mapM cDecl ds+ return (concat dss)+ where cDecl (n,DRec _ vs [] ss) = do te <- cTEnv env ss+ return [(n, Kindle.Struct vs te Kindle.Top)]+ cDecl (n,DType vs t) = return []+ cDecl (n,DData vs [] cs) = do ds <- mapM (cCon n vs) cs+ return ((n, Kindle.Struct vs [] Kindle.Union) : ds)++ cCon n vs (c,Constr ts ps ke) + = do te' <- cValTEnv env te+ return (injectCon c, Kindle.Struct (vs++dom ke) te' (Kindle.Extends n))+ where te = abcSupply `zip` (ps++ts)+++injectCon (Name s t m a) = Name ('_':s) t m a+injectCon n = n+++-- =========================================================================================+-- Translating schemes and types into Kindle form+-- =========================================================================================++-- Translate a Core.Scheme into an Kindle.Type on basis of arity and polymorphism+cScheme env (Scheme rh ps ke) = do ts0 <- mapM (cAScheme env) ps+ (ts,t) <- cRho env rh+ case (dom ke, ts0++ts) of -- concatenate witness params with ts+ ([],[]) -> return (Kindle.ValT t)+ (vs,ts) -> return (Kindle.FunT vs ts t)+ ++-- Translate a Core.Rho type+cRho env (F scs rh) = do ts <- mapM (cAScheme env) scs+ (ts',t) <- cRho' env rh+ return (ts++ts', t) -- concatenate ts with monadic params+cRho env (R t) = cType env t+++-- Translate a Core.Rho type but treat function types as closures+cRho' env (R t) = cType' env (tFlat t)+cRho' env rh = do t <- cAScheme env (Scheme rh [] [])+ return ([],t)+++-- Translate a Core.Type+cType env (TFun ts t) = do ts <- mapM (cAType env) ts+ (ts',t) <- cType' env (tFlat t)+ return (ts++ts', t) -- concatenate ts with monadic params+cType env t = cType' env (tFlat t)+++-- Translate a Core.Type but treat function types as closures+cType' env (TId (Prim Action _), []) = return ([t,t], Kindle.tId Msg)+ where t = Kindle.tId Time+cType' env (TId (Prim Request _), [t]) = do t <- cAType env t+ return ([Kindle.tInt], t)+cType' env (TId (Prim Class _), [t]) = do t <- cAType env t+ return ([Kindle.tInt], t)+cType' env (TId (Prim Cmd _), [s,t]) = do s <- cAType env s+ t <- cAType env t+ return ([Kindle.tRef s], t)+cType' env (TId (Prim PMC _), [t]) = do t <- cAType env t+ return ([], t)+cType' env (TId n, ts) = do ts <- mapM (cAType env) ts+ if isVar n then+ return ([], Kindle.TVar n ts)+ else+ return ([], Kindle.TCon n ts)+cType' env (TVar _, []) = return ([], Kindle.tInt)+cType' env (TVar _, ts) = do ts <- mapM (cAType env) ts+ return ([], Kindle.TCon (tuple (length ts)) ts)+cType' env (t, _) = do t <- cAType env t+ return ([], t)+++-- Translate a Core.Type unconditionally into a Kindle.AType+cAType env t = do (ts, t) <- cType env t+ case ts of+ [] -> return t+ _ -> findClosureType env [] ts t+++-- Translate a Core.Scheme unconditionally into a Kindle.AType+cAScheme env sc = do t0 <- cScheme env sc+ case t0 of+ Kindle.ValT t -> return t+ Kindle.FunT vs ts t -> findClosureType env vs ts t+++-- Translate a Core.Scheme unconditionally into a ValT variant of a Kindle.Type+cValScheme env sc = do t <- cAScheme env sc+ return (Kindle.ValT t)+++-- Translate a Core.TEnv into an Kindle.TEnv+cTEnv env te = do ts <- mapM (cScheme env) scs+ return (xs `zip` ts)+ where (xs,scs) = unzip te+ ++-- Translate a Core.TEnv into an Kindle.ATEnv+cATEnv env te = do ts <- mapM (cAScheme env) scs+ return (xs `zip` ts)+ where (xs,scs) = unzip te+ + +-- Translate a Core.TEnv into an Kindle.TEnv with only ValT types+cValTEnv env te = do ts <- mapM (cValScheme env) scs+ return (xs `zip` ts)+ where (xs,scs) = unzip te+++-- =========================================================================================+-- Translating bindings+-- =========================================================================================++-- Translate a list of strongly connected Core binding groups into a list of Kindle bindings+cBindsList env [] = return []+cBindsList env (bs:bss) = do (te,bf) <- cBinds env bs+ bs <- cBindsList (addTEnv te env) bss+ return (flatBinds bf ++ bs)+++flatBinds bf = flat (bf Kindle.CBreak)+ where flat (Kindle.CBind r bs c) = bs ++ flat c+ flat _ = []+++-- Translate a list of (mutually recursive) Core bindings into a Kindle.CBind on basis of declared type+cBinds env (Binds rec te eqs) = do te1 <- cValTEnv env te1+ te2 <- cTEnv env te2+ let te' = te1 ++ te2+ assert (not rec || all Kindle.okRec (rng te')) "Illegal value recursion" (dom te')+ (bf,bs) <- cEqs (addTEnv te' env) te' eqs+ return (te', comb rec bf bs)+ where comb False bf bs = bf . Kindle.CBind False bs+ comb True bf bs = Kindle.CBind True (flatBinds bf ++ bs)+ insts = dom (filter (isNewAp . snd) eqs)+ (te1,te2) = partition ((`elem` insts) . fst) te+++-- Translate a list of Core equations into a list of Kindle bindings on basis of declared type+cEqs env te eqs = do (bfs,bs) <- fmap unzip (mapM (cEq env te) eqs)+ return (foldr (.) id bfs, bs)++cEq env te (x,e) = case lookup' te x of+ Kindle.ValT t0 -> do+ (bf,e) <- cValExpT env t0 e+ return (bf, (x, Kindle.Val t0 e))+ Kindle.FunT _ ts0 t0 -> do+ (vs,te,t,c) <- cFunN env (length ts0) e+ return (id, (x, Kindle.Fun vs t te c))+++-- Translate a Core.Exp with a known type into a Kindle.Exp+cValExpT env t e = do (bf,t',e') <- cValExp env e+ e'' <- adaptClos env [] t [] t' e'+ return (bf, e'')+ ++adaptClos env [] t0 [] t1 e+ | t0 == t1 = return e -- A+adaptClos env xs t0 [] t1 e = do (ts,t1) <- openClosureType t1+ adaptClos env xs t0 ts t1 e -- B+adaptClos env xs t0 ts t1 e+ | length xs >= length ts = adaptClos env xs2 t0 [] t1 (Kindle.enter e [] (map Kindle.EVar xs1)) -- C+ | otherwise = do (ts',t') <- openClosureType t0+ te <- newEnv paramSym ts'+ e' <- adaptClos env (xs ++ dom te) t' ts t1 e+ return (Kindle.closure t0 t' te (Kindle.CRet e')) -- D+ where (xs1,xs2) = splitAt (length ts) xs+ (ts1,ts2) = splitAt (length xs) ts+++-- [] (s1 s2 s3 -> s4 -> s5 -> s0) [] (t1 t2 -> t3 t4 t5 -> t0) e = B+-- [] (s1 s2 s3 -> s4 -> s5 -> s0) t1 t2 (t3 t4 t5 -> t0) e C (s1 x1, s2 x2, s3 x3) = D+-- x1 x2 x3 (s4 -> s5 -> s0) t1 t2 (t3 t4 t5 -> t0) e = C+-- x3 (s4 -> s5 -> s0) [] (t3 t4 t5 -> t0) e->C(x1,x2) = B+-- x3 (s4 -> s5 -> s0) t3 t4 t5 t0 e->C(x1,x2) C (s4 x4) = D+-- x3 x4 (s5 -> s0) t3 t4 t5 t0 e->C(x1,x2) C (s5 x5) = D+-- x3 x4 x5 s0 t3 t4 t5 t0 e->C(x1,x2)->C(x3,x4,x5) = C+-- [] s0 [] t0 e->C(x1,x2)->C(x3,x4,x5) = A++-- new Code (s1 x1, s2 x2, s3 x3) { ret new Code (s4 x4) { ret new Code (s5 x5) { ret e->Code(x1,x2)->Code(x3,x4,x5) }}}+++-- [] (s1 s2 -> s3 s4 s5 -> s0) [] (t1 t2 t3 -> t4 -> t5 -> t0) e = B+-- [] (s1 s2 -> s3 s4 s5 -> s0) t1 t2 t3 (t4 -> t5 -> t0) e C (s1 x1, s2 x2) = D+-- x1 x2 (s3 s4 s5 -> s0) t1 t2 t3 (t4 -> t5 -> t0) e C (s3 x3, s4 x4, s5 x5) = D+-- x1 .. x5 s0 t1 t2 t3 (t4 -> t5 -> t0) e = C+-- x4 x5 s0 [] (t4 -> t5 -> t0) e->C(x1,x2,x3) = B+-- x4 x5 s0 t4 (t5 -> t0) e->C(x1,x2,x3) = C+-- x5 s0 [] (t5 -> t0) e->C(x1,x2,x3)->C(x4) = B+-- x5 s0 t5 t0 e->C(x1,x2,x3)->C(x4) = C+-- [] s0 [] t0 e->C(x1,x2,x3)->C(x4)->C(x5) = A++-- s1 s2 -> s3 s4 s5 -> s0 || t1 t2 t3 -> t4 -> t5 -> t0+-- new Code (s1 x1, s2 x2) { ret new Code (s3 x3, s4 x4 s5 x5) { ret e->Code(x1, x2, x3)->Code(x4)->Code(x5) }}++++ +cValExpTs env [] [] = return (id, [])+cValExpTs env (t:ts) (e:es) = do (bf,e) <- cValExpT env t e+ (bf',es) <- cValExpTs env ts es+ return (bf . bf', e:es)+++-- Translate a Core.Exp into a Kindle command, a return type, a type abstraction, and an argument list of given length+cFunN env n e = do (vs,te,t,c) <- cFun0 env e+ (te,t,c) <- adapt te t c+ return (vs, te, t, c)+ where adapt te t c+ | n == l_te = return (te, t, c)+ | n > l_te = do (tss,t') <- splitClosureType env (n - l_te) t+ te' <- newEnv paramSym (concat tss)+ return (te++te', t', Kindle.cmap (Kindle.multiEnter tss (map Kindle.EVar (dom te'))) c)+ | n < l_te = do t1 <- findClosureType env [] (rng te2) t+ return (te1, t1, Kindle.CRet (Kindle.closure t1 t te2 c))+ where l_te = length te+ (te1,te2) = splitAt n te+++-- =========================================================================================+-- Translating abstractions+-- =========================================================================================++-- Convert a Core.Exp into a type abstraction, a parameter list and a Kindle.Cmd+cFun0 env (ELet bs e)+ | isTAbsEncoding bs = do (te,t,c) <- cFun env e+ return (tAbsVars bs, te, t, c)+cFun0 env e = do (te,t,c) <- cFun env e+ return ([], te, t, c)+ ++-- Convert a Core.Exp into a parameter list and a Kindle.Cmd+cFun env (ELam te e) = do te <- cATEnv env te+ (te',t,c) <- cFun (addATEnv te env) e+ return (te ++ te', t, c)+cFun env (EReq e (EDo x tx c)) = do tx <- fmap Kindle.tRef (cAType env tx)+ (bf,e) <- cValExpT env tx e+ (t,c) <- cCmd (pushSelf x (addATEnv [(x,tx)] env)) c+ let bf' = Kindle.cBind [(x,Kindle.Val tx (Kindle.lock tx e))]+ y <- newName dummySym+ return ([(y,Kindle.tInt)], t, bf (bf' (Kindle.unlock x c)))+cFun env (EReq e e') = do (bf,tx,e) <- cValExp env e+ x <- newName selfSym+ (t,c) <- cCmdExp (pushSelf x (addATEnv [(x,tx)] env)) e'+ y <- newName dummySym+ let bf' = Kindle.cBind [(x,Kindle.Val tx (Kindle.lock tx e))]+ return ([(y,Kindle.tInt)], t, bf (bf' (Kindle.unlock x c)))+cFun env e@(EAct _ _) = cAct env id id e+cFun env e@(EAp e0 _) + | isPrim After e0 || isPrim Before e0 = cAct env id id e+cFun env (ETempl x tx te c) = do tx@(Kindle.TCon n []) <- cAType env tx -- Type-checker guarantees tx is a struct type name+ te <- cValTEnv env te+ (t,c) <- cCmd (pushSelf x (addATEnv [(x,Kindle.tRef tx)] (addTEnv te env))) c+ addToStore (n, Kindle.Struct vs te Kindle.Top)+ y <- newName dummySym+ let e = Kindle.ENew (prim Ref) [tx] [(prim STATE, Kindle.Val tx (Kindle.ENew n ts []))]+ return ([(y,Kindle.tInt)], t, Kindle.cBind [(x,Kindle.Val (Kindle.tRef tx) e)] c)+ where vs = nub (tyvars te)+ ts = map Kindle.tVar vs+cFun env (EDo x tx c) = do tx <- fmap Kindle.tRef (cAType env tx)+ (t,c) <- cCmd (pushSelf x (addATEnv [(x,tx)] env)) c+ return ([(x,tx)], t, c)+cFun env e = do (t,r) <- cBody env e+ case r of+ FunR f ts -> do xs <- newNames paramSym (length ts)+ return (xs `zip` ts, t, f (map Kindle.EVar xs))+ ValR c -> return ([], t, c)+++-- Translate an action expression into a Core.Cmd+cAct env fa fb (EAp e0 [e,e'])+ | isPrim After e0 = do (bf,e1) <- cValExpT env Kindle.tTime e+ (te,t,c) <- cAct env (sum e1 . fa) fb e'+ return (te, t, bf c)+ | isPrim Before e0 = do (bf,e1) <- cValExpT env Kindle.tTime e+ (te,t,c) <- cAct env fa (min e1 . fb) e'+ return (te, t, bf c)+ where sum (Kindle.EVar (Prim Inherit _)) a = a+ sum e1 a = Kindle.ECall (prim TimePlus) [] [e1,a]+ min (Kindle.EVar (Prim Inherit _)) a = a+ min e1 b = Kindle.ECall (prim TimeMin) [] [e1,b]+cAct env fa fb (EAct e e') = do (_,_,c) <- cFun env (EReq e e')+ -- Ignore returned te (must be unused) and result type (will be replaced below)+ a <- newName paramSym+ b <- newName paramSym+ m <- newName tempSym+ let c1 = Kindle.cBind bs (Kindle.CRun e1 (Kindle.CRet (Kindle.EVar m)))+ c2 = Kindle.cmap (\_ -> Kindle.unit) c+ bs = [(m, Kindle.Val Kindle.tMsg (Kindle.ENew (prim Msg) [] bs'))]+ bs' = [(prim Code, Kindle.Fun [] Kindle.tUNIT [] c2)]+ es = [Kindle.EVar m, fa (Kindle.EVar a), fb (Kindle.EVar b)]+ e1 = Kindle.ECall (prim ASYNC) [] es+ return ([(a,Kindle.tTime),(b,Kindle.tTime)], Kindle.tMsg, c1)+cAct env fa fb e = do (bf,t0,f,[ta,tb]) <- cFunExp env e+ a <- newName paramSym+ b <- newName paramSym+ let c = bf (Kindle.CRet (f [fa (Kindle.EVar a), fb (Kindle.EVar b)]))+ return ([(a,Kindle.tTime), (b,Kindle.tTime)], Kindle.tMsg, c)+++-- =========================================================================================+-- Translating let- and case expressions+-- =========================================================================================++-- Translate a Core (Pat,Exp) pair into a Kindle.Alt result+cAlt cBdy env (PLit l, e) = do (t1,r) <- cBdy env e+ return (t1, rcomp (Kindle.ALit l) r)+cAlt cBdy env (PWild, e) = do (t1,r) <- cBdy env e+ return (t1, rcomp Kindle.AWild r)+cAlt cBdy env (PCon k, e) = do (vs,te,t,r) <- cRhs0 cBdy env (length te0) e+ return (t, rcomp (Kindle.ACon (injectCon k) vs te) r)+ where Kindle.Struct vs0 te0 _ = findDecl env k+++-- Translate a Core right-hand-side into a Kindle.Cmd result, a binding, and a type abstraction+cRhs0 cBdy env n (ELet bs e)+ | isTAbsEncoding bs = do (te,t,r) <- cRhs cBdy env n [] e+ return (tAbsVars bs, te, t, r)+cRhs0 cBdy env n e = do (te,t,r) <- cRhs cBdy env n [] e+ return ([], te, t, r)+ ++-- Translate a Core right-hand-side into a Kindle.Cmd result and a binding+cRhs cBdy env n te (ELam te' e) = do te' <- cATEnv env te'+ cRhs cBdy (addATEnv te' env) n (te++te') e+cRhs cBdy env n te e+ | n == l_te = do (t,r) <- cBdy env e+ return (te, t, r)+ | n < l_te = do (t,r) <- cBdy env e+ t' <- findClosureType env [] (rng te2) t+ return (te1, t', rcomp (Kindle.CRet . Kindle.closure t' t te2) r)+ | n > l_te = do (t,r) <- cBdy env e+ (tss,t') <- splitClosureType env (n - l_te) t+ te' <- newEnv paramSym (concat tss)+ let f = Kindle.multiEnter tss (map Kindle.EVar (dom te'))+ return (te++te', t', rcomp (Kindle.cmap f) r)+ where l_te = length te+ (te1,te2) = splitAt n te+++-- Translate a Core.Exp into a Kindle.Cmd result+cBody env (ELet bs e)+ | not (isEncoding bs) = do (te,bf) <- cBinds env bs+ (t,r) <- cBody (addTEnv te env) e+ return (t, rcomp bf r)+cBody env (ECase e alts) = cCase cBody env e alts+cBody env (EAp e0 [e]) + | isPrim Match e0 = do (t,r) <- cPMC cBody env e+ return (t, rcomp (\c -> Kindle.CSeq c (Kindle.CRaise (Kindle.ELit (lInt 1)))) r)+cBody env e = do (bf,t,h) <- cExp env e+ case h of+ ValR e -> return (t, ValR (bf (Kindle.CRet e)))+ FunR f ts -> return (t, FunR (bf . Kindle.CRet . f) ts)+++-- Note: we don't really handle PMC terms as first class citizens, rather like constructors in a small grammar+-- of pattern-matching expressions:+-- e ::= ... | Match pm+-- pm ::= Commit e | Fail | Fatbar pm pm | case e of {p -> pm} pm | let bs in pm+-- This syntax is followed when PMC terms are introduced in module Match, and is also respected by Termred.+--+-- However, should we for some reason want to allow abstraction over PMC terms, as in (\e -> Commit e),+-- the translation below will need to be complemented with a concrete implementation of the PMC type constructor+-- (using Maybe, for example), and corresponding general implementations of Match, Commit, Fail & Fatbar.+++-- Translate a Core.Exp corresponding to a PMC term into a Kindle.Cmd result+cPMC cE env (ELet bs e)+ | not (isEncoding bs) = do (te,bf) <- cBinds env bs+ (t,r) <- cPMC cE (addTEnv te env) e+ return (t, rcomp bf r)+cPMC cE env (ECase e alts) = cCase (cPMC cE) env e alts+cPMC cE env (EAp e0 [e1,e2])+ | isPrim Fatbar e0 = do r1 <- cPMC cE env e1+ r2 <- cPMC cE env e2+ let n = maximum [rArity r1, rArity r2]+ r1 <- adaptR env n r1+ r2 <- adaptR env n r2+ return (mkSeq r1 r2)+cPMC cE env (EAp e0 [e])+ | isPrim Commit e0 = cE env e+cPMC cE env e0+ | isPrim Fail e0 = do [t] <- cTArgs env e0+ return (t, ValR Kindle.CBreak)+cPMC cE env e = internalError "PMC syntax violated in Core2Kindle" e+++-- Translate the parts of a case expression into a Kindle.Cmd result+cCase cE env e ((PCon k,e'):_)+ | isTuple k = do (bf,_,e) <- cValExp env e+ (te,t1,r) <- cRhs cE env (width k) [] e'+ let (xs,ts) = unzip te+ bs = mkBinds xs ts (map (Kindle.ESel e) (take (width k) abcSupply))+ return (t1, rcomp (bf . Kindle.cBind bs) r)+cCase cE env e alts = do (bf,t0,e0) <- cValExp env e+ rs <- mapM (cAlt cE env) alts+ let n = maximum (map rArity rs)+ rs <- mapM (adaptR env n) rs+ return (mkSwitch bf rs e0)+++adaptR env 0 (t0, ValR c) = return (t0, ValR c)+adaptR env n (t0, FunR f ts)+ | n == l_ts = return (t0, FunR f ts)+ | n > l_ts = do (tss,t) <- splitClosureType env (n - l_ts) t0+ return (t, FunR (g tss) (ts ++ concat tss))+ where l_ts = length ts+ g tss es = let (es1,es2) = splitAt l_ts es+ in Kindle.cmap (Kindle.multiEnter tss es2) (f es1)+adaptR env n (t0, ValR c) = do (tss,t) <- splitClosureType env n t0+ return (t, FunR (g tss) (concat tss))+ where g tss es = Kindle.cmap (Kindle.multiEnter tss es) c+++rArity (t, ValR _) = 0+rArity (t, FunR f ts) = length ts++mkSwitch bf ((t,ValR c):rs) e0 = (t, ValR (bf (Kindle.CSwitch e0 alts)))+ where alts = c : [ alt | (_,ValR alt) <- rs ] +mkSwitch bf ((t,FunR g ts):rs) e0 = (t, FunR (\es -> bf (Kindle.CSwitch e0 (map ($es) (g:gs)))) ts)+ where gs = [ g | (_,FunR g _) <- rs ]++mkSeq (t1,ValR c1) (t2,ValR c2) = (t1, ValR (Kindle.CSeq c1 c2))+mkSeq (t1,FunR g1 ts1) (t2,FunR g2 ts2) = (t1, FunR (\es -> Kindle.CSeq (g1 es) (g2 es)) ts1)+++-- =========================================================================================+-- Translating commands+-- =========================================================================================++-- Translate a Core.Cmd into a Kindle.Cmd+cCmd env (CRet e) = do (bf,te,e) <- freezeState env e+ (bf',t,e) <- cValExp (addTEnv te env) e+ if Kindle.simpleExp e then -- No state references or non-termination in e+ return (t, bf (bf' (Kindle.CRet e))) -- Can be ignored (see CGen alternative)+ else do+ x <- newName tempSym+ let bf'' = Kindle.cBind [(x, Kindle.Val t e)]+ return (t, bf (bf' (bf'' (Kindle.CRet (Kindle.EVar x)))))+cCmd env (CAss x e c) = do (bf,te,e) <- freezeState env e+ (bf',e) <- cValExpT (addTEnv te env) tx e+ (t,c) <- cCmd env c+ return (t, bf (bf' (Kindle.CUpdS (stateRef env) x e c)))+ where Kindle.ValT tx = lookup' (tenv env) x+cCmd env (CLet bs c) = do (bf,te,bs) <- freezeState env bs+ (te',bf') <- cBinds (addTEnv te env) bs+ (t,c) <- cCmd (addTEnv te' env) c+ return (t, bf (bf' c))+cCmd env (CGen x tx (ECase e alts) c)+ | isDummy x && null alts' = cCmd env c+ | isDummy x = do (_,ValR c1) <- cCase cValCmdExp env e alts'+ (t,c2) <- cCmd env c+ return (t, Kindle.CSeq (Kindle.cMap (\_ -> Kindle.CBreak) c1) c2)+ where alts' = filter useful alts+ useful (_,EDo _ _ (CRet (ECon (Prim UNITTERM _)))) = False+ useful _ = True+cCmd env (CGen x tx e c) = do (bf,te,e) <- freezeState env e+ tx <- cAType env tx+ (bf',e) <- cValExpT (addTEnv te env) tx (EAp e [EVar (self env)])+ (t,c) <- cCmd (addATEnv [(x,tx)] env) c+ return (t, bf (bf' (Kindle.cBind [(x,Kindle.Val tx e)] c)))+cCmd env (CExp e) = cCmdExp env e+++-- Translate a Core.Exp in the monadic execution path into a Kindle.Cmd+cCmdExp env (ELet bs e)+ | not (isEncoding bs) = do (bf,te,bs) <- freezeState env bs+ (te',bf') <- cBinds (addTEnv te env) bs+ (t,c) <- cCmdExp (addTEnv te' env) e+ return (t, bf (bf' c))+cCmdExp env (EAp e0 [e]) +-- | isPrim ReqToCmd e0 = ...+ | isPrim Raise e0 = do (bf,te,e) <- freezeState env e+ (bf',t,e') <- cValExp (addTEnv te env) e+ return (t, bf (bf' (Kindle.CRaise e')))+ | isPrim Match e0 = do (bf,te,e) <- freezeState env e+ (t,ValR c) <- cPMC cValCmdExp (addTEnv te env) e+ return (t, bf (Kindle.CSeq c (Kindle.CRaise (Kindle.ELit (lInt 1)))))+cCmdExp env (EDo x tx c) = do tx <- cAType env tx+ (t,c) <- cCmd (pushSelf x (addATEnv [(x,Kindle.tRef tx)] env)) c+ return (t, Kindle.cBind [(x,Kindle.Val (Kindle.tRef tx) (Kindle.EVar (self env)))] c)+cCmdExp env (ECase e alts) = do (bf,te,e) <- freezeState env e+ (t,ValR c) <- cCase cValCmdExp (addTEnv te env) e alts+ return (t, bf c)+cCmdExp env e = do (bf,te,e) <- freezeState env e+ (bf',t,e) <- cValExp (addTEnv te env) (EAp e [EVar (self env)])+ x <- newName tempSym+ let bf'' = Kindle.cBind [(x, Kindle.Val t e)]+ return (t, bf (bf' (bf'' (Kindle.CRet (Kindle.EVar x)))))+++cValCmdExp env e = do (t,c) <- cCmdExp env e+ return (t, ValR c)+ ++-- State variables are normally translated into field selections from the current "self". For example,+-- x := 7; result (x + 1)+-- gets translated into+-- self->x := 7; result (self->x + 1)+-- However, closure values, which may be invoked long after they are defined, must not be sensitive to state+-- mutations. This means that "self" dereferencing operations for any contained state variables must be done +-- when the closure is defined, not when it is invoked. Here's a challenging example:+-- x := 7; f = \y->x+y; x := 2; result (f 1);+-- If we naively translate the x reference in f to self->x, we end up with the wrong behavior:+-- self->x := 7; int f(int y) { return self->x + y }; self->x := 2; return f(1); -- gives 3, not 8+--+-- A correct translation can instead be obtained if we make sure that no state variables are ever referenced +-- from within a lambda abstraction, as in the equivalent example+-- x := 7; x' = x; f = \y->x'+y; x := 2; return (f 1); (for some fresh variable x')+-- Achieving this is the job of function freezeState below. It takes an expression e and returns a renaming +-- of e with the "fragile" free variables (i.e., state vars inside lambdas) replaced by fresh variables, +-- together with a type environment and Kindle bindings for the new variables. For the example above, +-- input (\y->x+y) results in output (\y->x'+y) together with the Kindle binding (int x' = self->x). When+-- composed with the rest of the translation process, the full output becomes+-- self->x := 7; int x' = self->x; int f(int y) { return x'+y }; self->x := 2; return f(1);+-- This form is perfectly valid as input to the subsequent lambda-lifting pass, whose result will be+-- int f(int x'', int y) { return x'' + y }+-- self->x := 7; int x' = self->x; self->x := 2; return f(x',1);+++class Fragile a where+ fragile :: a -> [Name]+ +instance Fragile Exp where+ fragile (ELam _ e) = filter isState (idents e)+ fragile (EAp e es) = concatMap fragile (e:es)+ fragile (ESel e l) = fragile e+ fragile (ERec c eqs) = concatMap fragile (rng eqs)+ fragile (ELet bs e) = fragile bs ++ fragile e+ fragile (ECase e alts) = fragile e ++ concatMap fragile alts+ fragile _ = []++instance Fragile (Pat,Exp) where+ fragile (_,ELam te e) = fragile e+ fragile (_,e) = fragile e+ +instance Fragile Binds where+ fragile bs = concatMap fragile (rng (eqnsOf bs))+++freezeState env xx+ | null vs = return (id, [], xx)+ | otherwise = do vs' <- newNames paramSym (length vs)+ return (Kindle.cBind (zipWith3 f vs' ts vs), vs' `zip` ts, subst (vs `zip` map EVar vs') xx)+ where vs = nub (fragile xx)+ ts = map (lookup' (tenv env)) vs+ f v' (Kindle.ValT t) v = (v', Kindle.Val t (Kindle.ESel (stateRef env) v))+++-- Return a Kindle expression identifying the current state struct+stateRef env = Kindle.ESel (Kindle.EVar (self env)) (prim STATE)+++-- =========================================================================================+-- Translating expressions+-- =========================================================================================++-- Translate a Core.Exp into an expression result that is either a value or a function,+-- overflowing into a list of Kindle.Binds if necessary+cExp env (ELet bs e)+ | isTAppEncoding bs = do ts <- mapM (cAType env) (tAppTypes bs)+ cExp (setTArgs env ts) e+ | not (isTAbsEncoding bs) = do (te,bf) <- cBinds env bs+ (bf',t,h) <- cExp (addTEnv te env) e+ return (bf . bf', t, h)+cExp env (ELit l) = return (id, Kindle.litType l, ValR (Kindle.ELit l))+cExp env (ERec c eqs) = do (bf,bs) <- cEqs (setTArgs env []) te' eqs+ return (bf, Kindle.TCon c ts, ValR (Kindle.ENew c ts bs))+ where ts = tArgs env+ Kindle.Struct vs te _ = findDecl env c+ te' = subst (vs `zip` ts) te+cExp env (EAp e0 [e])+ | isPrim ActToCmd e0 = do (bf,t,e) <- cValExp env (EAp e [EVar (prim Inherit), EVar (prim Inherit)])+ [t1] <- cTArgs env e0+ return (bf, t, FunR (\_ -> e) [Kindle.tRef t1])+ | isPrim ReqToCmd e0 = do (bf,t,e) <- cValExp env (EAp e [ELit (lInt 0)])+ [t1,t2] <- cTArgs env e0+ return (bf, t, FunR (\_ -> e) [Kindle.tRef t2])+ | Just t <- isCastPrim e0 = do (bf,_,e') <- cExp env e+ return (bf, t, rcomp (Kindle.ECast t) e')+ | isPrim RefToPID e0 = do (bf,t,e) <- cExp env e+ return (bf, Kindle.tPID, rcomp (Kindle.ECast Kindle.tPID) e)+ | isPrim New e0 = cExp env (EAp e [ELit (lInt 0)]) -- Can't occur but in CBind rhs, syntactic restriction+cExp env (EAp e0 [e,e'])+ | isPrim After e0 = do (bf,e1) <- cValExpT env Kindle.tTime e+ (bf',t,f,ts) <- cFunExp env e'+ return (bf . bf', t, FunR (\[a,b] -> f [sum a e1, b]) ts)+ | isPrim Before e0 = do (bf,e1) <- cValExpT env Kindle.tTime e+ (bf',t,f,ts) <- cFunExp env e'+ return (bf . bf', t, FunR (\[a,b] -> f [a, min b e1]) ts)+ where sum a e1 = Kindle.ECall (prim TimePlus) [] [a,e1]+ min b e1 = Kindle.ECall (prim TimeMin) [] [b,e1]+cExp env (EAp e es) + | not (isPrim Match e) = do (bf,t,f,ts) <- cFunExp env e+ appFun env bf t f ts es+ where appFun env bf t f ts es+ | l_ts < l_es = do (bf',es1) <- cValExpTs env ts es1+ (ts',t') <- openClosureType t + appFun env (bf . bf') t' (Kindle.enter (f es1) []) ts' es2+ | l_ts == l_es = do (bf',es) <- cValExpTs env ts es+ return (bf . bf', t, ValR (f es))+ | l_ts > l_es = do (bf',es) <- cValExpTs env ts1 es+ return (bf . bf', t, FunR (f . (es++)) ts2)+ where l_ts = length ts+ l_es = length es+ (ts1,ts2) = splitAt l_es ts+ (es1,es2) = splitAt l_ts es+cExp env (EVar x) = case lookup' (tenv env) x of+ Kindle.ValT t -> return (id, t, ValR e)+ Kindle.FunT vs ts' t + | null ts' -> return (id, subst s t, ValR (Kindle.ECall x ts []))+ | otherwise -> return (id, subst s t, FunR (Kindle.ECall x ts) (subst s ts'))+ where s = vs `zip` ts+ where e = if stateVar (annot x) then Kindle.ESel (stateRef env) x else Kindle.EVar x+ ts = tArgs env+cExp env (ESel e l) = do (bf,e) <- cValExpT (setTArgs env []) (Kindle.TCon k ts0) e+ case subst (vs0 `zip` ts0) rhstype of+ Kindle.ValT t -> return (bf, t, ValR (Kindle.ESel e l))+ Kindle.FunT vs ts t -> return (bf, subst s t, FunR (Kindle.EEnter e l ts1) (subst s ts))+ where s = vs `zip` ts1+ where (k,vs0,rhstype) = Kindle.typeOfSel (decls env) l+ (ts0,ts1) = splitAt (length vs0) (tArgs env) -- tArgs lists *full* instantiation, not just local quantification+cExp env (ECon k) = case te of+ [] -> return (id, t0, ValR (newK []))+ _ -> return (id, t0, FunR (newK . mkBinds abcSupply ts') ts')+ where ts = tArgs env+ Kindle.Struct vs te _ = findDecl env k+ ts' = subst (vs `zip` ts) (map (Kindle.rngType . snd) te)+ (k0,n) = Kindle.typeOfCon (decls env) k+ t0 = Kindle.TCon k0 (take n ts)+ newK | isTuple k = Kindle.ENew k ts+ | otherwise = Kindle.ECast t0 . Kindle.ENew (injectCon k) ts+cExp env e = do (vs,te,t,c) <- cFun0 env e+ case (vs,te) of+ ([],[]) -> do+ x <- newName tempSym+ return (Kindle.cBind [(x, Kindle.Fun [] t [] c)], t, ValR (Kindle.ECall x [] []))+ _ -> do + t' <- findClosureType env vs (rng te) t+ return (id, t', ValR (Kindle.closure2 t' vs t te c))+++-- Translate a Core.Exp into a Kindle value expression+cValExp env e = do (bf,t,h) <- cExp env e+ case h of+ ValR e -> + return (bf, t, e)+ FunR f ts -> do+ xs <- newNames paramSym (length ts)+ t' <- findClosureType env [] ts t+ let es = map Kindle.EVar xs+ te = xs `zip` ts+ return (bf, t', Kindle.closure t' t te (Kindle.CRet (f es)))+++-- Translate a Core.Exp into a Kindle function+cFunExp env e = do (bf,t,h) <- cExp env e+ case h of+ FunR f ts -> return (bf, t, f, ts)+ ValR e' -> do (ts,t') <- openClosureType t+ return (bf, t', Kindle.enter e' [], ts)+ ++-- Map a Kindle.ATEnv (unzipped) and a list of Kindle.Exps into a list of Kindle.Binds+mkBinds xs ts es = zipWith3 f xs ts es+ where f x t e = (x, Kindle.Val t e)+++-- Check if expression is a primitive, possibly applied to type arguments+isPrim p (ELet bs e) + | isTAppEncoding bs = isPrim p e+isPrim p (EVar (Prim p' _))+ | p == p' = True+isPrim p e = False++isCastPrim (EVar (Prim p _))+ | p `elem` intCasts = Just Kindle.tInt+ | p == IntToChar = Just Kindle.tChar+ | p == IntToBITS8 = Just Kindle.tBITS8+ | p == IntToBITS16 = Just Kindle.tBITS16+ | p == IntToBITS32 = Just Kindle.tBITS32+ where intCasts = [CharToInt,BITS8ToInt,BITS16ToInt,BITS32ToInt]+isCastPrim _ = Nothing+++-- Extract type arguments from expression+cTArgs env (ELet bs e)+ | isTAppEncoding bs = mapM (cAType env) (tAppTypes bs)+cTArgs env e = return []++++-- Additional entry point for translating imported environments+c2kTEnv ds te = localStore f+ where f = do mapM_ addToStore (filter (isClosure . fst) ds)+ te <- cTEnv env0 te+ return (filter p te)+-- p (_,Kindle.FunT _ _ (Kindle.TCon n _)) +-- = not (isClosure n) -- ???+ p _ = True
+ src/Decls.hs view
@@ -0,0 +1,208 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Decls where++import Common+import Core+import Env+import Reduce+import PP++-- Declaration processing ---------------------------------------------------------------------++{-++? Check acyclic tsym deps +? Generate future subtype instances+? Generate future class instances++-}+++-- Extend kind environment+-- Initialize empty class witness graph+-- Extract selector and constructor type schemes+-- Construct class member type schemes and bindings+-- Replace subtyping in type declarations with explicit selectors/constructors+-- Initialize subtyping graph with reflexivity witnesses+-- Close subtyping graph under transitivity (report cyclic and ambiguity errors)+-- Return extended environment, transformed decls and added witness bindings+++typeDecls env (Types ke ds) = do (ds,pe1,eq1) <- desub env0 ds+ (env',bs) <- instancePreds env0 pe1+ let tds = Types ke ds+ return (addTEnv0 (tenvSelsCons tds) env', tds, catBinds (Binds False pe1 eq1) bs)+ where env0 = addClasses cs (addKEnv0 ke env)+ cs = [ c | (c, DRec True _ _ _) <- ds ]++impDecls env (Types ke ds) = env1+ where + env1 = addClasses cs (addKEnv0 ke env)+ cs = [ c | (c, DRec True _ _ _) <- ds ]++-- Close the top-level instance delcarations+-- Return the extended environment and the added witness bindings++instancePreds env pe = do (env',qe,eq) <- closePreds0 env pe+ let bss = preferParams env' pe qe eq+ return (env', concatBinds bss)++impPreds env pe = addPreds (addPEnv0 pe env) pe+++-- Computes the stand-alone type schemes associated with selectors and constructors+-- Note: these constants have no corresponding definition (i.e., no rhs)++tenvSelsCons (Types ke ds) = concatMap (tenvSelCon ke) ds++tenvSelCon ke0 (c,DRec _ vs _ ss) = map (f t ke) ss+ where (t,ke) = mkHead ke0 c vs+ f t ke (l, Scheme rh ps ke') = (l, Scheme rh (scheme t : ps) (ke++ke'))+tenvSelCon ke0 (c,DData vs _ cs) = map (f t ke) cs+ where (t,ke) = mkHead ke0 c vs+ f t ke (k, Constr ts ps ke') = (k, Scheme (tFun' ts t) ps (ke++ke'))+tenvSelCon ke0 _ = []++tenvCon ke0 (c,DData vs _ cs) = map (f t ke) cs+ where (t,ke) = mkHead ke0 c vs+ f t ke (k, Constr ts ps ke') = (k, Scheme (tFun' ts t) ps (ke++ke'))+tenvCon ke0 _ = []++mkHead ke0 i vs = (tAp' i vs, vs `zip` kArgs (findKind0 ke0 i))+++-- Decomposition of type declarations ---------------------------------------------------------++desub env ds = do (ds',pes,eqs) <- fmap unzip3 (mapM desub' ds)+ return (ds', concat pes, concat eqs)+ where + desub' (i, DData vs bs cs) = do (pe,eq,cs') <- fmap unzip3 (mapM (con (fromMod i) (mkHead ke0 i vs)) bs)+ return ((i, DData vs [] (cs'++cs)), pe, eq)+ desub' (i, DRec isC vs bs ss) = do (pe,eq,ss') <- fmap unzip3 (mapM (sel (fromMod i) (mkHead ke0 i vs)) bs)+ return ((i, DRec isC vs [] (ss'++ss)), pe, eq)+ desub' (i, DType vs t) = return ((i, DType vs t), [], [])+ ke0 = kindEnv0 env+ con m (t0,ke0) (Scheme (R t) [] ke) = do w <- newNameMod m coercionSym+ k <- newNameMod m (coerceConstr t t0)+ x <- newName paramSym+ let p = (w, Scheme (R (t `sub` t0)) [] (ke0++ke))+ eq = (w, ELam [(x,scheme t)] (EAp (ECon k) [EVar x]))+ c = (k, Constr [scheme t] [] ke)+ return (p, eq, c)+ sel m (t0,ke0) (Scheme (R t) [] ke) = do w <- newNameMod m coercionSym+ l <- newNameMod m (coerceLabel t0 t)+ x <- newName paramSym+ let p = (w, Scheme (R (t0 `sub` t)) [] (ke0++ke))+ eq = (w, ELam [(x,scheme t0)] (ESel (EVar x) l))+ s = (l, Scheme (R t) [] ke)+ return (p, eq, s)++coerceConstr t t0 = coerceConstrSym ++ "_" ++ render (prId3 (tId(tHead t))) ++ "_" ++ render (prId3 (tId (tHead t0)))++coerceLabel t0 t = coerceLabelSym ++ "_" ++ render (prId3 (tId(tHead t0))) ++ "_" ++ render (prId3 (tId (tHead t)))++{-++ *data Exists m = All a . Pack (All b . D m b a) (All b . C m b a -> m b a)++ Pack :: All m,a . (All b . D m b a) -> (All b . C m b a -> m b a) -> Exists m++ f1 :: All a,b . (All b . D m b a) -> D m' b a+ f1 :: All a . (All b . D m b a) -> (All b . D m' b a)+ f2 :: All a,b . (All b . D m b a) -> (All b . C m b a -> m b a) -> C m' b a -> m' b a+ f2 :: All a . (All b . D m b a) -> (All b . C m b a -> m b a) -> (All b . C m' b a -> m' b a)+ case x of+ Pack -> \d::(All b . D m b a) -> \r::(All b . C m b a -> m b a) -> Pack (f1 d) (f2 d r)+++ *data Exists m = All a . (All b . D m b a) => Pack (All b . C m b a -> m b a)++ Pack :: All m,a . (All b . D m b a) => (All b . C m b a -> m b a) -> Exists m++ f1 :: All a,b . (All b . D m b a) -> D m' b a+ f1 :: All a . (All b . D m b a) -> (All b . D m' b a)+ f2 :: All a,b . (All b . D m b a) -> (All b . C m b a -> m b a) -> C m' b a -> m' b a+ f2 :: All a . (All b . D m b a) -> (All b . C m b a -> m b a) -> (All b . C m' b a -> m' b a)+ case x of+ Pack -> \d::(All b . D m b a) => \r::(All b . C m b a -> m b a) -> Pack (f1 d) (f2 d r)+++ + *data Exists m = Pack (D m b a \\ b) (C m b a -> m b a \\ b) \\ a++ Pack :: (D m b a \\ b) -> (C m b a -> m b a \\ b) -> Exists m \\ m, a++ f1 :: (D m b a \\ b) -> D m' b a \\ a, b+ f1 :: (D m b a \\ b) -> (D m' b a \\ b) \\ a+ f2 :: (D m b a \\ b) -> (C m b a -> m b a \\ b) -> C m' b a -> m' b a \\ a, b+ f2 :: (D m b a \\ b) -> (C m b a -> m b a \\ b) -> (C m' b a -> m' b a \\ b) \\ a+ case x of+ Pack -> \d::(D m b a \\ b) -> \r::(C m b a -> m b a \\ b) -> Pack (f1 d) (f2 d r)+++ *data Exists m = Pack (m b a \\ b, C m b a) \\ a, (D m b a \\ b)++ Pack :: (m b a \\ b, C m b a) -> Exists m \\ m, a, (D m b a \\ b)++ f1 :: (D m b a \\ b) -> D m' b a \\ a,b+ f1 :: (D m b a \\ b) -> (D m' b a \\ b) \\ a+ f2 :: (m b a \\ b, C m b a) -> m' b a \\ a, b, C m' b a, (D m b a \\ b)+ f2 :: (m b a \\ b, C m b a) -> (m' b a \\ b, C m' b a) \\ a, (D m b a \\ b)+ case x of+ Pack -> \d::(D m b a \\ b) => \r::(m b a \\ b, C m b a) -> Pack (f1 d) (f2 d r)++++ *record T a =+ x :: b -> a -> b \\ b, b < a++ x :: T a -> b -> a -> b \\ b, b < a++ f :: (b -> a -> b \\ b, b < a) -> b -> a' -> b \\ b, b < a'+ f :: (b -> a -> b \\ b, b < a) -> (b -> a' -> b \\ b, b < a')+ { x = f r.x }++++ *record T a =+ x :: (b<a) -> b -> a -> b \\ b++ x :: T a -> (b<a) -> b -> a -> b \\ b++ f :: ((b<a) -> b -> a -> b \\ b) -> (b<a') -> b -> a' -> b \\ b+ f :: ((b<a) -> b -> a -> b \\ b) -> ((b<a') -> b -> a' -> b \\ b)+ { x = f r.x }+-}+
+ src/Depend.hs view
@@ -0,0 +1,119 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Depend where++import Common+import Core+import Syntax+import PP++type Graph a = Map a [a]++graph nbors ps = map f ps+ where f (i,d) = (i,[v | v <- nbors d, v/=i, v `elem` domain])+ domain = dom ps+ +scc :: Eq a => Graph a -> [[a]]+scc g = dfs g' (concat (dfs g (dom g)))+ where g' = [(i,[x | (x,ys) <- g, i `elem` ys]) | (i,_) <- g]++dfs g is = snd (dfs' ([],[]) is)+ where dfs' p [] = p+ dfs' p@(vs,ns) (x:xs)+ | x `elem` vs = dfs' p xs+ | otherwise = dfs' (vs', (x:concat ns'):ns) xs+ where (vs',ns') = dfs' (x:vs,[]) (nbors x)+ nbors i = fromJust (lookup i g)++order ms ns = ns `zip` map (fromJust . flip lookup ms) ns+ +group ms nss = map (order ms) nss++topSort :: Eq a => (b -> [a]) -> [(a,b)] -> Either [a] [(a,b)]+topSort nbors ms = case dropWhile (null . tail) ns of+ [] -> Right (order ms (concat ns))+ xs : _ -> Left xs+ where ns = scc (graph nbors ms)++groupBinds (Binds _ te es) = map f ess+ where gs = scc (graph evars es)+ ess = group es gs+ f [(x,e)] = Binds (x `elem` evars e) (restrict te [x]) (restrict es [x])+ f es' = Binds True (restrict te xs) (restrict es xs)+ where xs = dom es'+++groupTypes (Types ke ts) = map f tss+ where gs = scc (graph tycons ts)+ tss = group ts gs+ f ts' = Types (restrict ke cs) (restrict ts cs)+ where cs = dom ts'+++groupMap bs = map f bss+ where gs = scc (graph evars bs)+ bss = group bs gs+ f bs@[(x,b)] = (x `elem` evars b, restrict bs [x])+ f bs' = (True, restrict bs xs)+ where xs = dom bs'+ +-- Dependency analysis on Syntax bindlists -------------------------------------------++isFunEqn v (BEqn (LFun v' _) _) = v == v'+isFunEqn v _ = False++graphInfo [] = []+graphInfo (s@(BSig [v] _) : bs)+ = (s:bs1, [v], nub (idents bs1)) : graphInfo bs2+ where (bs1,bs2) = span (isFunEqn v) bs+graphInfo (e@(BEqn (LFun v _) rh) : bs) + = (e:bs1, [v], nub (idents (e:bs1))) : graphInfo bs2+ where (bs1,bs2) = span (isFunEqn v) bs+graphInfo (e@(BEqn (LPat p) rh) : bs) + = ([e], nub (idents p), nub (idents rh)) : graphInfo bs+graphInfo (BSig _ _ : bs) = graphInfo bs++buildGraph :: [([Bind],[Name],[Name])] -> Graph Int+buildGraph vs = zip ns (map findDeps fvss)+ where (_,bvss,fvss) = unzip3 vs+ ns = [1..]+ dict = concatMap mkDict (zip bvss ns)+ mkDict (vs,n) = map (\v -> (v,n)) vs+ findDeps xs = [n | Just n <- map (flip lookup dict) xs]++groupBindsS :: [Bind] -> [[Bind]]+groupBindsS bs = map f gs+ where infos = graphInfo bs+ gs = scc (buildGraph infos)+ f indices = concat (map (\i -> fst3 (fromJust (lookup i (zip [1..] infos)))) indices)
+ src/Derive.hs view
@@ -0,0 +1,199 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Derive where++import Common+import Core+import Env+import PP+++derive ts ds [] = return ([],[])+derive ts ds (d@(Default _ _ _) : xs)+ = do (is,xs) <- derive ts ds xs+ return (is,d:xs)+derive ts ds (Derive n sc : xs) = do let (s,d) = analyze ds sc+ n1 = str (fst s)+ m = fromMod (fst s)+ (is,xs) <- derive ts ds xs+ if n1=="Show" && m==Just "Prelude"+ then do i <- mkShowInstance n sc s d+ return (i:is,xs)+ else + if n1=="Parse" && m==Just "Prelude" + then do let eq = EVar (findByNameStr ts "==")+ i <- mkParseInstance n eq sc s d+ return (i:is,xs)+ else do b <- mkFunPair d+ i <- mkInstance n ts s sc b+ -- tr ("### Default instance \n"++render (prInsts i))+ return (i:is,xs)++analyze ds sc = case tFlat (scheme2Type sc) of+ (TId c,[t']) -> findDataType c t'+ _ -> errorTree "Not an instance of a one-parameter type constructor" sc + where findDataType c t' = case tFlat t' of+ (TId d,_) -> case lookup c (tdefsOf ds) of+ Nothing -> errorTree ("Unknown typeclass "++show c) sc+ Just c'@(DRec True [a] _ _) -> case lookup d (tdefsOf ds) of+ Nothing -> errorTree ("Unknown data type "++show d) sc+ Just d'@(DData _ _ _) -> ((c,c'),(d,d')) + Just _ -> errorTree (show d++" is not a data type") sc+ Just (DRec True _ _ _) -> errorTree "Default instances only for one-parameter typeclasses; not" sc+ Just _ -> errorTree (show c++" is not a typeclass") sc + +mkInstance n ts (nm,DRec True [a] ps ss) sc (ns,bss)+ = do fs <- mapM (mkField a ts ns) ss+ return (Binds False [(n,sc)] [(n,foldr ELet (ERec nm fs) bss)])++mkField a ts [from,to] (nm,sc) = do let nm' = findByNameStr ts (str nm)+ e <- expand a from to (EVar nm') sc+ return (nm,e)++findByNameStr ts s = lookup' [(name0 (str n),n {annot = (annot n) {explicit=False}}) | n <- ts ] (name0 s)++expand a from to e sc = exp0 to (e,scheme2Type sc)+ where exp0 f (e,TFun ts t) = do ns <- newNames paramSym (length ts)+ let xs = map EVar ns+ es <- mapM (exp0 from) (zip xs ts)+ e' <- exp0 to (EAp e es,t)+ eLam' ns e'+ exp0 f (e,TId n)+ | n==a = return (EAp (EVar f) [e])+ exp0 _ (e,t) = expTup (e,tFlat t)+ + expTup (e,(TId (Tuple n _),ts))+ = do let n = length ts+ ns <- newNames paramSym n+ let xs = map EVar ns+ es <- mapM (exp0 to) (zip xs ts)+ lam <- eLam' ns (etup n es)+ return (ECase e [(PCon (tuple n), lam)])+ expTup (e,_) = return e++eLam' xs e = do ts <- mapM (\_ -> newTVar Star) xs+ return (ELam (zipWith (\x t -> (x,scheme t)) xs ts) e)+ +mkFunPair (nm,DData _ (_:_) _) = errorIds "Not yet implemented: default instances for data type with subtypes" [nm]+mkFunPair (nm,DData vs ss cs) = do [from,to] <- mapM newName ["from"++str nm,"to"++str nm]+ frhs <- fromRHS+ trhs <- toRHS+ return ( [from,to], [Binds False [(from,fromType)] [(from,frhs)], Binds False [(to,toType)] [(to,trhs)]])++ where ot = foldr1 tEither (map mkTuple cs)+ dt = foldl TAp (TId nm) (map TId vs)+ mkTuple (_,Constr [] _ _) = tUnit+ mkTuple (_,Constr ss _ _) = foldr1 (ttup2) (map scheme2Type ss)+ ttup2 t1 t2 = ttup 2 [t1,t2]+ etup2 e1 e2 = etup 2 [e1,e2]+ fromType = Scheme (F [scheme dt] (R ot)) [] (map (\n -> (n,Star)) vs)+ toType = Scheme (F [scheme ot] (R dt)) [] (map (\n -> (n,Star)) vs)++ prefixLR fs e = foldr (\f e -> EAp (ECon f) [e]) e (map prim fs)+ mkAlt fs (nm,Constr [] _ _) = return (PCon nm,prefixLR fs (ECon (prim UNITTERM)))+ mkAlt fs (nm,Constr ss _ _) = do ns <- newNames tempSym (length ss)+ lam <- eLam' ns (prefixLR fs (foldr1 (etup2) (map EVar ns)))+ return (PCon nm,lam)+ alts fs [c] = do a <- mkAlt fs c+ return [a]+ alts fs (c:cs) = do a <- mkAlt (fs++[LEFT]) c+ as <- alts (fs++[RIGHT]) cs+ return (a:as)+ fromRHS = do x <- newName paramSym+ as <- alts [] cs+ return (ELam [(x,scheme dt)] (ECase (EVar x) as))++ mkCase t@(TAp (TAp (TId (Prim EITHER _)) a) b) (c:cs) (x:xs)+ = do [y,z] <- newNames paramSym 2+ l <- mkCase a [c] (y:xs)+ r <- mkCase b cs (z:xs)+ lam1 <- eLam' [y] l+ lam2 <- eLam' [z] r+ return (ECase (EVar x) [(PCon (prim LEFT),lam1),(PCon (prim RIGHT),lam2)])+ mkCase t@(TAp (TAp (TId (Tuple 2 _)) a) b) cs (x:xs)+ = do [y,z] <- newNames paramSym 2+ r <- mkCase b cs (z:y:xs)+ lam <- eLam' [y,z] r+ return (ECase (EVar x) [(PCon (tuple 2),lam)])+ mkCase (TId (Prim UNITTYPE _)) (c:_) xs + = return (ECon c)+ mkCase t (c:_) xs = return (EAp (ECon c) (map EVar (reverse xs)))+ toRHS = do x <- newName paramSym+ r <- mkCase ot (map fst cs) [x] + eLam' [x] r+++ttup n ts = foldl TAp (TId (tuple n)) ts+etup n es = EAp (ECon (tuple n)) es+++scheme2Type (Scheme r _ _) = rho2Type r+rho2Type (R t) = t+rho2Type (F ss r) = TFun (map scheme2Type ss) (rho2Type r) ++mkShowInstance n sc s (nm, DData vs [] cs) + = do sh <- mkShow+ return (Binds False [(n,sc)] [(n,ERec (fst s) [(n',sh)])])+ where DRec _ _ _ [(n',_)] = snd s+ mkShow = do x <- newName paramSym+ as <- mapM mkShowAlt cs+ eLam' [x] (ECase (EVar x) as)+ mkShowAlt (nm,Constr [] _ _) = return (PCon nm,ELit (LStr Nothing (str nm)))+ mkShowAlt (nm,_) = errorIds "Sorry, as yet only default Show for enumeration types, without constructors as" [nm]+-- cons = ECon (prim CONS)+-- nil = ECon (prim NIL)+ chr c = ELit (lChr c)+mkShowInstance n sc s (nm, DData vs _ cs) + = errorIds "Not yet implemented: default Show instance for data type with subtypes" [nm]++++mkParseInstance n eq sc s (nm, DData vs [] cs) + = do p <- mkParse+ return (Binds False [(n,sc)] [(n,ERec (fst s) [(n',p)])])+ where DRec _ _ _ [(n',_)] = snd s+ mkParse = do x <- newName paramSym+ as <- mapM (mkParseAlt x) cs+ eLam' [x] (EAp (EVar (prim Match)) [foldr (\x y -> EAp (EVar (prim Fatbar)) [x,y]) + (EAp (EVar (prim Commit)) [EAp (ECon (prim LEFT)) [mkList "no Parse"]]) + as]) + mkParseAlt x (nm,Constr [] _ _) = return (ECase (EAp eq [EVar x, mkList (str nm)])+ [(PCon (prim TRUE),EAp (EVar (prim Commit)) [EAp (ECon (prim RIGHT)) [ECon nm]]),(PWild,EVar (prim Fail))])+ mkParseAlt x (nm,_) = errorIds "Sorry, as yet only default Parse for enumeration types, without constructors as" [nm]+-- cons = ECon (prim CONS)+-- nil = ECon (prim NIL)+ mkList str = ELit (LStr Nothing str)+ chr c = ELit (lChr c)+mkParseInstance n eq sc s (nm, DData vs _ cs) + = errorIds "Not yet implemented: default Parse instance for data type with subtypes" [nm]
+ src/Desugar1.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE FlexibleInstances #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Desugar1 where++import List(sort, sortBy)+import Monad+import Common+import Syntax+import Depend+import PP++desugar1 e0 (Module c is ds ps) = do let (env,expInfo) = mkEnv c (ds ++ ps) e0+ ds' <- dsDecls env ds+ ps' <- dsDecls env {isPublic = False} ps+ return (Module c is ds' ps',expInfo)++{-+ This module performs desugaring transformations that must be performed before the renaming pass:+ - Implements Record Stuffing; i.e. replacing ".." in record patterns and expressions + by sequences of bindings of the form "x=x" for missing record fields x. + - Adds type tag to anonymous record expressions/patterns.+ - Makes the "self" variable explicit.+ - Checks validity of result statement+ - Replaces prefix expression statement with dummy generator statement+ - Replaces if/case statements with corresponding expressions forms+ - Checks the restricted command syntax of template bodies+ - Unfolds use of type synonyms+-}++-- The selector environment --------------------------------------------------------------------------------------++data Env = Env { sels :: Map Name [Name], + self :: Maybe Name , + selSubst :: Map Name Name,+ modName :: Maybe String,+ isPat :: Bool,+ isPublic :: Bool,+ isTail :: Bool,+ tsyns :: Map Name ([Name],Type)+ } deriving Show+++env0 ss = Env { sels = [], self = Nothing, selSubst = [], modName = Nothing, isPat = False, + isPublic = True, isTail = True, tsyns = ss }+++mkEnv c ds (rs,rn,ss) = (env {sels = map transClose recEnv, modName = Just(str c), selSubst = rnSels },+ (map (\(n,ss) -> (qName (str c) n,ss)) closeRecEnvLoc,tsynsLoc))+ where (env,ssLoc) = tsynE (env0 ss) [] tsynDecls+ tsynsLoc = map (\(n,y) -> (n {fromMod = Just (str c)},y)) ssLoc+ recEnvLoc = [ (c,(map type2head ts, concat (map sels ss))) | DRec _ c _ ts ss <- ds ] + recEnvImp = zip ns (zip (repeat []) ss) where (ns,ss) = unzip rs+ closeRecEnvLoc = map transClose recEnvLoc+ closeRecEnvImp = map transClose recEnvImp+ recEnv = recEnvLoc ++ recEnvImp+ selsLocQual = concatMap (snd . snd) recEnvLoc+ selsLoc = map dropMod selsLocQual+ rnSels = zip selsLoc selsLocQual ++ zip selsLocQual selsLocQual ++ rn+ sels (Sig vs _) = map (qName (str c)) vs+ transClose (c,(cs,ss)) = (c, sort (ss ++ nub(concat (map (selectors [c]) cs))))+ selectors cs0 c+ | c `elem` cs0 = errorIds "Circular struct dependencies" (c:cs0)+ | otherwise = case lookup c recEnv of+ Just (cs,ss) -> ss ++ concat (map (selectors (c:cs0)) cs)+ Nothing -> errorIds "Unknown struct constructor" [c]++ tsynDecls + | not (null dups) = errorIds "Duplicate type synonym declarations" dups+ | otherwise = case topSort (tyCons . snd) syns of+ Left ns -> errorIds "Mutually recursive type synonyms" ns+ Right syns' -> syns'+ syns = [(c,(vs,t)) | DType c vs t <- ds]+ dups = duplicates (map fst syns)+++tsynE env ls [] = (env,ls)+tsynE env ls ((c,(vs,t)) : ps) + | c `elem` tyCons t = errorIds "Type synonym is recursive" [c]+ | otherwise = tsynE env {tsyns =p : tsyns env} (p:ls) ps+ where p = (c,(vs,ds1 env t))++selsFromType env c = case lookup c (sels env) of+ Just ss -> ss+ Nothing -> if fromMod c == modName env+ then selsFromType env (c {fromMod = Nothing})+ else errorIds "Unknown struct constructor" [c]+++typeFromSels env ss = case [ c | (c,ss') <- sels env, ss' == ss ] of+ [] -> errorIds "No struct type with selectors" ss+ [c] -> c+ cs -> case filter isQualified cs of+ [c] -> c+ _ -> errorIds ("Multiple struct types defined by selectors") ss+++haveSelf env = self env /= Nothing++haveTail env [] = env+haveTail env _ = env { isTail = False }++tSubst env c ts = case lookup c (tsyns env) of+ Nothing -> foldl TAp (TCon c) ts1+ Just (vs,t)+ | length vs > length ts -> errorIds "Type synonym not fully applied" [c]+ | otherwise -> foldl TAp (subst (zip vs (take (length vs) ts1)) t) + (drop (length vs) ts1)+ where ts1 = ds1 env ts++ren env cs = map ren' cs + where ren' c = case lookup c (selSubst env) of+ Nothing -> errorIds "Unknown struct selector" [c]+ Just c' -> c'++patEnv env = env {isPat = True}++sortFields fs = sortBy cmp fs+ where cmp (Field l1 _) (Field l2 _) = compare (str l1) (str l2)++-- Desugaring -------------------------------------------------------------------------------------------++dsDecls env (DType c vs t : ds) = liftM (DType c vs (ds1 env t) :) (dsDecls env ds)+dsDecls env (DData c vs ss cs : ds) = liftM (DData c vs (ds1 env ss) (ds1 env cs) :) (dsDecls env ds)+dsDecls env (DRec b c vs ss ss' : ds) = liftM (DRec b c vs (ds1 env ss) (ds1 env ss') :) (dsDecls env ds)+dsDecls env (DPSig n t : ds) = liftM (\ds -> DInstance [n] : DBind [BSig [n] (ds1 env t)] : ds) (dsDecls env ds)+dsDecls env (DInstance ws : ds) = liftM (DInstance ws :) (dsDecls env ds)+dsDecls env (DTClass ts : ds) = liftM (DTClass ts :) (dsDecls env ds)+dsDecls env (DDefault ts : ds) = liftM (DDefault (ds1 env ts) :) (dsDecls env ds)+dsDecls env ds@(DBind _ : _) = dsDs [] ds+ where dsDs bs (DBind bs':ds) = dsDs (bs++bs') ds+ dsDs bs ds = liftM (DBind (ds1 env bs) :) (dsDecls env ds)+dsDecls env (d : ds) = liftM (d :) (dsDecls env ds)+dsDecls env [] = return []+++class Desugar1 a where+ ds1 :: Env -> a -> a++instance Desugar1 a => Desugar1 [a] where+ ds1 env = map (ds1 env)++instance Desugar1 a => Desugar1 (Maybe a) where+ ds1 env Nothing = Nothing+ ds1 env (Just a) = Just (ds1 env a)++instance Desugar1 (Default Type) where+ ds1 env (Default _ a b) = Default (isPublic env) a b+ ds1 env (Derive v t) = Derive v (ds1 env t)++instance Desugar1 Constr where+ ds1 env (Constr c ts ps) = Constr c (ds1 env ts) (ds1 env ps)++instance Desugar1 Sig where+ ds1 env (Sig vs t) = Sig vs (ds1 env t)++instance Desugar1 Type where+ ds1 env t@(TAp t1 t2) = case tFlat t of+ (TCon c,ts) -> tSubst env c ts+ _ -> TAp (ds1 env t1) (ds1 env t2)+ ds1 env (TQual t ps) = TQual (ds1 env t) (ds1 env ps)+ ds1 env (TSub t1 t2) = TSub (ds1 env t1) (ds1 env t2)+ ds1 env (TList t) = TList (ds1 env t)+ ds1 env (TTup ts) = TTup (ds1 env ts)+ ds1 env (TFun ts t) = TFun (ds1 env ts) (ds1 env t)+ ds1 env (TCon c) = tSubst env c []+ ds1 env t = t++instance Desugar1 Pred where+ ds1 env (PType t) = PType (ds1 env t)+ ds1 env p = p+instance Desugar1 Decl where+ ds1 env (DBind bs) = DBind (ds1 env bs)+ ds1 env d = d++instance Desugar1 Bind where+ ds1 env (BEqn lh rh) = BEqn (ds1 env lh) (ds1 env rh)+ ds1 env (BSig vs t) = BSig vs (ds1 env t)++instance Desugar1 Lhs where+ ds1 env (LFun v ps) = LFun v (ds1 (patEnv env) ps)+ ds1 env (LPat (EVar x)) = LFun x []+ ds1 env (LPat p) = LPat (ds1 (patEnv env) p)++instance Desugar1 (Rhs Exp) where+ ds1 env (RExp e) = RExp (ds1 env e)+ ds1 env (RGrd gs) = RGrd (ds1 env gs)+ ds1 env (RWhere e bs) = RWhere (ds1 env e) (ds1 env bs)++instance Desugar1 (GExp Exp) where+ ds1 env (GExp qs e) = GExp (ds1 env qs) (ds1 env e)++instance Desugar1 Qual where+ ds1 env (QExp e) = QExp (ds1 env e)+ ds1 env (QGen p e) = QGen (ds1 (patEnv env) p) (ds1 env e)+ ds1 env (QLet bs) = QLet (ds1 env bs)++instance Desugar1 Exp where+-- ds1 env e@(EVar _) = e+ ds1 env (ERec Nothing fs)+ | not (null dups) = errorIds "Duplicate field definitions in struct" dups+ | otherwise = ERec (Just (c,True)) (sortFields (ds1 env fs))+ where c = typeFromSels env (sort (ren env (bvars fs)))+ dups = duplicates (bvars fs)+ ds1 env (ERec (Just (c,all)) fs)+ | not (null dups) = errorIds "Duplicate field definitions in struct" dups+ | all && not (null miss) = errorIds "Missing selectors in struct" miss+ | otherwise = ERec (Just (c,True)) (sortFields (fs' ++ ds1 env fs))+ where miss = ren env (selsFromType env c) \\ ren env (bvars fs)+ dups = duplicates (ren env (bvars fs))+ fs' = map (\s -> Field (tag0 (mkLocal s)) (EVar (dropMod (tag0 s)))) miss+ mkLocal s+ | fromMod s == modName env = dropMod s+ | otherwise = s+ ds1 env (EBStruct _ _ bs) = EBStruct (Just c) labs (ds1 env bs)+ where labs = selsFromType env c+ c = typeFromSels env (sort (ren env (bvars bs)))+ ds1 env (ELet bs e) = ELet (ds1 env bs) (ds1 env e)+ ds1 env (EAp e1 e2) = EAp (ds1 env e1) (ds1 env e2)+ ds1 env (ETup es) = ETup (ds1 env es)+ ds1 env (EList es) = EList (ds1 env es)+ ds1 env (ESig e t) = ESig (ds1 env e) (ds1 env t)+ ds1 env (ELam ps e) = ELam (ds1 (patEnv env) ps) (ds1 env e)+ ds1 env (ECase e as) = ECase (ds1 env e) (ds1 env as)+ ds1 env (EIf e1 e2 e3) = EIf (ds1 env e1) (ds1 env e2) (ds1 env e3)+ ds1 env (ENeg (ELit (LInt p i))) = ELit (LInt p (-i))+ ds1 env (ENeg (ELit (LRat p r))) = ELit (LRat p (-r))+ ds1 env (ENeg e) = EAp (EVar (name' "negate" e)) (ds1 env e)+ ds1 env (ESeq e1 Nothing e3) = EAp (EAp (EVar (name' "enumFromTo" e1)) (ds1 env e1)) (ds1 env e3)+ ds1 env (ESeq e1 (Just e2) e3) = EAp (EAp (EAp (EVar (name' "enumFromThenTo" e1)) (ds1 env e1)) (ds1 env e2)) (ds1 env e3)+ ds1 env (EComp e qs) = EComp (ds1 env e) (ds1 env qs)+ ds1 env (ESectR e op) = ESectR (ds1 env e) op+ ds1 env (ESectL op e) = ESectL op (ds1 env e)+ ds1 env (ESelect e s) = ESelect (ds1 env e) s+ ds1 env e@(ELit (LInt _ n))+ | isPat env = e+ | otherwise = EAp (EVar (name' "fromInt" e)) e ++ ds1 env (ETempl Nothing t ss) = ds1 env (ETempl (Just (name0 "self")) (ds1 env t) ss)+ ds1 env (EDo Nothing t ss)+ | haveSelf env = ds1 env (EDo (self env) (ds1 env t) ss)+ | otherwise = ds1 env (EDo (Just (name0 "self")) (ds1 env t) ss)+ ds1 env e@(EAct Nothing ss)+ | haveSelf env = ds1 env (EAct (self env) ss)+ | otherwise = errorTree "Action outside class" e+ ds1 env e@(EReq Nothing ss)+ | haveSelf env = ds1 env (EReq (self env) ss)+ | otherwise = errorTree "Request outside class" e++ ds1 env (ETempl v t ss) = ETempl v t (ds1T (env{self=v}) [] [] ss)+ ds1 env (EDo v t ss) = EDo v t (ds1S (env { self=v, isTail = True }) ss)+ ds1 env (EAct v ss) = EAct v [SExp (EDo v Nothing (ds1S (env { isTail = False }) ss))]+ ds1 env (EReq v ss) = EReq v [SExp (EDo v Nothing (ds1S (env { isTail = True }) ss))]++ ds1 env (EAfter e1 e2) = EAfter (ds1 env e1) (ds1 env e2)+ ds1 env (EBefore e1 e2) = EBefore (ds1 env e1) (ds1 env e2) ++ ds1 env e = e++instance Desugar1 (Alt Exp) where+ ds1 env (Alt p rh) = Alt (ds1 (patEnv env) p) (ds1 env rh)++instance Desugar1 Field where+ ds1 env (Field l e) = Field l (ds1 env e)+++ds1S env [] = [SRet (ECon (prim UNITTERM))]+ds1S env [SExp e] = [SExp (ds1 env e)]+ds1S env (SExp e : ss) = SGen EWild (ds1 env e) : ds1S env ss+ds1S env [SRet e] = [SRet (ds1 env e)]+ds1S env (s@(SRet _) : ss) = errorTree "Result statement must be last in sequence" s+ds1S env (SGen p e : ss) = SGen (ds1 (patEnv env) p) (ds1 env e) : ds1S env ss+ds1S env ss@(SBind _ : _) = dsBs [] ss+ where dsBs bs (SBind bs' : ss) = dsBs (bs++bs') ss+ dsBs bs ss = SBind (ds1 env bs) : ds1S env ss+ds1S env (SAss p e : ss) = dsAss p e : ds1S env ss+ where dsAss (EAp (EAp (EVar (Prim IndexArray _)) a) i) e+ = dsAss a (EAp (EAp (EAp (EVar (prim UpdateArray)) a) i) e)+ dsAss p e = SAss (ds1 env p) (ds1 env e)+ {-+ a|x|y|z := e+ a|x|y := a|x|y \\ (z,e)+ a|x := a|x \\ (y, a|x|y \\ (z,e))+ a := a \\ (x, a|x \\ (y, a|x|y \\ (z,e)))+ -}+ds1S env (SCase e as : ss) = ds1S env (SExp (retComplete (haveTail env ss) (ECase e (map doAlt as))) : ss)+ where doAlt (Alt p r) = Alt (ds1 (patEnv env) p) (doRhs r)+ doRhs (RExp ss) = RExp (eDo env ss)+ doRhs (RGrd gs) = RGrd (map doGrd gs)+ doRhs (RWhere r bs) = RWhere (doRhs r) bs+ doGrd (GExp qs ss) = GExp qs (eDo env ss)+ds1S env (SIf e ss' : ss) = doIf (EIf e (eDo env ss')) ss+ where doIf f (SElsif e ss':ss) = doIf (f . EIf e (eDo env ss')) ss+ doIf f (SElse ss':ss) = ds1S env (SExp (retComplete (haveTail env ss) (f (eDo env ss'))) : ss)+ doIf f ss = doIf f (SElse [] : ss)+ds1S env (s@(SElsif _ _) : _) = errorTree "elsif without corresponding if" s+ds1S env (s@(SElse _) : _) = errorTree "else without corresponding if" s+ds1S env (SForall q ss' : ss) = ds1S env (SExp (ds1Forall env q ss') : ss)+ds1S env (SWhile e ss' : ss) = internalError0 "while stmt not yet implemented"++ds1Forall env [] ss = eDo env ss+ds1Forall env (QLet bs : qs) ss = ELet bs (eDo env [SForall qs ss])+ds1Forall env (QGen p (ESeq e1 Nothing e3) : qs) ss+ = EAp (EAp (EAp (EVar (name' "forallSeq" p)) (ELam [p] (ds1Forall env qs ss))) e1) e3+ds1Forall env (QGen p (ESeq e1 (Just e2) e3) : qs) ss+ = EAp (EAp (EAp (EAp (EVar (name' "forallSeq1" p)) (ELam [p] (ds1Forall env qs ss))) e1) e2) e3+ds1Forall env (QGen p e : qs) ss = EAp (EAp (EVar (name' "forallList" p)) (ELam [p] (ds1Forall env qs ss))) e+ds1Forall env (QExp e : qs) ss = EIf e (eDo env []) (ds1Forall env qs ss)++ds1T env [] asg [SRet e] = reverse asg ++ [SRet (ds1 env e)]+ds1T env bss asg [SRet e] = SBind (ds1 env (concat (reverse bss))) : reverse asg ++ [SRet (ds1 env e)]+ds1T env bss asg [s] = errorTree "Last statement in class must be result, not" s+ds1T env bss asg (s@(SRet _):_) = errorTree "Result statement must be last in sequence" s+ds1T env bss asg (SBind bs : ss) = ds1T env (bs:bss) asg ss+ds1T env bss asg (SAss p e : ss) = ds1T env bss (SAss (ds1 (patEnv env) p) (ds1 env e) : asg) ss+ds1T env bss asg (s : _) = errorTree "Illegal statement in class: " s++retComplete env e+ | partialE e = addRetE e+ | isTail env = e+ | otherwise = addRetE e+ where partialE (EIf _ e1 e2) = partialE e1 || partialE e2+ partialE (ECase _ alts) = any partialA alts+ partialE (EDo _ _ ss) = partialS ss+ partialE _ = False+ partialS [] = True+ partialS _ = False+ partialA (Alt p r) = partialR r+ partialR (RExp e) = partialE e+ partialR (RGrd gs) = any partialG gs+ partialR (RWhere r bs) = partialR r+ partialG (GExp qs e) = partialE e+ + addRetE (EIf e e1 e2) = EIf e (addRetE e1) (addRetE e2)+ addRetE (ECase e alts) = ECase e (map addRetA alts)+ addRetE (EDo v t ss) = EDo v t (addRetS ss)+ addRetE e = e+ addRetA (Alt p r) = Alt p (addRetR r)+ addRetR (RExp e) = RExp (addRetE e)+ addRetR (RGrd gs) = RGrd (map addRetG gs)+ addRetR (RWhere r bs) = RWhere (addRetR r) bs+ addRetG (GExp qs e) = GExp qs (addRetE e)+ addRetS [] = [SRet (ECon (prim UNITTERM))]+ addRetS s@[SRet (ECon (Prim UNITTERM _))]+ = s+ addRetS s@[SRet _] = errorTree "Illegal result statement" s+ addRetS (s:ss) = s : addRetS ss+++eDo env ss = EDo (self env) Nothing ss++maybeGen e [] = [SExp e]+maybeGen e ss = SGen EWild e : ss++name' s e = Name s 0 Nothing (noAnnot {location = loc (posInfo e)})+ where loc Unknown = Nothing+ loc (Between p _) = Just p++-- Printing --------++instance Pr (Module,([(Name, [Name])], [(Name, ([Name], Type))])) where+ + pr (m,_) = pr m
+ src/Desugar2.hs view
@@ -0,0 +1,393 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Desugar2(desugar2) where++import Monad+import Common+import Syntax+import Match+import Maybe+import Fixity+import PP++desugar2 :: Module -> M s Module+desugar2 m = dsModule m+++-- Modules ------------------------------------------------------------------++dsModule :: Module -> M s Module+dsModule (Module c is ds ps) = do ds <- dsDecls ds+ return (Module c is ds ps)+++-- Top level declarations ---------------------------------------------------++++dsDecls [] = return []+dsDecls (d@(DKSig _ _) : ds) = liftM (d :) (dsDecls ds)+dsDecls (DData c vs bs cs : ds) = liftM (DData c vs (map dsQualBaseType bs) (map dsConstr cs) :) (dsDecls ds)+dsDecls (DRec i c vs bs ss:ds) = liftM (DRec i c vs (map dsQualBaseType bs) (map dsSig ss) :) (dsDecls ds)+dsDecls (DType c vs t : ds) = liftM (DType c vs (dsType t) :) (dsDecls ds)+dsDecls (DPSig v t : ds) = liftM (DPSig v (dsQualPred t) :) (dsDecls ds)+dsDecls (DInstance vs : ds) = liftM (DInstance vs :) (dsDecls ds)+dsDecls (DTClass vs : ds) = dsDecls ds+dsDecls (DDefault ts : ds) = liftM (DDefault (map dsDefault ts) :) (dsDecls ds) +dsDecls (DBind bs : ds) = do bs <- dsBinds bs+ liftM (DBind bs :) (dsDecls ds)+ ++dsConstr (Constr c ts ps) = Constr c (map dsQualType ts) (map dsQual ps)++dsSig (Sig vs t) = Sig vs (dsQualType t)++dsDefault (Default t a b) = Default t a b+dsDefault (Derive v t) = Derive v (dsQualType t)++-- Types ----------------------------------------------------------------------++dsQualType (TQual t ps) = checkQual (dsRhoType t) (map dsQual ps)+dsQualType t = dsRhoType t++dsRhoType (TFun ts t) = TFun (map dsQualType ts) (dsRhoType t)+dsRhoType t = dsType t++dsType (TAp t t') = TAp (dsType t) (dsType t')+dsType (TFun ts t) = TFun (map dsType ts) (dsType t)+dsType (TList t) = TAp (TCon (prim LIST)) (dsType t)+dsType (TTup ts) = foldl TAp (TCon (tuple (length ts))) (map dsType ts)+dsType (TCon c) = TCon c+dsType (TVar v) = TVar v+dsType t = internalError "Bad type expressionin dsType" t+++-- Types with wildcards ---------------------------------------------------------------++dsQualWildType (TQual t ps) = checkQual (dsRhoWildType t) (map dsQual ps)+dsQualWildType t = TQual (dsRhoWildType t) []++dsRhoWildType (TFun ts t) = TFun (map dsQualWildType ts) (dsRhoWildType t)+dsRhoWildType t = dsWildType t++dsWildType (TAp t t') = TAp (dsWildType t) (dsWildType t')+dsWildType (TFun ts t) = TFun (map dsWildType ts) (dsWildType t)+dsWildType (TList t) = TAp (TCon (prim LIST)) (dsWildType t)+dsWildType (TTup ts) = foldl TAp (TCon (tuple (length ts))) (map dsWildType ts)+dsWildType (TCon c) = TCon c+dsWildType (TVar v) = TVar v+dsWildType (TWild) = TWild+dsWildType t = internalError "Bad type expression in dsWildType" t+++-- Base types -------------------------------------------------------------++dsQualBaseType (TQual t ps) = checkQual (dsBaseType t) (map dsKindQual ps)+dsQualBaseType t = TQual (dsBaseType t) []++dsBaseType (TAp t t') = TAp (dsBaseType t) (dsType t')+dsBaseType (TList t) = TAp (TCon (prim LIST)) (dsType t)+dsBaseType (TCon c) = TCon c+dsBaseType t = internalError "Bad base type expression in dsBaseType" t+++-- Predicates ------------------------------------------------------------++dsQual (PKind v k) = PKind v k+dsQual (PType (TVar v)) = PKind v KWild+dsQual (PType t) = PType (dsQualPred t)+++dsKindQual (PKind v k) = PKind v k+dsKindQual (PType (TVar v)) = PKind v KWild+dsKindQual q = internalError "Bad qualifier in dsKindQual" q+++dsQualPred (TQual t ps) = checkQual (dsSubOrClassPred t) (map dsQual ps)+dsQualPred t = TQual (dsSubOrClassPred t) []++dsSubOrClassPred (TSub t t') = TSub (dsType t) (dsType t')+dsSubOrClassPred t = dsClassPred t++dsClassPred (TAp t t') = TAp (dsClassPred t) (dsType t')+dsClassPred (TCon c) = TCon c+dsClassPred p = internalError "Bad class predicate in dsClassPred" p+++-- Bindings ---------------------------------------------------------------++dsBinds [] = return []+dsBinds (BSig vs qt : bs) = do bs <- dsBinds bs+ return (BSig vs (dsQualWildType qt) : bs)+dsBinds bs = f [] bs+ where f eqns (BEqn lh rh :bs) = f ((lh,rh) : eqns) bs+ f eqns bs = do eqns <- dsEqns (reverse eqns)+ bs <- dsBinds bs+ return (map (uncurry BEqn) eqns ++ bs)+++-- Equations -----------------------------------------------------------------++dsEqns [] = return []+dsEqns ((LPat p,RExp (EVar v)):eqns)+ = do p' <- dsPat p -- Checks validity+ sels <- mapM (sel (EVar v)) vs+ dsEqns (sels ++ eqns)+ where vs = pvars p+ sel e0 v = do es <- mapM (newEVarPos paramSym) vs+ return (LFun v [], RExp (selectFrom e0 (vs `zip` es) p (EVar v)))+dsEqns ((LPat p,rh):eqns) = do v <- newNamePos patSym p+ eqns <- dsEqns ((LPat p, RExp (EVar v)) : eqns)+ e <- dsExp (rh2exp rh)+ return ((LFun v [],RExp e) : eqns)+dsEqns ((LFun v ps,rh):eqns) = dsFunBind v [(ps,rh)] eqns+++dsFunBind v alts ((LFun v' ps,rh) : eqns)+ | v' == v = dsFunBind v ((ps,rh) : alts) eqns+dsFunBind v [(ps,RExp e)] eqns+ | not (null ps) = do e' <- dsExp (ELam ps e)+ eqns <- dsEqns eqns+ return ((LFun v [], RExp e') : eqns)+dsFunBind v alts eqns+ | length arities /= 1 = errorIds "Different arities for function" [v]+ | otherwise = do ws <- newNamesPos paramSym (fst (head alts))+ alts <- mapM dsA (reverse alts)+ e <- pmc' ws alts+ eqns <- dsEqns eqns + return ((LFun v [], RExp (eLam (map EVar ws) e)) : eqns)+ where arities = nub (map (length . fst) alts)+ dsA (ps,rh) = liftM2 (,) (mapM dsPat ps) (dsRh rh)+++-- Helper functions --------------------------------------------------++checkQual t ps+ | not (null ambig) = errorIds "Ambiguous type scheme, orphans are" ambig+ | otherwise = TQual t ps+ where ambig = tvs_ps \\ (vclose tvss tvs)+ tvs_ps = nub (concat tvss `intersect` bvs)+ tvs = tyvars t+ tvss = map tyvars ps+ bvs = bvars ps+++zipSigs (v:vs) (ESig _ t : ps) = ESig (EVar v) t : zipSigs vs ps+zipSigs (v:vs) (p : ps) = EVar v : zipSigs vs ps+zipSigs _ _ = []++rh2exp (RExp e) = e+rh2exp (RWhere rh bs) = ELet bs (rh2exp rh)+rh2exp rh = ECase (ECon (prim UNITTERM)) [Alt (ECon (prim UNITTERM)) rh]++selectFrom e0 s p e = ECase e0 [Alt (subst s p) (RExp (subst s e))]+++-- Expressions --------------------------------------------------------+++dsExp (EAp e e') = liftM2 EAp (dsExp e) (dsExp e')+dsExp (ESig e qt) = do x <- newNamePos tempSym e+ dsExp (ELet [BSig [x] qt, BEqn (LFun x []) (RExp e)] (EVar x))+dsExp (ELam ps e) + | all isESigVar ps = liftM2 ELam (mapM dsPat ps) (dsExp e)+ | otherwise = do ps <- mapM dsPat ps+ e <- dsExp e+ ws <- newNamesPos paramSym ps+ e' <- pmc' ws [(ps,RExp e)]+ return (ELam (zipSigs ws ps) e')+dsExp (ELet [BEqn (LPat p) rh] e)+ | nonRecursive = dsExp (ECase (rh2exp rh) [Alt p (RExp e)])+ where nonRecursive = not (any (`elem` evars rh) (pvars p))+dsExp (ELet bs e) = liftM2 ELet (dsBinds bs) (dsExp e)+dsExp (EIf e e1 e2) = dsExp (ECase e [Alt true (RExp e1), Alt false (RExp e2)])+dsExp (ESectR e op) = dsExp (EAp (op2exp op) e)+dsExp (ESectL op e) = do x <- newEVarPos paramSym op+ dsExp (ELam [x] (EAp (EAp (op2exp op) x) e))+dsExp (ECase e alts) = do e <- dsExp e+ alts <- mapM dsA alts+ pmc e alts+ where dsA (Alt p rh) = liftM2 Alt (dsPat p) (dsRh rh)+dsExp (ESelect e s) = liftM (flip ESelect s) (dsExp e)+dsExp (ESel s) = do x <- newNamePos paramSym s+ return (ELam [EVar x] (ESelect (EVar x) s))+dsExp (EWild) = errorTree "Non-pattern use of wildcard variable" EWild+dsExp (EVar v) = return (EVar v)+dsExp (ECon c) = return (ECon c)+dsExp (ELit l) = return (ELit l)+dsExp (ERec m fs) = liftM (ERec m) (mapM dsF fs)+ where dsF (Field s e) = liftM (Field s) (dsExp e)+dsExp (EDo v t ss) = liftM (EDo v (fmap dsWildType t)) (dsStmts False ss)+dsExp (ETempl v t ss) = liftM (ETempl v (fmap dsWildType t)) (dsStmts True ss)+dsExp (EAct v ss) = liftM (EAct v) (dsStmts False ss)+dsExp (EReq v ss) = liftM (EReq v) (dsStmts False ss)+dsExp (EAfter e e') = dsExp (EAp (EAp (EVar (prim After)) e) e')+dsExp (EBefore e e') = dsExp (EAp (EAp (EVar (prim Before)) e) e')+dsExp (ETup es) = dsExp (foldl EAp (ECon (tuple (length es))) es)+dsExp (EList es) = dsExp (foldr cons nil es)+dsExp (EComp e qs) = do e <- comp2exp e qs nil+ dsExp e+++-- List comprehensions --------------------------------------------------++comp2exp e [] r = return (cons e r)+comp2exp e (QExp e' : qs) r = do e <- comp2exp e qs r+ return (EIf e' e r)+comp2exp e (QLet bs : qs) r = do e <- comp2exp e qs r+ return (ELet bs e)+comp2exp e (QGen p e' : qs) r = do f <- newNamePos functionSym p+ x <- newEVarPos paramSym p+ e <- comp2exp e qs (EAp (EVar f) x)+ return (ELet (binds f x e) (EAp (EVar f) e'))+ where binds f x e = [BEqn (LFun f [nil]) (RExp r),+ BEqn (LFun f [cons p x]) (RExp e)] ++ dflt f x+ dflt f x | isEVar p = []+ | otherwise = [BEqn (LFun f [cons EWild x]) (RExp (EAp (EVar f) x))]+++-- Statements ------------------------------------------------------------++dsStmts cl [] = return []+dsStmts cl (SBind [BEqn (LPat p) rh] : ss)+ | not cl && nonRecursive = do x <- newName tempSym+ dsStmts cl [SExp (ECase (rh2exp rh) [Alt p (RExp (EDo (Just x) Nothing ss))])]+ where nonRecursive = not (any (`elem` evars rh) (pvars p))+dsStmts cl (SBind bs : ss) = do bs <- dsBinds bs+ liftM (SBind bs :) (dsStmts cl ss)+dsStmts cl [SRet e] = do e <- dsExp e+ return [SRet e]+dsStmts cl [SExp e] = do e <- dsExp e+ return [SExp e]+dsStmts cl (SGen p e : ss)+ | isESigVar p = do p <- dsInnerPat p+ e <- dsExp e+ ss <- dsStmts cl ss+ return (SGen p e : ss)+ | otherwise = do v' <- newEVarPos tempSym p+ dsStmts cl (SGen v' e : SBind [BEqn (LPat p) (RExp v')] : ss)+dsStmts cl (s@(SAss p e) : ss)+ | null vs = errorTree "Bad assignment" s+ | not cl && p0 /= p = errorTree "Illegal signature in assignment" s+ | isESigVar p = do p <- dsPat p+ e <- dsExp e+ ss <- dsStmts cl ss+ return (SAss p e : ss)+ | otherwise = do v0 <- newNamePos tempSym p+ assigns <- mapM (assign (EVar v0)) ps+ dsStmts cl (SBind [BEqn (LFun v0 []) (RExp e)] : assigns ++ ss)+ where assign e0 p = do vs' <- newNamesPos paramSym vs+ return (SAss p (selectFrom e0 (vs `zip` map EVar vs') p0 (unsig p)))+ p0 = unsig p+ ps = sigvars p+ vs = pvars ps+dsStmts cl ss = internalError ("dsStmts; did not expect") ss++unsig (ESig p _) = unsig p+unsig (ETup ps) = ETup (map unsig ps)+unsig (EList ps) = EList (map unsig ps)+unsig (ERec m fs) = ERec m [ Field l (unsig p) | Field l p <- fs ]+unsig p = p++sigvars (ETup ps) = concatMap sigvars ps+sigvars (EList ps) = concatMap sigvars ps+sigvars (ERec m fs) = concat [ sigvars p | Field l p <- fs ]+sigvars p+ | isESigVar p = [p]+ | otherwise = []+++-- Alternatives -----------------------------------------------------------------------++dsRh (RExp e) = liftM RExp (dsExp e)+dsRh (RGrd gs) = liftM RGrd (mapM dsGrd gs)+dsRh (RWhere rh [BEqn (LPat p) rh'])+ | nonRecursive = liftM RExp (dsExp (ECase (rh2exp rh') [Alt p (RExp (rh2exp rh))]))+ where nonRecursive = not (any (`elem` evars rh') (pvars p)) +dsRh (RWhere rh bs) = liftM2 RWhere (dsRh rh) (dsBinds bs)++dsGrd (GExp qs e) = do qs <- mapM dsEQual qs+ e <- dsExp e+ return (GExp qs e)++dsEQual (QExp e) = do e <- dsExp e+ return (QGen true e)+dsEQual (QGen p e) = do p <- dsPat p+ e <- dsExp e+ return (QGen p e)+dsEQual (QLet [BEqn (LPat p) rh])+ | nonRecursive = do p <- dsPat p+ e <- dsExp (rh2exp rh)+ return (QGen p e)+ where nonRecursive = not (any (`elem` evars rh) (pvars p)) +dsEQual (QLet bs) = liftM QLet (dsBinds bs)+++-- Patterns ----------------------------------------------------------------------------++dsPat (ESig p qt)+ | isEVar p = do p <- dsPat p+ return (ESig p (dsQualWildType qt))+dsPat (EVar v) = return (EVar v)+dsPat (EWild) = do v <- newName dummySym+ return (EVar v)+dsPat (ENeg (ELit (LInt p i))) = return (ELit (LInt p (-i)))+dsPat (ENeg (ELit (LRat p r))) = return (ELit (LRat p (-r)))+dsPat (ELit l) = return (ELit l)+dsPat (ETup ps) = dsPat (foldl EAp (ECon (tuple (length ps))) ps)+dsPat (EList ps) = dsPat (foldr cons nil ps)+dsPat (ERec m fs) = liftM (ERec m) (mapM dsField fs)+dsPat p = dsConPat p++dsField (Field l p) = liftM (Field l) (dsPat p)+++dsConPat (EAp p p') = liftM2 EAp (dsConPat p) (dsInnerPat p')+dsConPat (ECon c) = return (ECon c)+dsConPat p = errorTree "Illegal pattern" p++dsInnerPat (ESig p t)+ | isEVar p = do p <- dsPat p+ return (ESig p (dsWildType t))+dsInnerPat p = dsPat p+++-- Literals ------------------------------------------------------------------++--dsLit (LStr (Just (l,c)) s) = return (foldr cons nil (map mkLit (zipWith f s [c..])))+-- where f s n = (s,Just (l,n))+-- mkLit (c,p) = (ELit (LChr p c))+--dsLit l = return (ELit l)++
+ src/Env.hs view
@@ -0,0 +1,881 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Env where++import PP+import Common+import Core++++data WGraph = WG { nodes :: PEnv,+ arcs :: [(Name,Name)] + }+ deriving Show++nameOf = fst+predOf = snd++--labelOf = fst+--witOf = snd++data Env = Env { kindEnv0 :: KEnv, -- Kind for each global tycon+ kindEnv :: KEnv, -- Kind for each local skolemized tyvar+ typeEnv0 :: TEnv, -- Type scheme for each top-level def (no free tyvars)+ typeEnv :: TEnv, -- Type scheme for each additional def+ predEnv0 :: PEnv, -- Predicate scheme for each global witness def (no free tyvars)+ predEnv :: PEnv, -- Predicate scheme for each local witness abstraction++ tevars :: [TVar], -- The tvars free in typeEnv (cached)+ pevars :: [TVar], -- The tvars free in predEnv (cached)+ stateT :: Maybe Type, -- Type of current state scope (invariant: included in typeEnv as well)+ + coercions :: Eqns, -- Defs of top-level subtype coercions++ aboveEnv :: Map Name WGraph, -- Overlap graph of all S > T for each T (closed under transitivity)+ belowEnv :: Map Name WGraph, -- Overlap graph of all S < T for each T (closed under transitivity)+ classEnv :: Map Name WGraph, -- Overlap graph of all instances for each type class (closed under subclassing)++ modName :: Maybe String, + -- The following fields are only used during constraint reduction:+ history :: [Pred], -- Stack of predicates currently being reduced+ skolEnv :: Map Name [TVar], -- For each skolemized tyvar T: a list of free tvars not unifiable with T+ pols :: ([TVar],[TVar]), -- Pair of tvars occurring in (positive,negative) position in reduction target+ equalities :: [(Name,Name)], -- List of witness names that must be equivalent++ errPos :: PosInfo, + ticked :: Bool, -- Root constraint is an automatically generated coercion (must be removed!)+ forced :: Bool, -- Non-conservative reduction turned on+ frozen :: Bool -- Treat tvars as constants (during env closure) -- Not yet meaningful+ }++instance Show Env where+ show env = "<env>"+++nullEnv = Env { kindEnv0 = [],+ kindEnv = [],+ typeEnv0 = [],+ typeEnv = [],+ predEnv0 = [],+ predEnv = [],+ tevars = [],+ pevars = [],+ stateT = Nothing,+ coercions = [],+ aboveEnv = [],+ belowEnv = [],+ classEnv = [],+ modName = Nothing,+ history = [],+ skolEnv = [],+ pols = ([],[]),+ equalities = [],+ errPos = Unknown,+ ticked = False,+ forced = False,+ frozen = False+ }+++addTEnv0 te env = env { typeEnv0 = te ++ typeEnv0 env }++addTEnv te env = env { typeEnv = te ++ typeEnv env,+ tevars = tvs `union` tevars env }+ where tvs = tvars te++addKEnv0 ke env = env { kindEnv0 = ke ++ kindEnv0 env }++addKEnv ke env = env { kindEnv = ke ++ kindEnv env }+++addPEnv0 pe env = env { predEnv0 = pe ++ predEnv0 env }++addPEnv pe env+ | null (tvars pe) = env { predEnv = pe ++ predEnv env }+ | otherwise = internalError0 "Positive predicate with free variables (not yet implemented)"+-- = env { predEnv = pe ++ predEnv env,+-- pevars = nub (tvars pe `union` pevars env) }++addClasses cs env = env { classEnv = ce ++ classEnv env }+ where ce = cs `zip` repeat nullWG++setSelf x t env = env' { stateT = Just t }+ where env' = addTEnv [(x,scheme (tRef t))] env++addCoercions eqs env = env { coercions = filter (isCoercion . fst) eqs ++ coercions env }++addSkolEnv se env = env { skolEnv = se ++ skolEnv env }++skolEnvs env cs = concat [ tvs | (c,tvs) <- skolEnv env, c `elem` cs ]++tick env x = env { ticked = x }++force env x = env { forced = x }++freeze env = env { frozen = True } -- Not yet meaningful++thaw env = env { frozen = False } -- Not yet meaningful++target t env = env { pols = polvars env t `pcat` pols env }++protect t env = env { pols = pdupl (tvars t) `pcat` pols env }++addEqs eqs env = env { equalities = eqs ++ equalities env }++setErrPos Unknown env = env+setErrPos p env = env {errPos = p}++insertClassPred pre n@(w,p) post env = env { classEnv = insert c wg' (classEnv env) }+ where c = headsym p+ ws = repeat w+ wg = findClass env c+ wg' = WG { nodes = insertBefore n post (nodes wg),+ arcs = pre `zip` ws ++ ws `zip` post ++ arcs wg }++insertDefault sigs d@(Default _ i1 i2) env+ | c1 /= c2 = errorTree ("Illegal defaulting; instances of different classes") d+ | i1 `elem` post2 = errorIds ("Cyclic default declarationsss for") [i1,i2]+ | otherwise = env { classEnv = (c1,wg') : (delete c1 (classEnv env)) }+ where p1 = lookup' sigs i1+ c1 = headsym p1+ c2 = headsym (lookup' sigs i2)+ WG ns as = findClass env c1+ post2 = [ j | (i,j) <- as, i == i2 ]+ wg' = WG { nodes = insertBefore (i1,p1) (i2:post2) (delete i1 ns),+ arcs = (i1,i2) : (repeat i1 `zip` post2) ++ as }+insertDefault _ _ env = env++insertDefaults env sigs ds = foldr (insertDefault sigs) env ds++ +insertSubPred n@(w,p) env = env { aboveEnv = insert a wg_a (aboveEnv env),+ belowEnv = insert b wg_b (belowEnv env) }+ where (a,b) = subsyms p+ ws = repeat w+ wg_a = buildAbove (findAbove env a)+ wg_b = buildBelow (findBelow env b)+ + buildAbove wg = WG { nodes = insertBefore n post (nodes wg),+ arcs = pre `zip` ws ++ ws `zip` post ++ arcs wg }+ where syms = mapSnd uppersym (nodes wg)+ pre = [ w | (w,c) <- syms, hasCoercion env c b ]+ post = [ w | (w,c) <- syms, hasCoercion env b c ]++ buildBelow wg = WG { nodes = insertBefore n post (nodes wg),+ arcs = pre `zip` ws ++ ws `zip` post ++ arcs wg }+ where syms = mapSnd lowersym (nodes wg)+ pre = [ w | (w,c) <- syms, hasCoercion env a c ]+ post = [ w | (w,c) <- syms, hasCoercion env c a ]+ ++instance Subst WGraph TVar Type where+ subst s (WG ns as) = WG (subst s ns) as+++instance Subst a TVar Type => Subst (Env,a) TVar Type where+ subst s (env,p) = (subst s env, subst s p)+++instance Subst Env TVar Type where+ subst [] env = env+ subst s env+ | null (pevars env) = env'+ | otherwise = env' { aboveEnv = subst s (aboveEnv env),+ belowEnv = subst s (belowEnv env),+ classEnv = subst s (classEnv env),+ predEnv = subst s (predEnv env),+ pevars = substT s (pevars env) }+ where env' = env { {- typeEnv = subst s (typeEnv env), -- redundant -}+ stateT = subst s (stateT env),+ tevars = substT s (tevars env),+ pols = substP env s (pols env),+ skolEnv = mapSnd (substT s) (skolEnv env) }+++sapp s tvs = subst s (map TVar tvs)++substT s tvs = tvars (sapp s tvs)++substP env s (pvs,nvs) = polvars env (sapp s pvs) `pcat` pswap (polvars env (sapp s nvs))+++logHistory (env,c) = (env { history = c : history env }, c)++conservative (env,c) = not (forced env)++findKind0 ke (Tuple n _) = tupleKind n+findKind0 ke c = case lookup c ke of+ Just k -> k+ Nothing -> Star -- Hack! This alternative is intended for the fresh type+ -- constants introduced when type-checking templates with + -- no explicit state type annotations. The proper handling + -- of these names would be to thread an accumulating list + -- of generated type declarations through the type-checker+ -- instead, but (1) that would further complicate an already+ -- complex piece of software, and (2) these declarations + -- still cannot be made sufficiently polymorphic until the+ -- final substitution has been computed (i.e., after type-+ -- checking). A more advanced alternative would be to in-+ -- troduce local type declarations to the language, although+ -- issue (2) above would still need to be handled separately.+ -- Considering that the Core2Kindle pass can generate correct+ -- Kindle types given only the generated type name and the + -- state variable annotations already present in template+ -- expressions, there is much merit to the shortcut implemented+ -- here. Note also that unknown type constructor names have+ -- already been trapped and reported during renaming.+ -- error ("Internal: Unknown type constructor: " ++ show c)+ +findKind env c = findKind0 (kindEnv env ++ kindEnv0 env) c+++findType0 te (Tuple n _) = tupleType n+findType0 te v = case lookup v te of+ Just sc -> sc+ Nothing -> internalError0 ("Unknown identifier: " ++ show v)++findType env v = findType0 (typeEnv env ++ typeEnv0 env) v+++findExplType env x+ | explicit (annot x) = let Scheme t ps ke = findType env x in Scheme (tFun ps t) [] ke+ | otherwise = findType env x+ ++findPred env w = case lookup w (predEnv env ++ predEnv0 env) of+ Just p -> p+ Nothing -> internalError0 ("Unknown witness identifier: " ++ show w)+++findAbove env c = case lookup c (aboveEnv env) of+ Just wg -> wg+ Nothing -> nullWG+++findBelow env c = case lookup c (belowEnv env) of+ Just wg -> wg+ Nothing -> nullWG+++findClass env c = case lookup c (classEnv env) of+ Just wg -> wg+ Nothing -> internalError0 ("Unknown class identifier: " ++ show c)++++findCoercion env a b+ | a == b = Just reflAll+ | otherwise = search (upperIs b) (nodes (findAbove env a))++findCoercion' env a b = case findCoercion env a b of+ Just n -> unitWG n+ Nothing -> nullWG+++upperIs t (w,p) = uppersym p == t+++hasCoercion env a b = findCoercion env a b /= Nothing+++++{-++Embedding order:+- T[a] < T[b], a[x] < T[b], b[x] < T[x], a[x] < b[x]+++ X Y+ \ /+ \ /+ Z Pt C+ | / \ |+ | / \ |+ | / \ |+ ZPt CPt+ \ /+ \ /+ CZPt++a->b \\ a < Pt, a < b, CPt < b++Pt->Pt, CPt3->CPt, CPt->CPt3, CPt->CPt, CPt->C++Pt b+| / |+| / |+a CPt++a->b \\ a < CPt, a < b, Pt < b++CPt b+| / |+| / |+a Pt++T < Eq T, S < T, Eq a < Eq b \\ b < a |- x < Eq x+++-}+++++findWG (RConCon i j) (env,_) = findCoercion' env i j+findWG (ROrd _ Pos i) (env,_) = addReflWG (findAbove env i)+findWG (ROrd _ Neg i) (env,_) = addReflWG (findBelow env i)+findWG (RUnif) (env,_) = reflWG+findWG (RInv _ Pos i) (env,_) = concatWG reflWG (findAbove env i)+findWG (RInv _ Neg i) (env,_) = concatWG reflWG (findBelow env i)+findWG (RClass _ i) (env,_) = lookup' (classEnv env) i+++addReflWG wg = WG { nodes = reflAll : nodes wg, + arcs = (repeat (prim Refl) `zip` dom (nodes wg)) ++ arcs wg }+ +shrinkWG wg t = WG { nodes = filter (upperIs t) (nodes wg), arcs = [] }++flattenWG wg = wg { arcs = [] }++reflWG = unitWG (reflAll)++isNullWG wg = null (nodes wg)++takeWG (WG (n:nodes) a) = (n, WG nodes a)+takeWG _ = internalError0 "takeWG: empty node list"++concatWG wg1 wg2 = WG { nodes = nodes wg1 ++ nodes wg2, arcs = [] }++pruneWG w wg = wg { nodes = filter ((`notElem` ws) . fst) (nodes wg) }+ where ws = [ w2 | (w1,w2) <- arcs wg, w1 == w ]++unitWG n = WG { nodes = [n], arcs = [] }++nullWG = WG { nodes = [], arcs = [] }+++++data Dir = Pos | Neg+ deriving (Ord,Eq,Show)++data Rank = RFun -- function type in either position, handle as a predicate scheme+ | RConCon Name Name -- con-con, only one solution possible (or failure!)+ | ROrd Int Dir Name -- con-var, with gravity governed by var's position in target type+ | RUnif -- var-var, unifiable (either safe or forced)+ | RInv Int Dir Name -- con-var, requires unordered search + | RClass Int Name -- class constraint, rank below all subpreds involving a tycon+ | RVar -- var-var sub or var-only class, search not meaningful+ deriving (Ord,Eq,Show)+++unique i [] = Nothing+unique i (g:gs) = case uniqueRank g of+ Just r -> Just (r,i)+ Nothing -> unique (i+1) gs+ where uniqueRank (_,TFun [l] u) = uniqueRank' (tHead l) (tHead u)+ uniqueRank (_,t) = if null (tvars t) then Just (RClass 0 (tId (tHead t))) else Nothing+ uniqueRank' (TFun _ _) (TFun _ _)+ = Just RFun+ uniqueRank' (TFun _ _) _ = Just RUnif+ uniqueRank' _ (TFun _ _) = Just RUnif+ uniqueRank' (TId i) (TId j) = Just (RConCon i j)+ uniqueRank' _ _ = Nothing+++rank info (env,TFun [l] u) = subrank (tFlat l) (tFlat u)+ where + (emb,vs,lb,ub,lb',ub',pvs) = info+ approx = forced env -- solve subtype predicates at all costs+ subrank (TFun _ _,_) (TFun _ _,_) = RFun -- resubmit to predicate scheme reducer+ subrank (TFun _ _, _) _ = RUnif+ subrank _ (TFun _ _, _) = RUnif+ subrank (TId i,_) (TId j,_) = RConCon i j -- only one choice, highest rank+ subrank (TId i,_) (TVar n,_)+ | l==0 && b==0 && not (isNeg v) = ROrd 0 Pos i -- no embeddings, only constant bounds, right polarity+ | approx && n `notElem` vs = ROrd l Pos i -- approximate in right direction if n not in environment+ | otherwise = RInv l Pos i -- otherwise rank below v-v unification (dir only for env lookup)+ where l = length (filter (==n) emb) -- # of embeddings of n+ b = length (filter (==n) lb) -- # of lower var bounds for n+ v = polarity pvs n -- polarity of n in target type+ subrank (TVar n,_) (TId i,_)+ | l==0 && b==0 && not (isPos v) = ROrd 0 Neg i -- no embeddings, only constant bounds, right polarity+ | approx && n `notElem` vs = ROrd l Neg i -- approximate in right direction if n not in environment+ | otherwise = RInv l Neg i -- otherwise rank below v-v unification (dir only for env lookup)+ where l = length (filter (==n) emb) -- # of embeddings of n+ b = length (filter (==n) ub) -- # of upper var bounds for n+ v = polarity pvs n -- polarity of n in target type+ subrank (TVar n,ts) (TVar n',ts')+ | n == n' = RUnif -- identical heads, and we only have invariant constructors+ | l==0 && b==1 && null ts && not (isPos v)+ = RUnif -- no n embeddings, only one bound (here!), no variance problems, set n = upper bound+ | l'==0 && b'==1 && null ts' && not (isNeg v')+ = RUnif -- no n' embeddings, only one bound (here!), no variance problems, set n' = lower bound+ | approx = RUnif -- eliminate var-to-var predicates early when approximating+ | otherwise = RVar -- just leave them be when in conservative mode+ where l = length (filter (==n) emb) -- # of embeddings of n+ b = length (filter (==n) ub') -- # of upper var OR con bounds for n+ v = polarity pvs n -- polarity of n in target type+ l' = length (filter (==n') emb) -- # of embeddings of n'+ b' = length (filter (==n') lb') -- # of lower var OR con bounds for n'+ v' = polarity pvs n' -- polarity of n' in target type+rank info (env,t)+ | all isTVar ts && not (forced env) = RVar -- trivial class predicate, just leave be when not approximating + | otherwise = RClass i c -- non-trivial class predicate, perform witness search+ where (TId c,ts) = tFlat t+ i = lookup' (dom (classEnv env) `zip` [0..]) c+++-- m x < n a b+-- m in fv(env), T i < S i j, S i j < S i j, T i < T i+-- s = [n a/m, b/x]+-- n a c < T t+-- m x < n a b, m x < T t+{-+instance Show ([TVar],[TVar],[TVar],[TVar],[TVar],[TVar],([TVar],[TVar])) where+ show (emb,vs,lb,ub,lb',ub',pols) = "emb = " ++ show emb ++ "\n" +++ "vs = " ++ show vs ++ "\n" +++ "lb = " ++ show lb ++ "\n" +++ "ub = " ++ show ub ++ "\n" +++ "lb' = " ++ show lb' ++ "\n" +++ "ub' = " ++ show ub' ++ "\n" +++ "pols = (" ++ show (fst pols) ++ "," ++ show (snd pols) ++ ")\n"+-}+varInfo gs = (emb, vs, lb, ub, lb', ub', polvs)+ where (sPreds,cPreds) = partition isSub (map snd gs)+ tts = map ((\(t1,t2) -> (tFlat t1, tFlat t2)) . subs) sPreds+ lb = [ n | ((TVar _, _), (TVar n, _)) <- tts ] -- all n with a lower var bound+ ub = [ n | ((TVar n, _), (TVar _, _)) <- tts ] -- all n with an upper var bound+ lb' = [ n | (_, (TVar n, _)) <- tts ] -- all n with any lower bound+ ub' = [ n | ((TVar n, _), _) <- tts ] -- all n with any upper bound+ emb = concat (map (\((_,ts1),(_,ts2)) -> tvars (ts1++ts2)) tts) -- the vars inside type exps+ vs = tevars env -- the vars free in the environment+ polvs = pnub (pols env `pcat` pdupl (vs++tvars cPreds)) -- target vars (positive & negative)+ env = fst (head gs) -- arbitrary choice, but we only use info that must be equal in all gs++++-- Instantiation & generalization ----------------------------------------------------++inst (Scheme t ps ke) = do ts <- mapM newTVar ks+ let s = vs `zip` ts+ return (subst s t, subst s ps)+ where (vs,ks) = unzip ke+++wildify ke pe = do ts <- mapM newTVar ks+ return (subst (vs `zip` ts) pe)+ where (vs,ks) = unzip ke+++saturate (t,ps) e = do pe <- newEnvPos assumptionSym ps e+ return (pe, t, eAp e (map EVar (dom pe)))+++instantiate sc e = do r <- inst sc+ saturate r e+++qual [] e sc = (e, sc)+qual qe e (Scheme t [] ke) = (ELam qe e, Scheme t (rng qe) ke)+qual qe (ELam te e) (Scheme t ps ke)+ = (ELam (qe++te) e, Scheme t (rng qe ++ ps) ke)+qual qe e (Scheme t ps ke) = (ELam (qe++te) (EAp e (map EVar (dom te))), Scheme t (rng qe ++ ps) ke)+ where te = abcSupply `zip` ps+++gen tvs0 sc@(Scheme t ps ke) = do ids <- newNames tyvarSym (length tvs)+ let s = tvs `zip` map TId ids+ ke' = ids `zip` map tvKind tvs + return (Scheme (subst s t) (subst s ps) (ke' ++ ke))+ where tvs = nub (filter (`notElem` tvs0) (tvars t ++ tvars ps))++genL tvs0 scs = do ids <- newNames tyvarSym (length tvs)+ let s = tvs `zip` map TId ids+ ke = ids `zip` map tvKind tvs+ addQuant (Scheme t ps ke') = Scheme t ps (restrict ke (tyvars t) ++ ke')+ return (map addQuant (subst s scs))+ where tvs = nub (filter (`notElem` tvs0) (tvars scs))+++-- Variance ------------------------------------------------------------------++polarity (pvs,nvs) tv = (tv `elem` pvs, tv `elem` nvs)++isPos = fst+isNeg = snd++covariant = (True,False)+contravariant = (False,True)+invariant = (True,True)+nonvariant = (False,False)++pcat (p,n) (p',n') = (p++p', n++n')++pswap (p,n) = (n, p)++pdupl tvs = (tvs,tvs)++pnub (p,n) = (nub p, nub n)+++class Polvars a where+ polvars :: Env -> a -> ([TVar],[TVar])++instance Polvars a => Polvars [a] where+ polvars env [] = ([],[])+ polvars env (x:xs) = pcat (polvars env x) (polvars env xs)++instance Polvars a => Polvars (Name,a) where+ polvars env (_,t) = polvars env t++instance Polvars Type where+ polvars env t = polvars env (tFlat t)+++instance Polvars (Type,[Type]) where+ polvars env (TFun ts t, []) = polvars env t `pcat` pswap (polvars env ts)+ polvars env (TId c, ts) = pdupl (tvars ts)+ where k = findKind env c -- Future work: let the result be determined by variances encoded in k+ polvars env (TVar n, ts) = ([n],[]) `pcat` pdupl (tvars ts)+ +instance Polvars Scheme where+ polvars env (Scheme t ps ke) = polvars env t `pcat` pdupl (tvars ps)++instance Polvars Rho where+ polvars env (R t) = polvars env t+ polvars env (F sc rh) = polvars env rh `pcat` pswap (polvars env sc)++{-+ T a a1 a2 a3 a4 < T a b1 b2 b3 b4 \\ a1<b1, b1<a1, a2<b2, b3<a3+ + If T t t1 t2 t3 t4 < T s s1 s2 s3 s4, where s,s1,s2,s3,s4 can have lower as well as upper bounds, then+ t==s may have upper as well as lower bounds+ t1 has an upper and a lower bound: [t1/a1,s1/b1](a1<b1, b1<a1) = t1<s1, s1<t1+ t2 has an upper bound: [t2/a2,s2/b2](a1<b2) = t2<s2+ t3 has a lower bound: [t3/a3,s3/b3](b3<a3) = s3<t3+ t4 has no bounds: [t4/a4,s4/b4]() = ()+ + If T s s1 s2 s3 s4 < T t t1 t2 t3 t4, where s,s1,s2,s3,s4 can have lower as well as upper bounds, then+ t==s may have lower as well as upper bounds+ t1 has a lower and an upper bound: [s1/a1,t1/t1](a1<b1, b1<a1) = s1<t1, t1<s1+ t2 has a lower bound: [s2/a2,t2/b2](a1<b2) = s2<t2+ t3 has an uooer bound: [s3/a3,t3/b3](b3<a3) = t3<s3+ t4 has no bounds: [s4/a4,t4/b4]() = ()+ + +: a, a1, a2+ -: a, a1, a3+ (T t t1 t2 t3 t4) in + => (t,t1,t2) in +, (t,t1,t3) in -+ (T t t1 t2 t3 t4( in - => (t,t1,t2) in -, (t,t1,t3) in ++ +-}++-- Printing -------------------------------------------------------------------++instance Pr Env where+ pr env = vpr (kindEnv env) $$+ vpr (aboveEnv env) $$+ vpr (belowEnv env) $$+ vpr (classEnv env) $$+ vpr (typeEnv env) ++instance Pr (Name,WGraph) where+ pr (_, WG ns as) = vpr ns $$ nest 4 (vpr as)++instance Pr (Name,Name) where+ pr (n,n') = prId n <+> text "<" <+> prId n'+++-- initEnv --------------------------------------------------------------------++initEnv v = nullEnv { kindEnv0 = primKindEnv,+ typeEnv0 = primTypeEnv,+ aboveEnv = primAboveEnv,+ belowEnv = primBelowEnv,+ classEnv = primClassEnv,+ predEnv0 = primPredEnv,+ modName = Just (str v) }++++primKindEnv = [ (prim Action, Star),+ (prim Request, KFun Star Star),+ (prim Class, KFun Star Star),+ (prim Cmd, KFun Star (KFun Star Star)),+ + (prim Msg, Star),+ (prim Ref, KFun Star Star),+ (prim PID, Star),+ (prim PMC, KFun Star Star),+ (prim Time, Star),+ + (prim Int, Star),+ (prim Float, Star),+ (prim Char, Star),+ (prim Bool, Star),++ (prim Array, KFun Star Star),++ (prim LIST, KFun Star Star),+ (prim EITHER, KFun Star (KFun Star Star)),+ (prim UNITTYPE, Star),+ (prim TIMERTYPE, Star) ]+++primTypeEnv = [ (prim UNITTERM, scheme0 [] tUnit),+ (prim NIL, scheme1 [] (tList a)),+ (prim CONS, scheme1 [a,tList a] (tList a)),++ (prim FALSE, scheme0 [] tBool),+ (prim TRUE, scheme0 [] tBool),+ (prim LEFT, scheme2 [a] (tEither a b)),+ (prim RIGHT, scheme2 [b] (tEither a b)),++ (prim Refl, scheme1 [a] a),++ (prim ActToCmd, scheme1 [tAction] (tCmd a tMsg)),+ (prim ReqToCmd, scheme2 [tRequest a] (tCmd b a)),+ (prim RefToPID, scheme1 [tRef a] tPID),++ (prim IntPlus, scheme0 [tInt,tInt] tInt),+ (prim IntMinus, scheme0 [tInt,tInt] tInt),+ (prim IntTimes, scheme0 [tInt,tInt] tInt),+ (prim IntDiv, scheme0 [tInt,tInt] tInt),+ (prim IntMod, scheme0 [tInt,tInt] tInt),+ (prim IntNeg, scheme0 [tInt] tInt),++ (prim IntEQ, scheme0 [tInt,tInt] tBool),+ (prim IntNE, scheme0 [tInt,tInt] tBool),+ (prim IntLT, scheme0 [tInt,tInt] tBool),+ (prim IntLE, scheme0 [tInt,tInt] tBool),+ (prim IntGE, scheme0 [tInt,tInt] tBool),+ (prim IntGT, scheme0 [tInt,tInt] tBool),++ (prim FloatPlus, scheme0 [tFloat,tFloat] tFloat),+ (prim FloatMinus, scheme0 [tFloat,tFloat] tFloat),+ (prim FloatTimes, scheme0 [tFloat,tFloat] tFloat),+ (prim FloatDiv, scheme0 [tFloat,tFloat] tFloat),+ (prim FloatNeg, scheme0 [tFloat] tFloat),++ (prim FloatEQ, scheme0 [tFloat,tFloat] tBool),+ (prim FloatNE, scheme0 [tFloat,tFloat] tBool),+ (prim FloatLT, scheme0 [tFloat,tFloat] tBool),+ (prim FloatLE, scheme0 [tFloat,tFloat] tBool),+ (prim FloatGE, scheme0 [tFloat,tFloat] tBool),+ (prim FloatGT, scheme0 [tFloat,tFloat] tBool),++ (prim IntToFloat, scheme0 [tInt] tFloat),+ (prim FloatToInt, scheme0 [tFloat] tInt),++ (prim CharToInt, scheme0 [tChar] tInt),+ (prim IntToChar, scheme0 [tInt] tChar),++ (prim BITS8ToInt, scheme0 [tBITS8] tInt),+ (prim BITS16ToInt, scheme0 [tBITS16] tInt),+ (prim BITS32ToInt, scheme0 [tBITS32] tInt),+ + (prim IntToBITS8, scheme0 [tInt] tBITS8),+ (prim IntToBITS16, scheme0 [tInt] tBITS16),+ (prim IntToBITS32, scheme0 [tInt] tBITS32),+ + (prim LazyOr, scheme0 [tBool,tBool] tBool),+ (prim LazyAnd, scheme0 [tBool,tBool] tBool),++ (prim PidEQ, scheme0 [tPID,tPID] tBool),+ (prim PidNE, scheme0 [tPID,tPID] tBool),++ (prim Sec, scheme0 [tInt] tTime),+ (prim Millisec, scheme0 [tInt] tTime),+ (prim Microsec, scheme0 [tInt] tTime),+ (prim Nanosec, scheme0 [tInt] tTime),+ (prim Infinity, scheme0 [] tTime),++ (prim Sqrt, scheme0 [tFloat] tFloat),+ (prim Log, scheme0 [tFloat] tFloat),+ (prim Log10, scheme0 [tFloat] tFloat),+ (prim Exp, scheme0 [tFloat] tFloat),+ (prim Sin, scheme0 [tFloat] tFloat),+ (prim Cos, scheme0 [tFloat] tFloat),+ (prim Tan, scheme0 [tFloat] tFloat),+ (prim Asin, scheme0 [tFloat] tFloat),+ (prim Acos, scheme0 [tFloat] tFloat),+ (prim Atan, scheme0 [tFloat] tFloat),+ (prim Sinh, scheme0 [tFloat] tFloat),+ (prim Cosh, scheme0 [tFloat] tFloat),+ (prim ShowFloat, scheme0 [tFloat] (tList tChar)),+ + (prim TimePlus, scheme0 [tTime,tTime] tTime),+ (prim TimeMinus, scheme0 [tTime,tTime] tTime),+ (prim TimeMin, scheme0 [tTime,tTime] tTime),+ + (prim TimeEQ, scheme0 [tTime,tTime] tBool),+ (prim TimeNE, scheme0 [tTime,tTime] tBool),+ (prim TimeLT, scheme0 [tTime,tTime] tBool),+ (prim TimeLE, scheme0 [tTime,tTime] tBool),+ (prim TimeGE, scheme0 [tTime,tTime] tBool),+ (prim TimeGT, scheme0 [tTime,tTime] tBool),++ (prim Raise, scheme1 [tInt] a), -- temporary+ (prim Catch, scheme0 [] tUnit), -- temporary+ + (prim TIMERTERM, scheme0 [] (tClass tTimer)),+ (prim Reset, Scheme (R (tRequest tUnit)) [Scheme (R tTimer) [] []] []),+ (prim Sample, Scheme (R (tRequest tTime)) [Scheme (R tTimer) [] []] []),+ (prim Sec, scheme0 [tInt] tTime),+ (prim Millisec, scheme0 [tInt] tTime),+ (prim Microsec, scheme0 [tInt] tTime),+ (prim Nanosec, scheme0 [tInt] tTime),+ (prim SecOf, scheme0 [tTime] tInt),+ (prim MicrosecOf, scheme0 [tTime] tInt),+ + (prim NOT8, scheme0 [tBITS8] tBITS8),+ (prim AND8, scheme0 [tBITS8,tBITS8] tBITS8),+ (prim OR8, scheme0 [tBITS8,tBITS8] tBITS8),+ (prim EXOR8, scheme0 [tBITS8,tBITS8] tBITS8),+ (prim SHIFTL8, scheme0 [tBITS8,tInt] tBITS8),+ (prim SHIFTR8, scheme0 [tBITS8,tInt] tBITS8),+ (prim SHIFTRA8, scheme0 [tBITS8,tInt] tBITS8),+ (prim SET8, scheme0 [tBITS8,tInt] tBITS8),+ (prim CLR8, scheme0 [tBITS8,tInt] tBITS8),+ (prim TST8, scheme0 [tBITS8,tInt] tBool),+ + (prim NOT16, scheme0 [tBITS16] tBITS16),+ (prim AND16, scheme0 [tBITS16,tBITS16] tBITS16),+ (prim OR16, scheme0 [tBITS16,tBITS16] tBITS16),+ (prim EXOR16, scheme0 [tBITS16,tBITS16] tBITS16),+ (prim SHIFTL16, scheme0 [tBITS16,tInt] tBITS16),+ (prim SHIFTR16, scheme0 [tBITS16,tInt] tBITS16),+ (prim SHIFTRA16, scheme0 [tBITS16,tInt] tBITS16),+ (prim SET16, scheme0 [tBITS16,tInt] tBITS16),+ (prim CLR16, scheme0 [tBITS16,tInt] tBITS16),+ (prim TST16, scheme0 [tBITS16,tInt] tBool),+ + (prim NOT32, scheme0 [tBITS32] tBITS32),+ (prim AND32, scheme0 [tBITS32,tBITS32] tBITS32),+ (prim OR32, scheme0 [tBITS32,tBITS32] tBITS32),+ (prim EXOR32, scheme0 [tBITS32,tBITS32] tBITS32),+ (prim SHIFTL32, scheme0 [tBITS32,tInt] tBITS32),+ (prim SHIFTR32, scheme0 [tBITS32,tInt] tBITS32),+ (prim SHIFTRA32, scheme0 [tBITS32,tInt] tBITS32),+ (prim SET32, scheme0 [tBITS32,tInt] tBITS32),+ (prim CLR32, scheme0 [tBITS32,tInt] tBITS32),+ (prim TST32, scheme0 [tBITS32,tInt] tBool),+ + (prim ListArray, scheme1 [tList a] (tArray a)),+ (prim UniArray, scheme1 [tInt, a] (tArray a)),+ (prim SizeArray, scheme1 [tArray a] tInt),+ (prim IndexArray, scheme1 [tArray a, tInt] a),+ (prim UpdateArray, scheme1 [tArray a, tInt, a] (tArray a)),++ (prim Abort, scheme1 [tMsg] (tCmd a tUnit)),++ (prim Fail, scheme1 [] (tPMC a)),+ (prim Commit, scheme1 [a] (tPMC a)),+ (prim Match, scheme1 [tPMC a] a),+ (prim Fatbar, scheme1 [tPMC a, tPMC a] (tPMC a)),++ (prim After, scheme0 [tTime,tAction] tAction),+ (prim Before, scheme0 [tTime,tAction] tAction),++ (prim New, scheme1 [tClass a] a)+ + ]++primTypeEnv1 = (prim Inherit, scheme0 [] tTime) : primTypeEnv++tAction = TId (prim Action)+tRequest a = TAp (TId (prim Request)) a+tClass a = TAp (TId (prim Class)) a+tCmd a b = TAp (TAp (TId (prim Cmd)) a) b+tTime = TId (prim Time)+tMsg = TId (prim Msg)+tRef a = TAp (TId (prim Ref)) a+tPID = TId (prim PID)+tPMC a = TAp (TId (prim PMC)) a+tInt = TId (prim Int)+tFloat = TId (prim Float)+tChar = TId (prim Char)+tBool = TId (prim Bool)+tArray a = TAp (TId (prim Array)) a+tList a = TAp (TId (prim LIST)) a+tUnit = TId (prim UNITTYPE)+tEither a b = TAp (TAp (TId (prim EITHER)) a) b+tTimer = TId (prim TIMERTYPE)+tBITS8 = TId (prim BITS8)+tBITS16 = TId (prim BITS16)+tBITS32 = TId (prim BITS32)+ +a = TId (name0 "a")+b = TId (name0 "b")+ +scheme0 ts t = Scheme (mkRho ts t) [] []+scheme1 ts t = Scheme (mkRho ts t) [] [(name0 "a",Star)]+scheme2 ts t = Scheme (mkRho ts t) [] [(name0 "a",Star),(name0 "b",Star)]++mkRho [] t = R t+mkRho ts t = F (map scheme ts) (R t)++primAboveEnv = [ (prim Action, unitWG subActCmd),+ (prim Request, unitWG subReqCmd),+ (prim Cmd, nullWG),+ (prim Ref, unitWG subRefPID),+ (prim PID, nullWG)+ ]++primBelowEnv = [ (prim Action, nullWG),+ (prim Request, nullWG),+ (prim Class, nullWG),+ (prim Cmd, WG [subActCmd,subReqCmd] []),+ (prim Ref, nullWG),+ (prim PID, unitWG subRefPID)+ ]+++reflAll = (prim Refl, scheme1 [] (a `sub` a))++subActCmd = (prim ActToCmd, scheme1 [] (tAction `sub` tCmd a tMsg))++subReqCmd = (prim ReqToCmd, scheme2 [] (tRequest a `sub` tCmd b a))++subRefPID = (prim RefToPID, scheme1 [] (tRef a `sub` tPID))+++primPredEnv = [reflAll, subActCmd, subReqCmd, subRefPID]+++primClassEnv = []
+ src/Execution.hs view
@@ -0,0 +1,119 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++--------------------------------------------------------------------------+--+-- Execution control.+--+-- This module contains an interface to the backend and functions to+-- control the execution of the compiler. +--+---------------------------------------------------------------------------++module Execution (+ abortCompiler,+ stopCompiler,+ compileC,+ linkO,+ ) where+ +import System (system, exitWith, ExitCode(..))+import qualified Monad+import qualified Directory+import Common++-- Timber compiler+import Config+import Name+++-- | Compile a C-file. +compileC cfg clo c_file = do+ let cmd = cCompiler cfg+ ++ " -c " ++ compileFlags cfg+ ++ " -I " ++ libDir clo ++ " " + ++ " -I " ++ includeDir clo ++ " " + ++ " -I " ++ rtsDir clo ++ " " + ++ " -I . "+ ++ c_file+ o_file = rmSuffix ".c" (rmDirs c_file) ++ ".o"+ res <- checkUpToDate c_file o_file+ if not res then do+ putStrLn ("[compiling "++c_file++"]")+ execCmd clo cmd+ else return ()+ where checkUpToDate c_file o_file+ = do o_exists <- Directory.doesFileExist o_file+ if not o_exists then+ return False+ else do+ c_time <- Directory.getModificationTime c_file+ o_time <- Directory.getModificationTime o_file+ return (c_time <= o_time)++-- | Link together a bunch of object files.+linkO cfg clo r o_files = do let Just rmod = fromMod r+ rootId = name2str r+ initId = "_init_" ++ map f rmod+ f '\'' = '_'+ f c = c+ let cmd = cCompiler cfg+ ++ linkFlags cfg+ ++ compileFlags cfg+ ++ " -o " ++ outfile clo ++ " "+ ++ unwords o_files ++ " "+ ++ " -L" ++ rtsDir clo ++ " " + ++ " -I" ++ includeDir clo ++ " " + ++ " -I" ++ libDir clo ++ " " + ++ " -I " ++ rtsDir clo ++ " " + ++ " -DROOT=" ++ rootId ++ " "+ ++ " -DROOTINIT=" ++ initId ++ " "+ ++ rtsMain clo + ++ " -lTimber"+ putStrLn "[linking]"+ execCmd clo cmd+++-- | Return with exit code /= 0+abortCompiler = exitWith (ExitFailure 1)++-- | Return with exit code == 0+stopCompiler = exitWith (ExitSuccess)++execCmd clo cmd = do Monad.when (isVerbose clo)+ (putStrLn ("exec: " ++ show cmd))+ exitCode <- system $ cmd + case exitCode of+ ExitSuccess -> return ()+ _ -> stopCompiler+
+ src/Fixity.hs view
@@ -0,0 +1,110 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Fixity where++import Common+import Syntax+import List(sort)++type Precedence = Int+data Associativity = LeftAss | RightAss | NonAss deriving (Eq,Show)++data Fixity = Fixity Associativity Precedence deriving (Eq,Show)++data OpExp = Nil Exp | Cons OpExp Name Exp ++fixity :: String -> Fixity+fixity op = case lookup op fixTable of+ Just f -> f+ Nothing -> fixFromChars op+ where fixTable = [(":", Fixity RightAss 5),+ ("++", Fixity RightAss 5),+ ("+", Fixity LeftAss 6),+ ("-", Fixity LeftAss 6),+ ("*", Fixity LeftAss 7),+ ("/", Fixity LeftAss 7),+ ("div",Fixity LeftAss 7),+ ("mod",Fixity LeftAss 7),+ ("@", Fixity RightAss 9),+ ("^", Fixity RightAss 8),+ ("==", Fixity NonAss 4),+ ("/=", Fixity NonAss 4),+ ("<", Fixity NonAss 4),+ ("<=", Fixity NonAss 4),+ (">", Fixity NonAss 4),+ (">=", Fixity NonAss 4),+ ("&&", Fixity RightAss 3),+ ("||", Fixity RightAss 2),+ (">>", Fixity LeftAss 1),+ (">>=",Fixity LeftAss 1),+ ("$", Fixity RightAss 0)+ ]+ fixFromChars op = case sort (nub (intersect op "+-*/<>")) of+ "+" -> Fixity LeftAss 6+ "-" -> Fixity LeftAss 6+ "+-" -> Fixity LeftAss 6+ "*" -> Fixity LeftAss 7+ "/" -> Fixity LeftAss 7+ "*/" -> Fixity LeftAss 7+ "<" -> Fixity NonAss 4+ ">" -> Fixity NonAss 4+ "<>" -> Fixity NonAss 4+ _ -> Fixity LeftAss 9++{-+Transforms a tree of infix expressions as produced by the parser +(i.e., with all operators treated as left associative and of equal precedence) +to a new tree reflecting operator associativity and precedence as given by+the function fixity.++Invariant: at each call to push, the second and third arguments have+the same length.+-}++transFix :: OpExp -> Exp+transFix e = push e [] []+ where push (Cons l o r) (o':os) es+ | prec==prec' && (ass/=ass' || ass==NonAss)+ = errorIds "Operator associativity ambiguity with operators" [o,o']+ | prec<prec' || (prec==prec' && ass==RightAss)+ = push (Cons l o (opApp r o' (head es))) os (tail es)+ where Fixity ass prec = fixity (show o)+ Fixity ass' prec' = fixity (show o')+ push (Cons l o r) os es = push l (o:os) (r:es)+ push (Nil e) os es = popAll os (e:es)+ opApp l o r = EAp (EAp (op2exp o) l) r+ + popAll (o:os) (e1:e2:es) = popAll os (opApp e1 o e2:es)+ popAll [] es = head es+
+ src/Interfaces.hs view
@@ -0,0 +1,270 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Interfaces where++import Common+import List (isPrefixOf)+import Data.Binary+import Rename +import Core+import qualified Syntax+import Decls+import PP+import qualified Core2Kindle +import qualified Kindle +import Termred+import qualified Config+import System+import Codec.Compression.BZip +import qualified Data.ByteString.Lazy+import Directory++decodeCFile ti_file = do str <- Data.ByteString.Lazy.readFile ti_file+ return(decode(decompress str)) ++encodeCFile ti_file ifc = Data.ByteString.Lazy.writeFile ti_file (compress(encode ifc))++{-+Reading/writing ti files without compression.++decodeCFile ti_file = decodeFile ti_file++encodeCFile ti_file ifc = encodeFile ti_file ifc+-}++-- Data type of interface file -----------------------------------------------++data IFace = IFace { impsOf :: [(Bool,Name)], -- imported/used modules+ defaults :: [Default Scheme], -- exported default declarations+ recordEnv :: Map Name [Name], -- exported record types and their selectors,+ tsynEnv :: Map Name ([Name],Syntax.Type), -- type synonyms+ tEnv :: Types, -- Core type environment+ insts :: [Name], -- types for instances+ valEnv :: Binds, -- types for exported values (including sels and cons) and some finite eqns+ kdeclEnv :: Kindle.Decls -- Kindle form of declarations+ }+ deriving (Show)++-- Building interface info from data collected during compilation of a module ---------------------------------+{-+Input to ifaceMod is+ - from Desugar1: exported record types with their selectors and exported type synomyms.+ - from Termred: the entire module in Core form after term reduction+ - from Core2Kindle: declarations in Kindle form.+The function checks that the public part is closed (does not mention private data) and computes+the IFace.+-}+ +ifaceMod :: (Map Name [Name], Map Name ([Name], Syntax.Type)) -> Module -> Kindle.Decls -> IFace+ifaceMod (rs,ss) (Module _ ns xs ds ws bss) kds+ | not(null vis) = errorIds "Private types visible in interface" vis+ | not(null ys) = errorTree "Public default declaration mentions private instance" (head ys)+ | otherwise = IFace ns xs' rs ss ds1 ws bs' kds+ where Types ke te = ds+ Binds r2 ts2 es2 = concatBinds bss+ xs' = [d | d@(Default True _ _) <- xs]+ ys = [d | d@(Default _ i1 i2) <- xs', isPrivate i1 || isPrivate i2 ]+ ds1 = Types (filter exported ke) (filter exported' te)+ bs' = Binds r2 (filter exported ts2) (filter (\ eqn -> fin eqn && exported eqn) (erase es2))+ vis = nub (localTypes [] (rng (tsigsOf bs')))+ exported (n,_) = isQualified n+ exported' p@(n,_) = isQualified n && (not(isAbstract p)) --Constructors/selectors are exported+ fin (_,e) = isFinite e && null(filter isPrivate (constrs e))++isPrivate nm@(Name _ _ _ _) = not(isQualified nm)+isPrivate _ = False++isAbstract (_,DData _ _ ((c,_):_)) = isPrivate c+isAbstract (_,DRec _ _ _ ((c,_):_)) = isPrivate c+isAbstract (_,_) = False -- this makes abstract types without selectors/constructors non-private...++++-- Building environments in which to compile the current module -----------------------------------------------+{- + Input to initEnvs is a map as built by chaseIFaceFiles;+ output is four tuples of data suitable for various compiler passes.+-}+type ImportInfo a = (Bool, a)+++type Desugar1Env = (Map Name [Name], Map Name Name, Map Name ([Name], Syntax.Type))+type RenameEnv = (Map Name Name, Map Name Name, Map Name Name)+type CheckEnv = ([Default Scheme], Types, [Name], Binds)+type KindleEnv = Map Name Kindle.Decl++initEnvs :: Map a (ImportInfo IFace) -> M s (Desugar1Env, RenameEnv, CheckEnv, KindleEnv)+initEnvs bms = do ims <- mapM (mkEnv . snd) bms+ let (rs,xs,ss,rnL,rnT,rnE,ds,ws,bs,kds) + = foldr mergeMod ([],[],[],[],[],[],Types [] [],[],Binds False [] [],[]) ims+ return ((rs,rnL,ss),(rnL,rnT,rnE),(xs,ds,ws,bs),kds)++ where mergeMod (rs1,xs1,ss1,rnL1,rnT1,rnE1,ds1,ws1,bs1,kds1)+ (rs2,xs2,ss2,rnL2,rnT2,rnE2,ds2,ws2,bs2,kds2) + = (rs1 ++ rs2, xs1 ++ xs2, ss1 ++ ss2, mergeRenamings2 rnL1 rnL2, + mergeRenamings2 rnT1 rnT2, mergeRenamings2 rnE1 rnE2,+ catDecls ds1 ds2, ws1++ws2, catBinds bs1 bs2,+ kds1 ++ kds2)++ mkEnv (unQual,IFace ns xs rs ss ds ws bs kds)+ = do ks <- renaming (dom ke)+ ts <- renaming (dom te'')+ ls' <- renaming ls -- (concatMap snd rs)+ return (unMod unQual rs, xs, unMod unQual ss, unMod unQual ls',unMod unQual ks,+ unMod unQual ts,ds,ws,Binds r te' es,kds)+ where Types ke ds' = ds+ Binds r te es = bs+ te' = te ++ concatMap (tenvSelCon ke) ds'+ te'' = te ++ concatMap (tenvCon ke) ds'+ ls = [ s | (_,DRec _ _ _ cs) <- ds', (s,_) <- cs, not (isGenerated s) ]+ unMod b ps = if b then [(tag0 (dropMod c),y) | (c,y) <- ps] ++ ps else ps++-- Checking that public part is closed ---------------------------------------------------------++class LocalTypes a where + localTypes :: [Name] -> a -> [Name]++instance LocalTypes a => LocalTypes [a] where+ localTypes ns ds = concatMap (localTypes ns) ds++instance LocalTypes b => LocalTypes (a,b) where+ localTypes ns (a,b) = localTypes ns b++instance LocalTypes Scheme where+ localTypes ns (Scheme r ps ke) = localTypes ns1 r ++ localTypes ns1 ps+ where ns1 = ns ++ dom ke++instance LocalTypes Rho where+ localTypes ns (R t) = localTypes ns t+ localTypes ns (F ss r) = localTypes ns ss ++ localTypes ns r++instance LocalTypes Type where+ localTypes ns (TId n) + | n `elem` ns || not (isPrivate n) = []+ | otherwise = [n]+ localTypes _ (TVar t) = internalError0 ("ChaseImports.localTypes: TVar in interface file")+ localTypes ns (TFun ts t) = localTypes ns (t : ts)+ localTypes ns (TAp t1 t2) = localTypes ns [t1, t2]++instance LocalTypes Decl where+ localTypes ns (DData vs ps cs) = localTypes ns1 ps ++ localTypes ns1 cs+ where ns1 = ns ++ vs+ localTypes ns (DRec _ vs ps ss) = localTypes ns1 ps ++ localTypes ns1 ss+ where ns1 = ns ++ vs+ localTypes ns (DType vs t) = localTypes (ns ++ vs) t++instance LocalTypes Constr where+ localTypes ns (Constr ts ps ke) = localTypes ns1 ts ++ localTypes ns1 ps+ where ns1 = ns ++ dom ke+ +-- Binary -------------------------------------------------------------------------------++instance Binary IFace where+ put (IFace a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> + get >>= \g -> get >>= \h -> return (IFace a b c d e f g h)++-- Printing -----------------------------------------------------------------------------++instance Pr IFace where+ pr (IFace ns xs rs ss ds1 ws bs kds) =+ text "Imported/used modules: " <+> prImports ns $$+ text "Default declarations: " <+> hpr ',' xs $$+ text ("Record types and their selectors: "++show rs) $$+ text "Type synonyms: " <+> hsep (map (prId . fst) ss) $$ + text "\nType definitions\n----------------" $$ pr ds1 $$ + text "\nTop level bindings\n------------------" $$ pr (simpVars bs) $$+ text "\nKindle declarations\n-------------------" $$ vcat (map pr kds)+ +-- prPair (n,t) = prId n <+> text "::" <+> pr t+ where simpVars (Binds rec te eqns) = Binds rec (map sV te) eqns+ +sV (n,t@(Scheme rh ps ke)) = case zip (filter isGenerated (idents (Scheme rh ps []))) abcSupply of+ [] -> (n,t)+ s -> (n,subst s t) ++listIface clo f = do (ifc,f) <- decodeModule clo f+ --writeAPI f ifc+ let modul = rmSuffix ".ti" f+ htmlfile = modul++".html"+ res <- checkUpToDate f htmlfile+ if not res then do+ writeAPI modul ifc+ system (Config.pager clo ++" " ++ htmlfile)+ else system (Config.pager clo ++" " ++ htmlfile)+ where checkUpToDate tiFile htmlFile = do html_exists <- Directory.doesFileExist htmlFile+ if not html_exists then+ return False+ else do+ ti_time <- Directory.getModificationTime tiFile+ html_time <- Directory.getModificationTime htmlFile+ return (ti_time <= html_time)+++writeAPI modul ifc = writeFile (modul ++ ".html") (render(toHTML modul (ifc :: IFace)))++toHTML n (IFace ns xs rs ss ds ws bs _) = text "<html><body>\n" $$+ text ("<h2>API for module "++n++"</h2>\n") $$+ section ns "Imported modules" prImports $$+ section xs "Default declarations" (hpr ',') $$+ section ke' "Kind declarations" (pr . flip Types []) $$+ section ds' "Type declarations" (pr . Types [] . map addSubs) $$+ section te' "Toplevel declarations" (prTop . stripTopdecls) $$+ text "</html>"+ + where section xs header f = if null xs + then empty + else text ("<h4>"++header++"</h4>\n<pre>") $$ f xs $$ text "</pre>"+ + Types ke ds' = ds+ ke' = [(n,k) | (n,k) <- ke, notElem n (dom ds')]+ Binds _ te _ = bs+ addSubs (n,DData vs _ cs) = (n,DData vs (map (\(_,Constr (s:_) _ _) -> s) cs1) cs2)+ where (cs1,cs2) = partition (isGenerated . fst) cs+ addSubs (n,DRec b vs _ ss) = (n,DRec b vs (map snd ss1) ss2)+ where (ss1, ss2) = partition (isGenerated . fst) (map stripStar ss)+ addSubs d = d+ stripStar (n,Scheme rh ps ke) = (n,Scheme rh ps (filter (( /= Star) . snd) ke))+ te' = map (sV . stripStar) (filter (not . isGenerated . fst) te)+ stripTopdecls te = bs1 ++ bs2+ where (bs1,bs2) = partition (flip elem ws . fst ) te+ + +decodeModule clo f = (do ifc <- decodeCFile f+ putStrLn ("[reading " ++ show f ++ "]")+ return (ifc,f)) `catch` (\e -> do let libf = Config.libDir clo ++ "/" ++ f+ ifc <- decodeCFile libf+ putStrLn ("[reading " ++ show libf ++ "]")+ return (ifc,libf))+
+ src/Kind.hs view
@@ -0,0 +1,231 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Kind where++import PP+import Common+import Core+import Env+import Derive+import Depend+import Monad++kindcheck m = kiModule m++kiModule (_,ds',_,bs') (Module v ns xs ds ws bss)+ = do ds <- kiDeclsList env (groupTypes ds)+ (bss',xs1) <- derive (concatMap bvars bss ++ bvars bs') (ds' `catDecls` ds) xs+ let env' = addKEnv0 (ksigsOf ds) env+ bss <- mapM (kiBinds env') (bss++bss')+ return (Module v ns xs1 ds (ws++dom(concatMap tsigsOf bss')) bss)+ where env = addKEnv0 (ksigsOf ds') (initEnv v)+++-- Kind unification ------------------------------------------------------------++type KSubst = Map Int Kind++type KEqs = [(Kind,Kind)]++kunify :: KEqs -> M s KSubst+kunify [] = return nullSubst+kunify ((Star,Star):cs) = kunify cs+kunify ((KVar n,k):cs) = kvarBind n k cs+kunify ((k,KVar n):cs) = kvarBind n k cs+kunify ((KFun k1 k2,KFun k1' k2'):cs) = kunify ((k1,k1'):(k2,k2'):cs)+kunify ((k1,k2):eqs) = fail ("Kinds do not unify: " ++ render (pr k1 <+> text "and" <+> pr k2))++kvarBind n k cs+ | k == KVar n = kunify cs+ | n `elem` kvars k = fail "Infinite kind inferred"+ | otherwise = do s' <- kunify (subst s cs)+ return (s' @@ s)+ where s = n +-> k+++kindUnify cs = do s <- kunify cs+ return (freeVars s `zip` repeat Star @@ s)+ where freeVars s = nub (concat (map kvars (rng s)))+++kiRho env (R t) = kiType env t+kiRho env (F scs t) = do css <- mapM (kiScheme env) scs+ cs <- kiRho env t+ return (concat css ++ cs)++kiType env t = do (cs,k) <- kiTExp env t+ return ((k,Star) : cs)++kiType' env t = do cs <- kiType env t+ s <- kunify cs+ return (subst s t)++kiTExp env (TFun ts t) = do css <- mapM (kiType env) ts+ cs <- kiType env t+ return (cs ++ concat css, Star)+kiTExp env (TId c) = return ([], findKind env c)+kiTExp env (TVar n) = return ([], tvKind n)+kiTExp env (TAp t t') = do (cs,k) <- kiTExp env t+ (cs',k') <- kiTExp env t'+ kv <- newKVar+ return ((k,KFun k' kv):cs++cs', kv)++-- Handle type declarations ----------------------------------------------------++kiDeclsList env [] = return nullDecls+kiDeclsList env (ds:dss) = do ds1 <- kiDecls env ds+ ds2 <- kiDeclsList (addKEnv0 (ksigsOf ds) env) dss+ return (catDecls ds1 ds2)+++kiDecls env t@(Types ke ds) = do css <- mapM (kiDecl (addKEnv0 ke env)) ds+ s <- kindUnify (concat css) `handle` \m -> errorTree m t+ return (Types (subst s ke) (subst s ds))+++newTScope env vs = do ks <- mapM (const newKVar) vs+ return (addKEnv (vs `zip`ks) env)+++kiDecl env (i, DData vs bs ks) = do env' <- newTScope env vs+ cs <- kiType env' (tAp' i vs)+ css1 <- mapM (kiScheme env') bs+ css2 <- mapM (kiConstr env' . snd) ks+ return (cs ++ concat (css1 ++ css2))+kiDecl env (i, DRec _ vs bs ss) = do env' <- newTScope env vs+ cs <- kiType env' (tAp' i vs)+ css1 <- mapM (kiScheme env') bs+ css2 <- mapM (kiScheme env' . snd) ss+ return (cs ++ concat (css1 ++ css2))+kiDecl env (i, DType vs t) = do env' <- newTScope env vs+ (cs1,k1) <- kiTExp env' (tAp' i vs)+ (cs2,k2) <- kiTExp env' t+ return ((k1,k2) : cs1 ++ cs2)+++kiConstr env (Constr ts ps ke) = do css1 <- mapM (kiScheme env') ts+ css2 <- mapM (kiScheme env') ps+ return (concat (css1 ++ css2))+ where env' = addKEnv ke env+++kiScheme env (Scheme t ps ke) = do cs <- kiRho env' t+ css <- mapM (kiScheme env') ps+ return (cs ++ concat css)+ where env' = addKEnv ke env+++kiTEnv env te = do css <- mapM (kiScheme env . snd) te+ s <- kindUnify (concat css) `handle` \m -> errorTree m te+ return (subst s te)++kiMaybeScheme env Nothing = return []+kiMaybeScheme env (Just t) = kiScheme env t+++-- Handle bindings -------------------------------------------------------------++kiBinds env (Binds r te es) = do te <- kiTEnv env te+ es <- mapM (kiEqn env) es+ return (Binds r te es)+++-- Traverse expressions --------------------------------------------------------+++kiExp env (ELam te e) = do te <- kiTEnv env te+ e <- kiExp env e+ return (ELam te e)+kiExp env (EAp e es) = do e <- kiExp env e+ es <- mapM (kiExp env) es+ return (EAp e es)+kiExp env (ELet bs e) = do bs <- kiBinds env bs+ e <- kiExp env e+ return (ELet bs e)+kiExp env (ERec c es) = do es <- mapM (kiEqn env) es+ return (ERec c es)+kiExp env (ECase e alts) = do e <- kiExp env e+ alts <- mapM (kiAlt env) alts+ return (ECase e alts)+kiExp env (EAct e e') = do e <- kiExp env e+ e' <- kiExp env e'+ return (EAct e e')+kiExp env (EReq e e') = do e <- kiExp env e+ e' <- kiExp env e'+ return (EReq e e')+kiExp env (ETempl x t te c) = do t <- kiType' env t+ te <- kiTEnv env te+ c <- kiCmd env c+ return (ETempl x t te c)+kiExp env (EDo x t c) = do t <- kiType' env t+ c <- kiCmd env c+ return (EDo x t c)+kiExp env e = return e+++kiAlt env (p,e) = do e <- kiExp env e+ return (p,e)+++kiEqn env (v,e) = do e <- kiExp env e+ return (v,e)++++-- Traverse commands -----------------------------------------------------------++kiCmd env (CAss x e c) = do e <- kiExp env e+ c <- kiCmd env c+ return (CAss x e c)+kiCmd env (CGen x t e c) = do cs <- kiType env t+ s <- kindUnify cs `handle` \m -> errorTree m t+ e <- kiExp env e+ c <- kiCmd env c+ return (CGen x (subst s t) e c)+kiCmd env (CLet bs c) = do bs <- kiBinds env bs+ c <- kiCmd env c+ return (CLet bs c)+kiCmd env (CRet e) = do e <- kiExp env e+ return (CRet e)+kiCmd env (CExp e) = do e <- kiExp env e+ return (CExp e)+++-- Compute kind of general type expression -------------------------------------++kindOfType env (TFun _ _) = Star+kindOfType env (TVar n) = tvKind n+kindOfType env (TId c) = findKind env c+kindOfType env (TAp t t') = k+ where KFun k' k = kindOfType env t
+ src/Kindle.hs view
@@ -0,0 +1,776 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Kindle where++import Monad+import Common+import PP+import qualified Core+import qualified Env+import Data.Binary+import Control.Monad.Identity++-- Kindle is the main back-end intermediate language. It is a typed imperative language with dynamic +-- memory allocation and garbage-collection, that can be described as a slightly extended version of+-- the common subset of C, Java and C++. The purpose of Kindle is to function as a high-level back-+-- end program format that can be translated into standard imperative languages as well as assembly+-- code without too much difficulty. None of C's pointer arithmetic features are present, neither+-- are the class hieracrhies of Java and C++. The type system of Kindle is a miniature variant of+-- System F, but unsafe type-casts are supported. The main extension compared to Java is nested+-- recursive functions. Heap-allocated struct objects may contain function-valued components which+-- are invoked using self-application. This provides a form of basic OO capability that may serve+-- as a target for a closure conversion pass. For more details on the relation between Kindle and+-- the primary intermediate language Core, see module Core2Kindle.+++-- A Kindle module consists of type declarations and term bindings. A type declaration introduces+-- a struct type, and optionally also an enumeration of type names. A binding defines either a named +-- function or a named value of atomic type. Function bindings are immutable. All type declarations +-- are mutually recursive, and so are binding groups.+data Module = Module Name [Name] Decls Binds+ deriving (Eq,Show)++-- A type declaration introduces a struct type that defines the layout of heap-allocated objects.+-- A struct type may bind type parameters and may contain both value and function fields. Each +-- struct introduces a private namespace for its field names. A struct can also be declared an+-- extension of another struct, as indicated by the Link parameter. If a struct is an extension,+-- a prefix of its field names and their types must match the definition of the extended struct+-- exactly. If a struct is not an extension, it must either be an ordinary Top of an extension +-- hierarchy, or a Union - the latter form supporting case analysis between different extensions +-- by means of the switch command.+type Decls = Map Name Decl++data Decl = Struct [Name] TEnv Link+ deriving (Eq,Show)++data Link = Top+ | Union+ | Extends Name+ deriving (Eq,Show)++-- A term binding is either a named value of atomic type or a named function. A named function can+-- bind type parameters, thus introducing polymorphism in the style of System F. The result and +-- parameter types of a function are in the scope of the defined type parameters and must all be +-- atomic.+type Binds = Map Name Bind++data Bind = Val AType Exp+ | Fun [Name] AType ATEnv Cmd+ deriving (Eq,Show)+++-- The type of a binding is either just an atomic type in case of a value binding, or a triple +-- consisting of abstracted type parameters, the argument types, and the result type in the +-- function binding case.+type TEnv = Map Name Type++data Type = ValT AType+ | FunT [Name] [AType] AType+ deriving (Eq,Show)+++-- An atomic type is either a named constructor or a type variable, both possibly applied to+-- further atomic type arguments.+type ATEnv = Map Name AType++data AType = TCon Name [AType]+ | TVar Name [AType]+ deriving (Eq,Show)+++-- A function body is a command that computes the desired result, possibly while performing imperative+-- side-effects. The current type system does not distinguish pure functions from side-effecting ones,+-- although that separation will indeed be maintained by the translation from type-checked Core programs.+data Cmd = CRet Exp -- simply return $1+ | CRun Exp Cmd -- evaluate $1 for its side-effects only, then execure tail $2+ | CBind Bool Binds Cmd -- introduce (recursive? $1) local bindings $2, then execute tail $3+ | CUpd Name Exp Cmd -- overwrite value variable $1 with value $2, execute tail $3+ | CUpdS Exp Name Exp Cmd -- overwrite value field $2 of struct $1 with value $3, execute tail $4+ | CUpdA Exp Exp Exp Cmd -- overwrite index $2 of array $1 with value $3, execute tail $4+ | CSwitch Exp [Alt] -- depending on the dynamic value of $1, choose tails from $2+ | CSeq Cmd Cmd -- execute $1; if fall-through, continue with $2+ | CBreak -- break out of a surrounding switch+ | CRaise Exp -- raise an exception+ | CWhile Exp Cmd Cmd -- run $2 while $1 is non-zero, then execute tail $3+ | CCont -- start next turn of enclosing while loop+ deriving (Eq,Show)++-- Note 1: command (CRun e c) is identical to (CBind False [(x,e)] c) if x is a fresh name not used anywhere else+-- Note 2: the Cmd alternatives CSeq and CBreak are intended to implement the Fatbar and Fail primitives +-- of the pattern-matching datatype PMC used in Core.++data Alt = ACon Name [Name] ATEnv Cmd -- if switch value has struct type variant $1, execute tail $4 with+ -- $3 bound to the actual struct fields and $2 bound to the struct+ -- type arguments not statically known+ | ALit Lit Cmd -- if switch value matches literal $1, execute tail $2 + | AWild Cmd -- execute tail $1 as default alternative+ deriving (Eq,Show)++-- Simple expressions that can be RH sides of value definitions as well as function arguments.+data Exp = EVar Name -- local or global value name, enum constructor or function parameter+ | EThis -- the implicit first parameter of a function-valued struct field+ | ELit Lit -- literal+ | ESel Exp Name -- selection of value field $2 from struct $1+ | ENew Name [AType] Binds -- a new struct of type $1 with args $2, (partially) initialized by $3+ | ECall Name [AType] [Exp] -- calling local or global function $1 with type/term arguments $2/$3+ | EEnter Exp Name [AType] [Exp] -- entering function $2 of struct $1 with type/term arguments $3/($1:$4)+ | ECast AType Exp -- unchecked cast of value $2 to type $1+ deriving (Eq,Show)++-- Note: Kindle allows free variables to occur inside local functions and function-valued struct fields. A+-- Kindle implementation must either handle this correctly at run-time, or such variable occurrences must be +-- transformed away at compile-time. The latter can be done using lambda-lifting for local functions and+-- explicitly closing the struct functions via extra value fields accessed through "this".++tId x = tCon (prim x)++tCon n = TCon n []+tVar n = TVar n []++tPOLY = tId POLY++tTime = tId Time+tMsg = tId Msg+tPID = tId PID+tUNIT = tId UNITTYPE+tInt = tId Int+tFloat = tId Float+tChar = tId Char+tBool = tId Bool+tBITS8 = tId BITS8+tBITS16 = tId BITS16+tBITS32 = tId BITS32+tTimer = tId TIMERTYPE++tRef a = TCon (prim Ref) [a]+tLIST a = TCon (prim LIST) [a]+tArray a = TCon (prim Array) [a]++litType (LInt _ _) = tInt+litType (LRat _ _) = tFloat+litType (LChr _ _) = tChar+litType (LStr _ _) = tLIST tChar --internalError0 "Kindle.litType LStr"++a = name0 "a"+b = name0 "b"+ta = TVar a []+tb = TVar b []+ +primDecls = (prim Bool, Struct [] [] Union) :+ (prim FALSE, Struct [] [] (Extends (prim Bool))) :+ (prim TRUE, Struct [] [] (Extends (prim Bool))) :+ (prim UNITTYPE, Struct [] [] Union) :+ (prim UNITTERM, Struct [] [] (Extends (prim UNITTYPE))) :+ (prim LIST, Struct [a] [] Union) :+ (prim NIL, Struct [a] [] (Extends (prim LIST))) :+ (prim CONS, Struct [a] [(a, ValT ta), + (b, ValT (tLIST ta))] (Extends (prim LIST))) :+ (prim Msg, Struct [] [(prim Code, FunT [] [] tUNIT),+ (prim Baseline, ValT (tId AbsTime)),+ (prim Deadline, ValT (tId AbsTime)),+ (prim Next, ValT (tId Msg))] Top) :+ (prim Ref, Struct [a] [(prim STATE, ValT ta)] Top) :+ (prim EITHER, Struct [a,b] [] Union) :+ (prim LEFT, Struct [a,b] [(a,ValT ta)] (Extends (prim EITHER))) :+ (prim RIGHT, Struct [a,b] [(a,ValT tb)] (Extends (prim EITHER))) :+ (prim TIMERTYPE, Struct [] [(prim Reset, FunT [] [tInt] tUNIT),+ (prim Sample, FunT [] [tInt] tTime)] Top) : + []+ +isInfix (Prim p _) = p `elem` [MIN____KINDLE_INFIX .. MAX____KINDLE_INFIX]+isInfix _ = False++isUnaryOp (Prim p _) = p `elem` [IntNeg, FloatNeg, NOT8, NOT16, NOT32]+isUnaryOp _ = False++primKindleTerms = map prim [ MIN____VAR .. MAX____KINDLEVAR ]++primTEnv = primTEnv0 ++ map cv (Env.primTypeEnv `restrict` primKindleTerms)+ where + cv (x,Core.Scheme r [] ke) = (x, cv0 r (dom ke))+ cv0 (Core.F ts t) vs = FunT vs (map cv1 ts) (cv2 t)+ cv0 (Core.R t) [] = ValT (cv3 t)+ cv0 (Core.R t) vs = FunT vs [] (cv3 t)+ cv1 (Core.Scheme r [] []) = cv2 r+ cv2 (Core.R t) = cv3 t+ cv3 t+ | isCon n = TCon n ts'+ | otherwise = TVar n ts'+ where (Core.TId n, ts) = Core.tFlat t+ ts' = map cv3 ts+ -- N.B.: This type/scheme conversion algorithm is partial; it is only intended to cover the cases that appear+ -- when converting Env.primTypeEnv restricted to primKindleTerms (note the exceptions for TIMERTERM and Abort).+++-- Primitive names only visible after translation into Kindle+primTEnv0 = (prim TIMERTERM, FunT [] [tInt] (tId TIMERTYPE)) :+ (prim Abort, FunT [a] [tMsg, tRef ta] tUNIT) :+ + (prim NEWREF, FunT [a] [ta] (tRef ta)) :+ (prim STATEOF, FunT [a] [tRef ta] ta) :+ (prim ASYNC, FunT [] [tMsg,tTime,tTime] tUNIT) :+ (prim LOCK, FunT [] [tPID] tUNIT) :+ (prim UNLOCK, FunT [] [tPID] tUNIT) :+ (prim Inherit, ValT tTime) :+ (prim EmptyArray, FunT [a] [tInt] (tArray ta)) :+ (prim CloneArray, FunT [a] [tArray ta, tInt] (tArray ta)) :+ []++okRec (ValT t) = okRec' t+okRec (FunT vs ts t) = True -- Good: recursive function+okRec' (TVar _ _) = False -- Bad: statically unknown representation+okRec' (TCon (Prim p _) _) = p `notElem` Kindle.scalarPrims -- Bad: type that can't fit placeholder+okRec' (TCon n _) = True -- Good: heap allocated data++scalarPrims = [Int, Float, Char, Bool, UNITTYPE, BITS8, BITS16, BITS32]++smallPrims = [Char, Bool, UNITTYPE, BITS8, BITS16]++tupleDecl (Tuple n _) = Struct ids (map f ids) Top+ where ids = take n abcSupply+ f n = (n, ValT (TVar n []))++isVal (_, Val _ _) = True+isVal (_, Fun _ _ _ _) = False++isFunT (_, ValT _) = False+isFunT (_, FunT _ _ _) = True++isTVar (TCon _ _) = False+isTVar (TVar _ _) = True++isArray (TCon (Prim Array _) _) = True+isArray _ = False++isEVar (EVar _) = True+isEVar _ = False++typeOf (Val t e) = ValT t+typeOf (Fun vs t te c) = FunT vs (rng te) t++rngType (ValT t) = t+rngType (FunT vs ts t) = t++typeOf' b = rngType (typeOf b)++declsOf (Module _ _ ds _) = ds++unions ds = [ n | (n,Struct _ _ Union) <- ds ]+ +variants ds n0 = [ n | (n,Struct _ _ (Extends n')) <- ds, n' == n0 ]++structRoot ds n+ | isTuple n = n+ | otherwise = case lookup' ds n of+ Struct _ _ (Extends n') -> n'+ _ -> n+ +structArity ds n + | isTuple n = width n+ | otherwise = length vs+ where Struct vs _ _ = lookup' ds n++typeOfCon ds k+ | isTuple k = (k, width k)+ | otherwise = (k0, structArity ds k0)+ where k0 = structRoot ds k+++typeOfSel ds l = head [ (k,vs,t) | (k,Struct vs te _) <- ds, (l',t) <- te, l'==l ]++unit = ECast tUNIT (ENew (prim UNITTERM) [] [])++cBind [] c = c+cBind bs c = CBind False bs c++cBindR r [] c = c+cBindR r bs c = CBind r bs c++simpleExp (EVar _) = True+simpleExp (ELit _) = True+simpleExp (ECast _ e) = simpleExp e+simpleExp _ = False++lock t e = ECast t (ECall (prim LOCK) [] [ECast tPID e])++unlock x c = cMap (CRun (ECall (prim UNLOCK) [] [e0]) . CRet) c+ where e0 = ECast tPID (EVar x)+++cMap f (CRet e) = f e+cMap f (CRun e c) = CRun e (cMap f c)+cMap f (CBind r bs c) = CBind r bs (cMap f c)+cMap f (CUpd y e c) = CUpd y e (cMap f c)+cMap f (CUpdS e y e' c) = CUpdS e y e' (cMap f c)+cMap f (CUpdA e i e' c) = CUpdA e i e' (cMap f c)+cMap f (CSwitch e alts) = CSwitch e (clift (cMap f) alts)+ where g (ACon y vs te c) = ACon y vs te (cMap f c)+ g (ALit l c) = ALit l (cMap f c)+ g (AWild c) = AWild (cMap f c)+cMap f (CSeq c c') = CSeq (cMap f c) (cMap f c')+cMap f (CBreak) = CBreak+cMap f (CRaise e) = CRaise e+cMap f (CWhile e c c') = CWhile e (cMap f c) (cMap f c')+cMap f (CCont) = CCont+++cMap' f = cMap (CRet . f)+++class CLift a where+ clift :: (Cmd -> Cmd) -> a -> a++instance CLift Cmd where+ clift f = f++instance CLift Alt where+ clift f (ACon y vs te c) = ACon y vs te (f c)+ clift f (ALit l c) = ALit l (f c)+ clift f (AWild c) = AWild (f c)++instance CLift a => CLift [a] where+ clift f = map (clift f)+++cmap f = clift (cMap (CRet . f))+++enter e ts es = EEnter e (prim Code) ts es++multiEnter [] [] e = e+multiEnter (ts:tss) es e = multiEnter tss es2 (enter e [] es1)+ where (es1,es2) = splitAt (length ts) es+ ++closure t0 t te c = closure2 t0 [] t te c++closure2 (TCon n ts) vs t te c = ENew n ts [(prim Code, Fun vs t te c)]+++findStruct s0 [] = Nothing+findStruct s0 ((n,s):ds)+ | equalStructs (s0,s) = Just n+ | otherwise = findStruct s0 ds+++equalStructs (Struct [] te1 l1, Struct [] te2 l2)+ = l1 == l2 && ls1 == ls2 && all equalTypes (ts1 `zip` ts2)+ where (ls1,ts1) = unzip te1+ (ls2,ts2) = unzip te2+equalStructs (Struct vs1 te1 l1, Struct vs2 te2 l2)+ = l1 == l2 && length vs1 == length vs2 &&+ ls1 == ls2 && all equalTypes (subst s ts1 `zip` ts2)+ where s = vs1 `zip` map tVar vs2+ (ls1,ts1) = unzip te1+ (ls2,ts2) = unzip te2++equalTypes (ValT t1, ValT t2) = t1 == t2+equalTypes (FunT vs1 ts1 t1, FunT vs2 ts2 t2)+ = length vs1 == length vs2 && (t1:ts1) == subst s (t2:ts2)+ where s = vs2 `zip` map tVar vs1+equalTypes _ = False+++subexps (CRet e) = [e]+subexps (CRun e _) = [e]+subexps (CBind _ bs _) = [ e | (_,Val _ e) <- bs ]+subexps (CUpd _ e _) = [e]+subexps (CUpdS e _ e' _) = [e,e']+subexps (CUpdA e _ e' _) = [e,e']+subexps (CSwitch e _) = [e]+subexps (CWhile e _ _) = [e]+subexps _ = []++raises es = [ e | ECall (Prim Raise _) _ [e] <- es ]++ +-- Free variables ------------------------------------------------------------------------------------++instance Ids Exp where+ idents (EVar x) = [x]+ idents (EThis) = []+ idents (ELit l) = []+ idents (ESel e l) = idents e+ idents (ENew x ts bs) = idents bs+ idents (ECall x ts es) = x : idents es+ idents (EEnter e x ts es) = idents e ++ idents es+ idents (ECast t e) = idents e++instance Ids Cmd where+ idents (CRet e) = idents e+ idents (CRun e c) = idents e ++ idents c+ idents (CBind False bs c) = idents bs ++ (idents c \\ dom bs)+ idents (CBind True bs c) = (idents bs ++ idents c) \\ dom bs+ idents (CUpd x e c) = idents e ++ idents c+ idents (CUpdS e x e' c) = idents e ++ idents e' ++ idents c+ idents (CUpdA e i e' c) = idents e ++ idents i ++ idents e' ++ idents c+ idents (CSwitch e alts) = idents e ++ idents alts+ idents (CSeq c c') = idents c ++ idents c'+ idents (CBreak) = []+ idents (CRaise e) = idents e+ idents (CWhile e c c') = idents e ++ idents c ++ idents c'+ idents (CCont) = []++instance Ids Alt where+ idents (ACon x vs te c) = idents c \\ dom te+ idents (ALit l c) = idents c+ idents (AWild c) = idents c++instance Ids Bind where+ idents (Val t e) = idents e+ idents (Fun vs t te c) = idents c \\ dom te++instance Ids AType where+ idents (TCon c ts) = c : idents ts+ idents (TVar v ts) = v : idents ts++instance Ids Type where+ idents (ValT t) = idents t+ idents (FunT vs ts t) = idents (t:ts) \\ vs+++class TypeVars a where+ typevars :: a -> [Name]++instance TypeVars a => TypeVars [a] where+ typevars xs = concatMap typevars xs++instance TypeVars a => TypeVars (Name,a) where+ typevars (_,x) = typevars x++instance TypeVars Bind where+ typevars (Val t e) = typevars t ++ typevars e+ typevars (Fun vs t te c) = (typevars t ++ typevars te ++ typevars c) \\ vs++instance TypeVars Exp where+ typevars (EVar _) = []+ typevars (EThis) = []+ typevars (ELit _) = []+ typevars (ESel e _) = typevars e+ typevars (ENew _ ts bs) = typevars ts ++ typevars bs+ typevars (ECall _ ts es) = typevars ts ++ typevars es+ typevars (EEnter e _ ts es) = typevars ts ++ typevars (e:es)+ typevars (ECast t e) = typevars t ++ typevars e++instance TypeVars Cmd where+ typevars (CRet e) = typevars e+ typevars (CRun e c) = typevars e ++ typevars c+ typevars (CBind _ bs c) = typevars bs ++ typevars c+ typevars (CUpd _ e c) = typevars e ++ typevars c+ typevars (CUpdS e _ e' c) = typevars [e,e'] ++ typevars c+ typevars (CUpdA e i e' c) = typevars [e,i,e'] ++ typevars c+ typevars (CSwitch e alts) = typevars e ++ typevars alts+ typevars (CSeq c c') = typevars c ++ typevars c'+ typevars (CBreak) = []+ typevars (CRaise e) = typevars e+ typevars (CWhile e c c') = typevars e ++ typevars [c,c']+ typevars (CCont) = []++instance TypeVars Alt where+ typevars (ACon _ vs te c) = (typevars c ++ typevars te) \\ vs+ typevars (ALit _ c) = typevars c+ typevars (AWild c) = typevars c++instance TypeVars AType where+ typevars (TCon _ ts) = typevars ts+ typevars (TVar n ts) = n : typevars ts+ +-- Substitutions ------------------------------------------------------------------------------------------++instance Subst Exp Name Exp where+ subst s (EVar v) = case lookup v s of+ Just e -> e+ _ -> EVar v+ subst s (EThis) = EThis+ subst s (ELit l) = ELit l+ subst s (ESel e l) = ESel (subst s e) l+ subst s (ENew x ts bs) = ENew x ts (subst s bs)+ subst s (ECall x ts es) = ECall x ts (subst s es)+ subst s (EEnter e x ts es) = EEnter (subst s e) x ts (subst s es)+ subst s (ECast t e) = ECast t (subst s e)++instance Subst Cmd Name Exp where+ subst s (CRet e) = CRet (subst s e)+ subst s (CRun e c) = CRun (subst s e) (subst s c)+ subst s (CBind r bs c) = CBind r (subst s bs) (subst s c)+ subst s (CUpd x e c) = CUpd x (subst s e) (subst s c)+ subst s (CUpdS e x e' c) = CUpdS (subst s e) x (subst s e') (subst s c)+ subst s (CUpdA e i e' c) = CUpdA (subst s e) (subst s i) (subst s e') (subst s c)+ subst s (CSwitch e alts) = CSwitch (subst s e) (subst s alts)+ subst s (CSeq c c') = CSeq (subst s c) (subst s c')+ subst s (CBreak) = CBreak+ subst s (CRaise e) = CRaise (subst s e)+ subst s (CWhile e c c') = CWhile (subst s e) (subst s c) (subst s c')+ subst s (CCont) = CCont++instance Subst Alt Name Exp where+ subst s (ACon x vs te c) = ACon x vs te (subst s c) -- NOTE: no alpha-conversion!!+ subst s (ALit l c) = ALit l (subst s c)+ subst s (AWild c) = AWild (subst s c)+ +instance Subst Bind Name Exp where+ subst s (Val t e) = Val t (subst s e)+ subst s (Fun vs t te c) = Fun vs t te (subst s c)+++instance Subst Type Name AType where+ subst s (ValT t) = ValT (subst s t)+ subst s (FunT vs t ts) = FunT vs (subst s t) (subst s ts) -- NOTE: no alpha-conversion!!++instance Subst AType Name AType where+ subst s (TCon c ts) = TCon c (subst s ts)+ subst s (TVar v ts) = case lookup v s of+ Just t -> appargs t+ _ -> TVar v ts'+ where ts' = subst s ts+ appargs (TCon c ts) = TCon c (ts++ts')+ appargs (TVar v ts) = TVar v (ts++ts')+++instance Subst Exp Name AType where+ subst s (ESel e l) = ESel (subst s e) l+ subst s (ENew x ts bs) = ENew x (subst s ts) (subst s bs)+ subst s (ECall x ts es) = ECall x (subst s ts) (subst s es)+ subst s (EEnter e f ts es) = EEnter (subst s e) f (subst s ts) (subst s es)+ subst s (ECast t e) = ECast (subst s t) (subst s e)+ subst s e = e++instance Subst Bind Name AType where+ subst s (Val t e) = Val (subst s t) (subst s e)+ subst s (Fun vs t te c) = Fun vs (subst s t) (subst s te) (subst s c) -- NOTE: no alpha-conversion!!+ +instance Subst Cmd Name AType where+ subst s (CRet e) = CRet (subst s e)+ subst s (CRun e c) = CRun (subst s e) (subst s c)+ subst s (CBind r bs c) = CBind r (subst s bs) (subst s c)+ subst s (CUpd x e c) = CUpd x (subst s e) (subst s c)+ subst s (CUpdS e x e' c) = CUpdS (subst s e) x (subst s e') (subst s c)+ subst s (CUpdA e i e' c) = CUpdA (subst s e) (subst s i) (subst s e') (subst s c)+ subst s (CSwitch e alts) = CSwitch (subst s e) (subst s alts)+ subst s (CSeq c c') = CSeq (subst s c) (subst s c')+ subst s (CBreak) = CBreak+ subst s (CRaise e) = CRaise (subst s e)+ subst s (CWhile e c c') = CWhile (subst s e) (subst s c) (subst s c')+ subst s (CCont) = CCont+ +instance Subst Alt Name AType where+ subst s (ACon x vs te c) = ACon x vs (subst s te) (subst s c)+ subst s (ALit l c) = ALit l (subst s c)+ subst s (AWild c) = AWild (subst s c)+ ++-- Tentative concrete syntax ------------------------------------------------------------------------------++instance Pr Module where+ pr (Module m ns ds bs) = text "module" <+> prId2 m <+> text "where" $$+ text "import" <+> hpr ',' ns $$+ vpr ds $$ + vpr bs+++instance Pr (Module,a) where+ pr (m,_) = pr m+++instance Pr (Name, Decl) where+ pr (c, Struct vs te lnk) = text "struct" <+> prId2 c <+> prTyvars vs <+> text "{" $$+ nest 4 (vpr te) $$+ text "}" <+> pr lnk++prTyvars [] = empty+prTyvars vs = text "<" <> commasep pr vs <> text ">"++instance Pr Link where+ pr Top = empty+ pr Union = text "union"+ pr (Extends n) = text "extends" <+> prId2 n+++instance Pr (Name, Type) where+ pr (x, ValT t) = pr t <+> prId2 x <> text ";"+ pr (x, FunT vs ts t) = prTyvars vs <+> pr t <+> prId2 x <> parens (commasep pr ts) <> text ";"+++instance Pr AType where+ pr (TCon c ts) = prId2 c <> prTyargs ts+ pr (TVar v ts) = prId2 v <> prTyargs ts++prTyargs [] = empty+prTyargs ts = text "<" <> commasep pr ts <> text ">"++instance Pr (Name, AType) where+ pr (x, t) = pr t <+> prId2 x+++instance Pr (Name, Bind) where+ pr (x, Val t e) = pr t <+> prId2 x <+> text "=" <+> pr e <> text ";"+ pr (x, Fun vs t te c) = prTyvars vs <+> pr t <+> prId2 x <+> parens (commasep pr te) <+> text "{" $$+ nest 4 (pr c) $$+ text "}"++instance Pr Cmd where+ pr (CRet e) = text "return" <+> pr e <> text ";"+ pr (CRun e c) = pr e <> text ";" $$+ pr c+ pr (CBind r bs c) = vpr bs $$+ pr c+ pr (CUpd x e c) = prId2 x <+> text "=" <+> pr e <> text ";" $$+ pr c+ pr (CUpdS e x e' c) = pr (ESel e x) <+> text "=" <+> pr e' <> text ";" $$+ pr c+ pr (CUpdA e i e' c) = pr (ECall (prim IndexArray) [] [e,i]) <+> text "=" <+> pr e' <> text ";" $$+ pr c+ pr (CSwitch e alts) = text "switch" <+> parens (pr e) <+> text "{" $$+ nest 2 (vpr alts) $$+ text "}"+ pr (CSeq c1 c2) = pr c1 $$+ pr c2+ pr (CBreak) = text "break;"+ pr (CRaise e) = text "RAISE" <> parens (pr e) <> text ";"+ pr (CWhile e c c') = text "while" <+> parens (pr e) <+> text "{" $$+ nest 4 (pr c) $$+ text "}" $$+ pr c'+ pr (CCont) = text "continue;"++++prScope (CRaise e) = pr (CRaise e)+prScope (CBreak) = pr CBreak+prScope (CCont) = pr CCont+prScope (CRet x) = pr (CRet x)+prScope c = text "{" <+> pr c $$+ text "}"++instance Pr Alt where+ pr (ACon x vs [] c) = prId2 x <+> prTyvars vs <> text ":" <+> prScope c+ pr (ACon x vs te c) = prId2 x <+> prTyvars vs <+> parens (commasep pr te) <> text ":" <+> prScope c+ pr (ALit l c) = pr l <> text ":" <+> prScope c+ pr (AWild c) = text "default:" <+> prScope c+++instance Pr Exp where+ prn 0 (ECall x [] [e1,e2])+ | isInfix x = prn 0 e1 <+> prId2 x <+> prn 1 e2+ prn 0 e = prn 1 e+++ prn 1 (ECall x [] [e])+ | isUnaryOp x = prId2 x <> prn 1 e+ prn 1 (ECast t e) = parens (pr t) <> prn 1 e+ prn 1 e = prn 2 e++ prn 2 (EVar x) = prId2 x+ prn 2 (EThis) = text "this"+ prn 2 (ELit l) = pr l+ prn 2 (ENew x ts bs)+ | all isVal bs = text "new" <+> prId2 x <> prTyargs ts <+> text "{" <> commasep prInit bs <> text "}"+ prn 2 (ENew x ts bs) = text "new" <+> prId2 x <> prTyargs ts <+> text "{" $$+ nest 4 (vpr bs) $$+ text "}"+ prn 2 (ECall x ts es) = prId2 x <> prTyargs ts <> parens (commasep pr es)+ prn 2 (ESel e l) = prn 2 e <> text "->" <> prId2 l+ prn 2 (EEnter e x ts es) = prn 2 e <> text "->" <> prId2 x <> prTyargs ts <> parens (commasep pr es)+ prn 2 e = parens (prn 0 e)+++prInit (x, Val t e) = prId2 x <+> text "=" <+> pr e+prInit b = pr b+++-- HasPos --------------------++instance HasPos AType where+ posInfo (TCon n ts) = between (posInfo n) (posInfo ts)+ posInfo (TVar n ts) = between (posInfo n) (posInfo ts)+++-- Binary --------------------+{-+instance Binary Module where+ put (Module a b c d) = put a >> put b >> put c >> put d+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (Module a b c d)+-}+instance Binary Decl where+ put (Struct a b c) = putWord8 0 >> put a >> put b >> put c+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (Struct a b c)+ _ -> fail "no parse"+ +instance Binary Link where+ put Top = putWord8 0+ put Union = putWord8 1+ put (Extends n) = putWord8 2 >> put n+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> return Top+ 1 -> return Union+ 2 -> get >>= \a -> return (Extends a)+ _ -> fail "no parse"+{-+instance Binary Bind where+ put (Val a b) = putWord8 0 >> put a >> put b+ put (Fun a b c) = putWord8 1 >> put a >> put b >> put c+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> return (Val a b)+ 1 -> get >>= \a -> get >>= \b -> get >>= \c -> return (Fun a b c)+ _ -> fail "no parse"+-}+instance Binary Type where+ put (ValT a) = putWord8 0 >> put a+ put (FunT a b c) = putWord8 1 >> put a >> put b >> put c+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (ValT a)+ 1 -> get >>= \a -> get >>= \b -> get >>= \c -> return (FunT a b c)+ _ -> fail "no parse"++instance Binary AType where+ put (TCon a b) = putWord8 0 >> put a >> put b+ put (TVar a b) = putWord8 1 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> return (TCon a b)+ 1 -> get >>= \a -> get >>= \b -> return (TVar a b)+ _ -> fail "no parse"+
+ src/Kindle2C.hs view
@@ -0,0 +1,487 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Kindle2C(kindle2c) where+++import Common+import Kindle+import PP+import Char+import Depend++kindle2c is m = return (render h, render c)+ where h = k2hModule m+ c = k2cModule is m++-- ====================================================================================================+-- Generate .h file+-- ====================================================================================================++k2hModule (Module n ns ds bs) = hHeader n ns $$$+ k2cDeclStubs True ds $$$+ k2cDecls True ds $$$+ k2cBindStubsH bs $$$+ k2cInitProcStub n <> text ";" $$$+ hFooter n+ +k2cImport n = text "#include \"" <> text (modToPath (str n) ++ ".h\"")+++hHeader n [] = includeGuard n $$ text "#include \"rts.h\"" $$ text "#include \"timber.h\""+hHeader n ns = includeGuard n $$ vcat (map k2cImport ns)++includeGuard n = text ("#ifndef " ++ g) $$+ text ("#define " ++ g)+ where g = map toUpper (modToundSc (str n)) ++ "_H_"+ +hFooter n = text "#endif\n"++k2cDeclStubs isH ds = vcat (map f ds)+ where f (n, _)+ | isH==isQualified n = text "struct" <+> k2cName n <> text ";" $$+ text "typedef" <+> text "struct" <+> k2cName n <+> text "*" <> k2cName n <> text ";"+ | otherwise = empty++k2cDecls isH ds = vcat (map f ds)+ where f (n, Struct [] te cs)+ | isH==isQualified n = text "struct" <+> k2cName n <+> text "{" $$+ nest 4 (k2cSigs n te) $$+ text "}" <> text ";"+ | otherwise = empty+ k2cSigs n te = vcat (map f te)+ where f (x,FunT [] ts t) + = k2cType t <+> parens (text "*" <> k2cName x) <+> parens (commasep k2cType (tCon n : ts)) <> text";"+ f (x,ValT t) = k2cType t <+> k2cName x <> text ";"+++k2cFunParams te = parens (commasep f te)+ where f (x, t) = k2cType t <+> k2cName x+++k2cBindStubsH bs = vcat (map f bs)+ where f (x, _)+ | not (isQualified x) = empty+ f (x, Fun [] t te c) = k2cType t <+> k2cName x <+> k2cFunParams te <> text";"+ f (x, Val _ (ECall (Prim GCINFO _) _ _))+ = text "extern" <+> text "WORD" <+> k2cName x <> text "[];"+ f (x, Val t e) = text "extern" <+> k2cType t <+> k2cName x <> text ";"+++-- Generate types+k2cType (TCon n _) = k2cName n+k2cType (TVar _ _) = k2cType tPOLY++++-- ====================================================================================================+-- Generate .c file+-- ====================================================================================================++{- + Here we need+ - stubs for private functions and values+ - bindings for all functions and for values with constant initializer+ - initialization procedure for values with non-constant initializer+ "Constant initializer" is presently interpreted as literals only for lack of better understanding.+-}++k2cModule is (Module n ns ds bs)= cHeader n $$$+ k2cDeclStubs False ds $$$+ k2cDecls False ds $$$+ k2cBindStubsC bs $$$+ k2cTopBinds bs $$$+ k2cInitProc n ns bs $$$+ cFooter n+++k2cSize n = text "WORDS(sizeof(struct" <+> k2cName n <> text "))"+++cHeader n = text "#include \"" <> text (modToPath (str n)) <> text ".h\"" +cFooter n = text "\n"+++k2cBindStubsC bs = vcat (map f bs)+ where f (x, Fun [] t te c)+ | isQualified x = empty+ | otherwise = k2cStatic x <+> k2cType t <+> k2cName x <+> k2cFunParams te <> text";"+ f (x, Val _ (ECall (Prim GCINFO _) _ _))+ | isQualified x = empty+ | otherwise = k2cStatic x <+> text "WORD" <+> k2cName x <> text "[];"+ f (x, Val t e) = k2cStatic x <+> k2cType t <+> k2cName x <> text ";"+++k2cStatic x+ | isQualified x = empty+ | otherwise = text "static"+++k2cValBindStubsC bs = vcat (map f bs)+ where f (x, Val t e) = k2cType t <+> k2cName x <> text ";"+++k2cInitProcStub n = text "void _init_" <> text (modToundSc (str n)) <+> text "()"++k2cInitImports ns = vcat (map f ns)+ where f n = text "_init_" <> text (modToundSc (str n)) <> text "();"++k2cOnce p = text "static int INITIALIZED = 0;" $$+ text "if (!INITIALIZED) {" $$+ nest 4 (p $$ text "INITIALIZED = 1;") $$+ text "}"+++k2cInitProc n ns bs = k2cInitProcStub n <+> text "{" $$+ nest 4 (k2cOnce (k2cInitImports ns $$ vcat (map k2cValBinds' (groupMap bs)))) $$+ text "}"+ where k2cValBinds' (r,bs) = k2cValBinds (r, filter isInitVal bs)+ isInitVal (_,Val _ (ECall (Prim GCINFO _) _ _))+ = False+ isInitVal (_,Val _ _) = True+ isInitVal _ = False++k2cTopBinds bs = vcat (map f bs)+ where f (x, Fun [] t te c) = k2cStatic x <+> k2cType t <+> k2cName x <+> k2cFunParams te <+> text "{" $$+ nest 4 (k2cCmd c) $$+ text "}"+ f (x, Val _ (ECall (Prim GCINFO _) [] es@(EVar n : _)))+ = k2cStatic x <+> text "WORD" <+> k2cName x <> text "[]" <+> text "=" <+> + braces (commasep (k2cGC n) es) <> text ";"+ f _ = empty+++k2cGC n (EVar x) | x == n = k2cSize x+ | otherwise = text "WORDS(offsetof(struct" <+> k2cName n <> text "," <+> k2cName x <> text "))"+k2cGC n e = k2cExp e+++k2cValBinds (rec,bs)+ | not rec || isSafe bs = vcat (map f bs) $$+ vcat (map g bs)+ where f (x, Val t (ENew (Prim Ref _) _ _))+ = internalError0 "new Ref in k2cValBinds"+ f (x, Val t (ENew n [] bs)) + = newCall t x (k2cSize n)+ f (x, Val t (ECast _ (ENew n [] bs)))+ = newCall t x (k2cSize n)+ f (x, Val t e) = k2cName x <+> text "=" <+> k2cExp e <> text ";"+ f _ = empty+ g (x, Val t (ENew n [] bs)) + = k2cStructBinds (EVar x) bs+ g (x, Val t (ECast _ (ENew n [] bs)))+ = k2cStructBinds (ECast (tCon n) (EVar x)) bs+ g _ = empty+ vs = dom bs+ isSafe bs = all isConst bs && strictBs bs `intersect` vs == []+ isConst (_, Val _ (ENew _ _ _)) = True+ isConst (_, Val _ (ECast _ (ENew _ _ _))) = True+ isConst _ = False+k2cValBinds (_,bs) = text ("{ Array roots = CYCLIC_BEGIN(" ++ show size ++ "," ++ show n_upd ++ ");") $$+ nest 4 (vcat (zipWith f [0..] bs) $$+ vcat (zipWith3 g [0..] upd bs) $$+ text "CYCLIC_END(roots, hp);") $$+ text "}"+ where size = length bs+ upd = updates [] bs+ n_upd = length (filter id upd)+ f i (x, Val t (ENew (Prim Ref _) _ _))+ = internalError0 "new Ref in k2cValBinds"+ f i (x, Val t _) = k2cName x <+> text "=" <+> k2cExp (rootInd' t i) <> text ";"+ g i u (x, Val t (ENew n [] bs'))+ = update u i $$+ newCall t x (k2cSize n) $$+ k2cExp (rootInd i) <+> text "=" <+> k2cExp (ECast tPOLY (EVar x)) <> text ";" $$+ k2cStructBinds (rootInd' t i) bs'+ g i u (x, Val t (ECast _ (ENew n [] bs')))+ = update u i $$+ newCall t x (k2cSize n) $$+ k2cExp (rootInd i) <+> text "=" <+> k2cExp (ECast tPOLY (EVar x)) <> text ";" $$+ k2cStructBinds (ECast (tCon n) (rootInd' t i)) bs'+ g i u (x, Val t e) = update u i $$+ k2cName x <+> text "=" <+> k2cExp e <> text ";" $$+ k2cExp (rootInd i) <+> text "=" <+> k2cExp (ECast tPOLY (EVar x)) <> text ";"+ update True i = text ("CYCLIC_UPDATE(roots, " ++ show i ++ ", hp);")+ update False i = empty+ rootInd i = ECall (prim IndexArray) [] [ELit (lInt 0), EVar (name0 "roots"), ELit (lInt i)]+ rootInd' t i = ECast t (rootInd i)+++strictBs bs = concat [ strict e | (_,Val _ e) <- bs ]+ -- We assume all free variables of function closures have been extracted as value+ -- bindings by llift, hence only Val patterns need to be considered above+strict (ECast _ e) = strict e+strict (ESel e l) = evars e+strict (EEnter e l [] es) = evars (e:es)+strict (ECall f [] es) = evars es+strict (ENew _ [] bs) = strictBs bs+strict _ = []++strictRhs (EVar x) = [x]+strictRhs (ECast _ e) = strictRhs e+strictRhs e = strict e++updates prev [] = []+updates prev ((x,Val _ e):bs) = mustUpdate : updates ((x,fwrefs):prev') bs+ where computed = dom prev+ bwrefs = filter (not . isPatTemp) (strictRhs e `intersect` computed)+ fragile = concat [ fws | (y,fws) <- prev, y `elem` bwrefs ]+ mustUpdate = not (null (fragile `intersect` computed))+ fwrefs = evars e `intersect` (x:dom bs)+ prev' | mustUpdate = [ (y,fws \\ computed) | (y,fws) <- prev ]+ | otherwise = prev+ +++newCall t x size = text "NEW" <+> parens (k2cType t <> text "," <+> + k2cName x <> text "," <+> + size) <> text ";"++++k2cStructBinds e0 bs = vcat (map f bs)+ where f (Prim GCINFO _, Val _ (ECall x [] es))+ = k2cExp (ESel e0 (prim GCINFO)) <+> text "=" <+> k2cName x <> off <> text ";"+ where off | null es = empty+ | otherwise = text "+" <> parens (k2cExp (head es))+ f (x, Val t e) = k2cExp (ESel e0 x) <+> text "=" <+> k2cExp e <> text ";"+ f (x, Fun [] t te (CRet (ECall f [] es)))+ = k2cExp (ESel e0 x) <+> text "=" <+> k2cName f <> text ";"+ f (x, _) = internalError0 "k2cSBind"++++k2cCmd (CRet e) = text "return" <+> k2cExp e <> text ";"+k2cCmd (CRun e c) = k2cExp e <> text ";" $$+ k2cCmd c+k2cCmd (CBind False [(x,Val t (ENew n [] bs))] (CBind False [(y,Val tref (ENew (Prim Ref _) [] bs'))] c))+ | st == ECast tPOLY (EVar x) = k2cType tref <+> k2cName y <> text ";" $$+ newCall (tref) y (k2cSize (prim Ref) <> text "+" <> k2cSize n) $$+ text "INITREF" <> parens (k2cName y) <> text ";" $$+ k2cStructBinds (ECast t (ESel (EVar y) (prim STATE))) bs $$+ k2cCmd c+ where Val _ st = lookup' bs' (prim STATE)+k2cCmd (CBind False [(_,Val (TCon (Prim UNITTYPE _) _) e)] (CRet (ECast (TCon (Prim UNITTYPE _) _) _)))+ = k2cExp e <> text ";"+k2cCmd (CBind False [(_,Val (TCon (Prim UNITTYPE _) _) e)] CBreak)+ = text "break;"+k2cCmd (CBind False bs c) = k2cValBindStubsC bs $$+ k2cValBinds (False,bs) $$+ k2cCmd c+k2cCmd (CBind True bs c) = k2cValBindStubsC bs $$+ vcat (map k2cValBinds (groupMap bs)) $$+ k2cCmd c+k2cCmd (CUpd x e c) = k2cName x <+> text "=" <+> k2cExp e <> text ";" $$+ k2cCmd c+k2cCmd (CUpdS e x e' c) = k2cExp (ESel e x) <+> text "=" <+> k2cExp e' <> text ";" $$+ k2cCmd c+k2cCmd (CUpdA e i e' c) = k2cExp (ECall (prim IndexArray) [] [ELit (lInt 0),e,i]) <+> text "=" <+> k2cExp e' <> text ";" $$+ k2cCmd c+k2cCmd (CSwitch e alts) = case litType (firstLit alts) of+ TCon (Prim LIST _) [TCon (Prim Char _) []] -> -- we know (from Prepare4C) that e is a variable+ k2cStringAlts False e alts+ TCon (Prim Float _) [] -> + k2cFloatAlts False e alts+ _ -> text "switch" <+> parens (k2cExp e) <+> text "{" $$+ nest 4 (vcat (map k2cAlt alts)) $$+ text "}"+k2cCmd (CSeq c c') = k2cCmd c $$+ k2cCmd c'+k2cCmd (CBreak) = text "break;"+k2cCmd (CRaise e) = text "RAISE" <> parens (k2cExp e) <> text ";"+k2cCmd (CWhile e c c') = text "while" <+> parens (k2cExp e) <+> text "{" $$+ nest 4 (k2cCmd c) $$+ text "}" $$+ k2cCmd c'+k2cCmd (CCont) = text "continue;"++firstLit (ALit l _ : _) = l+firstLit (_ : as) = firstLit as++k2cStringAlts b e (ALit l c : as) + = (if b then text "else " else empty) <> text "if (strEq (" <> k2cExp e <>+ text "," <> k2cExp (ELit l) <> text ")) {" $$+ nest 4 (k2cNestIfCmd c) $$+ text "}" $$+ k2cStringAlts True e as+k2cStringAlts _ e [AWild c] = text "else {" $$+ nest 4 (k2cNestIfCmd c) $$+ text "}"++k2cFloatAlts b e (ALit l c : as) + = (if b then text "else " else empty) <> text "if (" <> k2cExp e <>+ text "=="<> k2cExp (ELit l) <> text ") {" $$+ nest 4 (k2cNestIfCmd c) $$+ text "}" $$+ k2cFloatAlts True e as+k2cFloatAlts _ e [AWild c] = text "else {" $$+ nest 4 (k2cNestIfCmd c) $$+ text "}"+ +k2cAlt (ACon n _ _ c) = internalError "Constructor tag in Kindle2C" n+k2cAlt (ALit l c) = text "case" <+> pr l <> text ":" <+> k2cNestCmd c+k2cAlt (AWild c) = text "default:" <+> k2cNestCmd c+++k2cNestCmd (CRet e) = text "return" <+> k2cExp e <> text ";"+k2cNestCmd (CBreak) = text "break;"+k2cNestCmd (CCont) = text "continue;"+k2cNestCmd (CRaise e) = text "RAISE" <> parens (k2cExp e) <> text ";"+k2cNestCmd c = text "{" <+> k2cCmd c $$+ text "}" $$+ text "break;" -- important in case contains a switch that might break++k2cNestIfCmd (CRet e) = text "return" <+> k2cExp e <> text ";"+k2cNestIfCmd (CBreak) = empty+k2cNestIfCmd (CCont) = text "continue;"+k2cNestIfCmd (CRaise e) = text "RAISE" <> parens (k2cExp e) <> text ";"+k2cNestIfCmd c = text "{" <+> k2cCmd c $$+ text "}" +++k2cExp (ECall x [] [e1,e2])+ | isInfix x = parens (k2cExp e1 <+> k2cName x <+> k2cExp1 e2)+k2cExp e = k2cExp1 e+++k2cExp1 (ECall x [] [e])+ | isUnaryOp x = k2cName x <> k2cExp1 e+k2cExp1 (ECast t e) = parens (k2cType t) <> k2cExp1 e+k2cExp1 e = k2cExp2 e+++k2cExp2 (EVar x) = k2cName x+k2cExp2 (ELit (LRat _ r)) = text (show (fromRational r :: Double))+k2cExp2 (ELit (LStr _ str)) = text ("getStr("++show str++")")+k2cExp2 (ELit l) = pr l+k2cExp2 (ESel e (Prim STATE _)) = text "STATEOF" <> parens (k2cExp e)+k2cExp2 (ESel e l) = k2cExp2 e <> text "->" <> k2cName l+k2cExp2 (EEnter (EVar x) f [] es) + = k2cExp2 (ESel (EVar x) f) <> parens (commasep k2cExp (EVar x : es))+k2cExp2 (ECall (Prim IndexArray _) [] [_,e1,e2])+ = k2cExp2 e1 <> text "->elems[" <> k2cExp e2 <> text "]"+k2cExp2 (ECall (Prim SizeArray _) [] [_,e])+ = k2cExp2 e<> text "->size"+k2cExp2 e@(ECall x [] es)+ | not (isInfix x) = k2cName x <> parens (commasep k2cExp es)+k2cExp2 EThis = internalError0 "k2cExp'"+k2cExp2 e = parens (k2cExp e)+++k2cName (Prim p _) = k2cPrim p+k2cName n = prId3 n+++k2cPrim IntPlus = text "+"+k2cPrim IntMinus = text "-"+k2cPrim IntTimes = text "*"+k2cPrim IntDiv = text "/"+k2cPrim IntMod = text "%"+k2cPrim IntNeg = text "-"++k2cPrim IntEQ = text "=="+k2cPrim IntNE = text "!="+k2cPrim IntLT = text "<"+k2cPrim IntLE = text "<="+k2cPrim IntGE = text ">="+k2cPrim IntGT = text ">"+ +k2cPrim FloatPlus = text "+"+k2cPrim FloatMinus = text "-"+k2cPrim FloatTimes = text "*"+k2cPrim FloatDiv = text "/"+k2cPrim FloatNeg = text "-"+ +k2cPrim FloatEQ = text "=="+k2cPrim FloatNE = text "!="+k2cPrim FloatLT = text "<"+k2cPrim FloatLE = text "<="+k2cPrim FloatGE = text ">="+k2cPrim FloatGT = text ">"++k2cPrim AND8 = text "&"+k2cPrim OR8 = text "|"+k2cPrim EXOR8 = text "^"+k2cPrim SHIFTL8 = text "<<"+k2cPrim SHIFTR8 = text ">>"+k2cPrim NOT8 = text "~"+ +k2cPrim AND16 = text "&"+k2cPrim OR16 = text "|"+k2cPrim EXOR16 = text "^"+k2cPrim SHIFTL16 = text "<<"+k2cPrim SHIFTR16 = text ">>"+k2cPrim NOT16 = text "~"+ +k2cPrim AND32 = text "&"+k2cPrim OR32 = text "|"+k2cPrim EXOR32 = text "^"+k2cPrim SHIFTL32 = text "<<"+k2cPrim SHIFTR32 = text ">>"+k2cPrim NOT32 = text "~"++k2cPrim IntToFloat = text "(Float)"+k2cPrim FloatToInt = text "(Int)"++k2cPrim CharToInt = text "(Int)"+k2cPrim IntToChar = text "(Char)"++k2cPrim LazyOr = text "||"+k2cPrim LazyAnd = text "&&"++k2cPrim PidEQ = text "=="+k2cPrim PidNE = text "!="+{-* +k2cPrim Sec = text "SEC"+k2cPrim Millisec = text "MILLISEC"+k2cPrim Microsec = text "MICROSEC"+k2cPrim Nanosec = text "NANOSEC"+-}+k2cPrim Infinity = text "Infinity"+k2cPrim Raise = text "Raise"+--k2cPrim Catch = text "Catch"+{- +k2cPrim TimePlus = text "TPLUS"+k2cPrim TimeMinus = text "TMINUS"+k2cPrim TimeMin = text "TMIN"+ +k2cPrim TimeEQ = text "=="+k2cPrim TimeNE = text "!="+k2cPrim TimeLT = text "<"+k2cPrim TimeLE = text "<="+k2cPrim TimeGE = text ">="+k2cPrim TimeGT = text ">"+-}+k2cPrim Abort = text "ABORT"++k2cPrim p = text (strRep2 p)
+ src/Kindlered.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE PatternGuards #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Kindlered where+ +import Monad+import Common+import Kindle+import PP+++kindlered ds m = redModule ds m+++data Env = Env { decls :: Decls }++nullEnv = Env { decls = [] }++addDecls ds env = env { decls = ds ++ decls env }++findSel env l = head [ t | (_,Struct _ te _) <- decls env, (l',t) <- te, l'==l ]+++-- Convert a module+redModule dsi (Module m ns ds bs) = do bs <- mapM (redBind env0) bs+ return (Module m ns ds bs)+ where env0 = addDecls (ds++dsi) nullEnv+++-- Convert a binding+redBind env (x, Fun vs t te c) = do c <- redCmd env c+ return (x, Fun vs t te c)+redBind env (x, Val t e) = do e <- redExp env e+ return (x, Val t e)+++single x e = length (filter (==x) (evars e)) == 1++newRef (ENew (Prim Ref _) _ _) = True+newRef _ = False++-- Convert a command+redCmd env c+ | not (null es) = liftM CRaise (redExp env (head es))+ where es = raises (subexps c)+redCmd env (CRet e) = do e <- redExp env e+ redRet env e+redCmd env e0@(CBind False [(x,Val _ e)] (CRet e'))+ | single x e' && not (newRef e) = redCmd env (CRet (subst [(x,e)] e'))+redCmd env (CBind r bs c) = liftM2 (CBind r) (mapM (redBind env) bs) (redCmd env c)+redCmd env (CRun e c) = liftM2 CRun (redExp env e) (redCmd env c)+redCmd env (CUpd x e c) = liftM2 (CUpd x) (redExp env e) (redCmd env c)+redCmd env (CUpdS e x v c) = do f <- redAssign env (arrayDepth t) (ESel e x) v+ liftM f (redCmd env c)+ where ValT t = findSel env x+redCmd env (CUpdA e i e' c) = do e <- redExp env e+ liftM2 (CUpdA e i) (redExp env e') (redCmd env c)+redCmd env (CSwitch e alts) = liftM2 CSwitch (redExp env e) (mapM (redAlt env) alts)+redCmd env (CSeq c c') = liftM2 CSeq (redCmd env c) (redCmd env c')+redCmd env (CBreak) = return CBreak+redCmd env (CRaise e) = liftM CRaise (redExp env e)+redCmd env (CWhile e c c') = liftM3 CWhile (redExp env e) (redCmd env c) (redCmd env c')+redCmd env (CCont) = return CCont+++redRet env (EEnter e f ts es) = do c <- redRet env e+ return (cMap (ff env f ts es) c)+redRet env e = return (CRet e)+++ff env f ts es (ENew n _ bs) = subst (vs `zip` ts) (subst (dom te `zip` es) c)+ where Fun vs t te c = lookup' bs f+ff env f ts es e = CRet (EEnter e f ts es)++++-- Convert a switch alternative+redAlt env (ACon x vs te c) = liftM (ACon x vs te) (redCmd env c)+redAlt env (ALit l c) = liftM (ALit l) (redCmd env c)+redAlt env (AWild c) = liftM AWild (redCmd env c)+++++-- Convert an expression+redExp env (EEnter e f ts es) = do e <- redExp env e+ es <- mapM (redExp env) es+ redEnter env e f ts es+redExp env e@(ECall (Prim IndexArray _) _ _)+ = redIndexArray env e 0+redExp env (ECall p@(Prim SizeArray _) [t] [e])+ = liftM (ECall p [t] . (:[])) (redExp' env e)+redExp env (ECall x ts es) = do es <- mapM (redExp env) es+ return (ECall x ts es)+redExp env (ENew n ts bs) = do bs <- mapM (redBind env) bs+ redNew env n ts bs+redExp env (EVar x) = return (EVar x)+redExp env (EThis) = return (EThis)+redExp env (ELit l) = return (ELit l)+redExp env a@(ESel e l)+ | stateVar (annot l) = redIndexArray env a 0+ | otherwise = liftM (flip ESel l) (redExp env e)+redExp env (ECast t e) = liftM (ECast t) (redExp env e)+++redEnter env e@(ENew n _ bs) f ts es = case c of+ CRet e' -> return (subst (vs `zip` ts) (subst (dom te `zip` es) e'))+ _ -> return (EEnter e f ts es)+ where Fun vs t te c = lookup' bs f+redEnter env e f ts es = return (EEnter e f ts es)+++redNew env n _ [(Prim Code _, Fun vs _ te (CRet (EEnter e (Prim Code _) ts es)))]+ | ts == map tVar vs && es == map EVar (dom te)+ = return e+redNew env n ts bs = return (ENew n ts bs)+++-- Convert an expression in a safe context (no cloning needed)+redExp' env (ECast t e) = liftM (ECast t) (redExp' env e)+redExp' env (ESel e l) = liftM (flip ESel l) (redExp env e)+redExp' env e = redExp env e+++-- Convert an array indexing expression+redIndexArray env (ECall (Prim IndexArray _) [t] [a,i]) n+ = do a <- redIndexArray env a (n+1)+ i <- redExp env i+ return (indexArray t a i)+redIndexArray env (ESel e l) n+ | stateVar (annot l) = do e <- redExp env e+ return (clone (arrayDepth t - n) t (ESel e l))+ where ValT t = findSel env l+redIndexArray env a n = redExp env a+++indexArray t a i = ECall (prim IndexArray) [t] [a,i]+++intExp i = ELit (lInt i)++arrayDepth (TCon (Prim Array _) [t]) = 1 + arrayDepth t+arrayDepth _ = 0++clone 0 t e = e+clone 1 t e@(ECall (Prim p _) _ _)+ | p `elem` [ListArray,UniArray] = e+clone _ t e@(ECall (Prim p _) _ _)+ | p `elem` [EmptyArray,SizeArray] = e+clone n t (ECall (Prim CloneArray _) _ [e,ELit (LInt _ n')])+ | toInteger n == n' = e+clone n t e = (ECall (prim CloneArray) [stripArray n t] [e, intExp n])++stripArray 0 t = t+stripArray n (TCon (Prim Array _) [t]) = stripArray (n-1) t++{-+ a|x|y|z := e+ a|x|y := a|x|y \\ (z,e)+ a|x := a|x \\ (y, a|x|y \\ (z,e))+ a := a \\ (x, a|x \\ (y, a|x|y \\ (z,e)))+-}++redAssign env n e0 (ECall (Prim UpdateArray _) [t] [a,i,v])+ | e0 == a = redAssign env (n-1) (indexArray t a i) v+ | otherwise = do f1 <- redAssign env n e0 a+ f2 <- redAssign env (n-1) (indexArray t e0 i) v+ return (f1 . f2)+redAssign env n e0 (ECall (Prim ListArray _) [t] [e])+ | Just es <- constElems e, + let m = length es = do f <- redAssign env n e0 (ECall (prim EmptyArray) [t] [ELit (lInt (toInteger m))])+ fs <- mapM mkAssign ([0..] `zip` es)+ return (foldl (.) f fs)+ where constElems (ENew (Prim CONS _) _ bs)+ = do es <- constElems eb+ return (ea:es)+ where Val _ ea = lookup' bs (head abcSupply)+ Val _ eb = lookup' bs (head (tail abcSupply))+ constElems (ENew (Prim NIL _) _ bs)+ = Just []+ constElems _ = Nothing+ mkAssign (i,e) = redAssign env (n-1) (indexArray t e0 (intExp i)) e+redAssign env n e0 (ECall (Prim UniArray _) [t] [m,e])+ = do x <- newName tempSym+ s <- newName tempSym+ i <- newName paramSym+ let f0 = cBind [(x,Val t e),(s,Val tInt m),(i,Val tInt (intExp 0))]+ f <- redAssign env n e0 (ECall (prim EmptyArray) [t] [EVar s])+ let f1 c = CWhile (ECall (prim IntLT) [] [EVar i, EVar s]) c+ f2 <- redAssign env (n-1) (indexArray t e0 (EVar i)) (EVar x)+ let c = CUpd i (ECall (prim IntPlus) [] [EVar i, intExp 1]) CCont+ return (f0 . f . f1 (f2 c))+redAssign env n (ESel e x) v = do v' <- redExp env v+ return (CUpdS e x (clone n t v'))+ where ValT t = findSel env x+redAssign env n (ECall (Prim IndexArray _) [t] [e,i]) v+ = do v' <- redExp env v+ return (CUpdA e i (clone n t v'))+
+ src/Lambdalift.hs view
@@ -0,0 +1,182 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Lambdalift(lambdalift) where++import Monad+import Common+import Kindle+import PP+++lambdalift ds m = localStore (llModule ds m)+++data Env = Env { decls :: Decls, -- global type declarations+ thisVars :: [Name], -- variables reachable through "this"+ locals :: ATEnv, -- non-global value names in scope+ expansions :: Map Name ([Name],[Name]) -- non-global functions and their added type/term parameters+ }++nullEnv = Env { decls = primDecls, + thisVars = [],+ locals = [],+ expansions = []+ }++addDecls ds env = env { decls = ds ++ decls env }++setThisVars xs env = env { thisVars = xs }++addLocals te env = env { locals = te ++ locals env }++addExpansions exps env = env { expansions = exps ++ expansions env }+++-- Convert a module+llModule dsi (Module m ns ds bs) = do bs <- mapM (llBind env0) bs+ s <- currentStore+ return (Module m ns (ds ++ declsOfStore s) (bs ++ bindsOfStore s))+ where env0 = addDecls (ds ++ dsi) nullEnv+++declsOfStore s = [ d | Left d <- s ]++bindsOfStore s = [ b | Right b <- s ]+++-- Convert a binding+llBind env (x, Fun vs t te c) = do c <- llCmd (addLocals te env) c+ return (x, Fun vs t te c)+llBind env (x, Val t e) = do e <- llExp env e+ return (x, Val t e)+++{- Lambda-lifting a set of recursive bindings:++ \v -> letrec f r v x = ... r ... v ...+ letrec f x = ... r ... v ... g r v y = ... f r v e ...+ r = { a = ... g e ... } ==> in \v ->+ g y = ... f e ... letrec r = { a = ... g r v e ... }+ in f e in f r v e+-}++{- Closing a struct with function fields:++ \v -> \v ->+ { f x = ... v ... { f x = ... this.v ...+ w = ... v ... } ==> w = ... v ...+ v = v }+-}++-- Convert a command+llCmd env (CBind r bs c) = do vals' <- mapM (llBind env') vals+ funs' <- mapM (llBind (setThisVars [] env')) funs+ mapM_ liftFun funs'+ c' <- llCmd env2 c+ return (cBindR r vals' c')+ where (vals,funs) = partition isVal bs+ free0 = evars funs+ free1 = free0 ++ concat [ xs | (f,(_,xs)) <- expansions env, f `elem` free0 ]+ fte = locals (if r then env1 else env) `restrict` free1+ tvs = nub (typevars funs ++ typevars fte)+ env1 = addLocals (mapSnd typeOf' vals) env+ env2 = addExpansions (dom funs `zip` repeat (tvs, dom fte)) env1+ env' = if r then env2 else env+ liftFun (x, Fun vs t te c) = addToStore (Right (x, Fun (tvs++vs) t (fte++te) c))+llCmd env (CRet e) = liftM CRet (llExp env e)+llCmd env (CRun e c) = liftM2 CRun (llExp env e) (llCmd env c)+llCmd env (CUpd x e c) = liftM2 (CUpd x) (llExp env e) (llCmd env c)+llCmd env (CUpdS e x e' c) = do e <- llExp env e+ liftM2 (CUpdS e x) (llExp env e') (llCmd env c)+llCmd env (CUpdA e i e' c) = liftM4 CUpdA (llExp env e) (llExp env i) (llExp env e') (llCmd env c)+llCmd env (CSwitch e alts) = liftM2 CSwitch (llExp env e) (mapM (llAlt env) alts)+llCmd env (CSeq c c') = liftM2 CSeq (llCmd env c) (llCmd env c')+llCmd env (CBreak) = return CBreak+llCmd env (CRaise e) = liftM CRaise (llExp env e)+llCmd env (CWhile e c c') = liftM3 CWhile (llExp env e) (llCmd env c) (llCmd env c')+llCmd env (CCont) = return CCont+++-- Convert a switch alternative+llAlt env (ACon x vs te c) = liftM (ACon x vs te) (llCmd (addLocals te env) c)+llAlt env (ALit l c) = liftM (ALit l) (llCmd env c)+llAlt env (AWild c) = liftM AWild (llCmd env c)+++-- Convert an expression+llExp env (ECall x ts es) = do es <- mapM (llExp env) es+ case lookup x (expansions env) of+ Just (vs,xs) -> return (ECall x (map tVar vs ++ ts) (map (mkEVar env) xs ++ es))+ Nothing -> return (ECall x ts es)+llExp env ee@(ENew n ts bs)+ | null fte && null fvs = liftM (ENew n ts) (mapM (llBind env) bs)+ | otherwise = do n' <- extendStruct n vs fvs te (mapSnd ValT fte)+ vals' <- mapM (llBind env) vals+ funs' <- mapM (llBind (setThisVars (dom fte) env)) funs+ -- tr ("lift ENew: " ++ render (pr (TCon n ts)) ++ " fvs: " ++ show fvs ++ " new: " ++ show n')+ return (ECast (TCon n ts) (ENew n' (ts ++ map tVar fvs) (vals' ++ funs' ++ map close fte)))+ where (vals,funs) = partition isVal bs+ free0 = evars funs+ free1 = free0 ++ concat [ xs | (f,(_,xs)) <- expansions env, f `elem` free0 ]+ fte = locals env `restrict` free1+ fvs = nub (typevars funs ++ typevars fte)+ Struct vs te _ = lookup' (decls env) n -- NOTE: n can't be a tuple or a cons if fte/fvs are nonempty...+ close (x,t) = (x, Val t (mkEVar env x))+++llExp env (EVar x) = return (mkEVar env x)+llExp env (EThis) = return (EThis)+llExp env (ELit l) = return (ELit l)+llExp env (ESel e l) = liftM (flip ESel l) (llExp env e)+llExp env (EEnter e f ts es) = do e <- llExp env e+ liftM (EEnter e f ts) (mapM (llExp env) es)+llExp env (ECast t e) = liftM (ECast t) (llExp env e)+++mkEVar env x = if x `elem` thisVars env then ESel EThis x else EVar x++extendStruct n vs vs' te te'+ | not (null (intersect vs vs')) = do vs1 <- newNames tyvarSym (length vs)+ let te1 = subst (vs `zip` map tVar vs1) te+ s1 = Struct (vs1++vs') (te1++te') (Extends n)+ n <- newName typeSym+ addToStore (Left (n, s1))+ return n+ | otherwise = do s <- currentStore+ case findStruct s0 (declsOfStore s) of+ Just n -> return n+ Nothing -> do n <- newName typeSym+ addToStore (Left (n, s0))+ return n+ where s0 = Struct (vs++vs') (te++te') (Extends n)
+ src/Lexer.hs view
@@ -0,0 +1,460 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-+**************************************************************************+** This file is based on sources distributed as the haskell-src package **+**************************************************************************+The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.+-}++module Lexer (Token(..), lexer, readInteger, readNumber, readRational) where+++import ParseMonad+import Char+import Ratio+import Token+import Common+++{-++The source location, (y,x), is the coordinates of the previous token.+col is the current column in the source file. If col is 0, we are+somewhere at the beginning of the line before the first token.++Setting col to 0 is used in two places: just after emitting a virtual+close brace due to layout, so that next time through we check whether+we also need to emit a semi-colon, and at the beginning of the file,+to kick off the lexer.++-}+lexer :: (Token -> PM a) -> PM a+lexer cont =+ PM $ \input (y,x) col ->+ if col == 0 then tab y x True input col+ else tab y col False input col -- throw away old x+ where+ -- move past whitespace and comments+ tab y x bol [] col = (unPM $ cont EOF) [] (y,x) col+ tab y x bol ('\t':s) col = tab y (nextTab x) bol s col+ tab y x bol ('\n':s) col = newLine s y col+ tab y x bol ('-':'-':s) col = newLine (drop 1 (dropWhile (/= '\n') s))+ y col+ tab y x bol ('{':'-':s) col = nestedComment tab y x bol s col+ tab y x bol (c:s) col+ | isSpace c = tab y (x + 1) bol s col+ | otherwise =+ if bol then+ (unPM $ lexBOL cont) (c:s) (y,x) x+ else+ (unPM $ lexToken cont) (c:s) (y,x) x++ newLine s y col = tab (y + 1) 1 True s col+++nextTab x = x + (tab_length - (x - 1) `mod` tab_length)++{-++When we are lexing the first token of a line, check whether we need to+insert virtual semicolons or close braces due to layout.++-}+lexBOL :: (Token -> PM a) -> PM a+lexBOL cont =+ PM $ \ s loc@(y,x) col ctx ->+ if need_close_curly x ctx then + -- tr' ("layout: inserting '}' at " ++ show loc ++ "\n") $+ -- Set col to 0, indicating that we're still at the+ -- beginning of the line, in case we need a semi-colon too.+ -- Also pop the context here, so that we don't insert+ -- another close brace before the parser can pop it.+ (unPM $ cont VRightCurly) s loc 0 (tail ctx)+ else if need_semi_colon x ctx then+ -- tr' ("layout: inserting ';' at " ++ show loc ++ "\n") $+ (unPM $ cont SemiColon) s loc col ctx+ else+ (unPM $ lexToken cont) s loc col ctx+ where+ need_close_curly x [] = False+ need_close_curly x (Layout n:Layout m:_)+ | n <= m = True+ need_close_curly x (i:_) = case i of+ NoLayout -> False+ Layout n -> x < n+ RecLayout n -> False++ need_semi_colon x [] = False+ need_semi_colon x (i:_) = case i of+ NoLayout -> False+ Layout n -> x == n+ RecLayout n -> x == n+++lexToken :: (Token -> PM a) -> PM a+lexToken cont =+ PM lexToken'+ where+ lexToken' (c:s) loc@(y,x') x =+ -- trace ("lexer: y = " ++ show y ++ " x = " ++ show x ++ "\n") $ + case c of+ -- First the special symbols+ '(' -> special LeftParen+ ')' -> special RightParen+ ',' -> special Comma+ ';' -> special SemiColon+ '[' -> special LeftSquare+ ']' -> special RightSquare+ '`' -> special BackQuote+ '{' -> special LeftCurly+ '}' -> \state ->+ case state of+ (_:ctxt) ->+ special RightCurly ctxt -- pop context on }+ [] ->+ (unPM $ parseError "parse error (possibly incorrect indentation)")+ s loc x []++ '\'' -> (unPM $ lexChar cont) s loc (x + 1)+ '\"' -> (unPM $ lexString cont) s loc (x + 1)++ '_' | null s || not (isIdent (head s)) -> special Wildcard+ + c | isDigit c ->+ case lexInt (c:s) of+ Decimal (n, rest) ->+ case rest of+ ('.':c2:rest2) | isDigit c2 ->+ case lexFloatRest (c2:rest2) of+ Nothing -> (unPM $+ parseError "illegal float.")+ s loc x+ Just (n2,rest3) ->+ let f = n ++ ('.':n2) in+ forward (length f) (FloatTok f) rest3+ _ -> forward (length n) (IntTok n) rest+ Octal (n,rest) -> forward (length n) (IntTok n) rest+ Hexadecimal (n,rest) -> forward (length n) (IntTok n) rest++ | isLower c -> lexVarId "" c s++ | isUpper c -> lexQualName "" c s++ | isSymbol c -> lexSymbol "" c s++ | otherwise ->+ (unPM $+ parseError ("illegal character \'" +++ showLitChar c "" ++ "\'\n"))+ s loc x+ + where+ special t = forward 1 t s+ forward n t s = (unPM $ cont t) s loc (x + n)+ + join "" n = n+ join q n = q ++ '.' : n++ len "" n = length n+ len q n = length q + length n + 1++ lexFloatRest r = case span isDigit r of+ (r2, 'e':r3) -> lexFloatExp (r2 ++ "e") r3+ (r2, 'E':r3) -> lexFloatExp (r2 ++ "e") r3+ f@(r2, r3) -> Just f+ + lexFloatExp r1 ('-':r2) = lexFloatExp2 (r1 ++ "-") r2+ lexFloatExp r1 ('+':r2) = lexFloatExp2 (r1 ++ "+") r2+ lexFloatExp r1 r2 = lexFloatExp2 r1 r2++ lexFloatExp2 r1 r2 = case span isDigit r2 of+ ("", _ ) -> Nothing+ (ds, r3) -> Just (r1++ds,r3)+ + lexVarId q c s = let (vidtail, rest) = span isIdent s+ vid = c:vidtail+ l_vid = len q vid+ in+ case lookup vid reserved_ids of+ Just keyword -> case q of+ "" -> forward l_vid keyword rest+ _ -> (unPM $ parseError "illegal qualified name") s loc x+ Nothing -> forward l_vid (VarId (q,vid)) rest++ lexQualName q c s = let (contail, rest) = span isIdent s+ con = join q (c:contail)+ l_con = length con+ in case rest of+ '.': c' : rest'+ | isUpper c' -> lexQualName con c' rest'+ | isLower c' -> lexVarId con c' rest'+ | isSymbol c' -> lexSymbol con c' rest'+ | otherwise -> (unPM $ parseError "illegal qualified name") s loc x+ _ -> forward l_con (ConId (q,c:contail)) rest+ + lexSymbol q c s = let (symtail, rest) = span isSymbol s+ sym = c:symtail+ l_sym = len q sym+ in case lookup sym reserved_ops of+ Just t -> case q of+ "" -> forward l_sym t rest+ _ -> (unPM $ parseError "illegal qualified name") s loc x+ Nothing -> case c of+ ':' -> forward l_sym (ConSym (q,sym)) rest+ _ -> forward l_sym (VarSym (q,sym)) rest+ + + lexToken' _ _ _ =+ internalError0 "Lexer.lexToken: empty input stream."+++lexInt ('0':o:d:r) | toLower o == 'o' && isOctDigit d+ = let (ds, rs) = span isOctDigit r+ in+ Octal ('0':'o':d:ds, rs)+lexInt ('0':x:d:r) | toLower x == 'x' && isHexDigit d+ = let (ds, rs) = span isHexDigit r+ in + Hexadecimal ('0':'x':d:ds, rs)+lexInt r = Decimal (span isDigit r)+++lexChar :: (Token -> PM a) -> PM a+lexChar cont = PM lexChar'+ where+ lexChar' s loc@(y,_) x =+ case s of+ '\\':s ->+ let (e, s2, i) =+ runPM (escapeChar s) "" loc x []+ in+ charEnd e s2 loc (x + i)+ c:s -> charEnd c s loc (x + 1)+ [] -> internalError0 "Lexer.lexChar: empty list."++ charEnd c ('\'':s) =+ \loc x -> (unPM $ cont (Character c)) s loc (x + 1)+ charEnd c s =+ (unPM $ parseError "improperly terminated character constant.") s +++lexString :: (Token -> PM a) -> PM a+lexString cont = PM lexString'+ where+ lexString' s loc@(y',_) x = loop "" s x y'+ where+ loop e s x y =+ case s of+ '\\':'&':s -> loop e s (x+2) y+ '\\':c:s | isSpace c -> stringGap e s (x + 2) y+ | otherwise ->+ let (e', sr, i) =+ runPM (escapeChar (c:s)) "" loc x [] + in+ loop (e':e) sr (x+i) y+ '\"':s{-"-} -> (unPM $ cont (StringTok (reverse e))) s loc (x + 1)+ c:s -> loop (c:e) s (x + 1) y+ [] -> (unPM $ parseError "improperly terminated string.")+ s loc x++ stringGap e s x y =+ case s of+ '\n':s -> stringGap e s 1 (y + 1)+ '\\':s -> loop e s (x + 1) y+ c:s' | isSpace c -> stringGap e s' (x + 1) y+ | otherwise ->+ (unPM $ parseError "illegal character in string gap.")+ s loc x+ [] -> internalError0 "Lexer.stringGap: empty list."+++escapeChar :: String -> PM (Char, String, Int)+escapeChar s = case s of+ 'a':s -> return ('\a', s, 2)+ 'b':s -> return ('\b', s, 2)+ 'f':s -> return ('\f', s, 2)+ 'n':s -> return ('\n', s, 2)+ 'r':s -> return ('\r', s, 2)+ 't':s -> return ('\t', s, 2)+ 'v':s -> return ('\v', s, 2)+ '\\':s -> return ('\\', s, 2)+ '"':s -> return ('\"', s, 2) -- "+ '\'':s -> return ('\'', s, 2)++ '^':x@(c:s) -> cntrl x+ 'N':'U':'L':s -> return ('\NUL', s, 4)+ 'S':'O':'H':s -> return ('\SOH', s, 4)+ 'S':'T':'X':s -> return ('\STX', s, 4)+ 'E':'T':'X':s -> return ('\ETX', s, 4)+ 'E':'O':'T':s -> return ('\EOT', s, 4)+ 'E':'N':'Q':s -> return ('\ENQ', s, 4)+ 'A':'C':'K':s -> return ('\ACK', s, 4)+ 'B':'E':'L':s -> return ('\BEL', s, 4)+ 'B':'S':s -> return ('\BS', s, 3)+ 'H':'T':s -> return ('\HT', s, 3)+ 'L':'F':s -> return ('\LF', s, 3)+ 'V':'T':s -> return ('\VT', s, 3)+ 'F':'F':s -> return ('\FF', s, 3)+ 'C':'R':s -> return ('\CR', s, 3)+ 'S':'O':s -> return ('\SO', s, 3)+ 'S':'I':s -> return ('\SI', s, 3)+ 'D':'L':'E':s -> return ('\DLE', s, 4)+ 'D':'C':'1':s -> return ('\DC1', s, 4)+ 'D':'C':'2':s -> return ('\DC2', s, 4)+ 'D':'C':'3':s -> return ('\DC3', s, 4)+ 'D':'C':'4':s -> return ('\DC4', s, 4)+ 'N':'A':'K':s -> return ('\NAK', s, 4)+ 'S':'Y':'N':s -> return ('\SYN', s, 4)+ 'E':'T':'B':s -> return ('\ETB', s, 4)+ 'C':'A':'N':s -> return ('\CAN', s, 4)+ 'E':'M':s -> return ('\EM', s, 3)+ 'S':'U':'B':s -> return ('\SUB', s, 4)+ 'E':'S':'C':s -> return ('\ESC', s, 4)+ 'F':'S':s -> return ('\FS', s, 3)+ 'G':'S':s -> return ('\GS', s, 3)+ 'R':'S':s -> return ('\RS', s, 3)+ 'U':'S':s -> return ('\US', s, 3)+ 'S':'P':s -> return ('\SP', s, 3)+ 'D':'E':'L':s -> return ('\DEL', s, 4)+++ -- Depending upon the compiler/interpreter's Char type, these yield either+ -- just 8-bit ISO-8859-1 or 2^16 UniCode.++ -- Octal representation of a character+ 'o':s -> let (ds, s') = span isOctDigit s+ n = readNumber 8 ds+ in + numberToChar n s' (length ds + 1)++ -- Hexadecimal representation of a character+ 'x':s -> let (ds, s') = span isHexDigit s+ n = readNumber 16 ds+ in+ numberToChar n s' (length ds + 1)+ + -- Base 10 representation of a character+ d:s | isDigit d -> let (ds, s') = span isDigit s+ n = readNumber 10 (d:ds)+ in + numberToChar n s' (length ds + 1)++ _ -> parseError "illegal escape sequence."++ where numberToChar n s l_n =+ if n < (toInteger $ fromEnum (minBound :: Char)) ||+ n > (toInteger $ fromEnum (maxBound :: Char)) then+ parseError "illegal character literal (number out of range)."+ else+ return (chr $ fromInteger n, s, l_n)+ ++cntrl :: String -> PM (Char, String, Int)+cntrl (c :s) | isUpper c = return (chr (ord c - ord 'A'), s, 2)+cntrl ('@' :s) = return ('\^@', s, 2)+cntrl ('[' :s) = return ('\^[', s, 2)+cntrl ('\\':s) = return ('\^\', s, 2)+cntrl (']' :s) = return ('\^]', s, 2)+cntrl ('^' :s) = return ('\^^', s, 2)+cntrl ('_' :s) = return ('\^_', s, 2)+cntrl _ = parseError "illegal control character"+++nestedComment cont y x bol s col =+ case s of+ '-':'}':s -> cont y (x + 2) bol s col+ '{':'-':s -> nestedComment (nestedComment cont) y (x + 2) bol s col+ '\t':s -> nestedComment cont y (nextTab x) bol s col+ '\n':s -> nestedComment cont (y + 1) 1 True s col+ c:s -> nestedComment cont y (x + 1) bol s col+ [] -> error "Open comment at end of file"++++readInteger :: String -> Integer+readInteger ('0':'o':ds) = readInteger2 8 isOctDigit ds+readInteger ('0':'O':ds) = readInteger2 8 isOctDigit ds+readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds+readInteger ('0':'X':ds) = readInteger2 16 isHexDigit ds+readInteger ds = readInteger2 10 isDigit ds++readNumber :: Integer -> String -> Integer+readNumber radix ds = readInteger2 radix (const True) ds++readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer+readInteger2 radix isDig ds + = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) + (takeWhile isDig ds))++readRational :: String -> Rational+readRational xs+ = (readInteger (i ++ m))%1 * 10^^((case e of+ "" -> 0+ ('+':e2) -> read e2+ _ -> read e) - length m)+ where (i, r1) = span isDigit xs+ (m, r2) = span isDigit (dropWhile (== '.') r1)+ e = dropWhile (== 'e') r2+
+ src/Main.hs view
@@ -0,0 +1,448 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Main where++-- Haskell98+import System(getArgs)+import List(isSuffixOf)+import qualified Monad+import qualified Char+import qualified Control.Exception as Exception ( catch, catchJust )+import System.Console.GetOpt+import qualified Directory++-- Timber Compiler+import System.FilePath+import Config+import Execution+import PP+import Common+import Parser+import qualified Syntax+import qualified Core+import Desugar1+import Rename+import Desugar2+import Depend+import Syntax2Core+import Kind+import Type+import Termred+import Type2+import Kindle+import Kindlered+import Prepare4C+import Kindle2C+import Core2Kindle+import Lambdalift+import Data.Binary+import Interfaces+import GHC.Exception+{-++Lexer:+- Checks lexical syntax and builds token stream+- Removes comments++Parser:+- Checks basic syntax and builds parse tree+- Builds constructor syntax (parsed as qualified types)+- Resolves nested infix expressions+- Converts record labels to proper selectors (with prefix .)+- Replaces prefix tuple constructors with primitive names++Desugar1:+- Checks record type acyclicity and selector consistence+- Completes dotdot record patterns and expressions with missing fields+- Translates instance declarations into instance signatures and named record terms+- Checks and resolves if/elsif/else statements+- Makes the "self" variable explicit.+- Checks validity of return statement+- Replaces prefix expression statement with dummy generator statement+- Replaces if/case statements with corresponding expressions forms+- Checks the restricted command syntax of template bodies++Rename:+- Checks for duplicate declarations and kind signatures+- Checks for duplicate selectors and constructors, and overlaps with class members+- Checks for duplicate equations and type signatures+- Checks for duplicated variables in patterns and templates+- Checks for duplication and dandling abstractions in type predicates+- Checks for unbound variables (not yet implemented -- what to do with globals?)++- Makes every type variable binding explicit in signatures and constructor declarations+- Shuffles signatures as close as possible to the corresponding definition (incl. inside patterns)++- Renames local variables using unique names+- Renames local (explicitly quantified) type variables using unique names++Desugar2:+- Checks validity of type and type scheme syntax in signatures and declarations+- Checks qualified types for syntactic ambiguity+- Removes special syntax for list, tuple and function types, as well as subtype predicates+- Captures single-variable predicates as short-hand for wildcard kind signature+- Checks syntactic validity of patterns+- Replaces after, before, [] and (:) with primitive names+- Replaces tuple expressions with primitive constructor applications +- Translates if expressions, operator sections, negations+- Collects functions defined with multiple equations while checking arities+- Flattens pattern bindings+- Removes non-trivial patterns in lambdas, assignments and generators+- Translates list expressions/patterns and list comprehensions++- Applies pattern-matching compiler to case expressions++Syntax2Core:+- Injects instance signatures among global type signatures++- Splits predicate contexts into kind environments (quantifiers) and predicates proper (qualifiers)+- Checks validity of base type syntax in declarations+- Replaces _ kinds with unique unification variable+- Replaces _ types with unique unification variable++- Applies up/down signature propagation within constructor/selector/member/signature environment+- Completes bindings and lambdas with missing signatures++- Does dependency analysis on local bindings+- Builds Core syntax tree++Kind:+- Does dependency analysis on type declarations+- Performs kind inference, replacing every kind unification variable (defaulting to *)++Decls:+- Extracts selector and constructor type schemes+- Generates global member signatures and bindings+- Replaces subtyping in type declarations with explicit coercion constructors/selectors++- Initiate subtyping graphs with reflexivity axioms (identity witness)+- Computes subtype above & below graph, closed under transitivity (checks cyclic and ambiguity errors)+- Computes instance overlap graph, closed under superclass relation (checks cyclic and ambiguity errors)++Type:+- Does dependency analysis on top-level bindings+- Performs type inference and constraint simplification/solving+- Makes all function calls match the arity of the called function+- Inserts explicit overloading and subtyping witnesses++Termred:+- Does simple term level reduction and restricted inlining within primitive environment (witnesses only)++Core2Kindle:+- Converts type expressions by making closure types explicit+- Approximates polymorphism by the wildcard type+- Splits non-trivial datatypes into constructor records with a common tag field++- Encodes monadic code by means of extra (mutable) state argument++- Sorts equations into value or function definitions, on basis of arity+- Makes fatbar and fail pattern-matching operators explicit, removes match and commit+- Implements after and before primitives in terms of Time arithmetic+- +- Replaces act and req by calls to the rts++- Builds Kindle abstract syntax++LambdaLift:+- Abstracts out free local variables from local function definitions and adds corresponding arguments to call sites+- Abstracts out free local variables from struct functions as extra value fields referenced through "this"+- Moves local function definitions to the top level++Kindle2C:+- Makes construction of cyclic data explicit+- Pretty-prints abstract syntax as C code+++-}+++-- | This compiles a set of Timber modules. +-- | Example: 'compile ["Main"] compiles the module in Main.t+-- | leaving the result in Main.c+-- | It also compiles every module *called* by this module +-- | right now.+++compileTimber clo ifs (sm,t_file) ti_file c_file h_file+ = do let Syntax.Module n is _ _ = sm+ putStrLn ("[compiling "++ t_file++"]")+ (imps,ifs') <- chaseIfaceFiles clo is ifs+ let ((htxt,mtxt),ifc) = runM (passes imps sm)+ encodeCFile ti_file ifc+ writeFile c_file mtxt+ writeFile h_file htxt+ if api clo then do+ writeAPI (rmSuffix ".ti" ti_file) ifc+ return ((n,ifc):ifs')+ else return ((n,ifc):ifs')+ where passes imps par = do (e0,e1,e2,e3) <- initEnvs imps+ (d1,a0) <- pass clo (desugar1 e0) Desugar1 par+ rn <- pass clo (renameM e1) Rename d1+ d2 <- pass clo desugar2 Desugar2 rn+ co <- pass clo syntax2core S2C d2+ kc <- pass clo (kindcheck e2) KCheck co+ tc <- pass clo (typecheck e2) TCheck kc+ rd <- pass clo (termred e2) Termred tc+ tc2 <- pass clo (typecheck2 e2) Type2 rd+ (ki,ds) <- pass clo (core2kindle e2 e3) C2K tc2+ ki' <- pass clo (kindlered e3) Kindlered ki+ ll <- pass clo (lambdalift e3) LLift ki'+ pc <- pass clo (prepare4c e2 e3) Prepare4C ll+ c <- pass clo (kindle2c (init_order imps)) K2C pc+ return (c,ifaceMod a0 tc2 ds)++ +pass clo m p a = do -- tr ("Pass " ++ show p ++ " ...")+ r <- m a+ Monad.when (dumpAfter clo p) + $ tr ("#### Result after " ++ show p ++ ":\n\n" ++ render (pr r))+ Monad.when (stopAfter clo p)+ $ fail ("#### Terminated after " ++ show p ++ ".")+ return r ++makeProg clo cfg root = do txt <- readFile (root ++ ".t")+ let ms@(Syntax.Module n is _ _) = runM (parser txt)+ (imps,ss) <- chaseSyntaxFiles clo is [(n,ms)]+ let cs = compile_order imps+ is = filter nonDummy cs+ let ps = map (\(n,ii) -> (snd ii,modToPath (str n)++".t")) is ++ [(ms,root++".t")]+ ifs <- compileAll (clo {shortcut = True}) [] ps+ r <- checkRoot clo ifs root+ let basefiles = map (rmSuffix ".t" . snd) ps+ c_files = map (++ ".c") basefiles+ o_files = map ((++ ".o") . rmDirs) basefiles+ mapM (compileC cfg clo) c_files+ linkO cfg clo{outfile = root} r o_files+ where nonDummy (_,(_,Syntax.Module n _ _ _)) = str n /= ""+++parse clo t_file = do t_exists <- Directory.doesFileExist t_file+ Monad.when (not t_exists) (fail ("File " ++ t_file ++ " does not exist."))+ txt <- readFile t_file+ let syntax = runM (pass clo parser Parser txt)+ return (syntax,t_file)++compileAll clo ifs [] = return ifs+compileAll clo ifs (p@(ms,t_file):t_files)+ = do res <- checkUpToDate clo t_file ti_file c_file h_file (impNames ms)+ if res then do + putStrLn ("[skipping " ++ t_file ++ " (output is up to date)]")+ compileAll clo ifs t_files+ else do+ ifs' <- compileTimber clo ifs (longName p) ti_file c_file h_file+ compileAll clo ifs' t_files+ where base = rmSuffix ".t" t_file+ ti_file = base ++ ".ti"+ c_file = base ++ ".c"+ h_file = base ++ ".h"+ qm = takeBaseName t_file+ longName (Syntax.Module m a b c,t)+ |reverse(takeWhile (/= '.') (reverse qm))==str m = (Syntax.Module (name0 qm) a b c,t_file)+ |otherwise = errorIds "Module name not last constructor id in file name" [m]++checkUpToDate clo t_file ti_file c_file h_file imps+ | shortcut clo = do ti_exists <- Directory.doesFileExist ti_file+ c_exists <- Directory.doesFileExist c_file+ h_exists <- Directory.doesFileExist h_file+ if not ti_exists || not c_exists || not h_exists then + return False + else do+ t_time <- Directory.getModificationTime t_file+ ti_time <- Directory.getModificationTime ti_file+ c_time <- Directory.getModificationTime c_file+ h_time <- Directory.getModificationTime h_file+ ti_OKs <- mapM (tiOK ti_time) imps+ return (t_time < ti_time && t_time < c_time && t_time < h_time && and ti_OKs)+ | otherwise = return False+ where tiOK ti_time1 n = do let ti_file = modToPath (str n) ++ ".ti"+ ti_exists <- Directory.doesFileExist ti_file+ if (not ti_exists) then do+ let lti_file = Config.libDir clo ++ "/" ++ modToPath (str n) ++ ".ti"+ lti_exists <- Directory.doesFileExist lti_file+ if (not lti_exists) then+ internalError0 ("Cannot find interface file " ++ ti_file)+ else do lti_time <- Directory.getModificationTime lti_file+ return (lti_time <= ti_time1)+ -- return True -- library module+ else do ti_time <- Directory.getModificationTime ti_file+ return (ti_time <= ti_time1)+------------------------------------------------------------------------------++main = do args <- getArgs+ main2 args++-- | We have the second entry point so ghci/hugs users can call+-- | main2 directly with arguments.++main2 args = do (clo, files) <- Exception.catch (cmdLineOpts args)+ fatalErrorHandler+ cfg <- Exception.catch (readCfg clo)+ fatalErrorHandler++ let t_files = filter (".t" `isSuffixOf`) files+ i_files = filter (".ti" `isSuffixOf`) files+ o_files = filter (".o" `isSuffixOf`) files+ badfiles = files \\ (t_files++i_files++o_files)+ + Monad.when (not (null badfiles)) $ do+ fail ("Bad input files: " ++ showids badfiles)+ + mapM (listIface clo) i_files+-- Monad.when (null t_files) stopCompiler+ + ps <- mapM (parse clo) t_files+ ifs <- compileAll clo [] ps `Exception.catch` handleError+ Monad.when (stopAtC clo) stopCompiler+ + let root = make clo+ Monad.when (root/="") (makeProg clo cfg root)++ let basefiles = map (rmSuffix ".t") t_files+ c_files = map (++ ".c") basefiles+ mapM (compileC cfg clo) c_files+ Monad.when (stopAtO clo) stopCompiler++ let basenames = map rmDirs basefiles+ o_files' = map (++ ".o") basenames+ Monad.when(not (null basenames)) (do r <- checkRoot clo ifs (last basenames)+ linkO cfg clo r (o_files ++ o_files'))++ return ()++handleError (ErrorCall mess) = do+ putStr ("*** Timber compilation error ***\n"++mess++"\n")+ abortCompiler+++checkRoot clo ifs def = do if1 <- getIFile rootMod+ if2 <- getIFile rtsMod + let ts = tEnv if2+ ke = Core.ksigsOf ts+ ds = Core.tdefsOf ts+ te = Core.tsigsOf (valEnv if1)+ case lookup rootT ke of+ Nothing -> fail ("Cannot locate RootType in module " ++ rtsMod)+ Just Star -> case lookup rootT ds of+ Nothing -> error "Internal: checkRoot"+ Just (Core.DType _ t') -> checkRoot' te t'+ Just _ -> checkRoot' te (Core.TId rootT)+ Just _ -> fail ("Bad RootType in module " ++ rtsMod)+ + where rtsMod = target clo+ (r,rootMod) = splitQual (root clo) def+ rootN = qName rootMod (name0 r)+ rootT = qName rtsMod (name0 "RootType")+ checkRoot' te t0 = case [ (n,sc) | (n,sc) <- te, n == rootN ] of+ [(n,sc)] -> if Core.sameType sc t0+ then return n+ else fail ("Incorrect root type: " ++ render (pr sc) ++ "; should be " ++ render(pr t0))+ _ -> fail ("Cannot locate root " ++ (root clo) ++ " in module " ++ rootMod)+ getIFile m = case lookup (name0 m) ifs of+ Just ifc -> return ifc+ Nothing -> do (ifc,_) <- decodeModule clo (modToPath m ++ ".ti")+ return ifc++------------------------------------------------------------------------------++-- | Catch internal errors, print them and then abortCompiler.+fatalErrorHandler :: TimbercException -> IO a+fatalErrorHandler e = do putStrLn (show e)+ abortCompiler++++++-- Getting import info ---------------------------------------------------------+++chaseImps :: (String -> IO (a,String)) -> (Bool -> a -> [(Name,Bool)]) -> String -> [Syntax.Import] -> Map Name a -> IO (Map Name (ImportInfo a), Map Name a)+chaseImps readModule iNames suff imps ifs + = do bms <- mapM (readImport ifs) imps+ let newpairs = [p | (p,True) <- bms]+ ifs1 = [(c,ifc) | (c,(_,ifc)) <- newpairs] ++ ifs+ chaseRecursively ifs1 (map fst bms) (concat [ iNames b c | ((_,(b,c)),_) <- bms ])+ where readIfile ifs c = case lookup c ifs of+ Just ifc -> return (ifc,False)+ Nothing -> do (ifc,f) <- readModule f+ return (ifc,True)+ where f = modToPath(str c) ++ suff+ readImport ifs (Syntax.Import b c) + = do (ifc,isNew) <- readIfile ifs c+ return ((c,(b,ifc)),isNew)+ chaseRecursively ifs ms []= return (ms,ifs)+ chaseRecursively ifs ms (p@(r,unQual) : rs)+ = case lookup r ms of+ Just (b,_) + | not b && unQual -> chaseRecursively ifs (update r ms) rs -- found import chain; previously only use chain+ | otherwise -> chaseRecursively ifs ms rs+ Nothing -> do (ifc,isNew) <- readIfile ifs r+ chaseRecursively (if isNew then (r,ifc) : ifs else ifs) ((r,(unQual,ifc)) : ms) (rs ++ iNames unQual ifc)+ update r ((r',(_,ifc)) : ps)+ | r == r' = (r,(True,ifc)) : ps+ update r (p : ps) = p : update r ps+ update _ [] = internalError0 "Main.update: did not find module"+ +++chaseIfaceFiles clo = chaseImps (decodeModule clo) impsOf2 ".ti"+ where impsOf2 b i = map (\(b',c) -> (c,b && b')) (impsOf i)+ +impName (Syntax.Import b c) = c+impNames (Syntax.Module _ is _ _) = map impName is++impNames2 b (Syntax.Module _ is _ _) + = map (\(Syntax.Import b' c) -> (c,b && b')) is++chaseSyntaxFiles clo = chaseImps readSyntax impNames2 ".t"+ where readSyntax f = (do cont <- readFile f+ let sm = runM (parser cont)+ return (sm,f)) `catch` (\ e -> do let libf = Config.libDir clo ++ "/" ++ f+ t_exists <- Directory.doesFileExist libf+ if t_exists + then return (Syntax.Module (name0 "") [] [] [],libf) + else fail ("File "++ f ++ " does not exist."))+ ++transImps (_,ifc) = map snd (impsOf ifc)++compile_order imps = case topSort (impNames . snd) imps of + Left ms -> errorIds "Mutually recursive modules" ms+ Right is -> is++init_order imps = case topSort transImps imps of+ Left ms -> errorIds "Mutually recursive modules" ms+ Right is -> map fst is++
+ src/Match.hs view
@@ -0,0 +1,175 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Match where++import Common+import Syntax+import Monad+import qualified List++pmc :: Exp -> [Alt Exp] -> M s Exp+pmc e alts = do e' <- match0 e alts+ return (eMatch e')++pmc' :: [Name] -> [([Pat],Rhs Exp)] -> M s Exp+pmc' ws eqs = do e <- match ws eqs+ return (eMatch e)+++-- The primitive pmc constants -----------------------------------------------------------++eFatbar (EVar (Prim Fail _)) e = e+eFatbar e (EVar (Prim Fail _)) = e+eFatbar e e' = foldl EAp (EVar (prim Fatbar)) [e,e']+eFail = EVar (prim Fail)+eCommit e = EAp (EVar (prim Commit)) e+eMatch e = case e of+ EAp (EVar (Prim Commit _)) e' -> e'+ ELet bs (EAp (EVar (Prim Commit _)) e') -> ELet bs e'+ _ -> EAp (EVar (prim Match)) e+++fat [] = return eFail+fat [m] = m+fat (m:ms) = do e1 <- m+ e2 <- fat ms+ return (eFatbar e1 e2)+++-- Pattern-matching compiler proper -----------------------------------------------------++match0 (EVar w) alts = match [w] [ ([p], rh) | Alt p rh <- alts ]+match0 e alts+ | all isTriv alts = return (ECase e [ Alt p (RExp (eCommit e)) | Alt p (RExp e) <- alts ])+ | otherwise = do w <- newNamePos tempSym e+ e' <- match0 (EVar w) alts+ return (ELet [BEqn (LFun w []) (RExp e)] e')+ where isTriv (Alt (ECon _) (RExp _)) = True+ isTriv _ = False+++match ws eqs = fat (match1 ws eqs)++match1 ws [] = []+match1 [] (([],rhs):eqs) = matchRhs rhs : match1 [] eqs+match1 (w:ws) eqs+ | all isVarEq eqs = match1 ws (map f eqs)+ where f (EVar v : ps, rh) = (ps, subst (v +-> EVar w) rh)+match1 ws (eq:eqs)+ | isSigVarEq eq = matchVar ws eq : match1 ws eqs+ | isLitEq eq = matchLits ws [eq] eqs+ | isERecEq eq = matchRecs ws [eq] eqs+ | otherwise = matchCons ws [prepConEq eq] eqs+++isLitEq (p:ps,rh) = isELit p++isVarEq (p:ps,rh) = isEVar p++isSigVarEq (p:ps,rh) = isESigVar p++isERecEq (p:ps,rh) = isERec p++isConEq (p:ps,rh) = isEConApp p++++matchVar (w:ws) (EVar v:ps, rh) = match ws [(ps, subst (v +-> EVar w) rh)]+matchVar (w:ws) (ESig (EVar v) t : ps, rh)+ = match ws [(ps, RWhere rh bs)]+ where bs = [BSig [v] t, BEqn (LFun v []) (RExp (EVar w))]+++matchLits ws eqs (eq:eqs')+ | isLitEq eq = matchLits ws (eq:eqs) eqs'+matchLits ws eqs eqs' = matchLit ws (reverse eqs) : match1 ws eqs'+++matchLit (w:ws) eqs = do alts <- mapM matchAlt lits+ return (ECase (EVar w) alts)+ where lits = nub [ l | (ELit l : ps, rhs) <- eqs ]+ matchAlt l = do e' <- match ws eqs'+ return (Alt (ELit l) (RExp e'))+ where eqs' = [ (ps,rhs) | (ELit l' : ps, rhs) <- eqs, l'==l ]++matchRecs ws eqs (eq:eqs')+ | isERecEq eq = matchRecs ws (eq:eqs) eqs'+matchRecs ws eqs eqs' = matchRec ws (reverse eqs) : match1 ws eqs'++matchRec (w:ws) eqs = do vs <- newNamesPos tempSym fs+ e <- match (vs ++ ws) (map matchAlt eqs)+ return (foldr ELet e (zipWith mkEqn vs fs))+ where ERec _ fs = head (fst (head eqs))+ mkEqn v (Field l _) = [BEqn (LFun v []) (RExp (ESelect (EVar w) l))]+ matchAlt (ERec _ fs:ps,rh)+ = (map patOf fs++ps,rh)+ patOf (Field _ p) = p+ +prepConEq (p:ps,rhs) = (c, ps', ps, rhs)+ where (ECon c, ps') = eFlat p+++matchCons ws ceqs (eq:eqs')+ | isConEq eq = matchCons ws (prepConEq eq : ceqs) eqs'+matchCons ws ceqs eqs' = matchCon ws (reverse ceqs) : match1 ws eqs'+++matchCon (w:ws) ceqs = do alts <- mapM matchAlt cs+ return (ECase (EVar w) alts)+ where cs = nub [ c | (c,_,_,_) <- ceqs ]+ matchAlt c = do vs <- newNamesPos tempSym (maxPat [] 0 eqs_c)+ e <- match (vs++ws) (map (mkeq vs) eqs_c)+ return (Alt (ECon c) (RExp (eLam (map EVar vs) e)))+ where eqs_c = [ (ps', ps, rhs) | (c',ps',ps,rhs) <- ceqs, c==c' ]+ maxPat ps _ [] = ps+ maxPat ps n ((ps',_,_) : ceqs)+ |length ps' > n = maxPat ps' (length ps') ceqs+ |otherwise = maxPat ps n ceqs+-- arity_c = maximum [ length ps' | (ps', ps, rhs) <- eqs_c ]+ mkeq vs (ps',ps,rhs) = (ps'++vs' ++ ps, rAp rhs vs')+ where vs' = map EVar (drop (length ps') vs)+++matchRhs (RExp e) = return (eCommit e)+matchRhs (RWhere rhs bs) = do e <- matchRhs rhs+ return (ELet bs e)+matchRhs (RGrd gs) = fat [ matchQuals qs e | GExp qs e <- gs ]+++matchQuals [] e = return (eCommit e)+matchQuals (QGen p e' : qs) e = match0 e' [Alt p (RGrd [GExp qs e])]+matchQuals (QLet bs : qs) e = do e' <- matchQuals qs e+ return (ELet bs e')+matchQuals (QExp e' : qs) e = matchQuals (QGen true e' : qs) e+
+ src/Name.hs view
@@ -0,0 +1,619 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Name where++import Debug.Trace+import List+import PP+import Token+import Char+import Maybe+import Data.Binary ++-- The type of names ---------------------------------------------------------------------++data Name = Name { str :: String, tag :: Int, fromMod :: Maybe String, annot :: Annot }+ | Prim { con :: Prim, annot :: Annot }+ | Tuple { width :: Int, annot :: Annot }+++data Annot = Annot { location :: Maybe (Int,Int), + explicit :: Bool, + stateVar :: Bool , + generated :: Bool,+ suppressMod :: Bool+ }+ deriving Show+++-- The built-in primitives ----------------------------------------------------------------++data Prim = ++ -- Constructor identifiers++ MIN____TYPE++ | Action -- Types+ | Request+ | Class+ | Cmd++ | Msg+ | Ref+ | PID+ | PMC+ | Time++ | Int+ | Float+ | Char+ | Bool++ | BITS8+ | BITS16+ | BITS32++ | Array+ | EITHER++ -- Constructor symbols (special syntax)++ | LIST -- Type+ | UNITTYPE -- Type+ | TIMERTYPE ++ | MAX____TYPE+ + | MIN____CONS+ + | UNITTERM -- Term+ | NIL -- Term+ | CONS -- Term++ -- Constructor identifiers++ | FALSE -- Terms+ | TRUE+ | LEFT+ | RIGHT++ | MAX____CONS+ | MIN____SELS++ | Reset+ | Sample+ + | MAX____SELS+ + -- Variable identifiers++ | MIN____VAR+ + | Refl -- Terms++ | MIN____KINDLE_INFIX+ + | IntPlus+ | IntMinus+ | IntTimes+ | IntDiv+ | IntMod++ | IntEQ+ | IntNE+ | IntLT+ | IntLE+ | IntGE+ | IntGT+ + | FloatPlus+ | FloatMinus+ | FloatTimes+ | FloatDiv+ + | FloatEQ+ | FloatNE+ | FloatLT+ | FloatLE+ | FloatGE+ | FloatGT++ | PidEQ+ | PidNE+ + | LazyOr+ | LazyAnd++ | AND8+ | OR8+ | EXOR8+ | SHIFTL8+ | SHIFTR8+ + | AND16+ | OR16+ | EXOR16+ | SHIFTL16+ | SHIFTR16+ + | AND32+ | OR32+ | EXOR32+ | SHIFTL32+ | SHIFTR32++ | MAX____KINDLE_INFIX++ | SHIFTRA8+ | SET8+ | CLR8+ | TST8++ | SHIFTRA16+ | SET16+ | CLR16+ | TST16++ | SHIFTRA32+ | SET32+ | CLR32+ | TST32++ | IntNeg+ | FloatNeg++ | IntToFloat+ | FloatToInt++ | NOT8+ | NOT16+ | NOT32+ + | Sqrt+ | Log+ | Log10+ | Exp+ | Sin+ | Cos+ | Tan+ | Asin+ | Acos+ | Atan+ | Sinh+ | Cosh+ | ShowFloat++ | Sec+ | Millisec+ | Microsec+ | Nanosec+ | Infinity+ | SecOf+ | MicrosecOf+ + | TimePlus+ | TimeMinus+ | TimeMin+ + | TimeEQ+ | TimeNE+ | TimeLT+ | TimeLE+ | TimeGE+ | TimeGT++ | Raise+ | Catch+ + | ListArray+ | UniArray+ | SizeArray+ | IndexArray+ | UpdateArray+ + | MAX____KINDLEVAR++ | Abort -- Preserved in Kindle, but given new translated types+ | TIMERTERM -- -"-++ +-- transformed away during Kindle conversion ----------------------------------------------------++ | ActToCmd+ | ReqToCmd+ | RefToPID++ | CharToInt+ | IntToChar++ | BITS8ToInt+ | BITS16ToInt+ | BITS32ToInt+ + | IntToBITS8+ | IntToBITS16+ | IntToBITS32+ + | MAX____VAR++-- invisible ------------------------------------------------------------------------------------++ | MIN____INVISIBLE+ + | New -- Encoding of the class instantiation syntax in terms of an operator+ + | Fail+ | Commit+ | Match+ | Fatbar++ | After+ | Before+ + | NEWREF -- RTS entry points+ | ASYNC+ | LOCK+ | UNLOCK+ + | EmptyArray -- For efficient creation of listArrays with constant lists+ | CloneArray -- To open up for destructive updates in Kindle++ | Inherit -- default Time value++ | Tag -- common selector of datatype/constructor structs+ + | GCINFO -- first selector of all structs / node constructor in gcinfo tables+ + | STATE -- selector of primitive struct Ref+ | STATEOF -- shortcut alternative to the above+ + | Code -- selectors of primitive struct Msg+ | Baseline+ | Deadline+ | Next+ + | AbsTime -- type of selectors Baseline and Deadline+ + | POLY -- Type representing polymorhic values+ + | Float2POLY -- Conversion macros required to circumvent C casting irreguliarity+ | POLY2Float+ + | MAX____INVISIBLE+ + deriving (Eq,Ord,Enum,Bounded,Show)++minPrim = minBound :: Prim+maxPrim = maxBound :: Prim++isConPrim p = p <= MAX____CONS++invisible p = p >= MIN____INVISIBLE++doEtaExpand (Prim p _) = not (invisible p)+doEtaExpand (Tuple _ _) = True+doEtaExpand _ = False++isIdPrim p = p `notElem` primSyms++primSyms = [LIST, NIL, CONS, LazyAnd, LazyOr, IndexArray]++primTypes = map primKeyValue [MIN____TYPE .. MAX____TYPE]++primTerms = map primKeyValue ([MIN____CONS .. MAX____CONS] ++ [MIN____VAR .. MAX____VAR])++primSels = map primKeyValue [MIN____SELS .. MAX____SELS]+ +primKeyValue p = (name0 (strRep p), prim p)++rigidNames = map rigidKeyValue [IndexArray, LazyAnd, LazyOr]++rigidKeyValue p = (strRep p, prim p)++lowPrims = [New,Sec,Millisec,Microsec,Nanosec,Raise,Catch,Baseline,Deadline,Next,+ Infinity,Reset,Sample,SecOf,MicrosecOf,Abort,+ Sqrt,Log,Log10,Exp,Sin,Cos,Tan,Asin,Acos,Atan,Sinh,Cosh]++strRep LIST = "[]"+strRep EITHER = "Either"+strRep UNITTYPE = "()"+strRep UNITTERM = "()"+strRep NIL = "[]"+strRep CONS = ":"+strRep TRUE = "True"+strRep FALSE = "False"+strRep LEFT = "Left"+strRep RIGHT = "Right"+strRep LazyAnd = "&&"+strRep LazyOr = "||"+strRep IndexArray = "!"+strRep ListArray = "array"+strRep UniArray = "uniarray"+strRep SizeArray = "size"+strRep TIMERTYPE = "Timer"+strRep TIMERTERM = "timer"+strRep p = strRep2 p+ +strRep2 p+ | p `elem` lowPrims = toLower (head s) : tail s+ | isConPrim p || invisible p = s+ | otherwise = "prim" ++ s+ where s = show p+++-- Name construction -----+-------------------------------------------------------++noAnnot = Annot { location = Nothing, explicit = False, stateVar = False, + generated = False, suppressMod = False }++-- This function is used (only) by the parser to build Names+name l (q,s) = case lookup s rigidNames of+ Just n -> n + Nothing -> Name s 0 (m q) (noAnnot {location = Just l})+ where m "" = Nothing+ m q = Just q+joinString [x] = x+joinString (x : xs) = x ++ '.' : joinString xs ++dropMod n = n {fromMod = Nothing}+qName m n = n {fromMod = Just m}++-- Used for module names in import clauses+modId n@(Name _ _ Nothing _) = n+modId (Name s t (Just m) a) = Name (m++'.':s) t Nothing a++prim p = Prim p noAnnot++tuple n = Tuple n noAnnot+++splitString s = case break (=='.') s of+ (local,[]) -> [local] + (qualStart,suf) -> qualStart : splitString (tail suf)++splitQual s def = case splitString s of+ [x] -> (x, def)+ xs -> (last xs, joinString (init xs))+++tag0 (Name s t m a) = Name s 0 m a+tag0 n = n++annotExplicit n = n { annot = a { explicit = True } }+ where a = annot n++annotGenerated n = n { annot = a { generated = True } }+ where a = annot n++pos n = location (annot n)++-- Generated names ----------------------------------------------------------------++genAnnot = noAnnot { generated = True }+name0 s = Name s 0 Nothing genAnnot++++-- Textual name supply ---------------------------------------------------------------------------++abcSupply = map name0 (gensupply "abcdefghijklmnopqrstuvwxyz")++_abcSupply = map (name0 . ('_':)) (gensupply "abcdefghijklmnopqrstuvwxyz")++_ABCSupply = map (name0 . ('_':)) (gensupply "ABCDEFGHIJKLMNOPQRSTUVWXYZ")++gensupply :: [Char] -> [String]+gensupply chars = map (:"") chars ++ concat (map g [1..])+ where g n = map (replicate n) chars+++-- Internal identifier conventions -----------------------------------------------------++witnessSym = "w"+assumptionSym = "v"+tempSym = "x"+patSym = "p"+functionSym = "f"+dummySym = "d"+paramSym = "a"+etaExpSym = "eta"+tyvarSym = "t"+coercionSym = "c"+coerceLabelSym = "l"+coerceConstrSym = "K"+typeSym = "T"+stateTypeSym = "S"+skolemSym = "sk"+selfSym = "self"+thisSym = "this"+instanceSym = "inst"+closureSym = "CLOS"+tappSym = "TApp"+tabsSym = "TAbs"+gcinfoSym = "__GC__"++isWitness n = isGenerated n && str n == witnessSym+isAssumption n = isGenerated n && str n == assumptionSym+isEtaExp n = isGenerated n && str n == etaExpSym+isCoercion n = isGenerated n && str n == coercionSym+isPatTemp n = isGenerated n && str n == patSym+isClosure n = isGenerated n && isPrefixOf closureSym (str n)+isDummy n = isGenerated n && str n == dummySym+isCoerceLabel n = isGenerated n && isPrefixOf coerceLabelSym (str n)+isCoerceConstr n = isGenerated n && isPrefixOf coerceConstrSym (str n)+isTApp n = isGenerated n && str n == tappSym+isTAbs n = isGenerated n && str n == tabsSym+isGCInfo n = isGenerated n && isPrefixOf gcinfoSym (str n)++explicitSyms = [coercionSym, assumptionSym, witnessSym]+++-- Testing Names ----------------------------------------------------------------++isId (Name s _ _ _) = isIdent (head s)+isId (Tuple _ _) = True+isId (Prim p _) = isIdPrim p++isSym i = not (isId i)+++isCon (Name (c:_) _ _ _) = isIdent c && isUpper c || c == ':'+isCon (Tuple _ _) = True+isCon (Prim p _) = isConPrim p++isTuple (Tuple _ _) = True+isTuple _ = False++isVar i = not (isCon i)++isQual m n = fromMod n == Just (str m)++isGenerated (Name _ _ _ a) = generated a +isGenerated _ = False++isState n = stateVar (annot n)++isQualified (Name _ _ (Just _) _) = True+isQualified _ = False++isLocal (Name _ _ Nothing _) = True+isLocal _ = False++-- Equality & Order ----------------------------------------------------------------++instance Eq Name where+ Name a 0 Nothing _ == Name b 0 Nothing _ = a == b+ Name a s Nothing _ == Name b t Nothing _ = s == t+ Name a 0 (Just m) _ == Name b _ (Just n) _ = a == b && m == n+ Name a _ (Just m) _ == Name b 0 (Just n) _ = a == b && m == n+ Name _ s (Just m) _ == Name _ t (Just n) _ = s == t && m == n+ Tuple a _ == Tuple b _ = a == b+ Prim a _ == Prim b _ = a == b+ _ == _ = False++instance Ord Name where+ Prim a _ <= Prim b _ = a <= b+ Prim _ _ <= _ = True+ Tuple a _ <= Tuple b _ = a <= b+ Tuple _ _ <= Name _ _ _ _ = True+ Name a _ (Just m) _ <= Name b _ (Just n) _ = a < b || ( a == b && m <= n )+ Name a 0 _ _ <= Name b 0 _ _ = a <= b+ Name _ a _ _ <= Name _ b _ _ = a <= b+ _ <= _ = False+++-- Printing Names -----------------------------------------------------------------++instance Show Name where+ show (Name s n m a) = mod ++ s ++ tag+ where tag = if n/=0 && generated a then '_' : show n else ""+ mod = if m==Nothing || suppressMod a then "" else fromJust m ++ "."+ show (Tuple n _) = '(' : replicate (n-1) ',' ++ ")"+ show (Prim p _) = strRep p++instance Pr Name where+-- pr (Name s n m a) = prExpl a <> text (maybe "" (++ ".") m ++ s++'_':show n)+ pr n = text (show n)++prExpl a = if explicit a then text "~" else empty+++prId i = if isSym i then parens (pr i) else pr i++prOp i = if isSym i then pr i else backQuotes (pr i)++prId2 (Prim p _) = text (strRep2 p)+prId2 (Tuple n _) = text ("TUP" ++ show n)+prId2 n = prId n+++prId3 n@(Name s t m a)+ | t == 0 || isClosure n || isCoerceLabel n || isCoerceConstr n+ = text (s ++ maybe "" (('_' :) . modToundSc) m)+prId3 (Name s n m a) = text (id ++ tag ++ mod ++ suff)+ where + id = if okForC s then s else "_sym"+ tag = if mod=="" || generated a || id=="_sym" then '_':show n else ""+ suff = if take 2 id == "_sym" then "/* "++s++" */" else ""+ mod = maybe "" (('_' :) . modToundSc) m+ okForC cs = all (\c -> isAlphaNum c || c=='_') cs+prId3 n = prId2 n++name2str n = render (prId3 n)++modToPath m = m -- concat (List.intersperse "/" (splitString m))++modToundSc m = concat (List.intersperse "_" (splitString m))++packName n = show n++unpackName x = case break (=='_') x of+ (s,"") -> let n0 = name0 s in + case lookup n0 primTerms of+ Just p -> p+ Nothing -> n0+ (s,n) -> (name0 s) { tag = read (tail n) }+++-- Binary --------------------------------------------------------++instance Binary Name where+ put (Name a b c d) = putWord8 0 >> put a >> put b >> put c >> put d+ put (Prim a b) = putWord8 1 >> put a >> put b+ put (Tuple a b) = putWord8 2 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (Name a b c d)+ 1 -> get >>= \a -> get >>= \b -> return (Prim a b)+ 2 -> get >>= \a -> get >>= \b -> return (Tuple a b)+ _ -> fail "no parse"+++instance Binary Annot where+ put (Annot _ b c d e) = put b >> put c >> put d >> put e >> put False+ get = get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \False -> return (Annot Nothing b c d e)+++maxPrimWord = fromIntegral (fromEnum maxPrim) :: Word8++instance Binary Prim where+ put p = putWord8 (fromIntegral (fromEnum p))+ get = do+ w <- getWord8+ if w <= maxPrimWord+ then return (toEnum (fromIntegral w))+ else fail "no parse"
+ src/PP.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module PP (module PP, module Text.PrettyPrint) where++import Text.PrettyPrint hiding (TextDetails(..))+import Char(showLitChar)+++class Pr a where+ pr :: a -> Doc+ pr x = prn 0 x++ prn :: Int -> a -> Doc+ prn n x = pr x++ vpr :: [a] -> Doc+ vpr xs = vcat (map pr xs)++ hpr :: Char -> [a] -> Doc+ hpr c xs = sep (punctuate (char c) (map pr xs))++ dump :: a -> IO ()+ dump x = putStr (render (pr x))+++instance Pr Int where + pr = int++-- XXX Is this correct?+-- AJG It is needed by Main, but it looks wrong.++instance Pr (String, String) where+ pr (a, b) = text a <> text b++infixl 4 $$$+a $$$ b = a $$ text " " $$ b++vcat2 xs = vcat (map ($$ text " ") xs)++backQuotes p = char '`' <> p <> char '`'+litChar = charQuotes . text . lit+litString = doubleQuotes . text . concat . map lit+lit c = showLitChar c ""+charQuotes p = char '\'' <> p <> char '\''+curlies = braces++commasep f xs = sep (punctuate comma (map f xs))+++show' :: Pr a => a -> String+show' = render . pr++vshow :: Pr a => [a] -> String+vshow = render . vpr++showlist :: Pr a => [a] -> String+showlist xs = render (text "(" <> hpr ',' xs <> text ")")+
+ src/ParseMonad.hs view
@@ -0,0 +1,136 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-+**************************************************************************+** This file is based on sources distributed as the haskell-src package **+**************************************************************************+The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.+-}++module ParseMonad where++import Common++data ParseResult a+ = Ok ParseState a+ | Failed String+ deriving Show++type ParseState = [LexContext]++data LexContext+ = NoLayout+ | Layout Int+ | RecLayout Int+ deriving (Eq, Ord, Show)++newtype PM a + = PM ( String -- input string+ -> (Int,Int) -- location of last token read (row,col)+ -> Int -- current column+ -> ParseState -- layout info+ -> ParseResult a)++unPM (PM p) = p++instance Monad PM where+ (>>=) = thenPM+ return = returnPM+ fail = failPM++m `thenPM` k = PM $ \i l c s -> + case (unPM m) i l c s of + Failed s -> Failed s+ Ok s' a -> case k a of PM k' -> k' i l c s'+returnPM a = PM $ \i l c s -> Ok s a+failPM a = PM $ \i l c s -> Failed a++runPM (PM p) i l c s =+ case p i l c s of+ Ok _ a -> a+ Failed err -> error err++runPM2 (PM p) input =+ case p input (1,1) 0 [] of+ Ok _ result -> return result+ Failed msg -> fail msg++getSrcLoc :: PM (Int,Int)+getSrcLoc = PM $ \i l c s -> Ok s l++pushContext :: LexContext -> PM ()+pushContext ctxt =+ PM $ \i l c s -> Ok (ctxt:s) ()++popContext :: PM ()+popContext = PM $ \i loc c stk ->+ case stk of+ (_:s) -> Ok s ()+ [] -> Failed $ show loc +++ ": parse error (possibly incorrect indentation)"+++parseError :: String -> PM a+parseError err =+ PM $ \r (l,c) -> (unPM $ fail $ "Syntax error at line "++show l++", column "++show c++ "\n") r (l,c)
+ src/Parser.y view
@@ -0,0 +1,686 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{++module Parser (parser) where++import Common+import Token+import Lexer+import ParseMonad+import Syntax+import Fixity++++}++%token+ VARID { VarId $$ }+ CONID { ConId $$ }+ '-' { VarSym ("","-") }+ '<' { VarSym ("","<") }+ '>' { VarSym ("",">") }+ '*' { VarSym ("","*") }+ VARSYM { VarSym $$ }+ CONSYM { ConSym $$ }+ INT { IntTok $$ }+ RATIONAL { FloatTok $$ }+ CHAR { Character $$ }+ STRING { StringTok $$ }+{-++Symbols+-}+ '(' { LeftParen }+ ')' { RightParen }+ ';' { SemiColon }+ '{' { LeftCurly }+ '}' { RightCurly }+ vccurly { VRightCurly } -- a virtual close brace+ '[' { LeftSquare }+ ']' { RightSquare }+ ',' { Comma }+ '`' { BackQuote }+ '_' { Wildcard }++{-++Reserved operators++-}+ '.' { Dot }+ '..' { DotDot }+ '::' { DoubleColon }+ ':=' { Assign }+ '=' { Equals }+ '\\' { Backslash }+ '|' { Bar }+ '<-' { LeftArrow }+ '->' { RightArrow }+ '\\\\' { Backslash2 }+{-++Reserved Ids++-}+ 'action' { KW_Action }+ 'after' { KW_After }+ 'before' { KW_Before }+ 'case' { KW_Case }+ 'class' { KW_Class }+ 'data' { KW_Data }+ 'default' { KW_Default }+ 'do' { KW_Do }+ 'else' { KW_Else }+ 'elsif' { KW_Elsif }+ 'forall' { KW_Forall }+ 'if' { KW_If }+ 'import' { KW_Import }+ 'instance' { KW_Instance }+ 'in' { KW_In }+ 'let' { KW_Let }+ 'module' { KW_Module }+ 'new' { KW_New }+ 'of' { KW_Of }+ 'private' { KW_Private }+ 'request' { KW_Request }+ 'result' { KW_Result }+ 'struct' { KW_Struct }+ 'then' { KW_Then }+ 'type' { KW_Type }+ 'typeclass' { KW_Typeclass }+ 'use' { KW_Use }+ 'where' { KW_Where }+ 'while' { KW_While }++%monad { PM } { thenPM } { returnPM }+%lexer { lexer } { EOF }+%name parse+%tokentype { Token }+%%++-- Module Header ------------------------------------------------------------++module :: { Module }+ : 'module' conid 'where' body { mkModule $2 $4 }++body :: { ([Import],[Decl],[Decl]) }+ : '{' layout_off imports topdecls '}' private { (reverse $3,reverse $4, $6) }+ | layout_on imports topdecls close private { (reverse $2, reverse $3, $5) }++private :: { [Decl] }+ : 'private' pbody { $2 }+ | {- empty -} { [] }++pbody :: { [Decl] }+ : '{' layout_off topdecls '}' { reverse $3 }+ | layout_on topdecls close { reverse $2 }++imports :: { [Import] }+ : imports import ';' { $2 : $1 }+ | {- empty -} { [] }++import :: { Import }+ : 'import' conid { Import True (modId $2) }+ | 'use' conid { Import False (modId $2) }+++-- Top-level declarations ---------------------------------------------------++topdecls :: { [Decl] }+ : topdecls ';' topdecl { $3 ++ $1 }+ | topdecl { $1 }++topdecl :: { [Decl] }+ : conid '::' kind { [DKSig $1 $3] }+ | 'type' conid tyvars '=' type { [DType $2 (reverse $3) $5] }+ | 'data' conid tyvars optsubs optcs { [DData $2 (reverse $3) $4 $5] }+ | 'struct' conid tyvars optsups optsigs { [DRec False $2 (reverse $3) $4 $5] }+ | 'typeclass' conid tyvars sups optsigs { [DRec True $2 (reverse $3) $4 $5] }+ | 'typeclass' conid tyvars 'where' siglist { [DRec True $2 (reverse $3) [] $5] }+ | 'typeclass' ids { [DTClass $2] }+ | 'instance' var '::' type { [DPSig $2 $4] } + | 'instance' var '::' type 'where' bindlist { [DBind [BEqn (exp2lhs (EVar $2)) (RExp (EBStruct Nothing [] $6))], DPSig $2 $4] }+ | 'instance' var '::' type rhs { [DBind [BEqn (exp2lhs (EVar $2)) $5], DPSig $2 $4] }+ | 'instance' ids { [DInstance $2] }+ | 'default' def { [DDefault (reverse $2)] }+ | vars '::' type { [DBind [BSig (reverse $1) $3]] }+ | lhs rhs { [DBind [BEqn $1 $2]] }++sups :: { [Type] }+ : '<' types { reverse $2 }+ | '<' type { [$2] }++optsups :: { [Type] }+ : sups { $1 }+ | {- empty -} { [] }++optsubs :: { [Type] }+ : '>' types { reverse $2 }+ | '>' type { [$2] }+ | {- empty -} { [] }++tyvars :: { [Name] }+ : tyvars varid { $2 : $1 }+ | {- empty -} { [] }++++ids :: { [Name] }+ : ids ',' id { $3 : $1 }+ | id { [$1] }++-- Default declarations ---------------------------------------------------++def :: { [Default Type] }+def : '{' layout_off prefs '}' { $3 }+ | layout_on prefs close { $2 }+ +prefs :: { [Default Type] }+ : prefs ';' pref { $3 : $1 }+ | pref { [$1] }+ ++pref :: { Default Type }+ : var '<' var { Default True $1 $3 }+ | var '::' type { Derive $1 $3 } +++-- Datatype declarations ---------------------------------------------------++optcs :: { [Constr] }+ : '=' constrs { reverse $2 }+ | {- empty -} { [] }+ +constrs :: { [Constr] }+ : constrs '|' type { type2cons $3 : $1 }+ | type { [type2cons $1] }+++-- Signatures --------------------------------------------------------------++optsigs :: { [Sig] }+ : 'where' siglist { $2 }+ | {- empty -} { [] }+ +siglist :: { [Sig] }+ : '{' layout_off sigs '}' { reverse $3 }+ | layout_on sigs close { reverse $2 }++sigs :: { [Sig] }+ : sigs1 { $1 }+ | {- empty -} { [] }+ +sigs1 :: { [Sig] }+ : sigs1 ';' sig { $3 : $1 }+ | sig { [$1] }++sig :: { Sig }+ : vars '::' type { Sig (reverse $1) $3 }+++-- Bindings ----------------------------------------------------------------++bindlist :: { [Bind] }+ : '{' layout_off binds '}' { reverse $3 }+ | layout_on binds close { reverse $2 }++binds :: { [Bind] }+ : binds ';' bind { $3 : $1 }+ | bind { [$1] }+ +bind :: { Bind }+ : vars '::' type { BSig (reverse $1) $3 }+ | lhs rhs { BEqn $1 $2 }+++recbinds :: { [Field] }+ : recbinds ',' recbind { $3 : $1 }+ | recbind { [$1] }+ +recbind :: { Field }+ : var '=' exp { Field $1 $3 }++vars :: { [Name] }+ : vars ',' var { $3 : $1 }+ | var { [$1] }++lhs :: { Lhs }+ : exp0s { exp2lhs $1 }++rhs :: { Rhs Exp }+ : '=' exp { RExp $2 }+ | gdrhss { RGrd (reverse $1) }+ | rhs 'where' bindlist { RWhere $1 $3 }++gdrhss :: { [GExp Exp] }+ : gdrhss gdrhs { $2 : $1 }+ | gdrhs { [$1] }++gdrhs :: { GExp Exp }+ : '|' quals '=' exp { GExp (reverse $2) $4 }+++-- Types ---------------------------------------------------------------------++type :: { Type }+ : ftype '\\\\' preds { TQual $1 $3 }+ | ftype { $1 }++ftype :: { Type }+ : btypes { tFun (reverse (tail $1)) (head $1) }+ | btype '<' btype { TSub $1 $3}++btypes :: { [Type] }+ : btypes '->' btype { $3 : $1 }+ | btype { [$1] }++btype :: { Type }+ : btype atype { TAp $1 $2 }+ | atype { $1 }++atype :: { Type }+ : con { TCon $1 }+ | varid { TVar $1 }+ | '_' { TWild }+ | '[' ']' { TCon (prim LIST) }+-- | '(' '->' ')' { TCon (prim ARROW) }+ | '(' commas ')' { TCon (tuple ($2+1)) }+ | '(' ')' { TCon (prim UNITTYPE) }+ | '(' type ')' { $2 }+ | '(' types ')' { TTup (reverse $2) }+ | '[' type ']' { TList $2 }++types :: { [Type] }+ : types ',' ftype { $3 : $1 }+ | ftype ',' ftype { [$3, $1] }++commas :: { Int }+ : commas ',' { $1 + 1 }+ | ',' { 1 }++-- Predicates -----------------------------------------------------------------++preds :: { [Pred] }+ : preds ',' pred { $3 : $1 }+ | pred { [$1] }+ +pred :: { Pred }+ : ftype { PType $1 }+ | varid '::' kind { PKind $1 $3 }++kind :: { Kind }+ : kind1 '->' kind { KFun $1 $3 }+ | kind1 { $1 }++kind1 :: { Kind }+ : '*' { Star }+ | '_' { KWild }+ | '(' kind ')' { $2 }+ ++-- Expressions -------------------------------------------------------------++exp :: { Exp }+ : exp0a '::' btype { ESig $1 $3 }+ | exp0 { $1}+ | 'struct' bindlist { EBStruct Nothing [] $2 }++exp0 :: { Exp }+ : exp0a { $1 }+ | exp0b { $1 }++exp0a :: { Exp }+ : opExpa { transFix $1 }+ | exp10a { $1 }+ +exp0b :: { Exp }+ : opExpb { transFix $1 }+ | exp10b { $1 }+ +opExpa :: { OpExp }+ : opExpa op '-' exp10a { Cons $1 $2 (ENeg $4) }+ | opExpa op exp10a { Cons $1 $2 $3 }+ | '-' exp10a { Nil (ENeg $2) }+ | exp10a op '-' exp10a { Cons (Nil $1) $2 (ENeg $4) }+ | exp10a op exp10a { Cons (Nil $1) $2 $3 }+ +opExpb :: { OpExp }+ : opExpa op '-' exp10b { Cons $1 $2 (ENeg $4) }+ | opExpa op exp10b { Cons $1 $2 $3 }+ | '-' exp10b { Nil (ENeg $2) }+ | exp10a op '-' exp10b { Cons (Nil $1) $2 (ENeg $4) }+ | exp10a op exp10b { Cons (Nil $1) $2 $3 }+ +exp10a :: { Exp }+ : 'case' exp 'of' altslist { ECase $2 $4 }+ | '{' layout_off recbinds '}' { ERec Nothing (reverse $3) }+ | '{' layout_off '}' { ERec Nothing [] }+ | exp10as { $1 }++exp10as :: { Exp }+ : loc 'do' stmtlist { EDo Nothing Nothing $3 }+ | loc 'class' stmtlist { ETempl Nothing Nothing $3 }+ | loc 'action' stmtlist { EAct Nothing $3 }+ | loc 'request' stmtlist { EReq Nothing $3 }+ | con '{' layout_off recbinds '}' { ERec (Just ($1,True)) (reverse $4) } + | con '{' layout_off recbinds '..' '}' { ERec (Just ($1,False)) (reverse $4) } + | con '{' layout_off recbinds ',' '..' '}' { ERec (Just ($1,False)) (reverse $4) } + | con '{' layout_off '..' '}' { ERec (Just ($1,False)) [] } + | con '{' layout_off '}' { ERec (Just ($1,True)) [] }+ | fexp { $1 }++exp10b :: { Exp }+ : 'if' exp 'then' exp 'else' exp { EIf $2 $4 $6 }+ | exp10bs { $1 }++exp10bs :: { Exp }+ : '\\' apats '->' exp { ELam (reverse $2) $4 }+ | 'let' bindlist 'in' exp { ELet $2 $4 }+ | 'after' aexp exp { EAfter $2 $3 }+ | 'before' aexp exp { EBefore $2 $3 }++fexp :: { Exp }+ : fexp aexp { EAp $1 $2 }+ | aexp { $1 }++aexp :: { Exp }+ : aexp '.' var { ESelect $1 $3 }+ | bexp { $1 }++bexp :: { Exp }+ : var { EVar $1 }+ | '_' { EWild }+ | con { ECon $1 }+ | lit { ELit $1 }+ | '(' ')' { ECon (prim UNITTERM) }+ | '(' '.' var ')' { ESel $3 }+ | '(' exp ')' { $2 }+ | '(' exps ')' { ETup (reverse $2) } + | '[' list ']' { $2 }+ | '(' exp10a op ')' { ESectR $2 $3 }+ | '(' op0 fexp ')' { ESectL $2 $3 }+ | '(' commas ')' { ECon (tuple ($2+1)) }++lit :: { Lit }+: loc INT { LInt (Just $1) (readInteger $2) }+| loc RATIONAL { LRat (Just $1) (readRational $2) }+| loc CHAR { LChr (Just $1) $2 }+| loc STRING { LStr (Just $1) $2 }++-- List expressions -------------------------------------------------------------++list :: { Exp }+ : {- empty -} { EList [] }+ | exp { EList [$1] }+ | exps { EList (reverse $1) }+ | exp '..' exp { ESeq $1 Nothing $3 }+ | exp ',' exp '..' exp { ESeq $1 (Just $3) $5 }+ | exp '|' quals { EComp $1 (reverse $3) }++exps :: { [Exp] }+ : exps ',' exp { $3 : $1 }+ | exp ',' exp { [$3,$1] }+ ++-- List comprehensions ---------------------------------------------------------++quals :: { [Qual] }+ : quals ',' qual { $3 : $1 }+ | qual { [$1] }++qual :: { Qual }+ : pat '<-' exp0s { QGen $1 $3 }+ | exp0s { QExp $1 }+ | 'let' bindlist { QLet $2 }+++-- Case alternatives ------------------------------------------------------------++altslist :: { [Alt Exp] }+ : '{' layout_off alts '}' { reverse $3 }+ | layout_on alts close { reverse $2 }+++alts :: { [Alt Exp] }+ : alts ';' alt { $3 : $1 }+ | alt { [$1] }++alt :: { Alt Exp }+ : pat rhscasealts { Alt $1 $2 }++rhscasealts :: { Rhs Exp }+ : '->' exp { RExp $2 }+ | gdcaserhss { RGrd (reverse $1) }+ | rhscasealts 'where' bindlist { RWhere $1 $3 }++gdcaserhss :: { [GExp Exp] }+ : gdcaserhss gdcaserhs { $2 : $1 }+ | gdcaserhs { [$1] }++gdcaserhs :: { GExp Exp }+ : '|' quals '->' exp { GExp (reverse $2) $4 }+++-- Case statement alternatives ------------------------------------------------------------++saltslist :: { [Alt [Stmt]] }+ : '{' layout_off salts '}' { reverse $3 }+ | layout_on salts close { reverse $2 }+++salts :: { [Alt [Stmt]] }+ : salts ';' salt { $3 : $1 }+ | salt { [$1] }++salt :: { Alt [Stmt] }+ : pat srhscasealts { Alt $1 $2 }++srhscasealts :: { Rhs [Stmt] }+ : '->' stmtlist { RExp $2 }+ | sgdcaserhss { RGrd (reverse $1) }+ | srhscasealts 'where' bindlist { RWhere $1 $3 }++sgdcaserhss :: { [GExp [Stmt]] }+ : sgdcaserhss sgdcaserhs { $2 : $1 }+ | sgdcaserhs { [$1] }++sgdcaserhs :: { GExp [Stmt] }+ : '|' quals '->' stmtlist { GExp (reverse $2) $4 }+++-- Statement sequences -----------------------------------------------------------++stmtlist :: { [Stmt] }+ : '{' layout_off stmts0 '}' { reverse $3 }+ | layout_on stmts0 close { reverse $2 }++stmts0 :: { [Stmt] }+ : stmts { $1 }+ | {- empty -} { [] }++stmts :: { [Stmt] }+ : stmts ';' stmt { $3 : $1 }+ | stmt { [$1] }++stmt :: { Stmt }+ : pat '<-' exp { SGen $1 $3 }+ | mexp { SExp $1 }+ | vars '::' type { SBind [BSig $1 $3] }+ | lhs rhs { SBind [BEqn $1 $2] }+ | lhs '=' 'new' exp { SBind [BEqn $1 (RExp (EAp (EVar (prim New)) $4))] }+ | pat ':=' exp { SAss $1 $3 }+ | 'result' exp { SRet $2 }+ | 'forall' quals 'do' stmtlist { SForall (reverse $2) $4 }+ | 'if' exp 'then' stmtlist { SIf $2 $4 }+ | 'elsif' exp 'then' stmtlist { SElsif $2 $4 }+ | 'else' stmtlist { SElse $2 }+ | 'while' exp 'do' stmtlist { SWhile $2 $4 }+ | 'case' exp 'of' saltslist { SCase $2 $4 }+ ++mexp :: { Exp }+-- : exp0as '::' type { ESig $1 $3 }+ : exp0s { $1}++exp0s :: { Exp }+ : exp0as { $1 }+ | exp0bs { $1 }++exp0as :: { Exp }+ : opExpas { transFix $1 }+ | exp10as { $1 }+ +exp0bs :: { Exp }+ : opExpbs { transFix $1 }+ | exp10bs { $1 }+ +opExpas :: { OpExp }+ : opExpas op '-' exp10as { Cons $1 $2 (ENeg $4) }+ | opExpas op exp10as { Cons $1 $2 $3 }+ | '-' exp10as { Nil (ENeg $2) }+ | exp10as op '-' exp10as { Cons (Nil $1) $2 (ENeg $4) }+ | exp10as op exp10as { Cons (Nil $1) $2 $3 }+ +opExpbs :: { OpExp }+ : opExpas op '-' exp10bs { Cons $1 $2 (ENeg $4) }+ | opExpas op exp10bs { Cons $1 $2 $3 }+ | '-' exp10bs { Nil (ENeg $2) }+ | exp10as op '-' exp10bs { Cons (Nil $1) $2 (ENeg $4) }+ | exp10as op exp10bs { Cons (Nil $1) $2 $3 }++++-- Patterns ----------------------------------------------------------------++pat :: { Pat }+ : exp0s { $1 }++apats :: { [Pat] }+ : apats apat { $2 : $1 }+ | apat { [$1] }++apat :: { Pat }+ : aexp { $1 }+++-- Variables, Constructors and Operators ------------------------------------++var :: { Name }+ : varid { $1 }+ | '(' varsym ')' { $2 }++con :: { Name }+ : conid { $1 }+ | '(' consym ')' { $2 }++varop :: { Name }+ : varsym { $1 }+ | '`' varid '`' { $2 }++conop :: { Name }+ : consym { $1 }+ | '`' conid '`' { $2 }++op :: { Name }+ : varop { $1 }+ | conop { $1 }++id :: { Name }+ : varid { $1 }+ | conid { $1 }++op0 :: { Name }+ : VARSYM0 {% do l <- getSrcLoc; return (name l $1) }+ | '`' varid '`' { $2 }+ | conop { $1 }+++varid :: { Name }+ : loc VARID { name $1 $2 }++conid :: { Name }+ : loc CONID { name $1 $2 }++varsym :: { Name }+ : VARSYM1 {% do l <- getSrcLoc; return (name l $1) }++consym :: { Name }+ : loc CONSYM { name $1 $2 }++++VARSYM1 :: { (String,String) }+ : VARSYM0 { $1 }+ | '-' { ("","-") }++VARSYM0 :: { (String,String) }+ : VARSYM { $1 }+ | '<' { ("","<") }+ | '>' { ("",">") }+ | '*' { ("","*") }+ | '\\\\' { ("","\\\\") }+ ++-- Layout ---------------------------------------------------------------------++close :: { () }+ : vccurly { () } -- context popped in lexer.+ | error {% popContext }++layout_off :: { () } : {% pushContext NoLayout }+layout_on :: { () } : {% do { (r,c) <- getSrcLoc ;+ pushContext (Layout c)+ }+ }++loc :: { (Int,Int) }+ : {- empty -} {% getSrcLoc }++{-+ layout_onR :: { () } : {% do { (_,c) <- getSrcLoc ;+ pushContext (RecLayout c)+ }+ }+-}++-- Error -----------------------------------------------------------------------++{+parser :: String -> M s Module+parser str = runPM2 parse str++happyError = parseError "parse error"+}
+ src/Prepare4C.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE ParallelListComp #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Prepare4C(prepare4c) where++import Monad+import Common+import Kindle+import PP+import qualified Core+import qualified Core2Kindle++-- Establishes that:+-- every struct function simply relays all work to a global function with an explicit "this" parameter+-- every EEnter expression has a variable as its body+-- every ENew expression occurs at the rhs of a Val binding++-- Removes the type arguments from all type constructors except Array+-- Replaces type variables with the special type constructor POLY+-- Adds type casts wherever necessary++-- Replaces type abstraction and application with BITSET parameters indicating pointer/non-pointer status++-- Replaces nullary structs with out-of-band pointers (casts from the corresponding tag value)+-- Replaces type constructor switching by switching on integer tags (embedded as pointer values or as explicit tag fields)+-- Makes field selection from matched struct variants explicit++-- Removes CBreak commands that appear directly under a CSeq (without any intervening CSwitch)+-- Removes redundant defaults in CSwitch commands++-- (Not yet):+-- Flattens the struct subtyping graph by inlining the first coercion field+-- Ditto for enums...+++prepare4c e2 e3 m = localStore (pModule e2 e3 m)+++-- ===========================+-- Local environment+-- ===========================++data Env = Env { decls :: Decls, -- all structs in scope+ tenv :: TEnv, -- all fun and val variables in scope+ strinfo :: Map Name (Int,[Bool]), -- number of ptr fields + 1 / relevance flags of tvars for each struct+ polyenv :: Map Name (Exp,Int), -- status location (refexp,bit-number) for type variables in scope+ conval :: Map Name Int, -- numerical values of all variant constructor names+ nulls :: [Name], -- lists all nullary struct variants+ tagged :: [Name], -- lists all struct variants that use an explicit tag field+ this :: Maybe Name }++env0 = Env { decls = [], tenv = [], strinfo = [], polyenv = [], conval = [], nulls = [], tagged = [], this = Nothing }++addDecls ds env = env { decls = ds ++ decls env, strinfo = info ++ strinfo env, conval = convals ++ conval env, + nulls = nullcons ++ nulls env, tagged = taggedcons ++ taggedunions ++ tagged env }+ where unioncons = unions ds+ allvariants = map (variants ds) unioncons+ convals = concat (map (`zip` [0..]) allvariants)+ nullcons = [ n | (n, Struct _ [] (Extends _)) <- ds ]+ singlecons = map head . filter ((==1) . length) . map (\\nullcons) $ allvariants+ taggedcons = dom convals \\ (singlecons++nullcons)+ taggedunions = [ n | (n,ns) <- unioncons `zip` allvariants, any (`elem` taggedcons) ns ]+ info = mapSnd structInfo ds+ +structInfo (Struct vs te _) = (length (ptrFields te []), map (`elem` relevant) vs)+ where relevant = rng (varFields te)++addTEnv te env = env { tenv = te ++ tenv env }++addVals te env = env { tenv = mapSnd ValT te ++ tenv env }++addPolyEnv vs is es env = env { polyenv = mkPolyEnv vs is es ++ polyenv env }++-- Create a polyTag ATEnv on basis of polymorphic arity and return a mapping from each tyvar to its corresponding arg/bit+mkPolyEnv [] _ _ = []+mkPolyEnv (v:vs) (i:is) es = (v, (es!!(i`div`32), i`mod`32)) : mkPolyEnv vs is es+++setThis x env = env { this = Just x }++findValT xx te x = t+ where ValT t = lookup'' xx te x+ +findFunT te x ts = (vs `zip` ts, ts', t)+ where FunT vs ts' t = lookup'' "B" te x++findStructTEnv xx env (TCon n ts)+ | isTuple n = (abcSupply `zip` ts, abcSupply `zip` map (ValT . tVar) (take (width n) abcSupply))+ | otherwise = (vs `zip` ts, te)+ where Struct vs te _ = lookup'' xx (decls env) n++findStructInfo env n+ | isTuple n = (width n + 1, take (width n) (repeat True))+ | otherwise = lookup' (strinfo env) n++findPolyTag xx env v = lookup'' (xx ++ ": " ++ show (polyenv env)) (polyenv env) v++conLit env n = lInt (lookup'' "GGG" (conval env) n)++allCons env (ACon n _ _ _ : _)+ | isTuple n = [n]+ | otherwise = variants (decls env) n0+ where Struct _ _ (Extends n0) = lookup'' "Apa" (decls env) n+allCons env _ = []++visibleArity env n = structArity ds (structRoot ds n)+ where ds = decls env+ +-- =====================================+-- Replacing polymorphism with polyTags+-- =====================================+ +-- Create a list of polyTag types on basis of polymorphic arity+polyTagTypes 0 = []+polyTagTypes a | a <= 32 = [tBITS32]+ | otherwise = tBITS32 : polyTagTypes (a-32)+++-- Create a polyTag TEnv on basis of polymorphic arity (the externally visible part)+polyTagEnv0 a | a <= 4 = [(prim GCINFO, ValT tPOLY)]+ | otherwise = (prim GCINFO, ValT tPOLY) : + _ABCSupply `zip` map ValT (polyTagTypes a)+++-- Create a polyTag TEnv on basis of polymorphic arity (the existentially quantified part)+polyTagEnv1 a = _abcSupply `zip` map ValT (polyTagTypes a)+++-- Create a polyTag struct binding from a list of type arguments+polyTagBinds env n ts = bs0 ++ bs1+ where mkBind (x,ValT t) e = (x, Val t e)+ ts0 = zipFilter vflags ts+ ts1 = drop va ts+ va = visibleArity env n+ l_ts0 = length ts0+ te0 = polyTagEnv0 l_ts0+ es0 = polyTagArgs env ts0+ bs0 | l_ts0 <= 4 = zipWith mkBind te0 [ECall (gcInfoName n) [] (map offset es0)]+ | otherwise = zipWith mkBind te0 (ECall (gcInfoName n) [] [] : es0)+ bs1 = zipWith mkBind (polyTagEnv1 (length ts1)) (polyTagArgs env ts1)+ offset e = ECall (prim IntTimes) [] [ELit (lInt (d + 2)),e]+ (d,vflags) = findStructInfo env n+++gcInfoName n@(Name s t m a)+ | isClosure n = Name (gcinfoSym ++ s) 0 m a+ | otherwise = Name (gcinfoSym ++ s) t m a+gcInfoName (Tuple n a) = Name (gcinfoSym ++ "TUP" ++ show n) 0 Nothing a+gcInfoName (Prim p a) = Name (gcinfoSym ++ strRep2 p) 0 Nothing a+++-- Create a list of polyTag Exp arguments from a list of type arguments+polyTagArgs env [] = []+polyTagArgs env ts + | vars && ordered && total = [e0]+ where vars = l_ts == length vs && length (nub es) == 1+ l_ts = length ts+ vs = [ n | TVar n _ <- ts ]+ (es,is) = unzip (map (findPolyTag "XX" env) vs)+ e0 = head es+ ordered = is == [0..l_ts-1]+ total = length [ v | (v,(e,_)) <- polyenv env, e == e0 ] == l_ts+polyTagArgs env ts = args (length ts) ts+ where + args 0 [] = []+ args a ts | a <= 32 = [arg 0 ts]+ | otherwise = arg 0 ts0 : args (a-32) ts1+ where (ts0,ts1) = splitAt a ts++ arg k [] = intlit 0+ arg k (TVar n _ : ts) = bor (arg (k+1) ts) (shift (band e (mask i)) i k)+ where (e,i) = findPolyTag "YY" env n+ arg k (TCon (Prim p _) _ : ts)+ | p `elem` scalarPrims = bor (mask k) (arg (k+1) ts)+ arg k (_ : ts) = arg (k+1) ts+++shift e i k | i < k = shiftL e (ELit (lInt (k-i)))+ | i > k = shiftR e (ELit (lInt (i-k)))+ | otherwise = e++shiftL e1 e2 = ECall (prim SHIFTL32) [] [e1,e2]+ +shiftR e1 e2 = ECall (prim SHIFTR32) [] [e1,e2]++mask i = intlit (2^i)++bor e1 e2 | e1 == intlit 0 = e2+ | e2 == intlit 0 = e1+ | otherwise = ECall (prim OR32) [] [e1,e2]+ +band e1 e2 = ECall (prim AND32) [] [e1,e2]++intlit i = ECast tBITS32 (ELit (lInt i))+++-- =============================+-- Prepare modules and types+-- =============================+ +pModule e2 dsi (Module m ns ds bs) + = do -- tr (render (vcat (map pr dsi))+ let (_,_,_,Core.Binds _ te2 _) = e2+ tei <- Core2Kindle.c2kTEnv dsi te2+ let env1 = addTEnv (primTEnv++tei) (addDecls (primDecls++dsi) env0)+ env = addTEnv (mapSnd typeOf bs) (addDecls ds env1)+ (bs1,bs) <- pBinds pBind env bs+ bs2 <- currentStore+ return (Module m ns (pDecls env ds) (gcinfo env ds ++ bs1 ++ bs ++ reverse bs2))+++-- Prepare structs declarations+pDecls env ds = map f ds+ where f (n,Struct vs te _) = (n, Struct [] (polyTagEnv0 l_vs0 ++ tagSig ++ mapSnd pType te ++ polyTagEnv1 l_vs1) Top)+ where tagSig = if n `elem` tagged env then [(prim Tag, ValT tInt)] else []+ l_vs0 = length (zipFilter vflags vs)+ l_vs1 = length (drop va vs)+ va = visibleArity env n+ (_,vflags) = findStructInfo env n+++-- gcinfo types: these must match corresponding defines in gc.c+gcSTD = ELit (lInt 0)+gcARRAY = ELit (lInt 1)+gcTUPLE = ELit (lInt 2)+gcBIG = ELit (lInt 3)+gcMUT = ELit (lInt 4)++-- Generate gcinfo for structs+gcinfo env ds = map f (prune ds (nulls env))+ where f (n,Struct vs te cs) = (gcInfoName n, Val tPOLY (ECall (prim GCINFO) [] es))+ where es | l_vs1 <= 4 = concat [ EVar n : gcSTD : pad l_es0 (ptrFields te vs) | vs <- sampleSpaces vs1 ]+ | otherwise = EVar n : gcBIG : es0 ++ concat (map bitRef (varFields te)) ++ [ELit (lInt 0)]+ es0 = ptrFields te []+ l_es0 = length es0+ (d,vflags) = findStructInfo env n+ vs1 = zipFilter vflags vs+ l_vs1 = length vs1+ idx = vs1 `zip` [0..]+ bitRef (n,v) = [ EVar n, ELit (lInt (i `div` 32 + 1)), ELit (lInt (i `mod` 32)) ]+ where i = lookup'' "DDD" idx v++pad n es = es ++ replicate (n - length es) (ELit (lInt 0))++ptrFields te vs = map EVar (dom (filter (isPtr vs) te)) ++ [ELit (lInt 0)]++sampleSpaces [] = [[]]+sampleSpaces (v:vs) = [ vs1 ++ vs2 | vs1 <- [[],[v]], vs2 <- sampleSpaces vs ]++isPtr vs (n,FunT _ _ _) = False+isPtr vs (n,ValT (TVar v _)) = v `notElem` vs+isPtr vs (n,ValT (TCon k _)) = not (isScalar k)++isScalar (Prim p _) = p `elem` scalarPrims+isScalar n = False++varFields te = [ (n,v) | (n,ValT (TVar v _)) <- te ]+++-- Simplify types+pType (ValT t) = ValT (erase t)+pType (FunT vs ts t) = FunT [] (polyTagTypes (length vs) ++ map erase ts) (erase t)+++-- Erase polymorphism from atomic types+erase (TCon n _) = TCon n []+erase (TVar _ _) = tPOLY++eraseEnv te = mapSnd erase te+++-- =============================+-- Prepare bindings and commands+-- =============================++-- Prepare bindings+pBinds f env xs = do (bss,xs) <- fmap unzip (mapM (f env) xs)+ return (concat bss, xs)+++-- Prepare top-level & cmd bindings (assume code is lambda-lifted)+pBind env (x, Val t e) = do (bs,t',e) <- pRhsExp env e + return (bs, (x, Val (erase t) (cast t t' e)))+pBind env (x, Fun vs t te c) = do te' <- newEnv paramSym (polyTagTypes (length vs))+ c <- pCmd (addVals te (addPolyEnv vs [0..] (map EVar (dom te')) env)) t c+ return ([], (x, Fun [] (erase t) (te' ++ eraseEnv te) c))+++-- Prepare struct bindings (assume code is lambda-lifted)+pSBind _ te0 env (x,Val t e) = do (bs,e) <- pExpT env t e + return (bs, (x, Val (erase t0) (cast t0 t e)))+ where t0 = findValT "1" te0 x+pSBind _ te0 env (x,Fun [] t te c@(CRet (ECall f [] (EThis:es))))+ | okAlready = return ([], (x, Fun [] t te c))+ where (_,ts0,t0) = findFunT te0 x []+ okAlready = t == erase t0 && rng te == map erase ts0 && es == map EVar (dom te)+pSBind ty te0 env (x,Fun vs t te c)+ = do y <- newName thisSym+ te0 <- newEnv paramSym ts0+ te' <- newEnv paramSym (polyTagTypes (length vs))+ let bs0 = [ (x, Val t (cast t t0 (EVar x0))) | (x0,t0) <- te0 | (x,t) <- te ]+ te1 = [ if isEVar e then (x,t) else xt0 | (x, Val t e) <- bs0 | xt0 <- te0 ]+ bs1 = [ b | b@(_,Val _ e) <- bs0, not (isEVar e) ]+ te1' = te' ++ eraseEnv te1+ env' = addPolyEnv vs [0..] (map EVar (dom te')) (rebindPolyEnv ty y env)+ c <- pCmd (setThis y (addVals ((y,ty):te) env')) t0 c+ f <- newName functionSym+ addToStore (f, Fun [] t0' ((y,erase ty):te1') (cBind bs1 c))+ return ([], (x, Fun [] t0' te1' (CRet (ECall f [] (EThis : map EVar (dom te1'))))))+ where (_,ts0,t0) = findFunT te0 x []+ t0' = erase t0+++rebindPolyEnv (TCon n ts) y env = addPolyEnv vs is (map (ESel (EVar y)) _abcSupply) env+ where ts1 = drop (visibleArity env n) ts+ (vs,is) = unzip [ (v,i) | (TVar v _, i) <- ts1 `zip` [0..] ]+++-- Prepare commands+pCmd env t0 (CRet e) = do (bs,e) <- pExpT env t0 e+ return (cBind bs (CRet e))+pCmd env t0 (CRun e c) = do (bs,_,e) <- pExp env e+ liftM (cBind bs . CRun e) (pCmd env t0 c)+pCmd env t0 (CBind False bs c) = do (bs1,bs) <- pBinds pBind env bs+ liftM (cBind bs1 . CBind False bs) (pCmd env' t0 c)+ where env' = addTEnv (mapSnd typeOf bs) env+pCmd env t0 (CBind True bs c) = do (bs1,bs) <- pBinds pBind env' bs+ liftM (CBind True (bs1++bs)) (pCmd env' t0 c)+ where env' = addTEnv (mapSnd typeOf bs) env+pCmd env t0 (CUpd x e c) = do (bs,e) <- pExpT env (findValT "2" (tenv env) x) e+ liftM (cBind bs . CUpd x e) (pCmd env t0 c)+pCmd env t0 (CUpdS e x e' c) = do (bs,t1,e) <- pExp env e+ let (s,te) = findStructTEnv "AA" env t1+ (bs',e') <- pExpT env (findValT "3" te x) e'+ liftM (cBind bs . cBind bs' . CUpdS e x e') (pCmd env t0 c)+pCmd env t0 (CUpdA e i e' c) = do (bs,TCon (Prim Array _) [t],e) <- pExp env e+ (bs',i) <- pExpT env tInt i+ (bs'',e') <- pExpT env tPOLY e'+ liftM (cBind bs . cBind bs' . cBind bs'' . CUpdA e i e') (pCmd env t0 c)+pCmd env t0 (CSwitch e alts) + | any litA alts = if simple (litType (firstLit alts)) then+ do (bs,e) <- pExpT env tInt e+ alts <- mapM (pAlt env e tInt t0) alts+ return (cBind bs (CSwitch e alts))+ else mkVarSwitch env t0 e alts+ | isEVar e || all nullA alts = do (bs,t,e) <- pExp env e+ alts <- mapM (pAlt env e t t0) alts+ let (alts0,alts1) = partition nullA [ a | a@(ACon _ _ _ _) <- alts ]+ altsW = [ a | a@(AWild _) <- alts ]+ return (cBind bs (mkSwitch env e (alts0++absent0 altsW) (alts1++absent1 altsW)))+ | otherwise = mkVarSwitch env t0 e alts+ where nullA (ACon k _ _ _) = k `elem` nulls env+ nullA _ = False+ absent = allCons env alts \\ [ k | ACon k _ _ _ <- alts ]+ (abs0,abs1) = partition (`elem` nulls env) absent+ absent0 altsW = [ ACon k [] [] d | k <- abs0, AWild d <- altsW ]+ absent1 altsW = [ a | a <- altsW, not (null abs1) ]+ litA (ALit _ _) = True+ litA _ = False+ firstLit (ALit l _ : _) = l+ firstLit (_ : as) = firstLit as+ simple (TCon (Prim Int _) []) = True+ simple (TCon (Prim Char _) []) = True+ simple _ = False++pCmd env t0 (CSeq c c') = liftM2 mkSeq (pCmd env t0 c) (pCmd env t0 c')+pCmd env t0 (CBreak) = return CBreak+pCmd env t0 (CRaise e) = do (bs,e) <- pExpT env tInt e+ return (cBind bs (CRaise e))+pCmd env t0 (CWhile e c c') = do (bs,e) <- pExpT env tBool e+ c <- pCmd env t0 c+ liftM (cBind bs . CWhile e c) (pCmd env t0 c')+pCmd env t0 (CCont) = return CCont++mkVarSwitch env t0 e alts+ | isEVar e = do (bs,t,e) <- pExp env e+ alts <- mapM (pAlt env e t t0) alts+ return (cBind bs (CSwitch e alts))+ | otherwise = do (bs,t,e) <- pExp env e+ x <- newName tempSym+ c <- pCmd (addVals [(x,t)] env) t0 (CSwitch (EVar x) alts)+ return (cBind bs (cBind [(x,Val t e)] c))++mkSwitch env e [] [ACon n _ _ c]+ | n `notElem` tagged env = c+mkSwitch env e [] [AWild c] = c+mkSwitch env e [] alts1 = CSwitch (ESel e (prim Tag)) (map (mkLitAlt env) alts1)+mkSwitch env e alts0@[ACon n _ _ c] []+ | allCons env alts0 == [n] = c+mkSwitch env e alts0 [] = CSwitch (ECast tInt e) (map (mkLitAlt env) alts0)+mkSwitch env e alts0 alts1 = mkSwitch env e (alts0++[AWild d]) []+ where d = mkSwitch env e [] alts1+++mkLitAlt env (ACon n [] [] c) = ALit (conLit env n) c+mkLitAlt env a = a+++-- Prepare switch alternatives+pAlt env _ _ t0 (AWild c) = liftM AWild (pCmd env t0 c)+pAlt env _ _ t0 (ALit l c) = liftM (ALit l) (pCmd env t0 c)+pAlt env e (TCon _ ts) t0 (ACon k vs te c)+ = do te' <- newEnv paramSym (polyTagTypes (length vs))+ c <- pCmd (addPolyEnv vs [0..] (map EVar (dom te')) (addVals te env)) t0 c+ return (ACon k [] [] (cBind (bs0 te' ++ bs1) c))+ where bs0 te = zipWith mkBind te (_abcSupply `zip` repeat (ValT tBITS32))+ (_,te0) = findStructTEnv "KKK" env (TCon k (ts ++ map tVar vs))+ bs1 = filter (not . isDummy . fst) (zipWith mkBind te te0)+ mkBind (x,t) (y,ValT u) = (x, Val t (cast t u (ESel (ECast (TCon k (ts ++ map tVar vs)) e) y)))+ + ++mkSeq c1 c2 = case anchor c1 of+ (bf,CBreak) -> bf c2+ (bf,CCont) -> c1+ _ -> CSeq c1 c2+ where anchor (CBind r bs c) = (CBind r bs . bf, c')+ where (bf,c') = anchor c+ anchor (CRun e c) = (CRun e . bf, c')+ where (bf,c') = anchor c+ anchor (CUpd x e c) = (CUpd x e . bf, c')+ where (bf,c') = anchor c+ anchor (CUpdS e x e' c) = (CUpdS e x e' . bf, c')+ where (bf,c') = anchor c+ anchor (CUpdA e i e' c) = (CUpdA e i e' . bf, c')+ where (bf,c') = anchor c+ anchor c = (id, c)++++-- =============================+-- Prepare expressions+-- =============================++-- Prepare a right-hand-side expression+pRhsExp env (ENew n ts bs) = pNewExp env n ts bs+pRhsExp env (ECast t (ENew n ts bs))+ = do (bs',t',e) <- pNewExp env n ts bs+ return (bs', t, cast t t' e)+pRhsExp env e = pExp env e+++pNewExp env n ts bs+ | n `elem` nulls env = return ([], t0, cast t0 tInt (ELit (conLit env n)))+ | otherwise = do (bs1,bs) <- pBinds (pSBind t0 te0) env bs+ return (bs1, t0, ENew n [] (bs''++bs'++bs))+ where bs' = if n `elem` tagged env then [(prim Tag, Val tInt (ELit (conLit env n)))] else []+ bs'' = polyTagBinds env n ts+ t0 = TCon n ts+ (_,te0) = findStructTEnv "BB" env t0+++pRefBind te0 env (x,Val _ e) = do (bs,t,e) <- pRhsExp env e + return (bs, (x, Val (erase t0) (cast t0 t e)))+ where t0 = findValT "1" te0 x+++-- Prepare an expression in an arbitrary position and match its type with the expected one+pExpT env t0 e = do (bs,t,e) <- pExp env e+ return (bs, cast t0 t e)+++cast t0 t1 e+ | u0 == u1 = e+ | u0 == tPOLY && smallPrim u1 = ECast tPOLY (ECast tInt e)+ | smallPrim u0 && u1 == tPOLY = ECast u0 (ECast tInt e)+ | u0 == tPOLY && u1 == tFloat = ECall (prim Float2POLY) [] [e]+ | u0 == tFloat && u1 == tPOLY = ECall (prim POLY2Float) [] [e]+ | otherwise = ECast u0 e+ where u0 = erase t0+ u1 = erase t1++smallPrim (TCon (Prim p _) _) = p `elem` smallPrims+smallPrim _ = False+++pExpTs env [] [] = return ([], [])+pExpTs env (t:ts) (e:es) = do (bs1,e) <- pExpT env t e+ (bs2,es) <- pExpTs env ts es+ return (bs1++bs2, e:es)+++-- Prepare an expression in an arbitrary position and compute its type+pExp env (EVar x) = return ([], findValT "4" (tenv env) x, EVar x)+pExp env (ELit l) = return ([], litType l, ELit l)+pExp env (EThis) = return ([], findValT "5" (tenv env) x, EVar x)+ where x = fromJust (this env)+pExp env (ESel e l) = do (bs,t1,e) <- pExp env e+ let (s,te) = findStructTEnv "CC" env t1+ t = findValT ("6" ++ " e: " ++ render (pr e) ++ " te: " ++ show te) te l+ specialize s t bs (ESel e l)+pExp env (ECall f ts es) = do (bs,es) <- pExpTs env ts0 es+ specialize s t bs (ECall f [] (polyTagArgs env ts ++ es))+ where (s,ts0,t) = findFunT (tenv env) f ts+pExp env (EEnter (EVar x) f ts es) = do let t1 = findValT "7" (tenv env) x+ let (s,te) = findStructTEnv "DD" env t1+ (s',ts0,t) = findFunT te f ts+ (bs2,es) <- pExpTs env ts0 es+ specialize (s'@@s) t bs2 (EEnter (EVar x) f [] (polyTagArgs env ts ++ es))+pExp env (EEnter e f ts es) = do (bs1,t1,e) <- pRhsExp env e+ let (s,te) = findStructTEnv "EE" env t1+ (s',ts0,t) = findFunT te f ts+ (bs2,es) <- pExpTs env ts0 es+ x <- newName tempSym+ specialize (s'@@s) t (bs1++bs2++[(x, Val (erase t1) e)]) (EEnter (EVar x) f [] (polyTagArgs env ts ++ es))+pExp env (ECast t e) = do (bs,t',e) <- pExp env e+ return (bs, t, cast t t' e)+pExp env (ENew n ts bs)+ | n `elem` nulls env = return ([], tInt, ELit (conLit env n))+ | otherwise = do (bs1,t,e) <- pNewExp env n ts bs+ x <- newName tempSym+ return (bs1++[(x, Val (erase t) e)], t, EVar x)++specialize s t bs e = return (bs, t', cast t' t e)+ where t' = subst s t
+ src/Reduce.hs view
@@ -0,0 +1,950 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Reduce where++import PP+import Common+import Core+import Env+import Kind+import Depend+import Termred+++++type TSubst = Map TVar Type++type TEqs = [(Type,Type)]++noreduce env eqs pe = do s0 <- unify env eqs+ return (s0, pe, id)++fullreduce :: Env -> TEqs -> PEnv -> M s (TSubst, PEnv, Exp->Exp)+fullreduce env eqs pe = do -- tr ("FULLREDUCE\n" ++ render (vpr pe))+ (s1,pe1,f1) <- normalize env eqs pe+ -- tr ("Subst: " ++ show s1)+ let env1 = subst s1 env+ (s2,pe2,f2) <- resolve env1 pe1+ -- tr ("END FULLREDUCE " ++ show pe2)+ return (s2@@s1, pe2, f2 . f1)++topresolve env eqs pe bs = do (s,[],f) <- fullreduce env eqs pe+ let Binds r te es = collect (f (ELit (lInt 0))) `catBinds` bs+ return (Binds r (subst s te) es)+ where collect (ELet bs e) = bs `catBinds` collect e+ collect e = nullBinds++normalize env eqs pe = do -- tr ("NORMALIZE: " ++ render (vpr pe))+ s0 <- unify env eqs+ -- tr ("NORMALZE B: " ++ show s0)+ let env0 = subst s0 env+ (s1,pe1,f1) <- norm env0 (subst s0 pe)+ -- tr ("END NORMALZE ")+ return (s1@@s0, pe1, f1)+ ++norm env [] = return ([], [], id)+norm env pe = do -- tr ("NORM A\n" ++ render (nest 8 (vpr pe)))+ (s1, pe1, f1) <- reduce env pe+ -- tr ("NORM B\n" ++ render (nest 8 (vpr pe1)))+ (s2, pe2, f2) <- simplify (subst s1 env) pe1+ -- tr ("NORM C\n" ++ render (nest 8 (vpr pe2)))+ return (s2@@s1, pe2, f2 . f1)++-- Auxiliary function for type error messages -------------------------------------------------++{-++Type error messages are still a hack.++The problem is to find reasonable error messages when the constraint-solver has failed after+having backtracked and tried several alternatives. he present approach works reasonably well +when failing in search for a witness of a typeclass, but gives a confusing message (only+the last alternative tried) in other cases. ++Also, coding of various types of failure in the first character of the error message is not+very elegant...++-}++data ErrType = Solve | Unify | Other++typeError e env msg = char e : "Type error " ++ (show (errPos env)) ++ "\n" ++ msg+ where char Solve = '+'+ char Unify = '-'+ char Other = ' '++-- Conservative reduction ----------------------------------------------------------------------++reduce env pe = do -- tr ("###reduce\n" ++ render (nest 8 (vpr pe)) ) -- ++ "\n\n" ++ show (tvars (typeEnv env)))+ (s,q,[],es) <- red [] (map mkGoal pe)+ -- tr ("###result\n" ++ render (nest 8 (vpr q)))+ -- tr (" " ++ show s)+ return (s, q, eLet pe (dom pe `zip` es))+ where mkGoal (v,p) = (tick env{errPos = posInfo v} (isCoercion v || isDummy v), p)++-- Simplification ------------------------------------------------------------------------------++simplify env pe = do cs <- newNames skolemSym (length tvs)+ -- tr ("****SIMPLIFY\n" ++ render (nest 8 (vpr (subst (tvs`zip`map TId cs) pe))))+ r <- expose (closePreds env [] (subst (tvs`zip`map TId cs) pe) (cs`zip`ks))+ case r of+ Right (env',qe,eq) -> return (nullSubst, pe', eLet' (subst s bss))+ where (pe',bss) = preferLocals env' pe qe eq+ s = cs `zip` map TVar tvs+ Left s -> case decodeError s of+ Nothing -> fail (typeError Other env s)+ Just (m,ids) | m == circularSubMsg -> + do (t:ts) <- mapM sat tvs'+ -- tr ("Circular: " ++ showids ids)+ s <- unify env (repeat t `zip` ts)+ -- tr ("New: " ++ render (nest 8 (vpr (subst s pe))))+ (s',pe',f) <- norm (subst s env) (subst s pe)+ return (s'@@s, pe', f)+ where tvs' = [ tv | (tv,c) <- tvs `zip` cs, c `elem` ids ]+ sat tv = do ts <- mapM newTVar (kArgs (tvKind tv))+ return (tAp (TVar tv) ts)+ Just (m,ids) | m `elem` [ambigSubMsg, ambigInstMsg] ->+ do -- tr ("Ambiguous: " ++ showids ids)+ -- tr (render (nest 8 (vpr (t:ts))))+ s <- unifyS env (repeat t `zip` ts)+ -- tr ("New:\n" ++ render (nest 8 (vpr (subst s pe))))+ (s',pe',f) <- norm (subst s env) (subst s pe)+ return (s'@@s, pe', f)+ where (t:ts) = map (lookup' (pe ++ predEnv env ++ predEnv0 env)) ids+ where tvs = tvars pe+ ks = map tvKind tvs+++{-++B x < C Int \\ x+A x < B x \\ x, A x < C x \\ x++A x < B x \\ x, A x < C x \\ x+B x < C Int \\ x++Show [a] \\ a+Show [Char] \\++E a \\ a+E a \\ a, F a++b x < c Int \\ x, a x < b x \\ x, a x < c x \\ x++a x < b x \\ x, a x < c x \\ x, b x < c Int \\ x++-}++-- Forced reduction ------------------------------------------------------------------------++resolve env pe = do -- tr ("############### Before resolve: ")+ -- tr (render (nest 8 (vpr pe)))+ -- tr ("tevars: " ++ show env_tvs ++ ", reachable: " ++ show reachable_tvs)+ (s1,q1,[],es) <- red [] (map mkGoal pe)+ -- tr ("############### After resolve: ")+ -- tr (render (nest 8 (vpr q1)))+ let f1 = eLet pe (dom pe `zip` es)+ badq = filter badDummy q1+ assert1 (null badq) "Cannot resolve predicates" (snd (head badq))+ -- tr "DONE RESOLVING"+ (s2,q2,f2) <- simplify (subst s1 env) q1+ return (s2@@s1, q2, f2 . f1)+ where env_tvs = tevars env+ reachable_tvs = vclose (map tvars pe) (ps ++ ns ++ env_tvs)+ where (ps,ns) = pols env+ mkGoal (v,p) = (force env' (coercion || ambig), p)+ where tvs = tvars p+ coercion = isCoercion v+ ambig = null (tvs `intersect` reachable_tvs)+ env' = tick env coercion+ badDummy (v,p) = isDummy v && null (tvars p `intersect` env_tvs)+++{-++ C1 x < C x+ C2 x < C Y+ C3 x < C y \\ x < y+++ |- m aa < C b |- Int < Int (All a . Exists b . m a < C b)+ ------------------------------ (All a . m a < C b)+ |- C b -> Int < m aa -> Int+ --------------------------------------- (All a . (All b . m a < C b) =>+ |- (All b . C b -> Int) < m aa -> Int+ ----------------------------------------------+ |- All a . (All b . C b -> Int) < m a -> Int++++ |- C1 aa < C aa |- Int < Int C1 / m, aa / b+ --------------------------------+ |- C aa -> Int < C1 aa -> Int+ ----------------------------------------+ |- (All b . C b -> Int) < C1 aa -> Int+ -----------------------------------------------+ |- All a . (All b . C b -> Int) < C1 a -> Int++++ |- C2 aa < C Y |- Int < Int C2 / m, Y / b+ -------------------------------+ |- C Y -> Int < C2 aa -> Int+ ----------------------------------------+ |- (All b . C b -> Int) < C2 aa -> Int+ ------------------------------------------------+ |- All a . (All b . C b -> Int) < C2 ab -> Int+++ All a . a < b |- aa < b C3 / m+ -----------------------+ All a . a < b |- C3 aa < C b |- Int < Int+ ---------------------------------------------+ All a . a < b |- C b -> Int < C3 aa -> Int+ -----------------------------------------------------+ All a . a < b |- (All b . C b -> Int) < m aa -> Int+ ------------------------------------------------------------+ All a . a < b |- All a . (All b . C b -> Int) < m a -> Int+++++-}++-- Scheme reduction -----------------------------------------------------------------------------+--+-- If red cs ps == (s,q,es,es') then q |- es :: subst s cs and q |- es' :: subst s ps+--+-------------------------------------------------------------------------------------------------++redg r i gs = do -- tr ("Chosen goal: " ++ render (pr (snd g)) ++ " at index " ++ show i ++ ", rank: " ++ show r)+ -- tr ("***All goals:")+ -- tr (render (nest 4 (vpr (rng gs))))+ (s,q,e:es) <- solve r g (gs1++gs2)+ let (es1,es2) = splitAt i es+ return (s, q, es1++[e]++es2, [])+ where (gs1, g:gs2) = splitAt i gs+++red [] [] = return (nullSubst, [], [], [])+red gs [] = do -- tr ("Ranks: " ++ show rs)+ case unique 0 gs of+ Just (r,i) -> redg r i gs -- goal can be selected without computing costly varInfo+ Nothing -> redg r i gs -- goal must be selected on basis of varInfo+ where rs = map (rank info) gs+ r = minimum rs+ i = length (takeWhile (/=r) rs)+ info = varInfo gs+red gs ((env, p@(Scheme (F [sc1] t2) ps2 ke2)):ps)+ = do (t1,ps1) <- inst sc1+ -- tr ("redf " ++ render (pr t1 <+> text "<" <+> pr t2))+ pe <- newEnv assumptionSym ps2+ v <- newName coercionSym+ (env',qe,eq) <- closePreds env (tvars sc1 ++ tvars t2 ++ tvars ps2) pe ke2+ let ps' = repeat (tick env' False) `zip` ps1+ (s,q,es,e,es') <- redf gs env' t1 t2 (ps'++ps)+ pe1 <- wildify ke2 pe+ qe1 <- wildify ke2 qe+ let (es1,es2) = splitAt (length ps') es'+ bss = preferParams env' pe1 qe1 eq+ e' = eLet' bss (EAp e [eAp (EVar v) es1])+ return (s, q, es, eLam pe1 (ELam [(v,sc1)] e') : es2)+red gs ((env, Scheme (R t) ps' ke):ps) = do pe <- newEnv assumptionSym ps'+ (env',qe,eq) <- closePreds env (tvars t ++ tvars ps') pe ke+ (s,q,e:es,es') <- red ((env',t) : gs) ps+ pe1 <- wildify ke pe+ qe1 <- wildify ke qe+ let bss = preferParams env' pe1 qe1 eq+ return (s, q, es, eLam pe1 (eLet' bss e) : es')++{-+ ts -> t < ts' -> t'+ts1,ts2 -> t < ts1',ts2' -> t'++es1 :: ts1' < ts1+e :: ts2->t < ts2'->t'++e0 = \(v::ts->t) -> \(ys1:ts1',ys2:ts2') -> e1++e1 :: t' = e e2 ys2+e2 :: ts2->t = \(xs2:ts2) -> v (es3,xs2)+es3 :: ts1 = es1@ys1+-}++redf gs env (F ts t) (F ts' t') ps = do te1' <- newEnv assumptionSym ts1'+ te2' <- newEnv assumptionSym ts2'+ te2 <- newEnv assumptionSym ts2+ v <- newName coercionSym+ (s,q,es,e,es1,es2) <- redf1 gs env (tFun ts2 t) (tFun ts2' t') ts1' ts1 ps+ let e0 = ELam [(v,scheme' (F ts t))] (ELam (te1'++te2') e1)+ e1 = eAp (EAp e [e2]) (map EVar (dom te2'))+ e2 = eLam te2 (EAp (EVar v) (es3 ++ map EVar (dom te2)))+ es3 = zipWith eAp1 es1 (map EVar (dom te1'))+ return (s, q, es, e0, es2)+ where (ts1 ,ts2 ) = splitAt (length ts') ts+ (ts1',ts2') = splitAt (length ts ) ts'+redf gs env (R (TFun ts t)) b ps = redf gs env (F (map scheme ts) (R t)) b ps+redf gs env a (R (TFun ts t)) ps = redf gs env a (F (map scheme ts) (R t)) ps+redf gs env (R a@(TVar n)) b@(F ts _) ps+ | n `elem` tvars b = fail (typeError Other env "Infinite function type")+ | otherwise = do (t:ts') <- mapM newTVar (replicate (length ts + 1) Star)+ s <- unify env [(a, TFun ts' t)]+ redf2 s gs env (F (map scheme ts') (R t)) b ps +redf gs env a@(F ts _) (R b@(TVar n)) ps+ | n `elem`tvars a = fail (typeError Other env "Infinite function type")+ | otherwise = do (t:ts') <- mapM newTVar (replicate (length ts + 1) Star)+ s <- unify env [(TFun ts' t, b)]+ redf2 s gs env a (F (map scheme ts') (R t)) ps +redf gs env (R a) (R b) ps = do (s,q,e:es,es') <- red ((tick env True, a `sub` b) : gs) ps+ return (s,q,es,e,es')+redf _ env t1 t2 _ = fail (typeError Other env ("Cannot solve " ++ render (pr t1) ++ " < " ++ render (pr t2)))+++redf1 gs env a b (sc1:ts1) (sc2:ts2) ps = do (s,q,es,e,es1,e2:es2) <- redf1 gs env a b ts1 ts2 ((env,sc):ps)+ return (s, q, es, e, flip e2 : es1, es2)+ where Scheme t2 ps2 ke2 = sc2+ sc = Scheme (F [sc1] t2) ps2 ke2+ flip e | null ps2 = e+ flip (ELam te2 (ELam te1 t)) = ELam te1 (ELam te2 t)+redf1 gs env a b [] [] ps = do (s,q,es,e,es2) <- redf gs env a b ps+ return (s,q,es,e,[],es2)++++redf2 s gs env a b ps = do (s',q,es,e,es') <- redf (subst s gs) (subst s env) + (subst s a) (subst s b) (subst s ps)+ return (s'@@s,q,es,e,es')++++-- Predicate reduction ----------------------------------------------------------------------++solve RFun (env,p) gs = do -- tr ("------ Resubmitting: " ++ render (pr p))+ (s,q,es,[e]) <- red gs [(env, scheme' (F [scheme a] (R b)))]+ return (s, q, e:es)+ where (a,b) = subs p+solve RUnif (env,p) gs = do -- tr ("------ Unifying: " ++ render (pr p))+ s <- unify env [(a,b)]+ (s',q,es,[]) <- red (subst s gs) []+ return (s'@@s, q, EVar (prim Refl) : es)+ where (a,b) = subs p+solve RVar g gs = do -- tr ("------ Abstracting\n" ++ render (nest 4 (vpr (rng (g:gs)))))+ (qs,es) <- fmap unzip (mapM newHyp (g:gs))+ return (nullSubst, concat qs, es)+solve r g gs+ | mayLoop g = do assert0 (conservative g) "Recursive constraint"+ -- tr ("------ Avoiding loop: " ++ render (pr (snd g)))+ (s,q,es,_) <- red gs []+ (q',e) <- newHyp (subst s g)+ return (s, q'++q, e:es)+ | otherwise = do -- tr ("------ Solving " ++ render (pr (snd g)))+ -- tr (render (nest 4 (vpr (rng gs))))+ -- tr ("Witness graph: " ++ show (findWG r g))+ try r (Left msg) (findWG r g) (logHistory g) gs+ where msg = typeError Solve (fst g) ("Cannot solve typing constraint "++render(prPred (snd g)))+++try r accum wg g gs+ | isNullWG wg || isNull accum = unexpose accum+ | otherwise = do -- tr ("Trying " ++ render (pr (snd g)) ++ " with " ++ render (pr (predOf wit)))+ res <- expose (hyp wit g gs)+ accum <- plus (g : gs) accum res+ -- tr ("New accum: " ++ show accum)+ try r accum (wg2 res) g gs+ where (wit,wg1) = takeWG wg+ wg2 res = if mayPrune res r g then pruneWG (nameOf wit) wg1 else wg1++mayPrune (Left _) _ _ = False+mayPrune (Right r) (RClass _ _) (env,c) = forced env || subst (fst3 r) c == c+mayPrune _ _ _ = True+++hyp (w,p) (env,c) gs = do (R c',ps) <- inst p+ -- tr ("### Trying: " ++ render (pr c) ++ " with " ++ render (pr (w,p)))+ s <- unify env [(c,c')]+ -- tr (" OK")+ let ps' = repeat (subst s env) `zip` subst s ps+ -- if not (null ps') then tr ("@@ Appending\n" ++ render (nest 4 (vpr (rng ps')))) else return ()+ (s',q,es,es') <- red (subst s gs) ps'+ return (s'@@s, q, eAp (EVar w) es' : es)+++plus gs (Left a) (Left b)+ |head a == '+' &&+ head b == '-' = return (Left a)+ |otherwise = return (Left b)+plus gs (Left a) b = return b+plus gs a (Left b) = return a+plus gs (Right (s1,_,es1)) (Right (s2,_,es2)) + = do s <- auSubst env s1 s2+ (s',q,es) <- auTerms (subst s gs) es1 es2+ return (Right (s'@@s, q, es))+ where env = fst (head gs)+++-- Anti-unification --------------------------------------------------------------------------++auSubst env [] s2 = return []+auSubst env ((v1,t1):s1) s2 = case lookup v1 s2 of+ Just t2 | h1 == h2 -> + do ts <- auTypes ts1 ts2+ s <- auSubst env s1 s2+ return ((v1, tAp h1 ts):s)+ where (h1,ts1) = tFlat t1+ (h2,ts2) = tFlat t2+ _ -> auSubst env s1 s2+ where auType t1 t2+ | h1 == h2 = do ts <- auTypes ts1 ts2+ return (tAp h1 ts)+ | otherwise = newTVar (kindOfType env t1)+ where (h1,ts1) = tFlat t1+ (h2,ts2) = tFlat t2+ auTypes ts1 ts2 = sequence (zipWith auType ts1 ts2)++++auTerms gs es1 es2 = auZip auTerm gs es1 es2+ where+ auZip f [] [] [] = return ([],[],[])+ auZip f (g:gs) (e1:es1) (e2:es2) = do (s,q,e) <- f g e1 e2+ (s',q',es) <- auZip f (subst s gs) es1 es2+ return (s'@@s, subst s' q ++ q', e:es)+ auZip f gs es1 es2 = internalError0 ("auZip " ++ show gs ++"\n" ++ show es1 ++ "\n" ++ show es2) + auTerm g@(env,c) e1 e2 = auTerm' g (eFlat e1) (eFlat e2)+++ auTerm' g@(env,c) (EVar v1, es1) (EVar v2, es2)+ | v1 == v2 = do (R c',ps) <- inst (findPred env v1)+ let s = matchTs [(c,c')]+ (s',q,es) <- auZip auSc (repeat (subst s env) `zip` subst s ps) es1 es2+ return (s'@@s, q, eAp (EVar v1) es)+ auTerm' g@(env,c) (ELam pe1 e1, es1) (ELam pe2 e2, es2)+ | ps1 == ps2 = do (s,q,e) <- auTerm g e1 (subst s0 e2)+ (s',q',es) <- auZip auSc (repeat (subst s env) `zip` subst s ps1) es1 es2+ return (s'@@s, subst s' q ++ q', eAp (ELam pe1 e) es)+ where (vs1,ps1) = unzip pe1+ (vs2,ps2) = unzip pe2+ s0 = vs2 `zip` map EVar vs1+ auTerm' g e1 e2 = do (q,e) <- newHyp g+ return ([], q, e)++ auSc (env,Scheme (R c) [] ke) e1 e2 = auTerm (addKEnv ke env,c) e1 e2+ auSc (env,Scheme (R c) ps ke) (ELam pe1 e1) (ELam pe2 e2) + = do (s,q,e) <- auTerm (env',c) e1 (subst s0 e2)+ return (s, q, ELam pe1 e)+ where s0 = dom pe2 `zip` map EVar (dom pe1)+ env' = addPEnv pe1 (addKEnv ke env)+ auSc _ _ _ = internalError0 "auTerms"+++newHyp (env,c) = do -- tr ("newHyp " ++ render (pr p) ++ " " ++ show (forced env))+ v <- newName (sym env)+ return ([(v,p)], eAp (EVar (annotExplicit v)) (map EVar vs))+ where p = Scheme (R c) ps ke+ (vs,ps) = unzip (predEnv env)+ ke = kindEnv env+ sym env+ | forced env = dummySym -- unwanted garbage predicate, trap in resolve+ | ticked env = coercionSym -- originates from a coercion predicate+ | otherwise = assumptionSym -- ordinary predicate+++-- Unification ----------------------------------------------------------++unify env [] = return nullSubst+unify env ((TVar n,t):eqs)+ | mayBind env n = tvarBind env n t eqs+unify env ((t,TVar n):eqs)+ | mayBind env n = tvarBind env n t eqs+unify env ((TAp t u,TAp t' u'):eqs) = unify env ((t,t'):(u,u'):eqs)+unify env ((TId c,TId c'):eqs)+ | c == c' = unify env eqs+unify env ((TFun ts t, TFun ts' t'):eqs)+ | length ts == length ts' = unify env ((t,t') : ts `zip` ts' ++ eqs)+unify env ((t1,t2):_) = fail (typeError Unify env ("Cannot unify " ++ render(pr t1) ++ " with " ++ render(pr t2)))++tvarBind env n t eqs+ | t == TVar n = unify env eqs+ | tvKind n /= kindOfType env t = fail (typeError Other env ("Kind mismatch in unify: " ++ show (tvKind n) ++ + " and " ++ show (kindOfType env t)))+ | n `elem` tvars t = fail (typeError Other env "Occurs check failed in unify")+ | n `elem` skolEnvs env (tyvars t) = fail (typeError Other env "Skolem escape in unify")+ | otherwise = do s' <- unify (subst s env) (subst s eqs)+ return (s' @@ s)+ where s = n +-> t++mayBind env n = not (frozen env && n `elem` pevars env)+++-- Unification lifted to type schemes: only used to resolve ambiguities found during simplification --------------------++unifyS env ((Scheme r ps ke,Scheme r' ps' ke'):eqs)+ | rng ke == rng ke' &&+ length ps == length ps' = do s <- unifyR env (subst s0 r, subst s0 r')+ s' <- unifyS env (subst s (subst s0 ((ps `zip` ps') ++ eqs)))+ return (s' @@ s)+ | otherwise = fail (typeError Other env "Quantified predicates not unifiable")+ where s0 = dom ke `zip` map TId (dom ke')+unifyS env [] = return nullSubst++unifyR env (R t, R t') = unify env [(t,t')]+unifyR env (F scs r, F scs' r')+ | length scs == length scs' = do s <- unifyS env (scs `zip` scs')+ s' <- unifyR env (subst s r, subst s r')+ return (s' @@ s)+unifyR env _ = fail (typeError Other env "Subtype predicates not unifiable")++ +-- Misc ----------------------------------------------------------------++mayLoop (env,c) = any (\c' -> equalTs [(c,c')]) (history env)+++isNull (Right ([],q,es))+ | all varTerm es = True+ where varTerm (EAp e es) = varTerm e+ varTerm (ELam pe e) = varTerm e+ varTerm (EVar v) = v `elem` vs+ varTerm _ = False+ vs = dom q+isNull _ = False++++-- Adding predicates to the environment -------------------------------------------------++closePreds0 env pe = do (env1,pe1,eq1) <- closeTransitive env0 pe+ (env2,pe2,eq2) <- closeSuperclass env1 pe+ return (env2, pe1++pe2, eq1++eq2)+ where env0 = addPEnv0 pe env++closePreds env tvs pe ke = do (env1,pe1,eq1) <- closeTransitive env0 pe+ (env2,pe2,eq2) <- closeSuperclass env1 pe+ return (thaw env2, pe1++pe2, eq1++eq2)+ where se = mapSnd (const (tvs ++ pevars env)) ke+ env0 = freeze (addPEnv pe (addSkolEnv se (addKEnv ke env)))+++preferLocals env pe qe eq = walk [] (equalities env)+ where walk bs [] = let (pe1,pe2) = partition ((`elem` dom bs) . fst) pe+ in (pe2, groupBinds (Binds False (pe1++qe) (prune eq (dom bs) ++ mapSnd EVar bs)))+ walk bs ((x,y):eqs)+ | x `notElem` vs1 = walk bs eqs+ | y `notElem` vs1 = walk bs eqs+ | otherwise = case (x `elem` vs0, y `elem` vs0) of+ (True, True) -> walk ((x,y):bs) eqs+ (True, False) -> walk ((x,y):bs) eqs+ (False, True) -> walk ((y,x):bs) eqs+ (False, False) -> walk ((y,x):bs) eqs+ vs0 = dom pe+ vs1 = vs0 ++ dom qe++preferParams env pe qe eq = walk [] [] (equalities env)+ where walk ws bs [] = groupBinds (Binds False (prune qe ws) (prune eq (ws ++ dom bs) ++ mapSnd EVar bs))+ walk ws bs ((x,y):eqs)+ | x `notElem` vs1 = walk ws bs eqs+ | y `notElem` vs1 = walk ws bs eqs+ | otherwise = case (x `elem` vs0, y `elem` vs0) of+ (True, True) -> walk ws bs eqs+ (True, False) -> walk ws ((y,x):bs) eqs+ (False, True) -> walk (x:ws) bs eqs+ (False, False) -> walk (x:ws) bs eqs+ vs0 = dom pe+ vs1 = vs0 ++ dom qe+++{-+ Top-level & local reduction: Action during simplify:+In (equalities env): Meaning: (prefer assumptions (v) in (pe)) (prefer local defs (w) in (qe))++ (v,v') Two witness assumptions equal Ignore equality info Remove assumption v+ [only v' is in use] Add def "let v = v' in ..."++ (v,w') Witness assumption is equal to a Remove local def of w' [in use] Remove assumption v+ local def Add "let w' = v in ..." Add def "let v = w' in ..."++ (w,v') Witness assumption is equal to a Remove local def of w Remove assumption v'+ local def [only assumption v' is in use] Add def "let v' = w in ..."++ (w,w') Two local witness definitions Remove local def of w Remove local def of w'+ are equal [only w' is in use] Add def "let w' = w in ..."++ v and v' are witness assumptions (elements of (dom pe))+ w and w' are locally generated witnesses (elements of (dom qe))++-}+++mapSuccess f xs = do xs' <- mapM (expose . f) xs+ return (unzip [ x | Right x <- xs' ])+++-- Handle subtype predicates+closeTransitive env [] = return (env, [], [])+closeTransitive env ((w,p):pe)+ | isSub' p = do assert1 (a /= b) "Illegal subtype predicate" p+ (pe1,eq1) <- mapSuccess (mkTrans env) [ (n1,n2) | n1 <- below_a, n2 <- [(w,p)] ]+ (pe2,eq2) <- mapSuccess (mkTrans env) [ (n1,n2) | n1 <- (w,p):pe1, n2 <- above_b ]+ let cycles = filter (uncurry (==)) (map (subsyms . predOf) (pe1++pe2))+ assert0 (null cycles) (encodeError circularSubMsg (nub (a:b:map fst cycles)))+ env2 <- addPreds env ((w,p):pe1++pe2)+ (env3,pe3,eq3) <- closeTransitive env2 pe+ return (env3, pe1++pe2++pe3, eq1++eq2++eq3)+ where (a,b) = subsyms p+ below_a = nodes (findBelow env a)+ above_b = nodes (findAbove env b)+closeTransitive env (_:pe) = closeTransitive env pe+++mkTrans env ((w1,p1), (w2,p2)) = do (pe1, R c1, e1) <- instantiate p1 (EVar w1)+ (pe2, R c2, e2) <- instantiate p2 (EVar w2)+ let (t1,t1') = subs c1+ (t2',t2) = subs c2+ s <- unify env [(t1',t2')]+ let t = subst s t1+ p = scheme (t `sub` subst s t2)+ (s',qe,f) <- norm (protect p env) (subst s (pe1++pe2))+ x <- newName paramSym+ let e = ELam [(x,scheme (subst s' t))] (f (EAp e2 [EAp e1 [EVar x]]))+ (e',p') = qual qe e (subst s' p)+ sc <- gen (tevars env) p'+ w <- newNameMod (modName env) coercionSym+ e' <- redTerm (coercions env) e'+ return ((w,sc), (w, e'))++-- Handle class predicates+closeSuperclass env [] = return (env, [], [])+closeSuperclass env ((w,p):pe)+ | isClass' p = do (pe1,eq1) <- mapSuccess (mkSuper env (w,p)) [ n | n <- above_c ]+ env1 <- addPreds env ((w,p):pe1)+ (env2,pe2,eq2) <- closeSuperclass env1 pe+ return (env2, pe1++pe2, eq1++eq2)+ where c = headsym p+ above_c = filter ((`elem` dom (classEnv env)) . uppersym . predOf) (nodes (findAbove env c))+closeSuperclass env (_:pe) = closeSuperclass env pe++mkSuper env (w1,p1) (w2,p2) = do (pe1, R c1, e1) <- instantiate p1 (EVar w1)+ (pe2, R c2, e2) <- instantiate p2 (EVar w2)+ let (t2',t2) = subs c2+ s <- unify env [(c1,t2')]+ let p = scheme (subst s t2)+ (s',qe,f) <- norm (protect p env) (subst s (pe1++pe2))+ let e = f (EAp e2 [e1])+ (e',p') = qual qe e (subst s' p)+ sc <- gen (tevars env) p'+ w <- newNameMod (modName env) witnessSym+ return ((w,sc), (w,e'))+ ++-- Add predicates to the environment and build overlap graph+addPreds env [] = return env+addPreds env (n@(w,p):pe)+ | isSub' p = case findCoercion env a b of+ Just (w',p') -> do + r <- implications env p' p+ case r of+ Equal -> addPreds (addEqs [(w,w')] env) pe+ ImplyRight -> addPreds env pe+ ImplyLeft -> addPreds env pe -- Ignore w for now (should really replace w')+ Unrelated -> fail (encodeError ambigSubMsg [w,w'])+ Nothing -> do + addPreds (insertSubPred n env) pe+ | isClass' p = do r <- cmpNode [] [] (nodes (findClass env c))+ case r of++ Right (pre,post) -> addPreds (insertClassPred pre n post env) pe+ Left w' -> addPreds (addEqs [(w,w')] env) pe+ where (a,b) = subsyms p+ c = headsym p++ cmpNode pre post [] = return (Right (pre,post))+ cmpNode pre post ((w',p'):pe') = do r <- implications env p' p+ case r of+ Equal + | isGenerated w || isGenerated w' -> return (Left w')+ | otherwise -> fail (encodeError ambigInstMsg [w,w'])+ ImplyRight -> cmpNode pre (w':post) pe'+ ImplyLeft -> cmpNode (w':pre) post pe'+ Unrelated -> cmpNode pre post pe'+++data Implications = Equal | ImplyRight | ImplyLeft | Unrelated+ deriving (Eq,Show)++implications env p1 p2 = do (R c1,ps1) <- inst p1+ (R c2,ps2) <- inst p2+ r1 <- expose (unify (addKEnv (quant p2) env) [(c1,body p2)])+ r2 <- expose (unify (addKEnv (quant p1) env) [(body p1,c2)])+ case (r1,r2) of+ (Right s, Right _) -> return Equal+ (Right _, Left _) -> return ImplyRight+ (Left _, Right _) -> return ImplyLeft+ (Left _, Left _) -> return Unrelated+++++{-++ Ord a |- Ord a++ Ord a \\ a |- Ord Int++ C a \\ a |- D a => C a \\ a++ D a => C a \\ a |- D a => E a => C a \\ a++ a < b |- a < b++ m a < m a \\ a |- m Int < m Int++ m a < n a \\ a, C a |- m a < n a \\ a+++ x : Eq a+ y : Eq a+ ==>+ eqid x : Eq a+ eqid y : Eq a+ ==>+ eqid x : Eq a |- (eqid x)/y : Eq a++-}++++{-+ A<A:0 : A : 0:A<A []+ B<B:0 : B : 0:B<B []++ buildAbove 7:A<B, (a,b)=(A,B), syms = {A}, c = A, adding A<B after A<A to aboveEnv A (0,7)++ 0:A<A : A : 0:A<A,7:A<B+++ buildBelow 7:A<B, (a,b)=(A,B), syms = {B}, c = B, adding A<B after B<B to belowEnv B (0,7)++ 7:A<B,0:B<B : B : 0:B<B++ ++-}++{-++ Ord a => Ord [a] \\ a++ (b < a) => Ord a < Ord b \\ a,b+ (b < a) => Ord a < Eq b \\ a,b++ (a < b) => [a] < [b] \\ a,b++ ...++ Ord a, [b] < [a] => Eq [b]++ Ord a, b < a => Eq [b]++ Ord a => Eq [a]+++ Eq a => Eq [a]+++ Ord aa, Eq aa, Eq a => Eq [a] \\ a |- Eq aa+ ---------------------------------------------+ Ord aa, Eq a => Eq [a] \\ a |- Eq aa+ ----------------------------------------+ Ord aa, Eq a => Eq [a] \\ a |- Eq [aa]+ ---------------------------------------------+ Eq a => Eq [a] \\ a |- Ord a => Eq [a] \\ a++-}+ ++{-++ 1: A < A x < A [ A < A, B < A, C < A ] A < x [ A < A ]++ 2: B < A x < B [ B < B, C < B ] B < x [ B < B, B < A ]++3: B < B 4: C < A x < C [ C < C ] C < x [ C < C, C < B, C < A ]++ 5: C < B++ 6: C < C++(1,2) (1,4) (2,3) (2,4) (3,5) (4,5) (4,6) (5,6)++++Show [a] \\ Show a++Show [C]++w : Eq A++u : Eq B++Eq C++x -> T \\ x < A, Show [x]++x -> T \\ x < A, Eq x++x -> T \\ x < y, y < a++++f : A->T+eq : Eq a => a->a->Bool+++ |- w : Eq A |- id : A->A->Bool < A->A->Bool+-----------------------------------------------------+ |- \v.id (v w) : Eq A => A->A->Bool < A->A->Bool+--------------------------------------------------+ |- \v.v w : Eq a => a->a->Bool < A->A->Bool+x:A |- eq : Eq a => a->a->Bool+--------------------------------+x:A |- (\v.v w) eq : A->A->Bool x:A |- x : A+-------------------------------- ---------------+x:A |- eq w x x : Bool x:A |- f x : T+-----------------------------------------------------------+x:A |- if eq w x x then f x else f x : T+-----------------------------------------------------------+ |- \x -> if eq w x x then f x else f x : A -> T+++ |- u : Eq B |- id : B->B->Bool < B->B->Bool+----------------------------------------------------+ |- \v.id (v u) : Eq B => B->B->Bool < B->B->Bool+--------------------------------------------------+ |- \v.v u : Eq a => a->a->Bool < B->B->Bool+x:B |- eq : Eq a => a->a->Bool x.B |- x : B |- b : B < A+------------------------------------ ----------------------------+x:B |- (\v.v u) eq : B->B->Bool x:B |- b x : A+------------------------------- ---------------+x:B |- eq u x x : Bool x:B |- f (b x) : T+---------------------------------------------------------------+x:B |- if eq u x x then f (b x) else f (b x) : T+---------------------------------------------------------------+ |- \x -> if eq u x x then f (b x) else f (b x) : B -> T+++P = k:x<A, j:Eq x+++P |- j : Eq x P |- id : x->x->Bool < x->x->Bool+----------------------------------------------------+P |- \v.id (v j) : Eq B => x->x->Bool < x->x->Bool+--------------------------------------------------+P |- \v.v j : Eq a => a->a->Bool < x->x->Bool+P | x:x |- eq : Eq a => a->a->Bool P | x.x |- x : x P |- k : x < A+------------------------------------ -----------------------------------+P | x:x |- (\v.v j) eq : x->x->Bool P | x:x |- k x : A+----------------------------------- ----------------------+P | x:x |- eq j x x : Bool P | x:x |- f (k x) : T+----------------------------------------------------------------------+P | x:x |- if eq j x x then f (k x) else f (k x) : T+---------------------------------------------------------------+P | |- \x -> if eq j x x then f (k x) else f (k x) : x -> T+------------------------------------------------------------------------------------+ | |- \k j x -> if eq j x x then f (k x) else f (k x) : (x < A, Eq x) => x -> T++++x < A |- x < A x < A |- T < T+------------------------------------+x < A |- A -> T < x -> T+--------------------------------+ |- x < A => (A -> T < x -> T)+--------------------------------+ |- A -> T < (x < A => x < T)+++x < A, Eq x |- x < A x < A, Eq x |- T < T+------------------------------------------------+x < A, Eq x |- A -> T < x -> T+-------------------------------------+ |- (x < T, Eq x) => (A -> T < x -> T)+--------------------------------------+ |- A -> T < ((x < A, Eq x) => x < T)+++w : Eq A+u : Eq B+c : B < A+eq : Eq a => a -> a -> Bool++eq w (f b1) (f b2) == eq u b1 b2 ???+++h . g . f == +++i2f : Int < Float++neq : Num a => a -> a++ni : Num Int+nf : Num Float++i2f (neg ni x) == neg nf (i2f x) ???+++bind : Monad m => m a -> (a->m b) -> m b+f : Request Int+g : Int -> Action+++Monad m, Request Int < m Int, Action < m b+++Monad Cmd, Request Int < Cmd Int, Action < Cmd ()++Monad (O s), Request Int < O s Int, Action < O s ()+++ |- c : Monad m => m a -> (a -> m b) -> m b < Cmd Int -> (Int -> Cmd ()) -> Cmd ()+ |- bind : Monad m => m a -> (a -> m b) -> m b +---------------------------------------------------------------------------------------------------------+ |- c bind : Cmd Int -> (Int -> Cmd ()) -> Cmd ()+----------------------------------------------+ |-> c bind f g : Cmd ()++-}+
+ src/Rename.hs view
@@ -0,0 +1,516 @@+{-# LANGUAGE FlexibleInstances #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Rename where++{-++This module does the following:+ - Checks all binding groups and patterns for duplicates (both types & terms).+ - Checks all signatures for duplicates and dangling references (kind and type sigs).+ - Completes all type signatures and constructor definitions with explicit type variable bindings.+ - Shuffles explicit signatures as close as possible to their binding occurrences (even inside patterns)+ - Checks that variables bound in generators and equations in commands do not shadow state variables.+ - Checks that assignments are to declared state variables only.+ - Resolves proper binding occurrences for all identifier references by setting the unique tag in each Name + identifier, or possibly replacing a Name with a Prim.+-}++import Monad+import Common+import Syntax+import Depend+import PP+import List(sort)++renameM e1 m = rename (initEnv e1) m+ ++-- Syntax traversal environment --------------------------------------------------++data Env = Env { rE :: Map Name Name, + rT :: Map Name Name, + rS :: Map Name Name,+ rL :: Map Name Name,+ self :: [Name],+ void :: [Name]+ } deriving Show++initEnv (rL',rT',rE') = Env { rE = primTerms ++ rE', rT = primTypes ++ rT', rS = [], rL = primSels ++ rL', self = [], void = [] }++stateVars env = dom (rS env)++tscope env = dom (rT env)+++renE env n@(Tuple _ _) = n+renE env n@(Prim _ _) = n+renE env v = case lookup v (rE env) of+ Just n -> n { annot = (annot v) {suppressMod = suppressMod (annot n)} }+ Nothing -> errorIds "Undefined identifier" [v]++renS env n@(Tuple _ _) = n+renS env n@(Prim _ _) = n+renS env v = case lookup v (rS env) of+ Just n -> n { annot = a { stateVar = True} }+ Nothing -> errorIds "Undefined state variable" [v]+ where a = annot v++renL env v = case lookup v (rL env) of+ Just n -> n { annot = (annot v){suppressMod = suppressMod (annot n)} }+ Nothing -> errorIds "Undefined selector" [v]++renT env n@(Tuple _ _) = n+renT env n@(Prim _ _) = n+renT env v = case lookup v (rT env) of+ Just n -> n { annot = (annot v) {suppressMod = suppressMod (annot n)} }+ Nothing -> errorIds "Undefined type identifier" [v]++extRenE env vs+ | not (null shadowed) = errorIds "Illegal shadowing of state variables" shadowed+ | not (null shadowed') = errorIds "Illegal shadowing of state reference" shadowed'+ | otherwise = do rE' <- renaming (noDups "Duplicate variables" (legalBind vs))+ return (env { rE = rE' ++ rE env })+ where shadowed = intersect vs (stateVars env)+ shadowed' = intersect vs (self env)+++setRenS env vs+ | not (null shadowed) = errorIds "Illegal shadowing of state reference" shadowed+ | otherwise = do rS' <- renaming (noDups "Duplicate state variables" (legalBind vs))+ return (env { rS = rS', void = vs })+ where shadowed = intersect vs (self env)++unvoid vs env = env { void = void env \\ vs }++unvoidAll env = env { void = [] }++extRenT env vs = do rT' <- renaming (noDups "Duplicate type variables" (legalBind vs))+ return (env { rT = rT' ++ rT env })++extRenEMod _ _ env [] = return env+extRenEMod pub m env vs = do rE' <- extRenXMod pub m (rE env) vs+ return (env {rE = rE'})++extRenTMod _ _ env [] = return env+extRenTMod pub m env vs = do rT' <- extRenXMod pub m (rT env) vs+ return (env {rT = rT'})++extRenLMod _ _ env [] = return env+extRenLMod pub m env vs = do rL' <- extRenXMod pub m (rL env) vs+ return (env {rL = rL'})++extRenSelf env s = do rE' <- renaming (legalBind [s])+ return (env { rE = rE' ++ rE env, self = [s] })++extRenXMod pub m rX vs = if pub+ then do rX1 <- renaming (map (qName (str m)) (legalBind vs))+ let rX2 = map suppressPair rX1+ return (mergeRenamings1 (map dropModFst rX2) rX ++ rX2)+ else do rX' <- renaming (legalBind vs)+ return (mergeRenamings1 rX' rX) + where suppressPair (n1,n2) = (n1, n2 {annot = (annot n2) {suppressMod = True}}) + dropModFst (n1,n2) = (dropMod n1,n2)++legalBind vs = map checkName vs+ where checkName v@(Tuple _ _) = errorIds "Tuple constructors may not be redefined" [v]+ checkName v@(Prim _ _) = errorIds "Rigid symbol may not be redefined" [v]+ checkName v+ | fromMod v == Nothing = v+ | otherwise = errorIds "Binding occurrence may not be qualified" [v]+++-- Binding of overloaded names ------------------------------------------------------------------------++oloadBinds xs ds = f te+ where te = [ (s,t') | DRec True c vs _ sels <- ds, let p = PType (foldl TAp (TCon c) (map TVar vs)),+ Sig ss t <- sels, s <- ss, s `notElem` xs, let t' = tQual [p] t ]+ f [] = []+ f (sig:te) = mkSig sig : mkEqn sig : f te+ mkSig (s,t) = BSig [s] t+ mkEqn (s,TQual t ps) = BEqn (LFun s' (w:ws)) (RExp (foldl EAp (ESelect w s') ws))+ where w:ws = map EVar (take (length ps) abcSupply)+ s' = annotExplicit s+++-- Renaming -----------------------------------------------------------------------------------------++class Rename a where+ rename :: Env -> a -> M s a++instance Rename a => Rename [a] where+ rename env as = mapM (rename env) as++instance Rename a => Rename (Maybe a) where+ rename env (Just e) = liftM Just (rename env e)+ rename env Nothing = return Nothing+++instance Rename Module where+ rename env (Module c is ds ps) = do assert (null kDups) "Duplicate kind signatures" kDups+ assert (null tDups) "Duplicate type constructors" tDups+ assert (null sDups) "Duplicate selectors" sDups+ assert (null cDups) "Duplicate constructors" cDups+ assert (null wDups) "Duplicate instance declarations" wDups+ assert (null eDups) "Duplicate top-level variable" eDups+ assert (null tcDups) "Duplicate typeclass declaration" tcDups+ assert (null dks) "Dangling kind signatures" dks+ assert (null dws1) "Dangling instance declarations" dws1+ assert (null dws2) "Dangling instance declarations" dws2+ assert (null dtcs1) "Dangling typeclass declarations" dtcs1+ assert (null dtcs2) "Dangling typeclass declarations" dtcs2+ assert (null badImpl) "Illegal type signature for instance" badImpl+ env1 <- extRenTMod True c env (ts1 ++ ks1')+ env2 <- extRenEMod True c env1 (cs1 ++ vs1 ++ vs1' ++ vss++is1)+ env3 <- extRenLMod True c env2 ss1+ env4 <- extRenTMod False c env3 ((ts2 \\ ks1') ++ ks2)+ env5 <- extRenEMod False c env4 (cs2 ++ (vs2 \\ vss) ++ vs2'++is2)+ env6 <- extRenLMod False c env5 ss2+ ds <- rename env6 (ds1 ++ ps1)+ bs <- rename env6 (bs1' ++ bs2' ++ shuffleB (bs1 ++ bs2))+ return (Module c is (ds ++ map DBind (groupBindsS bs)) [])+ where (ks1,ts1,ss1,cs1,ws1,tcs1,is1,bss1) = renameD [] [] [] [] [] [] [] [] ds+ (ks2,ts2,ss2,cs2,ws2,tcs2,is2,bss2) = renameD [] [] [] [] [] [] [] [] ps+ ds1 = mergeTClasses tcs1 ds+ ps1 = mergeTClasses tcs2 ps+ vs1 = concat (map bvars bss1)+ vs2 = concat (map bvars bss2)+ bs1 = concat (reverse bss1)+ bs2 = concat (reverse bss2)+ vss = concat [ ss | BSig ss _ <- bs1 ] \\ vs1+ vs = vs1 ++ vs2+ ks = ks1 ++ ks2+ ts = ts1 ++ ts2+ ws = ws1 ++ ws2+ bs1' = oloadBinds vs ds1+ bs2' = oloadBinds vs ps1+ vs1' = bvars bs1'+ vs2' = bvars bs2'+ ks1' = ks1 \\ ts1+ dks = ks \\ ts+ dws1 = ws1 \\ concat [ ss | BSig ss _ <- bs1 ]+ dws2 = ws2 \\ concat [ ss | BSig ss _ <- bs2 ]+ dtcs1 = tcs1 \\ [ n | DRec False n _ _ _ <- ds ]+ dtcs2 = tcs2 \\ [ n | DRec False n _ _ _ <- ps ]+ badImpl = concat [ ws | BSig ss t <- bs1++bs2, not (null (ss `intersect` ws)), isWild t ]+ kDups = duplicates ks+ tDups = duplicates ts+ sDups = duplicates (ss1 ++ ss2)+ cDups = duplicates (cs1 ++ cs2)+ wDups = duplicates ws+ eDups = duplicates vs+ tcDups = duplicates (tcs1++tcs2)+ isWild (TQual t ps) = isWild t || any isWild [ t | PType t <- ps ]+ isWild (TAp t t') = isWild t || isWild t'+ isWild (TSub t t') = isWild t || isWild t'+ isWild (TList t) = isWild t+ isWild (TTup ts) = any isWild ts+ isWild (TFun ts t) = any isWild (t:ts)+ isWild TWild = True+ isWild _ = False+ +mergeTClasses tcs (DRec isC n vs ts ss : ds) = DRec (isC || elem n tcs) n vs ts ss : mergeTClasses tcs ds+mergeTClasses tcs (DTClass _ : ds) = mergeTClasses tcs ds+mergeTClasses tcs (DBind _ : ds) = mergeTClasses tcs ds+mergeTClasses tcs (d : ds) = d : mergeTClasses tcs ds+mergeTClasses _ [] = []++renameD ks ts ss cs ws tcs is bss (DKSig c k : ds)+ = renameD (c:ks) ts ss cs ws tcs is bss ds+renameD ks ts ss cs ws tcs is bss (DRec _ c _ _ sigs : ds)+ = renameD ks (c:ts) (sels++ss) cs ws tcs is bss ds+ where sels = concat [ vs | Sig vs t <- sigs ]+renameD ks ts ss cs ws tcs is bss (DData c _ _ cdefs : ds)+ = renameD ks (c:ts) ss (cons++cs) ws tcs is bss ds+ where cons = [ c | Constr c _ _ <- cdefs ]+renameD ks ts ss cs ws tcs is bss (DType c _ _ : ds)+ = renameD ks (c:ts) ss cs ws tcs is bss ds+renameD ks ts ss cs ws tcs is bss (DInstance vs : ds)+ = renameD ks ts ss cs (ws++vs) tcs is bss ds+renameD ks ts ss cs ws tcs is bss (DTClass vs : ds)+ = renameD ks ts ss cs ws (tcs++vs) is bss ds+renameD ks ts ss cs ws tcs is bss (DDefault ps : ds)+ = renameD ks ts ss cs ws tcs (is1 ++ is) bss ds+ where is1 = [i | Derive i _ <- ps]+renameD ks ts ss cs ws tcs is bss (DBind bs : ds)+ = renameD ks ts ss cs ws tcs is (bs : bss) ds+renameD ks ts ss cs ws tcs is bss []+ = (ks, ts, ss, cs, ws, tcs, is, bss)+++instance Rename Decl where+ rename env d@(DKSig _ _) = return d+ rename env (DData c vs ts cs) = do env' <- extRenT env vs+ liftM2 (DData (renT env c) (map (renT env') vs)) (renameQTs env' ts) (rename env' cs)+ rename env (DRec isC c vs ts ss) = do env' <- extRenT env vs+ liftM2 (DRec isC (renT env c) (map (renT env') vs)) (renameQTs env' ts) (rename env' ss)+ rename env (DType c vs t) = do env' <- extRenT env vs+ liftM (DType (renT env c) (map (renT env') vs)) (rename env' t)+ rename env (DInstance vs) = return (DInstance (map (renE env) vs))+ rename env (DDefault ts) = liftM DDefault (rename env ts)+ rename env (DBind bs) = liftM DBind (rename env bs)++instance Rename (Default Type) where+ rename env (Default pub a b) = return (Default pub (renE env a) (renE env b))+ rename env (Derive v t) = liftM (Derive (renE env v)) (renameQT env t)++instance Rename Constr where+ rename env (Constr c ts ps) = do env' <- extRenT env (bvars ps')+ liftM2 (Constr (renE env c)) (rename env' ts) (rename env' ps')+ where ps' = completeP env ts ps++completeP env t ps+ | not (null dups) = errorIds "Duplicate type variable abstractions" dups+ | not (null dang) = errorIds "Dangling type variable abstractions" dang+ | otherwise = ps ++ zipWith PKind implicit (repeat KWild)+ where vs = tyvars t ++ tyvars ps+ bvs = bvars ps+ dups = duplicates bvs+ dang = bvs \\ vs+ implicit = nub vs \\ (tscope env ++ bvs)+++renameQT env (TQual t ps) = rename env (TQual t (completeP env t ps))+renameQT env t+ | null ps = rename env t+ | otherwise = rename env (TQual t ps)+ where ps = completeP env t []+++renameQTs env ts = mapM (renameQT env) ts+++instance Rename Sig where+ rename env (Sig vs t) = liftM (Sig (map (renL env) vs)) (renameQT env t)++instance Rename Pred where+ rename env (PType p) = liftM PType (rename env p)+ rename env (PKind v k) = return (PKind (renT env v) k)++instance Rename Type where+ rename env (TQual t ps) = do env' <- extRenT env (bvars ps)+ liftM2 TQual (rename env' t) (rename env' ps)+ rename env (TCon c) = return (TCon (renT env c))+ rename env (TVar v) = return (TVar (renT env v))+ rename env (TAp t1 t2) = liftM2 TAp (rename env t1) (rename env t2)+ rename env (TSub t1 t2) = liftM2 TSub (rename env t1) (rename env t2)+ rename env TWild = return TWild+ rename env (TList ts) = liftM TList (rename env ts)+ rename env (TTup ts) = liftM TTup (rename env ts)+ rename env (TFun t1 t2) = liftM2 TFun (rename env t1) (rename env t2)++instance Rename Bind where+ rename env (BEqn (LFun v ps) rh) = do env' <- extRenE env (pvars ps)+ ps' <- rename env' ps+ liftM (BEqn (LFun (renE env v) ps')) (rename env' rh)+ rename env (BEqn (LPat p) rh) = do p' <- rename env p+ liftM (BEqn (LPat p')) (rename env rh)+ rename env (BSig vs t) = liftM (BSig (map (renE env) vs)) (renameQT env t)++instance Rename Exp where+ rename env (EVar v)+ | v `elem` void env = errorIds"Uninitialized state variable" [v]+ | v `elem` stateVars env = return (EVar (renS env v))+ | otherwise = return (EVar (renE env v))+ rename env (ECon c) = return (ECon (renE env c))+ rename env (ESel l) = return (ESel (renL env l))+ rename env (EAp e1 e2) = liftM2 EAp (rename env e1) (rename env e2)+ rename env (ELit l) = return (ELit l)+ rename env (ETup ps) = liftM ETup (rename env ps)+ rename env (EList es) = liftM EList (rename env es)+ rename env EWild = return EWild+ rename env (ESig e t) = liftM2 ESig (rename env e) (renameQT env t)+ rename env (ERec m fs) = liftM (ERec (renRec env m)) (rename env fs)+ rename env (ELam ps e) = do env' <- extRenE env (pvars ps)+ liftM2 ELam (rename env' ps) (rename env' e)+ rename env (ELet bs e) = do env' <- extRenE env (bvars bs)+ bs' <- rename env' (shuffleB bs)+ e' <- rename env' e+ return (foldr ELet e' (groupBindsS bs'))+ rename env (ECase e as) = liftM2 ECase (rename env e) (rename env as)+ rename env (EIf e1 e2 e3) = liftM3 EIf (rename env e1) (rename env e2) (rename env e3)+ rename env (ENeg e) = liftM ENeg (rename env e)+ rename env (ESeq e1 e2 e3) = liftM3 ESeq (rename env e1) (rename env e2) (rename env e3)+ rename env (EComp e qs) = do (qs,e) <- renameQ env qs e+ return (EComp e qs)+ rename env (ESectR e op) = liftM (flip ESectR (renE env op)) (rename env e) + rename env (ESectL op e) = liftM (ESectL (renE env op)) (rename env e)+ rename env (ESelect e l) = liftM (flip ESelect (renL env l)) (rename env e) + rename env (EAct v ss) = liftM (EAct (fmap (renE env) v)) (renameS (unvoidAll env) (shuffleS ss))+ rename env (EReq v ss) = liftM (EReq (fmap (renE env) v)) (renameS (unvoidAll env) (shuffleS ss))+ rename env (EDo (Just v) Nothing ss)+ = do env1 <- extRenSelf env v+ liftM (EDo (Just (renE env1 v)) Nothing) (renameS (unvoidAll env1) (shuffleS ss))+ rename env (ETempl (Just v) Nothing ss)+ = do env1 <- extRenSelf env v+ env2 <- setRenS env1 st+ liftM (ETempl (Just (renE env2 v)) Nothing) (renameS env2 (shuffleS ss))+ where st = assignedVars ss+ rename env (EAfter e1 e2) = liftM2 EAfter (rename env e1) (rename env e2)+ rename env (EBefore e1 e2) = liftM2 EBefore (rename env e1) (rename env e2)+ rename env e@(EBStruct (Just c) ls bs)+ = do let ls' = map (dropMod . annotGenerated) ls+ env' <- extRenE env ls' + r <- rename env' (ERec (Just (c,True)) (map (\(s,s') -> Field s (EVar s')) (ls `zip` ls')))+ bs' <- mapM (renSBind env' env) bs+ return (foldr ELet r (groupBindsS bs'))++renRec env (Just (n, t)) = Just (renT env n, t)+renRec env Nothing = Nothing++renSBind envL envR (BEqn (LFun v ps) rh) = do envR' <- extRenE envR (pvars ps)+ ps' <- rename envR' ps+ liftM (BEqn (LFun (annotGenerated (renE envL v)) ps')) (rename envR' rh)+renSBind envL envR (BEqn (LPat (EVar v)) rh)= liftM (BEqn (LPat (EVar (annotGenerated (renE envL v))))) (rename envR rh)+renSBind _ _ (BEqn (LPat p) _) = errorTree "Illegal pattern in struct value" p +renSBind _ _ s@(BSig vs t) = errorTree "Signature in struct value" s ++instance Rename Field where+ rename env (Field l e) = liftM (Field (renL env l)) (rename env e)++instance Rename (Rhs Exp) where+ rename env (RExp e) = liftM RExp (rename env e)+ rename env (RGrd gs) = liftM RGrd (rename env gs)+ rename env (RWhere e bs) = do env' <- extRenE env (bvars bs)+ bs' <- rename env' (shuffleB bs)+ e' <- rename env' e+ return (foldr (flip RWhere) e' (groupBindsS bs'))+++instance Rename (GExp Exp) where+ rename env (GExp qs e) = do (qs,e) <- renameQ env qs e+ return (GExp qs e)+++renameQ env [] e0 = do e0 <- rename env e0+ return ([], e0)+renameQ env (QExp e : qs) e0 = do e <- rename env e+ (qs,e0) <- renameQ env qs e0+ return (QExp e : qs, e0)+renameQ env (QGen p e : qs) e0 = do e <- rename env e+ env' <- extRenE env (pvars p)+ p <- rename env' p+ (qs,e0) <- renameQ env' qs e0+ return (QGen p e : qs, e0)+renameQ env (QLet bs : qs) e0 = do env' <- extRenE env (bvars bs)+ bs <- rename env' bs+ (qs,e0) <- renameQ env' qs e0+ return (map QLet (groupBindsS bs) ++ qs, e0)+++instance Rename (Alt Exp) where+ rename env (Alt p rh) = do env' <- extRenE env (pvars p)+ liftM2 Alt (rename env' p) (rename env' rh) +++renameS env [] = return []+renameS env [SRet e] = liftM (:[]) (liftM SRet (rename env e))+renameS env (SExp e : ss) = liftM2 (:) (liftM SExp (rename env e)) (renameS env ss)+renameS env (SGen p e : ss) = do env' <- extRenE env (pvars p)+ liftM2 (:) (liftM2 SGen (rename env' p) (rename env e)) (renameS env' ss)+renameS env (SBind bs : ss) = do env' <- extRenE env (bvars bs)+ bs' <- rename env' bs+ ss' <- renameS env' ss+ return (map SBind (groupBindsS bs') ++ ss')+renameS env (SAss p e : ss)+ | not (null illegal) = errorIds "Unknown state variables" illegal+ | otherwise = liftM2 (:) (liftM2 SAss (rename (unvoidAll env) p) (rename env e)) (renameS (unvoid (pvars p) env) ss)+ where illegal = pvars p \\ stateVars env++++-- Signature shuffling -------------------------------------------------------------------------++shuffleB bs = shuffle [] bs+++shuffle [] [] = []+shuffle sigs [] = errorIds "Dangling type signatures" (dom sigs)+shuffle sigs (BSig vs t : bs)+ | not (null s_dups) = errorIds "Duplicate type signatures" s_dups+ | otherwise = shuffle (vs `zip` repeat t ++ sigs) bs+ where s_dups = duplicates vs ++ (vs `intersect` dom sigs)+shuffle sigs (b@(BEqn (LFun v _) _) : bs)+ = case lookup v sigs of+ Just t -> BSig [v] t : b : shuffle (prune sigs [v]) bs+ Nothing -> b : shuffle sigs bs+shuffle sigs (BEqn (LPat p) rh : bs)+ = BEqn (LPat p') rh : shuffle sigs' bs+ where (sigs',p') = attach sigs p++++shuffleS ss = shuffle' [] ss++shuffle' [] [] = []+shuffle' sigs [] = errorIds "Dangling type signatures for" (dom sigs)+shuffle' sigs (SBind bs : ss) = SBind (shuffle sigs1 bs1) : shuffle' ([ (v,t) | BSig [v] t <- bs2 ] ++ sigs2) ss+ where (sigs1,sigs2) = partition ((`elem` vs) . fst) sigs+ (bs1,bs2) = partition local (concatMap flat bs)+ vs = bvars bs+ local (BSig [v] _) = v `elem` vs+ local _ = True+ flat (BSig vs t) = [ BSig [v] t | v <- vs ]+ flat b = [b]+shuffle' sigs (SGen p e : ss) = SGen p' e : shuffle' sigs' ss+ where (sigs',p') = attach sigs p+shuffle' sigs (SAss p e : ss) = SAss p' e : shuffle' sigs2 ss+ where (sigs',p') = attach sigs1 p+ (sigs1,sigs2) = partition ((`elem` vs) . fst) sigs+ vs = evars p+shuffle' sigs (s : ss) = s : shuffle' sigs ss++++attach sigs e@(ESig (EVar v) t)+ | v `elem` dom sigs = errorIds "Conflicting signatures for" [v]+ | otherwise = (sigs, e)+attach sigs (EVar v) = case lookup v sigs of+ Nothing -> (sigs, EVar v)+ Just t -> (prune sigs [v], ESig (EVar v) t)+attach sigs (EAp p1 p2) = (sigs2, EAp p1' p2')+ where (sigs1,p1') = attach sigs p1+ (sigs2,p2') = attach sigs1 p2+attach sigs (ETup ps) = (sigs', ETup ps')+ where (sigs',ps') = attachList sigs ps+attach sigs (EList ps) = (sigs', EList ps')+ where (sigs',ps') = attachList sigs ps+attach sigs p = (sigs, p)++attachList sigs [] = (sigs, [])+attachList sigs (p:ps) = (sigs2, p':ps')+ where (sigs1,p') = attach sigs p+ (sigs2,ps') = attachList sigs1 ps+
+ src/Syntax.hs view
@@ -0,0 +1,1051 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Syntax where++import Common+import Lexer+import PP+import Data.Binary++data Module = Module Name [Import] [Decl] [Decl]+ deriving (Show)++data Import = Import Bool Name + deriving (Show)+ +data Decl = DKSig Name Kind+ | DData Name [Name] [Type] [Constr]+ | DRec Bool Name [Name] [Type] [Sig]+ | DType Name [Name] Type -- removed by desugaring+-- | DInst Type [Bind] -- -"-+ | DPSig Name Type + | DDefault [Default Type] + | DInstance [Name]+ | DTClass [Name]+ | DBind [Bind]+ deriving (Eq,Show)++data Constr = Constr Name [Type] [Pred]+ deriving (Eq,Show)++data Sig = Sig [Name] Type+ deriving (Eq,Show)++data Bind = BSig [Name] Type+ | BEqn Lhs (Rhs Exp)+ deriving (Eq,Show)+++type Eqn = (Lhs, Rhs Exp)++data Type = TQual Type [Pred]+ | TCon Name+ | TVar Name+ | TAp Type Type+ | TSub Type Type+ | TWild+ | TList Type+ | TTup [Type]+ | TFun [Type] Type+ deriving (Eq,Show)++data Pred = PType Type+ | PKind Name Kind+ deriving (Eq,Show)+ +data Lhs = LFun Name [Pat]+ | LPat Pat+ deriving (Eq,Show)++type Pat = Exp++data Exp = EVar Name+ | EAp Exp Exp+ | ECon Name+ | ESel Name+ | ELit Lit+ | ETup [Exp]+ | EList [Exp]+ | EWild+ | ESig Exp Type+ | ERec (Maybe (Name,Bool)) [Field]+ -- pattern syntax ends here+ | EBStruct (Maybe Name) [Name] [Bind] -- struct value in bindlist syntax+ | ELam [Pat] Exp+ | ELet [Bind] Exp+ | ECase Exp [Alt Exp]+-- the following and ETup, EList removed in desugaring+ | EIf Exp Exp Exp+ | ENeg Exp+ | ESeq Exp (Maybe Exp) Exp+ | EComp Exp [Qual]+ | ESectR Exp Name+ | ESectL Name Exp+ | ESelect Exp Name+ | EDo (Maybe Name) (Maybe Type) [Stmt] + | ETempl (Maybe Name) (Maybe Type) [Stmt]+ | EAct (Maybe Name) [Stmt] + | EReq (Maybe Name) [Stmt] + | EAfter Exp Exp+ | EBefore Exp Exp+ deriving (Eq,Show)++data Field = Field Name Exp+ deriving (Eq,Show)+ +data Rhs a = RExp a+ | RGrd [GExp a]+ | RWhere (Rhs a) [Bind]+ deriving (Eq,Show)++data GExp a = GExp [Qual] a+ deriving (Eq,Show)+ +data Alt a = Alt Pat (Rhs a)+ deriving (Eq,Show)++data Qual = QExp Exp+ | QGen Pat Exp+ | QLet [Bind]+ deriving (Eq,Show)+ +data Stmt = SExp Exp+ | SRet Exp+ | SGen Pat Exp+ | SBind [Bind]+ | SAss Pat Exp+ | SForall [Qual] [Stmt]+ | SWhile Exp [Stmt]+ | SIf Exp [Stmt]+ | SElsif Exp [Stmt]+ | SElse [Stmt]+ | SCase Exp [Alt [Stmt]]+ deriving (Eq,Show)+++-- Primitives ----------------------------------------------------------------++cons x xs = EAp (EAp (ECon (prim CONS)) x) xs+nil = ECon (prim NIL)+true = ECon (prim TRUE)+false = ECon (prim FALSE)+++-- Helper functions ----------------------------------------------------------------++imports c is + | str c == "Prelude" = []+ | otherwise = Import True (name0 "Prelude") : is++mkModule c (is,ds,ps) = Module c (imports c is) ds ps++newEVarPos v p = do i <- newNamePos v p+ return (EVar i)++op2exp c = if isCon c then ECon c else EVar c++isEVar (EVar _) = True+isEVar (EWild) = True+isEVar _ = False++isEConApp (EAp e es) = isEConApp e+isEConApp (ECon _) = True+isEConApp _ = False++isELit (ELit _) = True+isELit _ = False++isERec (ERec _ _) = True+isERec _ = False++isESigVar (ESig e _) = isEVar e+isESigVar e = isEVar e++isETup (ETup _) = True+isETup _ = False++isSAss (SAss _ _) = True+isSAss _ = False++isSGen (SGen _ _) = True+isSGen _ = False++isSBind (SBind _) = True+isSBind _ = False++isDBind (DBind _) = True+isDBind _ = False++isBSig (BSig _ _) = True+isBSig _ = False++isPKind (PKind _ _) = True+isPKind _ = False++tAp isDType (DType _ _ _) = True+isDType _ = False++isLPatEqn (BEqn (LPat _) _) = True+isLPatEqn _ = False++tupSize (ETup es) = length es+tupSize _ = -1+++eFlat e = flat e []+ where flat (EAp e e') es = flat e (e':es)+ flat e es = (e,es)++eLam [] e = e+eLam ps (ELam ps' e) = ELam (ps++ps') e+eLam ps e = ELam ps e++rAp (RExp e) es = RExp (foldl EAp e es)+rAp (RWhere rhs bs) es = RWhere (rAp rhs es) bs+rAp (RGrd gs) es = RGrd [ GExp qs (foldl EAp e es) | GExp qs e <- gs ]+++eLet [] e = e+eLet bs e = ELet bs e+++simpleEqn x e = BEqn (LFun x []) (RExp e)+++exp2lhs e = case eFlat e of+ (EVar v, ps)+ |not(null ps) -> LFun v ps+ _ -> LPat e++tFun [] t = t+tFun ts t = TFun ts t++tQual ps (TQual t ps') = TQual t (ps++ps')+tQual ps t = TQual t ps++tFlat t = flat t []+ where flat (TAp t1 t2) ts = flat t1 (t2:ts)+ flat t ts = (t,ts)+++type2cons (TQual t ps) = type2cons t+type2cons t = case tFlat t of+ (TCon c,ts) -> Constr c ts []+ _ -> errorTree "Bad type constructor in" t++type2head (TQual t ps) = type2head t+type2head t = case tFlat t of+ (TCon c,ts) -> c+ _ -> errorTree "Bad instance head in" t++stripSigs (ESig p _) = p+stripSigs p = p+++tyCons :: Type -> [Name]+tyCons (TQual t ps) = nub (tyCons t ++ concatMap tC ps)+ where tC (PType t) = tyCons t+ tC _ = []+tyCons (TCon c) = [c]+tyCons (TVar _) = []+tyCons (TAp t1 t2) = nub (tyCons t1 ++ tyCons t2)+tyCons (TSub t1 t2) = nub (tyCons t1 ++ tyCons t2)+tyCons TWild = []+tyCons (TList t) = tyCons t+tyCons (TTup ts) = nub (concatMap tyCons ts)+tyCons (TFun ts t) = nub (concatMap tyCons (t : ts))++-- Substitution --------------------------------------------------------------++instance Subst Bind Name Exp where+ subst s (BSig xs t) = BSig xs t+ subst s (BEqn lhs rhs) = BEqn lhs (subst s rhs)+++instance Subst Exp Name Exp where+ subst s (EVar x) = case lookup x s of+ Just e -> e+ Nothing -> EVar x+ subst s (EAp e e') = EAp (subst s e) (subst s e')+ subst s (ECon c) = ECon c+ subst s (ELit l) = ELit l+ subst s (ETup es) = ETup (subst s es)+ subst s (EList es) = EList (subst s es)+ subst s (EWild) = EWild+ subst s (ESig e t) = ESig (subst s e) t+ subst s (ELam ps e) = ELam ps (subst s e)+ subst s (ELet bs e) = ELet (subst s bs) (subst s e)+ subst s (ECase e alts) = ECase (subst s e) (subst s alts)+ subst s (ERec m fs) = ERec m (subst s fs)+ subst s (EBStruct c ls bs) = EBStruct c ls (subst s bs)+ subst s (EIf e1 e2 e3) = EIf (subst s e1) (subst s e2) (subst s e3)+ subst s (ENeg e) = ENeg (subst s e)+ subst s (ESeq e1 Nothing e2) = ESeq (subst s e1) Nothing (subst s e2)+ subst s (ESeq e1 (Just e) e2) = ESeq (subst s e1) (Just (subst s e)) (subst s e2)+ subst s (EComp e qs) = EComp (subst s e) (subst s qs)+ subst s (ESectR e op) = ESectR (subst s e) op+ subst s (ESectL op e) = ESectL op (subst s e)+ subst s (ESelect e l) = ESelect (subst s e) l+ subst s (ESel l) = ESel l+ subst s (EDo v t st) = EDo v t (subst s st)+ subst s (ETempl v t st) = ETempl v t (subst s st) + subst s (EAct v st) = EAct v (subst s st)+ subst s (EReq v st) = EReq v (subst s st)+ subst s (EAfter e e') = EAfter (subst s e) (subst s e')+ subst s (EBefore e e') = EBefore (subst s e) (subst s e')+++instance Subst Field Name Exp where+ subst s (Field l e) = Field l (subst s e)+++instance Subst a Name Exp => Subst (Rhs a) Name Exp where+ subst s (RExp e) = RExp (subst s e)+ subst s (RGrd gs) = RGrd (subst s gs)+ subst s (RWhere rhs bs) = RWhere (subst s rhs) (subst s bs)+++instance Subst a Name Exp => Subst (GExp a) Name Exp where+ subst s (GExp qs e) = GExp (subst s qs) (subst s e)++ +instance Subst a Name Exp => Subst (Alt a) Name Exp where+ subst s (Alt p rhs) = Alt p (subst s rhs)+++instance Subst Qual Name Exp where+ subst s (QExp e) = QExp (subst s e)+ subst s (QGen p e) = QGen p (subst s e)+ subst s (QLet bs) = QLet (subst s bs)+++ +instance Subst Stmt Name Exp where+ subst s (SExp e) = SExp (subst s e)+ subst s (SRet e) = SRet (subst s e)+ subst s (SGen p e) = SGen p (subst s e)+ subst s (SBind bs) = SBind (subst s bs)+ subst s (SAss p e) = SAss p (subst s e)+ subst s (SForall qs st) = SForall (subst s qs) (subst s st)+ subst s (SWhile e st) = SWhile (subst s e) (subst s st)+ subst s (SIf e st) = SIf (subst s e) (subst s st)+ subst s (SElsif e st) = SElsif (subst s e) (subst s st)+ subst s (SElse st) = SElse (subst s st)+ subst s (SCase e alts) = SCase (subst s e) (subst s alts)+++instance Subst Type Name Type where+ subst s (TQual t ps) = TQual (subst s t) (subst s ps)+ subst s (TCon c) = TCon c+ subst s (TVar a) = case lookup a s of+ Just t -> t+ Nothing -> TVar a+ subst s (TAp t1 t2) = TAp (subst s t1) (subst s t2)+ subst s (TSub t1 t2) = TSub (subst s t1) (subst s t2)+ subst s TWild = TWild+ subst s (TList t) = TList (subst s t)+ subst s (TTup ts) = TTup (subst s ts)+ subst s (TFun ts t) = TFun (subst s ts) (subst s t)++instance Subst Pred Name Type where+ subst s (PType t) = PType (subst s t)+ subst s p = p++-- Printing ==================================================================++-- Modules -------------------------------------------------------------------++instance Pr Module where+ pr (Module c is ds ps) = text "module" <+> prId c <+> text "where"+ $$ vpr is $$ vpr ds + $$ text "private" $$ vpr ps++instance Pr Import where+ pr (Import True n) = text "import" <+> prId n+ pr (Import False n) = text "use" <+> prId n++-- Declarations --------------------------------------------------------------++instance Pr Decl where+ pr (DKSig c k) = prId c <+> text "::" <+> pr k+ pr (DType c vs t) = text "type" <+> prId c <+> hsep (map prId vs) + <+> equals <+> pr t+ pr (DData c vs subs cs) = text "data" <+> prId c <+> hsep (map prId vs) + <+> prSubs subs <+> prCons cs+ pr (DRec isC c vs sups ss) = text kwd <+> prId c <+> hsep (map prId vs) + <+> prSups sups <+> prEq ss $$ prSigs ss+ where kwd = if isC then "typeclass " else "struct"+-- pr (DInst t bs) = text "instance" <+> pr t <+> text "=" $$ nest 4 (vpr bs)+ pr (DPSig v t) = text "typeclass" <+> prId v <+> text "::" <+> pr t+ pr (DDefault ts) = text "default" <+> hpr ',' ts+ pr (DInstance ns) = text "instance" <+> hpr ',' ns + pr (DTClass ns) = text "typeclass" <+> hpr ',' ns + pr (DBind bs) = vpr bs++prPreds [] = empty+prPreds ps = text " \\\\" <+> hpr ',' ps++prEq [] = empty+prEq bs = text "where"++prSigs ss = nest 4 (vpr ss)++-- Sub/supertypes -----------------------------------------------------------++prSups [] = empty+prSups ts = char '<' <+> hpr ',' ts++prSubs [] = empty+prSubs ts = char '>' <+> hpr ',' ts+ ++-- Constructors and contexts -----------------------------------------------+++instance Pr Constr where+ pr (Constr c ts ps) = prId c <+> hsep (map (prn 3) ts) <> prPreds ps++prCons [] = empty+prCons (c:cs) = vcat (char '=' <+> pr c : map ((char '|' <+>) . pr) cs)++++-- Signatures ------------------------------------------------------------++instance Pr Sig where+ pr (Sig vs qt) = hcat (punctuate comma (map prId vs)) <+> text "::" <+> pr qt+ + +-- Predicates ------------------------------------------------------------++instance Pr Pred where+ pr (PType t) = pr t+ pr (PKind v k) = prId v <+> text "::" <+> pr k++-- Left hand sides ------------------------------------------------------++instance Pr Lhs where+ pr (LFun v ps) = prId v <+> hsep (map (prn 13) ps)+ pr (LPat p) = pr p++{-+-- Patterns --------------------------------------------------------------++instance Pr Pat where++ prn 0 (PCon c ps) = prId c <+> hsep (map (prn 13) ps) + prn 0 p = prn 13 p++ prn 13 (PVar v) = prId v+ prn 13 (PLit l) = pr l+ prn 13 (PTup ps) = parens (hpr ',' ps)+ prn 13 (PList ps) = brackets (hpr ',' ps)+ prn 13 p = parens (pr p)++ prn n p = prn 13 p+-}++-- Types -----------------------------------------------------------------++instance Pr Type where+ prn 0 (TQual t ps) = prn 1 t <> prPreds ps+ prn 0 t = prn 1 t++ prn 1 (TFun ts t) = prArgs ts <+> prn 2 t+ where prArgs [] = empty+ prArgs (t:ts) = prn 2 t <+> text "->" <+> prArgs ts+ prn 1 (TSub t t') = prn 2 t <+> text "<" <+> prn 2 t'+ prn 1 t = prn 2 t++ prn 2 (TAp t t') = prn 2 t <+> prn 3 t'+ prn 2 t = prn 3 t+ + prn 3 (TCon c) = prId c+ prn 3 (TVar v) = prId v+ prn 3 (TWild) = text "_"+ prn 3 (TList t) = brackets (pr t)+ prn 3 (TTup ts) = parens (hpr ',' ts)+ prn 3 t = parens (prn 0 t)++-- Bindings ----------------------------------------------------------------++instance Pr Bind where+ pr (BSig vs qt) = hcat (punctuate comma (map prId vs)) <+> text "::" <+> pr qt+ pr (BEqn p (RExp e)) = pr p <+> equals <+> pr e+ pr (BEqn p rhs) = pr p $$ nest 2 (prRhs equals rhs)++prRhs eq (RExp e) = eq <+> pr e+prRhs eq (RGrd gs) = vcat (map (prGuard eq) gs)+prRhs eq (RWhere rhs bs) = prRhs eq rhs $$ text "where" $$ nest 4 (vpr bs)++prGuard eq (GExp qs e) = char '|' <+> hpr ',' qs <+> eq <+> pr e+++-- Expressions -------------------------------------------------------------++instance Pr Exp where+ prn 0 (ELam ps e) = sep [char '\\' <> hsep (map (prn 13) ps) <+> text "->", pr e]+ prn 0 (ELet bs e) = text "let" <+> vpr bs $$ text "in" <+> pr e+ prn 0 (EIf e e1 e2) = text "if" <+> pr e $$+ nest 3 (text "then" <+> pr e1 $$+ text "else" <+> pr e2)+ prn 0 (ECase e alts) = text "case" <+> pr e <+> text "of" $$ nest 2 (vpr alts)+ prn 0 (EDo v t ss) = text "do"<>prN v <+> vpr ss + prn 0 (ETempl v t ss) = text "class"<>prN v $$ nest 4 (vpr ss)+ prn 0 (EAct v ss) = text "action"<>prN v $$ nest 4 (vpr ss) + prn 0 (EReq v ss) = text "request"<>prN v $$ nest 4 (vpr ss) + prn 0 (EAfter e e') = text "after" <+> prn 12 e <+> pr e'+ prn 0 (EBefore e e') = text "before" <+> prn 12 e <+> pr e'+ prn 0 e = prn 1 e++ prn 11 (EAp e e') = prn 11 e <+> prn 12 e'+ prn 11 e = prn 12 e+ + prn 12 (ESelect e l) = prn 12 e <> text "." <> prId l+ prn 12 e = prn 13 e+ + prn 13 (EVar v) = prId v+ prn 13 (ECon c) = prId c+ prn 13 (ESel l) = parens (text "." <> prId l)+ prn 13 (EWild) = text "_"+ prn 13 (ELit l) = pr l+ prn 13 (ERec Nothing fs) = text "{" <+> hpr ',' fs <+> text "}"+ prn 13 (ERec (Just(c,b)) fs)= prId c <+> text "{" <+> hpr ',' fs <+> (if b then empty else text "..") <+> text "}"+ prn 13 (EBStruct _ _ bs) = text "struct" $$ nest 4 (vpr bs)+ prn 13 (ENeg e) = text "-" <+> prn 0 e+ prn 13 (ESig e qt) = parens (pr e <+> text "::" <+> pr qt)+ prn 13 (ETup es) = parens (hpr ',' es)+ prn 13 (ESectR e op) = parens (pr e <> prOp op)+ prn 13 (ESectL op e) = parens (prOp op <> pr e)+ prn 13 (EList es) = brackets (hpr ',' es)+ prn 13 (ESeq e Nothing to) + = brackets (pr e <> text ".." <> pr to)+ prn 13 (ESeq e (Just by) to) + = brackets (pr e <> comma <> pr by <> text ".." <> pr to)+ prn 13 (EComp e qs) = brackets (empty <+> pr e <+> char '|' <+> hpr ',' qs)+ prn 13 e = parens (prn 0 e)++ prn n e = prn 11 e+ +prN (Just v) = text "@" <> pr v+prN Nothing = empty +instance Pr Field where+ pr (Field l e) = prId l <+> equals <+> pr e+ +instance Pr a => Pr (Alt a) where+ pr (Alt p (RExp e)) = pr p <+> text "->" <+> pr e+ pr (Alt p rhs) = pr p <+> prRhs (text "->") rhs++instance Pr Qual where+ pr (QExp e) = pr e+ pr (QGen p e) = pr p <+> text "<-" <+> pr e+ pr (QLet bs) = text "let" <+> hpr ';' bs++-- Statements --------------------------------------------------------------++instance Pr [Stmt] where+ pr ss = vpr ss++instance Pr Stmt where+ pr (SExp e) = pr e+ pr (SRet e) = text "result" <+> pr e+ pr (SGen p e) = pr p <+> text "<-" <+> pr e+ pr (SBind bs) = vpr bs+ pr (SAss p e) = pr p <+> text ":=" <+> pr e+ pr (SIf e ss) = text "if" <+> pr e <+> text "then" $$ nest 4 (pr ss)+ pr (SElsif e ss) = text "elsif" <+> pr e <+> text "then" $$ nest 4 (pr ss)+ pr (SElse ss) = text "else" $$ nest 4 (pr ss)+ pr (SWhile e ss) = text "while" <+> pr e <+> text "do" $$ nest 4 (pr ss)+ pr (SForall qs ss) = text "forall" <+> hpr ',' qs <+> text "do" $$ nest 4 (pr ss)+ pr (SCase e alts) = text "case" <+> pr e <+> text "of" $$ nest 4 (vpr alts)+++-- Free variables ------------------------------------------------------------++instance Ids Bind where+ idents (BEqn (LFun v ps) rh)= idents rh \\ (v : idents ps)+ idents (BEqn (LPat p) rh) = idents rh \\ idents p + idents (BSig _ _) = []++instance Ids Exp where+ idents (EVar v) = [v]+ idents (EAp e e') = idents e ++ idents e'+ idents (ETup es) = idents es+ idents (EList es) = idents es+ idents (ESig e _) = idents e+ idents (ERec _ fs) = idents fs+ idents (EBStruct _ _ bs) = idents bs+ idents (ELam ps e) = idents e \\ idents ps+ idents (ELet bs e) = idents bs ++ (idents e \\ bvars bs)+ idents (ECase e as) = idents e ++ idents as+ idents (EIf b t e) = idents b ++ idents t ++ idents e+ idents (ENeg e) = idents e+ idents (ESeq f Nothing t) = idents f ++ idents t+ idents (ESeq f (Just s) t) = idents f ++ idents s ++ idents t+ idents (EComp e qs) = (idents e \\ bvars qs) ++ identQuals qs+ idents (ESectR e v) = v : idents e+ idents (ESectL v e) = v : idents e+ idents (ESelect e _) = idents e+ idents (EDo _ _ ss) = identStmts ss+ idents (ETempl _ _ ss) = identStmts ss+ idents (EAct _ ss) = identStmts ss + idents (EReq _ ss) = identStmts ss + idents (EAfter e e') = idents e ++ idents e'+ idents (EBefore e e') = idents e ++ idents e'+ idents _ = []++instance Ids Field where+ idents (Field _ e) = idents e+ +instance Ids (Rhs Exp) where+ idents (RExp a) = idents a+ idents (RGrd gs) = idents gs+ idents (RWhere a bs) = idents bs ++ (idents a \\ bvars bs)++instance Ids (GExp Exp) where+ idents (GExp qs a) = identQuals qs ++ idents a+ +instance Ids (Alt Exp) where+ idents (Alt p a) = idents a \\ idents p ++instance Ids (Rhs [Stmt]) where+ idents (RExp a) = identStmts a+ idents (RGrd gs) = idents gs+ idents (RWhere a bs) = idents bs ++ (idents a \\ bvars bs)++instance Ids (GExp [Stmt]) where+ idents (GExp qs a) = identQuals qs ++ identStmts a+ +instance Ids (Alt [Stmt]) where+ idents (Alt p a) = idents a \\ idents p +++identQuals [] = []+identQuals (QExp e : qs) = idents e ++ identQuals qs+identQuals (QGen p e : qs) = idents e ++ (identQuals qs \\ pvars p)+identQuals (QLet bs : qs) = idents bs ++ (identQuals qs \\ bvars bs)+++identStmts [] = []+identStmts (SExp e : ss) = idents e ++ identStmts ss+identStmts (SRet e : ss) = idents e ++ identStmts ss+identStmts (SGen p e : ss) = idents e ++ (identStmts ss \\ pvars p)+identStmts (SBind bs : ss) = identSBind bs ss+identStmts (SAss p e : ss) = idents e ++ (identStmts ss \\ pvars p)+identStmts (SForall qs ss' : ss)= identQuals qs ++ (identStmts ss' \\ bvars qs) ++ identStmts ss+identStmts (SWhile e ss' : ss) = idents e ++ identStmts ss' ++ identStmts ss+identStmts (SIf e ss' : ss) = idents e ++ identStmts ss' ++ identStmts ss+identStmts (SElsif e ss' : ss) = idents e ++ identStmts ss' ++ identStmts ss+identStmts (SElse ss' : ss) = identStmts ss' ++ identStmts ss+identStmts (SCase e as : ss) = idents e ++ idents as ++ identStmts ss++identSBind bs (SBind bs' : ss ) = identSBind (bs++bs') ss+identSBind bs ss = idents bs ++ (identStmts ss \\ bvars bs)+++pvars p = evars p++assignedVars ss = concat [ pvars p | SAss p _ <- ss ]+++-- Bound variables ----------------------------------------------------------++instance BVars [Bind] where+ bvars [] = []+ bvars (BEqn (LPat p) _ : bs) = pvars p ++ bvars bs+ bvars (BEqn (LFun v _) _ : bs) = bvars' v bs+ where bvars' v (BEqn (LFun v' _) _ : bs)+ | v == v' = bvars' v bs+ | otherwise = v : bvars' v' bs+ bvars' v bs = v : bvars bs+ bvars (_ : bs) = bvars bs++instance BVars [Field] where+ bvars bs = [ s | Field s e <- bs ]++instance BVars [Qual] where+ bvars [] = []+ bvars (QGen p _ : qs) = pvars p ++ bvars qs+ bvars (QLet bs : qs) = bvars bs ++ bvars qs+ bvars (_ : qs) = bvars qs++instance BVars [Stmt] where+ bvars [] = []+ bvars (SGen p e : ss) = pvars p ++ bvars ss+ bvars (SBind bs : ss) = bvars bs ++ bvars ss+ bvars (_ : ss) = bvars ss+ ++instance BVars Lhs where+ bvars (LFun v ps) = pvars ps+ bvars (LPat p) = []++instance BVars [Pred] where+ bvars [] = []+ bvars (PKind v k : ps) = v : bvars ps+ bvars (PType (TVar v) : ps) = v : bvars ps+ bvars (p : ps) = bvars ps+++-- Free type variables -------------------------------------------------------++instance Ids Type where+ idents (TQual t ps) = (idents t ++ idents ps) \\ bvars ps+ idents (TCon c) = [c]+ idents (TVar v) = [v]+ idents (TAp t t') = idents t ++ idents t'+ idents (TSub t t') = idents t ++ idents t'+ idents (TWild) = []+ idents (TList t) = idents t+ idents (TTup ts) = concatMap idents ts+ idents (TFun t t') = idents t ++ idents t'+++instance Ids Pred where+ idents (PType (TVar v)) = []+ idents (PType t) = idents t+ idents (PKind v k) = []+++-- PosInfo -------------------------------------------------------------------++instance HasPos Type where+ posInfo (TQual t ps) = between (posInfo t) (posInfo ps)+ posInfo (TCon n) = posInfo n+ posInfo (TVar n) = posInfo n + posInfo (TAp t t') = between (posInfo t) (posInfo t')+ posInfo (TSub t t') = between (posInfo t) (posInfo t')+ posInfo TWild = Unknown+ posInfo (TList t) = posInfo t + posInfo (TTup ts) = posInfo ts+ posInfo (TFun ts t) = between (posInfo ts) (posInfo t)++instance HasPos Pred where+ posInfo (PType t) = posInfo t+ posInfo (PKind n k) = posInfo n++instance HasPos Exp where+ posInfo (EVar n) = posInfo n+ posInfo (ECon c) = posInfo c+ posInfo (EAp e e') = between (posInfo e) (posInfo e')+ posInfo (ESel n) = posInfo n+ posInfo (ETup es) = posInfo es+ posInfo (EList es) = posInfo es+ posInfo (ESig e t) = between (posInfo e) (posInfo t)+ posInfo (ERec m fs) = between (posInfo m) (posInfo fs)+ posInfo (EBStruct c _ bs) = between (posInfo c) (posInfo bs)+ posInfo (ELam ps e) = between (posInfo ps) (posInfo e)+ posInfo (ELet bs e) = between (posInfo bs) (posInfo e)+ posInfo (ECase e as) = between (posInfo e) (posInfo as)+ posInfo (EIf e t f) = posInfo [e,t,f]+ posInfo (ENeg e) = posInfo e+ posInfo (ESeq e1 m e2) = foldr1 between [posInfo e1, posInfo m, posInfo e2]+ posInfo (EComp e qs) = between (posInfo e) (posInfo qs)+ posInfo (ESectR e n) = between (posInfo e) (posInfo n)+ posInfo (ESectL n e) = between (posInfo n) (posInfo e)+ posInfo (ESelect e n) = between (posInfo e) (posInfo n)+ posInfo (EDo n t ss) = between (posInfo n) (posInfo ss)+ posInfo (ETempl n t ss) = between (posInfo n) (posInfo ss)+ posInfo (EAct n ss) = between (posInfo n) (posInfo ss)+ posInfo (EReq n ss) = between (posInfo n) (posInfo ss)+ posInfo (EAfter e e') = between (posInfo e) (posInfo e')+ posInfo (EBefore e e') = between (posInfo e) (posInfo e')+ posInfo (ELit l) = posInfo l+ posInfo _ = Unknown++instance HasPos Field where+ posInfo (Field n e) = between (posInfo n) (posInfo e)++instance HasPos a => HasPos (Rhs a) where+ posInfo (RExp a) = posInfo a+ posInfo (RGrd gs) = posInfo gs+ posInfo (RWhere r bs) = between (posInfo r) (posInfo bs)+ +instance HasPos a => HasPos (GExp a) where+ posInfo (GExp qs a) = between (posInfo qs) (posInfo a)++instance HasPos a => HasPos (Alt a) where+ posInfo (Alt p r) = between (posInfo p) (posInfo r)++instance HasPos Qual where+ posInfo (QExp e) = posInfo e+ posInfo (QGen p e) = between (posInfo p) (posInfo e)+ posInfo (QLet bs) = posInfo bs++instance HasPos Stmt where+ posInfo (SExp e) = posInfo e+ posInfo (SRet e) = posInfo e+ posInfo (SGen p e) = between (posInfo p) (posInfo e)+ posInfo (SBind b) = posInfo b+ posInfo (SAss p e) = between (posInfo p) (posInfo e)+ posInfo (SForall qs ss) = between (posInfo qs) (posInfo ss)+ posInfo (SWhile e ss) = between (posInfo e) (posInfo ss)+ posInfo (SIf e ss) = between (posInfo e) (posInfo ss)+ posInfo (SElsif e ss) = between (posInfo e) (posInfo ss)+ posInfo (SElse ss) = posInfo ss+ posInfo (SCase e as) = between (posInfo e) (posInfo as)++instance HasPos Bind where+ posInfo (BSig ns t) = posInfo ns+ posInfo (BEqn l r) = between (posInfo l) (posInfo r)++instance HasPos Lhs where+ posInfo (LFun n ps) = between (posInfo n) (posInfo ps)+ posInfo (LPat p) = posInfo p++-- Binary --------------------------------------------------------------------++instance Binary Module where+ put (Module a b c d) = put a >> put b >> put c >> put d+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (Module a b c d)++instance Binary Import where+ put (Import a b) = put a >> put b+ get = get >>= \a -> get >>= \b -> return (Import a b)++instance Binary Decl where+ put (DKSig a b) = putWord8 0 >> put a >> put b+ put (DData a b c d) = putWord8 1 >> put a >> put b >> put c >> put d+ put (DRec a b c d e) = putWord8 2 >> put a >> put b >> put c >> put d >> put e+ put (DType a b c) = putWord8 3 >> put a >> put b >> put c+-- put (DInst a b) = putWord8 4 >> put a >> put b+ put (DPSig a b) = putWord8 4 >> put a >> put b+ put (DDefault a) = putWord8 5 >> put a+ put (DInstance a) = putWord8 6 >> put a+ put (DTClass a) = putWord8 7 >> put a+ put (DBind a) = putWord8 8 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> return (DKSig a b)+ 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (DData a b c d)+ 2 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> return (DRec a b c d e)+ 3 -> get >>= \a -> get >>= \b -> get >>= \c -> return (DType a b c)+-- 4 -> get >>= \a -> get >>= \b -> return (DInst a b)+ 4 -> get >>= \a -> get >>= \b -> return (DPSig a b)+ 5 -> get >>= \a -> return (DDefault a)+ 6 -> get >>= \a -> return (DInstance a)+ 7 -> get >>= \a -> return (DTClass a)+ 8 -> get >>= \a -> return (DBind a)+ _ -> fail "no parse"+++instance Binary Constr where+ put (Constr a b c) = put a >> put b >> put c+ get = get >>= \a -> get >>= \b -> get >>= \c -> return (Constr a b c)++instance Binary Sig where+ put (Sig a b) = put a >> put b+ get = get >>= \a -> get >>= \b -> return (Sig a b)++instance Binary Bind where+ put (BSig a b) = putWord8 0 >> put a >> put b+ put (BEqn a b) = putWord8 1 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> return (BSig a b)+ 1 -> get >>= \a -> get >>= \b -> return (BEqn a b)+ _ -> fail "no parse"++instance Binary Type where+ put (TQual a b) = putWord8 0 >> put a >> put b+ put (TCon a) = putWord8 1 >> put a+ put (TVar a) = putWord8 2 >> put a+ put (TAp a b) = putWord8 3 >> put a >> put b+ put (TSub a b) = putWord8 4 >> put a >> put b+ put TWild = putWord8 5+ put (TList a) = putWord8 6 >> put a+ put (TTup a) = putWord8 7 >> put a+ put (TFun a b) = putWord8 8 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> return (TQual a b)+ 1 -> get >>= \a -> return (TCon a)+ 2 -> get >>= \a -> return (TVar a)+ 3 -> get >>= \a -> get >>= \b -> return (TAp a b)+ 4 -> get >>= \a -> get >>= \b -> return (TSub a b)+ 5 -> return TWild+ 6 -> get >>= \a -> return (TList a)+ 7 -> get >>= \a -> return (TTup a)+ 8 -> get >>= \a -> get >>= \b -> return (TFun a b)+ _ -> fail "no parse"++instance Binary Pred where+ put (PType a) = putWord8 0 >> put a+ put (PKind a b) = putWord8 1 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (PType a)+ 1 -> get >>= \a -> get >>= \b -> return (PKind a b)+ _ -> fail "no parse"++instance Binary Lhs where+ put (LFun a b) = putWord8 0 >> put a >> put b+ put (LPat a) = putWord8 1 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> return (LFun a b)+ 1 -> get >>= \a -> return (LPat a)+ _ -> fail "no parse"++instance Binary Exp where+ put (EVar a) = putWord8 0 >> put a+ put (EAp a b) = putWord8 1 >> put a >> put b+ put (ECon a) = putWord8 2 >> put a+ put (ESel a) = putWord8 3 >> put a+ put (ELit a) = putWord8 4 >> put a+ put (ETup a) = putWord8 5 >> put a+ put (EList a) = putWord8 6 >> put a+ put EWild = putWord8 7+ put (ESig a b) = putWord8 8 >> put a >> put b+ put (ERec a b) = putWord8 9 >> put a >> put b+ put (ELam a b) = putWord8 10 >> put a >> put b+ put (ELet a b) = putWord8 11 >> put a >> put b+ put (ECase a b) = putWord8 12 >> put a >> put b+ put (EIf a b c) = putWord8 13 >> put a >> put b >> put c+ put (ENeg a) = putWord8 14 >> put a+ put (ESeq a b c) = putWord8 15 >> put a >> put b >> put c+ put (EComp a b) = putWord8 16 >> put a >> put b+ put (ESectR a b) = putWord8 17 >> put a >> put b+ put (ESectL a b) = putWord8 18 >> put a >> put b+ put (ESelect a b) = putWord8 19 >> put a >> put b+ put (EDo a b c) = putWord8 21 >> put a >> put b >> put c+ put (ETempl a b c) = putWord8 22 >> put a >> put b >> put c+ put (EAct a b) = putWord8 23 >> put a >> put b+ put (EReq a b) = putWord8 24 >> put a >> put b+ put (EAfter a b) = putWord8 25 >> put a >> put b+ put (EBefore a b) = putWord8 26 >> put a >> put b+ put (EBStruct a b c) = putWord8 27 >> put a >> put b >> put c+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (EVar a)+ 1 -> get >>= \a -> get >>= \b -> return (EAp a b)+ 2 -> get >>= \a -> return (ECon a)+ 3 -> get >>= \a -> return (ESel a)+ 4 -> get >>= \a -> return (ELit a)+ 5 -> get >>= \a -> return (ETup a)+ 6 -> get >>= \a -> return (EList a)+ 7 -> return EWild+ 8 -> get >>= \a -> get >>= \b -> return (ESig a b)+ 9 -> get >>= \a -> get >>= \b -> return (ERec a b)+ 10 -> get >>= \a -> get >>= \b -> return (ELam a b)+ 11 -> get >>= \a -> get >>= \b -> return (ELet a b)+ 12 -> get >>= \a -> get >>= \b -> return (ECase a b)+ 13 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EIf a b c)+ 14 -> get >>= \a -> return (ENeg a)+ 15 -> get >>= \a -> get >>= \b -> get >>= \c -> return (ESeq a b c)+ 16 -> get >>= \a -> get >>= \b -> return (EComp a b)+ 17 -> get >>= \a -> get >>= \b -> return (ESectR a b)+ 18 -> get >>= \a -> get >>= \b -> return (ESectL a b)+ 19 -> get >>= \a -> get >>= \b -> return (ESelect a b)+ 21 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EDo a b c)+ 22 -> get >>= \a -> get >>= \b -> get >>= \c -> return (ETempl a b c)+ 23 -> get >>= \a -> get >>= \b -> return (EAct a b)+ 24 -> get >>= \a -> get >>= \b -> return (EReq a b)+ 25 -> get >>= \a -> get >>= \b -> return (EAfter a b)+ 26 -> get >>= \a -> get >>= \b -> return (EBefore a b)+ 27 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EBStruct a b c)+ _ -> fail "no parse"++instance Binary Field where+ put (Field a b) = put a >> put b+ get = get >>= \a -> get >>= \b -> return (Field a b)++instance (Binary a) => Binary (Rhs a) where+ put (RExp a) = putWord8 0 >> put a+ put (RGrd a) = putWord8 1 >> put a+ put (RWhere a b) = putWord8 2 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (RExp a)+ 1 -> get >>= \a -> return (RGrd a)+ 2 -> get >>= \a -> get >>= \b -> return (RWhere a b)+ _ -> fail "no parse"++instance (Binary a) => Binary (GExp a) where+ put (GExp a b) = put a >> put b+ get = get >>= \a -> get >>= \b -> return (GExp a b)++instance (Binary a) => Binary (Alt a) where+ put (Alt a b) = put a >> put b+ get = get >>= \a -> get >>= \b -> return (Alt a b)++instance Binary Qual where+ put (QExp a) = putWord8 0 >> put a+ put (QGen a b) = putWord8 1 >> put a >> put b+ put (QLet a) = putWord8 2 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (QExp a)+ 1 -> get >>= \a -> get >>= \b -> return (QGen a b)+ 2 -> get >>= \a -> return (QLet a)+ _ -> fail "no parse"++instance Binary Stmt where+ put (SExp a) = putWord8 0 >> put a+ put (SRet a) = putWord8 1 >> put a+ put (SGen a b) = putWord8 2 >> put a >> put b+ put (SBind a) = putWord8 3 >> put a+ put (SAss a b) = putWord8 4 >> put a >> put b+ put (SForall a b) = putWord8 5 >> put a >> put b+ put (SWhile a b) = putWord8 6 >> put a >> put b+ put (SIf a b) = putWord8 7 >> put a >> put b+ put (SElsif a b) = putWord8 8 >> put a >> put b+ put (SElse a) = putWord8 9 >> put a+ put (SCase a b) = putWord8 10 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> return (SExp a)+ 1 -> get >>= \a -> return (SRet a)+ 2 -> get >>= \a -> get >>= \b -> return (SGen a b)+ 3 -> get >>= \a -> return (SBind a)+ 4 -> get >>= \a -> get >>= \b -> return (SAss a b)+ 5 -> get >>= \a -> get >>= \b -> return (SForall a b)+ 6 -> get >>= \a -> get >>= \b -> return (SWhile a b)+ 7 -> get >>= \a -> get >>= \b -> return (SIf a b)+ 8 -> get >>= \a -> get >>= \b -> return (SElsif a b)+ 9 -> get >>= \a -> return (SElse a)+ 10 -> get >>= \a -> get >>= \b -> return (SCase a b)+ _ -> fail "no parse"+
+ src/Syntax2Core.hs view
@@ -0,0 +1,412 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Syntax2Core where+++import Common+import Syntax+import Monad+import qualified Core+import PP++syntax2core m = s2c m+++-- translate a module in the empty environment++s2c :: Module -> M s Core.Module+s2c (Module v is ds ps) = do (xs,ts,ws,bss) <- s2cDecls env0 ds [] [] [] [] []+ return (Core.Module v is' xs ts ws bss)+ where env0 = Env { sigs = [] }+ is' = [(b,n) | Import b n <- is]+++-- type signature environments+data Env = Env { sigs :: Map Name Type }++addSigs te env = env { sigs = te ++ sigs env }+++-- Syntax to Core translation of declarations ========================================================++-- Translate top-level declarations, accumulating signature environment env, kind environment ke, +-- type declarations ts, instance names ws, bindings bs as well as default declarations xs+s2cDecls env [] ke ts ws bss xs = do bss <- s2cBindsList env (reverse bss)+ ke' <- mapM s2cKSig (impl_ke `zip` repeat KWild)+ xs' <- mapM s2cDefault xs+ let ds = Core.Types (reverse ke ++ ke') (reverse ts)+ return (xs', ds, ws, bss)+ where impl_ke = dom ts \\ dom ke++s2cDecls env (DKSig c k : ds) ke ts ws bss xs+ = do ck <- s2cKSig (c,k)+ s2cDecls env ds (ck:ke) ts ws bss xs+s2cDecls env (DData c vs bts cs : ds) ke ts ws bss xs+ = do bts <- mapM s2cQualType bts+ cs <- mapM s2cConstr cs+ s2cDecls env' ds ke ((c,Core.DData vs bts cs):ts) ws bss xs+ where env' = addSigs (teConstrs c vs cs) env+s2cDecls env (DRec isC c vs bts ss : ds) ke ts ws bss xs+ = do bts <- mapM s2cQualType bts+ sss <- mapM s2cSig ss+ s2cDecls env' ds ke ((c,Core.DRec isC vs bts (concat sss)):ts) ws bss xs+ where env' = addSigs (teSigs c vs ss) env+s2cDecls env (DType c vs t : ds) ke ts ws bss xs+ = do t <- s2cType t+ s2cDecls env ds ke ((c,Core.DType vs t):ts) ws bss xs+s2cDecls env (DInstance vs : ds) ke ts ws bss xs+ = s2cDecls env ds ke ts (ws++vs) bss xs+s2cDecls env (DDefault d : ds) ke ts ws bss xs+ = s2cDecls env ds ke ts ws bss (d ++ xs)+s2cDecls env (DBind bs : ds) ke ts ws bss xs+ = s2cDecls env ds ke ts ws (bs:bss) xs+++s2cBindsList env [] = return []+s2cBindsList env (bs:bss) = do (te,bs) <- s2cBinds env bs+ bss <- s2cBindsList (addSigs te env) bss+ return (bs:bss)+++s2cDefault (Default t a b) = return (Default t a b)+s2cDefault (Derive n t) = do t <- s2cQualType t+ return (Derive n t)++--translate a constructor declaration+s2cConstr (Constr c ts ps) = do ts <- mapM s2cQualType ts+ (qs,ke) <- s2cQuals ps+ return (c, Core.Constr ts qs ke)+++-- translate a field declaration+s2cSig (Sig vs qt) = s2cTSig vs qt+++-- add suppressed wildcard kind +pVar v = PKind v KWild+++-- buld a signature environment for data constructors cs in type declaration tc vs+teConstrs tc vs cs = map f cs+ where t0 = foldl TAp (TCon tc) (map TVar vs)+ f (Constr c ts ps) = (c,TQual (tFun ts t0) (ps ++ map pVar vs))++-- build a signature environment for record selectors ss in type declaration tc vs+teSigs tc vs ss = concat (map f ss)+ where t0 = foldl TAp (TCon tc) (map TVar vs)+ f (Sig ws (TQual t ps)) = ws `zip` repeat (TQual (TFun [t0] t) (ps ++ map pVar vs))+ f (Sig ws t) = ws `zip` repeat (TQual (TFun [t0] t) (map pVar vs))+++-- Signatures =========================================================================++-- translate a type signature+s2cTSig vs t = do ts <- mapM (s2cQualType . const t) vs+ return (vs `zip` ts)+++-- Types ==============================================================================++-- translate a qualified type scheme+s2cQualType (TQual t qs) = do (ps,ke) <- s2cQuals qs+ t <- s2cRhoType t+ return (Core.Scheme t ps ke)+s2cQualType t = s2cQualType (TQual t [])+++-- translate a rank-N function type+s2cRhoType (TFun ts t) = do ts <- mapM s2cQualType ts+ t <- s2cRhoType t+ return (Core.F ts t)+s2cRhoType t = liftM Core.R (s2cType t)+++-- translate a monomorphic type+s2cType (TSub t t') = s2cType (TFun [t] t')+s2cType (TFun ts t) = do ts <- mapM s2cType ts+ t <- s2cType t+ return (Core.TFun ts t)+s2cType (TAp t t') = liftM2 Core.TAp (s2cType t) (s2cType t')+++s2cType (TCon c) = return (Core.TId c)+s2cType (TVar v) = return (Core.TId v)+s2cType (TWild) = do k <- newKVar+ Core.newTVar k+++-- translate qualifiers, separating predicates from kind signatures along the way+s2cQuals qs = s2c [] [] qs+ where+ s2c ps ke [] = return (reverse ps, reverse ke)+ s2c ps ke (PKind v k : qs) = do k <- s2cKind k+ s2c ps ((v,k) : ke) qs+ s2c ps ke (PType t : qs) = do p <- s2cQualType t+ s2c (p : ps) ke qs+++-- Kinds ==============================================================================++-- translate a kind+s2cKind Star = return Star+s2cKind KWild = newKVar+s2cKind (KFun k k') = liftM2 KFun (s2cKind k) (s2cKind k')++s2cKSig (v,k) = do k <- s2cKind k+ return (v,k)++-- Expressions and bindings ============================================================++-- the translated default case alternative+dflt = [(Core.PWild, Core.EVar (prim Fail))]+++-- translate a case alternative, inheriting type signature t top-down+s2cA env t (Alt (ELit l) (RExp e)) = do e' <- s2cEc env t e+ return (Core.PLit l, e')+s2cA env t (Alt (ECon c) (RExp e)) = do e' <- s2cEc env (TFun ts t) e+ return (Core.PCon c, e')+ where ts = splitArgs (lookupT c env)+++-- translate a record field+s2cF env (Field s e) = do e <- s2cEc env (snd (splitT (lookupT s env))) e+ return (s,e)+++-- split bindings bs into type signatures and equations+splitBinds bs = s2cB [] [] bs+ where + s2cB sigs eqs [] = (reverse sigs, reverse eqs)+ s2cB sigs eqs (BSig vs t : bs) = s2cB (vs `zip` repeat t ++ sigs) eqs bs+ s2cB sigs eqs (BEqn (LFun v []) (RExp e) : bs)+ = s2cB sigs ((v,e):eqs) bs+++-- translate equation eqs in the scope of corresponding signatures sigs+s2cBinds env bs = do (ts,es) <- fmap unzip (mapM s2cEqn eqs)+ let te = vs `zip` ts+ te' <- s2cTE te+ return (te, Core.Binds isRec te' (vs `zip` es))+ where (sigs,eqs) = splitBinds bs+ vs = dom eqs+ isRec = not (null (filter (not . isPatTemp) vs `intersect` evars (rng eqs)))+ env' = addSigs sigs env+ s2cEqn (v,e) = case lookup v sigs of+ Nothing -> s2cEi env' e+ Just t -> do e <- s2cEc env' t' e+ return (t,e)+ where t' = if explicit (annot v) then expl t else peel t+++-- Expressions, inherit mode ===============================================================++-- translate an expression, inheriting type signature t top-down+s2cEc env t (ELam ps e) = do e' <- s2cEc (addSigs te env) t' e+ te' <- s2cTE te+ return (Core.ELam te' e')+ where (te,t') = mergeT ps t+s2cEc env _ (EAp e1 e2) = do (t,e1) <- s2cEi env e1+ let (t1,_) = splitT t+ e2 <- s2cEc env (peel t1) e2+ return (Core.eAp2 e1 [e2])+s2cEc env t (ELet bs e) = do (te',bs') <- s2cBinds env bs+ e' <- s2cEc (addSigs te' env) t e+ return (Core.ELet bs' e')+s2cEc env t (ECase e alts) = do e <- s2cEc env TWild e+ alts <- mapM (s2cA env t) alts+ return (Core.ECase e (alts++dflt))+s2cEc env t (ESelect e s) = do e <- s2cEc env (peel t1) e+ return (Core.ESel e s)+ where (t1,_) = splitT (lookupT s env)+s2cEc env t (ECon c) = return (Core.ECon c)+s2cEc env t (EVar v) = return (Core.EVar v)+s2cEc env t (ELit l) = return (Core.ELit l)+s2cEc env _ e = s2cE env e+++-- Expressions, agnostic mode ================================================================++-- translate an expression whose type cannot be rank-N polymorphic +-- (i.e., no point inheriting nor synthesizing signatures)+s2cE env (ERec (Just (c,_)) eqs) = do eqs <- mapM (s2cF env) eqs+ return (Core.ERec c eqs)+s2cE env (EAct (Just x) [SExp e]) = do (_,e) <- s2cEi env e+ return (Core.EAct (Core.EVar x) e)+s2cE env (EReq (Just x) [SExp e]) = do (_,e) <- s2cEi env e+ return (Core.EReq (Core.EVar x) e)+s2cE env (EDo (Just x) Nothing ss) = do c <- s2cS env ss+ t <- s2cType TWild+ return (Core.EDo x t c)+s2cE env (ETempl (Just x) Nothing ss) = do c <- s2cS (addSigs te env) ss+ t <- s2cType TWild+ te' <- s2cTE te+ return (Core.ETempl x t te' c)+ where + vs = assignedVars ss+ te = sigs ss++ sigs [] = []+ sigs (SAss (ESig (EVar v) t) _ :ss) = (v,t) : sigs ss+ sigs (SAss (EVar v) _:ss) = (v,TWild) : sigs ss+ sigs (_ : ss) = sigs ss++s2cE env e = internalError "s2cE: did not expect" e+++-- Statements ==================================================================================++-- translate a statement list+s2cS env [] = return (Core.CRet (Core.ECon (prim UNITTERM)))+s2cS env [SRet e] = do (t,e') <- s2cEi env e+ return (Core.CRet e')+s2cS env [SExp e] = do (t,e') <- s2cEi env e+ return (Core.CExp e')+s2cS env (SGen (ESig (EVar v) t) e :ss) = do t' <- s2cType t+ e' <- s2cEc env TWild e+ c <- s2cS (addSigs [(v,t)] env) ss+ return (Core.CGen v t' e' c)+s2cS env (SGen (EVar v) e : ss) = do (_,e') <- s2cEi env e+ t <- s2cType TWild+ c <- s2cS env ss+ return (Core.CGen v t e' c)+s2cS env (SAss (ESig v t) e : ss) = s2cS env (SAss v e : ss)+s2cS env (SAss (EVar v) e : ss) = do e' <- s2cEc env (lookupT v env) e+ c <- s2cS env ss+ return (Core.CAss v e' c)+s2cS env (SBind bs : ss) = do (te',bs') <- s2cBinds env bs+ c <- s2cS (addSigs te' env) ss+ return (Core.CLet bs' c)+++-- Expressions, synthesize mode ================================================================++-- translate an expression, synthesize type signature bottom-up+s2cEi env (ELam ps e) = do (t,e') <- s2cEi (addSigs te env) e+ te' <- s2cTE te+ return (TFun (rng te) t, Core.ELam te' e')+ where (te,_) = mergeT ps TWild+s2cEi env (EAp e1 e2) = do (t,e1) <- s2cEi env e1+ let (t1,t2) = splitT t+ e2 <- s2cEc env (peel t1) e2+ return (t2, Core.eAp2 e1 [e2])+s2cEi env (ELet bs e) = do (te',bs') <- s2cBinds env bs+ (t,e') <- s2cEi (addSigs te' env) e+ return (t, Core.ELet bs' e')+s2cEi env (ECase e alts) = do e <- s2cEc env TWild e+ alts <- mapM (s2cA env TWild) alts+ return (TWild, Core.ECase e (alts++dflt))+s2cEi env (ESelect e s) = do e <- s2cEc env (peel t1) e+ return (t2, Core.ESel e s)+ where (t1,t2) = splitT (lookupT s env)+s2cEi env (ECon c) = return (lookupT c env, Core.ECon c)+s2cEi env (EVar v) = return (lookupT v env, Core.EVar v)+s2cEi env (ELit l) = return (TWild, Core.ELit l)+s2cEi env e = do e' <- s2cE env e+ return (TWild, e')+++-- Misc ====================================================================================++-- translate type enviroment te+s2cTE te = mapM s2cVT te+ where s2cVT (v,t) = do t <- s2cQualType t+ return (v,t)+++-- split a function type into domain (one parameter only) and range+-- if not a function type, fail gracefully (error will be caught later by real type-checker)+splitT (TFun [t] t') = (t, t')+splitT (TFun (t:ts) t') = (t, TFun ts t')+splitT TWild = (TWild,TWild)+splitT _ = (TWild,TWild)+++-- return the domain of a function type (all immediate parameters)+splitArgs (TFun ts t) = ts+splitArgs t = []+++-- merge any signatures in patterns ps with domain of type t, pair with range of t+mergeT ps t = (zipWith f ts ps, t')+ where (ts,t') = split (length ps) t+ f t (EVar v) = (v,t)+ f t (ESig (EVar v) t') = (v,t')+ f t e = internalError "mergeT: did not expect" e+ split 0 t = ([],t)+ split n t = (t1:ts,t')+ where (t1,t2) = splitT t+ (ts,t') = split (n-1) t2+++-- find and instantate the type signature for x if present, otherwise return _+lookupT x env = case lookup x (sigs env) of+ Nothing -> TWild+ Just t -> peel t+++-- peel off the outermost qualifiers of a type, replacing all bound variables with _+peel (TQual t ps) = mkWild (bvars ps) t+peel t = t+++-- turn class and subtype predicates into explicit function arguments, and peel off the quantifiers+expl (TQual t ps) = mkWild (bvars ps) (TFun ts t)+ where ts = [ t | PType t <- ps ]+++-- replace all variables vs in a type by _+mkWild vs (TQual t ps) = TQual (mkWild vs' t) (map (mkWild' vs') ps)+ where vs' = vs \\ bvars ps+mkWild vs (TAp t t') = TAp (mkWild vs t) (mkWild vs t')+mkWild vs (TFun ts t) = TFun (map (mkWild vs) ts) (mkWild vs t)+mkWild vs (TSub t t') = TSub (mkWild vs t) (mkWild vs t')+mkWild vs (TList t) = TList (mkWild vs t)+mkWild vs (TTup ts) = TTup (map (mkWild vs) ts)+mkWild vs (TVar v)+ | v `elem` vs = TWild+mkWild vs t = t+++-- replace all variables vs in a predicate by _+mkWild' vs (PType t) = PType (mkWild vs t)+mkWild' vs p = p++-- Checking whether bindings are recursive ++checkRecBinds (Core.Binds _ te es@[(x,e)])+ = Core.Binds (x `elem` evars e) te es+checkRecBinds (Core.Binds _ te es) + = Core.Binds True te es+
+ src/Termred.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Termred(termred, redTerm, isFinite, constrs) where++import Monad+import Common+import Core+import PP+import Char++termred (_,ds',_,bs') m = redModule (consOf ds') (eqnsOf bs') m++redTerm coercions e = redExp (initEnv { eqns = coercions }) e++isFinite e = finite initEnv e+++data Env = Env { eqns :: Map Name Exp,+ args :: [Name],+ cons :: [Map Name Int]+ }++initEnv = Env { eqns = [], args = [], cons = cons0 }++cons0 = [ [(prim TRUE, 0), (prim FALSE, 0)] , [(prim NIL, 0), (prim CONS, 2)] ]++consOf (Types _ ds) = [ map f ce | (_,DData _ _ ce) <- ds ]+ where f (c, Constr te pe _) = (c, length te + length pe)+++conArity env (Tuple n _) = n+conArity env c = lookup' (concat (cons env)) c+++complete _ [Tuple _ _] = True+complete _ [] = False+complete [] cs0 = False+complete (cs:css) cs0 = all (`elem`cs0) (dom cs) || complete css cs0++addArgs env vs = env { args = vs ++ args env }++addEqns env eqs = env { eqns = eqs ++ eqns env }++addCons env css = env { cons = css ++ cons env }++redModule impCons impEqs (Module m ns xs ds is bss)+ = do (bss,_) <- redTopBinds env1 bss+ return (Module m ns xs ds is bss)+ where env0 = addCons initEnv (impCons ++ consOf ds)+ env1 = addEqns env0 (finiteEqns env0 impEqs)+++redTopBinds env [] = return ([], [])+redTopBinds env (bs : bss) = do Binds r te es <- redBinds env bs+ (bss,vs) <- redTopBinds (addEqns env (finiteEqns env es)) bss+ let necessary (v,_) = maybe (elem v vs) (const True) (fromMod v)+ te' = filter necessary te+ es' = filter necessary es+ bs' = Binds r te' es'+ bss' = if null te' then bss else bs':bss+ return (bss', idents es' ++ vs)+ ++finiteEqns env eqs = filter p eqs+ where p (x,e) = isSmall e && finite env e+++-- can be safely ignored without changing cbv semantics+value (EVar x) = x /= prim New+value (ECon _) = True+value (ELit _) = True+value (ESel e _) = value e+value (EAp (EVar (Prim IntDiv _)) [e1,e2])+ = value e1 && nonzero e2+value (EAp (EVar (Prim FloatDiv _)) [e1,e2])+ = value e1 && nonzero e2+value (EAp (EVar (Prim _ _)) es)+ = all value es+value (EAp (EVar (Tuple _ _)) es)+ = all value es+value (EAp (ECon c) es) = all value es+value (ELam _ _) = True+value (ERec _ eqs) = all (value . snd) eqs+value e = False++nonzero (ELit (LInt _ n)) = n /= 0+nonzero (ELit (LRat _ n)) = n /= 0+nonzero _ = False+++-- may be safely inlined (can't lead to infinite expansion even if part of a recursive binding group)+finite env (EVar (Prim c _)) = True --c `notElem` [ListArray, UniArray, UpdateArray]+finite env (EVar (Tuple _ _)) = True+finite env (EVar x) = x `elem` args env || maybe False (finite env )(lookup x (eqns env))+finite env (ECon _) = True+finite env (ELit _) = True+finite env (ESel e _) = finite env e+finite env (ELam te e) = finite (addArgs env (dom te)) e+finite env (ERec _ eqs) = all (finite env) (rng eqs)+finite env (EAp e es) = all (finite env) (e:es)+finite env (ELet bs e) = fin bs && finite (addArgs env (bvars bs)) e+ where fin (Binds True _ _) = False+ fin (Binds _ _ eqns) = all (finite env . snd) eqns+finite env (ECase e alts) = finite env e && all (finite env . snd) alts+finite env e = False++++redBinds env (Binds r te eqns) = liftM (Binds r te) (redEqns env eqns)+++redEqns env [] = return []+redEqns env ((x,e):eqns) = do e' <- redExp env e+ let env' = if finite env e' && isSmall e + then addEqns env [(x,e')] -- no risk of infinite inlining+ else env+ liftM ((x,e'):) (redEqns env' eqns)+++redExp env (ERec c eqs) = do es' <- mapM (redExp env) es+ return (ERec c (ls `zip` es'))+ where (ls,es) = unzip eqs+redExp env (ETempl x t te c) = liftM (ETempl x t te) (redCmd env c)+redExp env (EAct e e') = liftM2 EAct (redExp env e) (redExp env e')+redExp env (EReq e e') = liftM2 EReq (redExp env e) (redExp env e')+redExp env (EDo x t c) = liftM (EDo x t) (redCmd env c)+redExp env (ELam te e) = do e <- redExp (addArgs env (dom te)) e+ redEta env te e+redExp env (ESel e s) = do e <- redExp env e+ redSel env e s+redExp env (ECase e alts) = do e <- redExp env e+ redCase env e alts+redExp env (ELet bs e) = do bs'@(Binds rec te eqs) <- redBinds env bs+ if rec then+ liftM (ELet bs') (redExp env e)+ else+ redBeta (addArgs env (dom te)) te e (map (lookup' eqs) (dom te))+redExp env e@(EVar (Prim {})) = return e+redExp env e@(EVar (Tuple {})) = return e+redExp env e@(EVar x) = case lookup x (eqns env) of+ Just e' | inline e' -> alphaConvert e'+ _ -> return e+ where inline (EVar _) = True+ inline (ECon _) = True+ inline (ELit _) = True+ inline (ELam _ _) = True+ inline _ = isGenerated x+redExp env (EAp e es) = do e' <- redExp env e+ es' <- mapM (redExp env) es+ redApp env e' es'+redExp env (ELit l) = return (ELit (normLit l))+redExp env e = return e+++normLit (LInt p i)+ | i >= 0x80000000 = normLit (LInt p (i - 0x100000000))+ | i < -0x80000000 = normLit (LInt p (i + 0x100000000))+ | otherwise = LInt p i+normLit l = l+++isRaise (EAp (EVar (Prim Raise _)) [_])+ = True+isRaise _ = False++isPMC (EVar (Prim p _)) = p `elem` [Match,Commit,Fatbar,Fail]+isPMC _ = False+++-- reduce an application e es (head and args already individually reduced)+redApp env e es+ | exception = return (head es')+ where es' = filter isRaise (e:es)+ exception = not (isPMC e) && not (null es')+redApp env (EVar (Prim p a)) es + = return (redPrim env p a es)+redApp env e@(EVar x) es = case lookup x (eqns env) of+ Just e' | inline e' -> do e' <- alphaConvert e'; redApp env e' es+ _ -> return (EAp e es)+ where inline (ELam _ _) = True+ inline (EVar _) = True+ inline _ = False+redApp env (ELam te e) es = do redBeta env te e es+redApp env (ECase e alts) es+ | length alts' == length alts = liftM (ECase e) (redAlts env alts')+ where alts' = [ a | Just a <- map (appAlt env es) alts ]+redApp env (ELet bs e) es = liftM (ELet bs) (redApp env e es)+redApp env e es = return (EAp e es)+++appAlt env es (PCon c,e) = case skipLambda (conArity env c) e es of+ Just e' -> Just (PCon c, e')+ _ -> Nothing+appAlt env es a = Just a+++skipLambda 0 e es = Just (EAp e es)+skipLambda n (ELam te e) es+ | n <= length te = Just (ELam te1 (eLam te2 (EAp e es)))+ where (te1,te2) = splitAt n te+skipLambda n e es = Nothing++++-- perform beta reduction (if possible)+redBeta env ((x,t):te) (EVar y) (e:es)+ | x == y = redBeta env te e es -- trivial body+redBeta env ((x,t):te) b (e:es)+ | inline x e = do e' <- redBeta (addEqns env [(x,e)]) te b es+ return (bindx e')+ | otherwise = liftM (ELet bs) (redBeta env te b es)+ where inline x e = isSafe x || isEVar e || (value e && finite env e && isSmall e)+ isSafe x = isEtaExp x || isAssumption x || isCoercion x + bindx e'+ | x `elem` evars e' = ELet bs e'+ | otherwise = e'+ bs = Binds False [(x,t)] [(x,e)]+ isEVar (EVar _) = True+ isEVar _ = False+redBeta env [] b [] = redExp env b+++redEta env te (EAp e es) = do es <- mapM (redExp env') es+ e <- redExp env' e+ if okEta e && es == map EVar xs then+ return e+ else do+ liftM (ELam te) (redApp env' e es)+ where okEta (ECon _) = False+ okEta (EVar (Prim _ _)) = False+ okEta e = null (evars e `intersect` xs)+ env' = addArgs env (dom te)+ xs = dom te+redEta env te e = liftM (ELam te) (redExp (addArgs env (dom te)) e)+++redSel env e s+ | isRaise e = return e+redSel env e@(EVar x) s = case lookup x (eqns env) of+ Just e' | inline e' -> do e' <- alphaConvert e'+ redSel env e' s+ _ -> return (ESel e s)+ where inline (ERec _ _) = True+ inline (EVar _) = True+ inline _ = False+redSel env (ERec c eqs) s+ | all value (rng eqs) = case lookup s eqs of+ Just e -> return e+ Nothing -> internalError0 ("redSel: did not find selector " ++ show s ++ " in " ++ show eqs) s+redSel env e s = return (ESel e s)+++redCase env e alts+ | isRaise e = return e+redCase env e@(EVar x) alts = case lookup x (eqns env) of+ Just e' | inline (eFlat e') -> do e' <- alphaConvert e'; redCase env e' alts+ Nothing -> liftM (ECase e) (redAlts env alts)+ where inline (ECon _,_) = True+ inline (ELit _,_) = True+ inline (EVar _, []) = True+ inline _ = False+redCase env (ELit l@(LStr _ _)) alts + = redCaseStrLit env l alts+redCase env (ELit l) alts = findLit env l alts+redCase env e alts = case eFlat e of+ (ECon k, es) -> findCon env k es alts+ _ -> liftM (ECase e) (redAlts env alts)++redAlts env alts+ | complete (cons env) cs = do es <- mapM (redExp env) es+ return (map PCon cs `zip` es)+ | otherwise = do es0 <- mapM (redExp env) es0+ return (ps `zip` es0)+ where (cs,es) = unzip [ (c,e) | (PCon c, e) <- alts ]+ (ps,es0) = unzip alts+ +redRhs env (ELam te e) = do e <- redRhs (addArgs env (dom te)) e+ return (ELam te e)+redRhs env e = redExp env e+++findCon env k es ((PWild,e):_) = redExp env e+findCon env k es ((PCon k',e):_)+ | k == k' = redExp env (eAp e es)+findCon env k es (_:alts) = findCon env k es alts+++findLit env l ((PWild,e):_) = redExp env e+findLit env l ((PLit l',e):_)+ | l == l' = redExp env e+findLit env l (_:alts) = findLit env l alts++redCaseStrLit env l ((PWild,e):_) = redExp env e+redCaseStrLit env l ((PLit l',e):_)+ | l == l' = redExp env e+redCaseStrLit env (LStr _ "") ((PCon (Prim NIL _),e):alts) = redExp env e+redCaseStrLit env l@(LStr _ str) alts@((PCon (Prim CONS _),e):_)+ = redCase env (foldr (\x y -> EAp cons [chr x,y]) nil str) alts+ where chr x = ELit (LChr Nothing x)+ cons = ECon (prim CONS)+ nil = ECon (prim NIL)+redCaseStrLit env l (_:alts) = redCaseStrLit env l alts++redPrim env Refl _ [e] = e+redPrim env Match a [e] = redMatch env a e+redPrim env Fatbar a [e,e'] = redFat a e e'+redPrim env UniArray a es = EAp (EVar (Prim UniArray a)) es+redPrim env p _ [ELit (LInt _ x), ELit (LInt _ y)] = redInt p x y+redPrim env p a [ELit (LRat _ x), ELit (LRat _ y)] = redRat p x y+redPrim env IntNeg _ [ELit (LInt _ x)] = ELit (lInt (-x))+redPrim env IntToFloat _ [ELit (LInt _ x)] = ELit (lRat (fromInteger x))+redPrim env IntToChar _ [ELit (LInt _ x)] = ELit (lChr (chr (fromInteger x)))+redPrim env FloatNeg _ [ELit (LRat _ x)] = ELit (lRat (-x))+redPrim env FloatToInt _ [ELit (LRat _ x)] = ELit (lInt (truncate x))+redPrim env CharToInt _ [ELit (LChr _ x)] = ELit (lInt (ord x))+redPrim env p a es = eAp (EVar (Prim p a)) es+++redMatch env a (ELet bs e) = ELet bs (redMatch (addArgs env (bvars bs)) a e)+redMatch env a (ELam te e) = ELam te (redMatch (addArgs env (dom te)) a e)+redMatch env a (EAp (EVar (Prim Commit _)) [e]) = e+redMatch env a (ECase e alts) = ECase e (mapSnd (redMatch env a) alts)+redMatch env _ (EVar (Prim Fail a)) = EAp (EVar (Prim Raise a)) [ELit (lInt 1)]+redMatch env _ e@(ELit _) = e+redMatch env a e = EAp (EVar (Prim Match a)) [e]+++redFat a (ELet bs e) e' = ELet bs (redFat a e e')+redFat a (EVar (Prim Fail _)) e = e+redFat a e@(EAp (EVar (Prim Commit _)) _) _ = e+redFat a e e' = EAp (EVar (Prim Fatbar a)) [e,e']+++redInt IntPlus a b = ELit (normLit (lInt (a + b)))+redInt IntMinus a b = ELit (normLit (lInt (a - b)))+redInt IntTimes a b = ELit (normLit (lInt (a * b)))+redInt IntDiv a b = ELit (lInt (a `div` b))+redInt IntMod a b = ELit (lInt (a `mod` b))+redInt IntEQ a b = eBool (a == b)+redInt IntNE a b = eBool (a /= b)+redInt IntLT a b = eBool (a < b)+redInt IntLE a b = eBool (a <= b)+redInt IntGE a b = eBool (a >= b)+redInt IntGT a b = eBool (a > b)+redInt p _ _ = internalError0 ("redInt: unknown primitive " ++ show p)+++redRat FloatPlus a b = ELit (lRat (a + b))+redRat FloatMinus a b = ELit (lRat (a - b))+redRat FloatTimes a b = ELit (lRat (a * b))+redRat FloatDiv a b = ELit (lRat (a / b))+redRat FloatEQ a b = eBool (a == b)+redRat FloatNE a b = eBool (a /= b)+redRat FloatLT a b = eBool (a < b)+redRat FloatLE a b = eBool (a <= b)+redRat FloatGE a b = eBool (a >= b)+redRat FloatGT a b = eBool (a > b)+redRat p _ _ = internalError0 ("redRat " ++ show p)+++eBool True = ECon (prim TRUE)+eBool False = ECon (prim FALSE)+++redCmd env (CRet e) = liftM CRet (redExp env e)+redCmd env (CExp e) = liftM CExp (redExp env e)+redCmd env (CGen p t (ELet bs e) c)+ = redCmd env (CLet bs (CGen p t e c))+redCmd env (CGen p t e c) = liftM2 (CGen p t) (redExp env e) (redCmd env c)+redCmd env (CLet bs c) = do bs'@(Binds rec te eqs) <- redBinds env bs+ if rec then+ liftM (CLet bs') (redCmd env c)+ else+ redBetaC (addArgs env (dom te)) te c (map (lookup' eqs) (dom te))+redCmd env (CAss x e c) = liftM2 (CAss x) (redExp env e) (redCmd env c)+++-- perform beta reduction (if possible)+redBetaC env ((x,t):te) (CRet (EVar y)) (e:es)+ | x == y = redBetaC env te (CRet e) es+redBetaC env ((x,t):te) c (e:es)+ | inline x e = do c' <- redBetaC (addEqns env [(x,e)]) te c es+ return (bindx c')+ | otherwise = liftM (CLet bs) (redBetaC env te c es)+ where inline x e = isSafe x || isEVar e || (value e && finite env e && isSmall e)+ isSafe x = isEtaExp x || isAssumption x || isCoercion x + bindx c'+ | x `elem` evars c' = CLet bs c'+ | otherwise = c'+ bs = Binds False [(x,t)] [(x,e)]+ isEVar (EVar _) = True+ isEVar _ = False+redBetaC env [] c [] = redCmd env c++-- Constructor presence++isSmall e = length (constrs e) < 5++class Constrs a where+ constrs :: a -> [Name]++instance Constrs Binds where+ constrs (Binds rec te eqns) = constrs (map snd eqns)++instance Constrs a => Constrs [a] where+ constrs xs = concatMap constrs xs++instance Constrs Exp where+ constrs (ECon c) = [c]+ constrs (ESel e l) = constrs e+ constrs (ELam te e) = constrs e+ constrs (EAp e e') = constrs e ++ constrs e'+ constrs (ELet bs e) = constrs bs ++ constrs e+ constrs (ECase e alts) = constrs e ++ constrs alts+ constrs (ERec c eqs) = constrs (map snd eqs)+ constrs (EAct e e') = constrs e ++ constrs e'+ constrs (EReq e e') = constrs e ++ constrs e'+ constrs (ETempl x t te c) = constrs c+ constrs (EDo x t c) = constrs c+ constrs _ = []++instance Constrs Alt where+ constrs (p,e) = constrs e+++instance Constrs Cmd where+ constrs (CLet bs c) = constrs bs ++ constrs c+ constrs (CGen x t e c) = constrs e ++ constrs c+ constrs (CAss x e c) = constrs e ++ constrs c+ constrs (CRet e) = constrs e+ constrs (CExp e) = constrs e+
+ src/Token.hs view
@@ -0,0 +1,179 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Token where++import Char+++data Token + = VarId (String,String)+ | ConId (String,String)+ | VarSym (String,String)+ | ConSym (String,String)+ | IntTok String+ | FloatTok String+ | Character Char+ | StringTok String+{-++Symbols++-}+ | LeftParen+ | RightParen+ | SemiColon+ | LeftCurly+ | RightCurly+ | VRightCurly -- a virtual close brace+ | LeftSquare+ | RightSquare+ | Comma+ | BackQuote+{-++Reserved operators++-}+ | Assign+ | Dot+ | DotDot+ | DoubleColon+ | Equals+ | Backslash+ | Bar+ | LeftArrow+ | RightArrow+ | Tilde+ | Wildcard+ | Backslash2+{-++Reserved Ids++-}+ | KW_Action+ | KW_After+ | KW_Before+ | KW_Case + | KW_Class + | KW_Data + | KW_Default + | KW_Do + | KW_Else + | KW_Elsif+ | KW_Forall+ | KW_If+ | KW_Import + | KW_Instance+ | KW_In + | KW_Let+ | KW_Module+ | KW_New + | KW_Of + | KW_Private + | KW_Request+ | KW_Result+ | KW_Struct+ | KW_Then + | KW_Type + | KW_Typeclass+ | KW_Use + | KW_Where+ | KW_While+ | EOF+ deriving (Eq, Show)+++reserved_ops :: [(String, Token)]+reserved_ops+ = [+ ( ".", Dot ), + ( "..", DotDot ), + ( "::", DoubleColon ),+ ( ":=", Assign ),+ ( "=", Equals ), + ( "\\", Backslash ), + ( "|", Bar ), + ( "<-", LeftArrow ), + ( "->", RightArrow ),+ ( "_", Wildcard ),+ ( "\\\\", Backslash2 )+ ]+++reserved_ids :: [(String, Token)]+reserved_ids+ = [+ ( "action", KW_Action ),+ ( "after", KW_After ),+ ( "before", KW_Before ),+ ( "case", KW_Case ), + ( "class", KW_Class ), + ( "data", KW_Data ),+ ( "default", KW_Default), + ( "do", KW_Do ), + ( "else", KW_Else ),+ ( "elsif", KW_Elsif ), + ( "forall", KW_Forall ),+ ( "if", KW_If ),+ ( "import", KW_Import ),+ ( "instance", KW_Instance ), + ( "in", KW_In ), + ( "let", KW_Let ), + ( "module", KW_Module ), + ( "new", KW_New ),+ ( "of", KW_Of ),+ ( "private", KW_Private ),+ ( "request", KW_Request ),+ ( "result", KW_Result ),+ ( "struct", KW_Struct ),+ ( "then", KW_Then ), + ( "type", KW_Type ), + ( "typeclass", KW_Typeclass ), + ( "use", KW_Use ), + ( "where", KW_Where ),+ ( "while", KW_While )+ ]++++tab_length = 8 :: Int++isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_'+isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"++data LexInt =+ Decimal (String,String)+ | Octal (String,String)+ | Hexadecimal (String,String)
+ src/Type.hs view
@@ -0,0 +1,535 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Type(typecheck) where+ +import Common+import Core+import Env+import Depend+import List(unzip4, zipWith3)+import Monad+import Kind+import Decls+import Reduce+import Termred+import PP+import Derive++--typecheck :: Module -> M s Module+typecheck e2 m = tiModule e2 m+++{-++Example 1:+==========++-- Initially:+let f :: P => S -> T+ f = \x -> e (f 7)++-- After exp inference:+ \x -> e w (f v 7) ::X->T' \\ w::W, v::V++-- After generalization:+ \w v x -> e w (f v 7) ::W->V->X->T' \\++-- After mu:+let f = c (\w v x -> e w (f v 7)) ::P->S->T \\ c::(W->V->X->T')->(P->S->T)++-- After improvement (T' = T, X = S, V = P):+let f = c (\w v x -> e w (f v 7)) ::P->S->T \\ c::(W->P->S->T)->(P->S->T)++-- After reduce:+let f = (\c -> c (\w v x -> e w (f v 7))) (\i -> i w0) ::P->S->T \\ w0 :: W++-- After generalization:+let f = \w0 -> (\f -> ((\c -> c (\w v x -> e w (f v 7))) (\i -> i w0))) (f w0) ::W->P->S->T \\++-- After inlining:+let f = \w0 -> \f -> ((\c -> c (\w v x -> e w (f v 7))) (\i -> i w0)) (f w0) ::W->P->S->T \\+let f = \w0 -> (\c -> c (\w v x -> e w (f w0 v 7))) (\i -> i w0) ::W->P->S->T \\+let f = \w0 -> (\i -> i w0) (\w v x -> e w (f w0 v 7)) ::W->P->S->T \\+let f = \w0 -> (\w v x -> e w (f w0 v 7)) w0 ::W->P->S->T \\+let f = \w0 v x -> e w0 (f w0 v 7) ::W->P->S->T \\++---------------+\i -> i w0 :: (W->P->S->T)->P->S->T \\ w0 :: W+---------------+-}++tiModule (xs',ds',ws',bs') (Module v ns xs ds ws bss)+ = do env0' <- impPreds env0 pe'+ (env1,ds1,bs1) <- typeDecls env0' ds+ (env2,bs2) <- instancePreds env1 pe+ -- Here it should be checked that any coercions in weqs follow the+ -- restricted rules for coercions, and that the equalities collected + -- in env2 are actually met by the equations in bs1, bs2 and bss+ let env3 = insertDefaults env2 (pe'++pe) (xs'++xs)+ env4 = addCoercions (weqs1 ++ weqs) env3+ weqs1 = eqnsOf bs1 ++ eqnsOf bs2+ (ss0,pe0,bs0) <- tiBindsList env4 bss+ -- tr ("Top-level: \n" ++ render (nest 4 (vpr (tsigsOf bs0) $$ vpr pe0)))+ bs3 <- topresolve env4 ss0 pe0 bs0+ -- tr ("Top-level after resolve: \n" ++ render (nest 4 (vpr (tsigsOf bs3))))+ return (Module v ns xs ds1 (dom weqs1 ++ ws) (groupBinds (concatBinds [bs1,bs2,bs3])))+ where bs = concatBinds bss+ weqs = restrict (eqnsOf bs') ws' ++ restrict (eqnsOf bs) ws+ pe = restrict (tsigsOf bs) ws+ pe' = restrict (tsigsOf bs') ws'+ env0 = addTEnv0 (tsigsOf bs') (impDecls (initEnv v) ds')+++tiBindsList env [] = return ([], [], nullBinds)+tiBindsList env (bs:bss) = do (ss1, pe1, bs1) <- tiBinds env bs+ (ss2, pe2, bs2) <- tiBindsList (addTEnv (tsigsOf bs1) env) bss+ return (ss1++ss2, pe1++pe2, bs1 `catBinds` bs2)++ +tiBinds env (Binds _ [] []) = return ([], [], nullBinds)+tiBinds env (Binds rec te eqs) = do -- tr ("TYPE-CHECKING " ++ showids xs ++ ", at line: " ++ show (pos (fst(head te))))+ -- tr (render (nest 8 (vpr te)))+ -- tr ("assuming\n" ++ render (nest 4 (vpr (typeEnv env))))+ (s,pe,es1) <- tiRhs0 (addTEnv te env) explWits ts es+ -- tr ("RESULT (" ++ showids xs ++ "):\n" ++ render (nest 8 (vpr pe)))+ -- tr ("EXPS:\n" ++ render (nest 8 (vpr es1)))+ (s',qe,f) <- fullreduce (target te (setErrPos (posInfo es) env)) s pe `handle` (fail . tail)+ -- tr ("PREDICATES OBTAINED (" ++ showids xs ++ "):\n" ++ render (nest 8 (vpr qe)))+ let env1 = subst s' env+ ts1 = subst s' ts+ tvs0 = if mono then tvars qe ++ tvs1 else []+ tvs1 = concat [ tvars t | (t,e) <- ts1 `zip` es, isNewAp e ]+ (qe1,qe2) = if mono then (qe,[]) else partition (isFixed (tevars env1)) qe+ (vs,qs) = unzip qe2+ es2 = map f es1+ es3 = if mono || not rec || null vs then es2 else map (subst (satSubst vs)) es2+ (es',ts') = if mono then (es3,ts1) else unzip (zipWith (qual qe2) es3 ts1)+ -- tr ("BEFORE GEN:\n" ++ render (nest 8 (vpr (xs `zip` ts') $$ vpr qe2)))+ -- Note: using genL below instead of mapM gen allows us to take a simplifying + -- shortcut later on in Type2+ ts'' <- genL (tevars env1 ++ tvs0) ts'+ -- tr ("DONE " ++ render (nest 8 (vpr (xs `zip` ts''))))+ -- tr ("EXPS " ++ render (nest 8 (vpr (xs `zip` es'))))+ return (mkEqns env s', qe1, Binds rec (xs `zip` ts'') (xs `zip` es'))+ where ts = map (lookup' te) xs+ (xs,es) = unzip eqs+ explWits = map (explicit . annot) xs+ satSubst [] = []+ satSubst vs = zipWith f xs ts+ where es = map EVar vs+ f x t = (x, eLam te (EAp (EVar x) (es ++ map EVar (dom te))))+ where te = abcSupply `zip` ctxt t+ mono = or [ isNewAp e || arity e == 0 && null (ctxt t) | (e,t) <- es `zip` ts ]+++tiRhs0 env explWits ts es = do (ss,pes,es') <- fmap unzip3 (mapM (tiExpT' env) (zip3 explWits ts es))+ return (concat ss, concat pes, es')++tiRhs env ts es = tiRhs0 env (repeat False) ts es+++tiExpT env t e = tiExpT' env (False, t, e)+++tiExpT' env (explWit, Scheme t0 ps ke, e)+ | isNewAp e = do (ss,pe,t,e') <- tiExp env e+ c <- newNamePos coercionSym e'+ return (ss, (c, Scheme (F [scheme' t] t0) ps ke) : pe, EAp (EVar c) [e'])+ | null ke && not explWit = do (ss,qe,t,e) <- tiExp env e+ c <- newNamePos coercionSym e+ pe0 <- newEnvPos assumptionSym ps e+ let ws = map EVar (dom pe0)+ e1 = eLam pe0 (EAp (eAp (EVar c) ws) [e])+ return (ss, (c, Scheme (F [scheme' t] t0) ps ke) : qe, e1)+ | otherwise = do (ss,qe,t,e) <- tiExp env e+-- tr ("REQUIRED: " ++ render (pr (Scheme t0 ps ke)))+-- tr ("INFERRED: " ++ render (pr t) ++ "\n" ++ render (nest 4 (vpr qe)))+ (s,qe,f) <- normalize (target t (setErrPos (posInfo e) env)) ss qe `handle` (fail . tail)+ c <- newNamePos coercionSym e+ pe0 <- newEnvPos assumptionSym ps e >>= wildify ke+ let env1 = subst s env+ (qe1,qe2) = partition (isFixed (tevars env1)) (subst s qe)+ (e',t') = qual qe2 (f e) (scheme' (subst s t))+ ws = map EVar (dom pe0)+ (ws',ps') = if explWit then (ws, ps) else ([], [])+ e1 = eLam pe0 (eAp (EAp (eAp (EVar c) ws) [e']) ws')+ sc <- gen (tevars env1 ++ tvars qe1) t'+ return (mkEqns env1 s, (c, Scheme (F [sc] (tFun ps' t0)) ps ke) : qe1, e1)++mkEqns env s = mapFst TVar (restrict s (tevars env))++isFixed tvs (w,p) = isDummy w || all (`elem` tvs) (tvars p)+++tiAp env s pe (F scs rho) e es+ | len_scs >= len_es = do (s',pe',es') <- tiRhs env scs1 es+ te <- newEnv paramSym scs2+ return (s++s', pe++pe', tFun scs2 rho, eLam te (EAp e (es'++map EVar (dom te))))+ | otherwise = do (s',pe',es') <- tiRhs env scs es1+ tiAp env (s++s') (pe++pe') rho (EAp e es') es2+ where len_scs = length scs+ len_es = length es+ (scs1,scs2) = splitAt len_es scs+ (es1,es2) = splitAt len_scs es+tiAp env s pe (R (TFun ts t)) e es+ = tiAp env s pe (F (map scheme ts) (R t)) e es+tiAp env s pe rho e es = do t <- newTVar Star+ c <- newNamePos coercionSym e+ (ss,pes,ts,es) <- fmap unzip4 (mapM (tiExp env) es)+ let p = Scheme (F [scheme' rho] (F (map scheme' ts) (R t))) [] []+ return (s++concat ss, (c,p):pe++concat pes, R t, EAp (EAp (EVar c) [e]) es)++etaExpand pe (R (TFun ts t)) e = etaExpand pe (F (map scheme ts) (R t)) e+etaExpand pe (F scs t) e = do te <- newEnv etaExpSym scs+ return ([], pe, F scs t, ELam te (EAp e (map EVar (dom te))))+etaExpand pe t e = return ([], pe, t, e)+++tiExp env (ELit l) = return ([], [], R (litType l), ELit l)+tiExp env (EVar x)+ | doEtaExpand x = do (pe,t,e) <- instantiate (findExplType env x) (EVar (annotExplicit x))+ etaExpand pe t e+ | otherwise = do (pe,t,e) <- instantiate (findExplType env x) (EVar (annotExplicit x))+ return ([], pe, t, e)+tiExp env (ECon k) = do (pe,t,e) <- instantiate (findExplType env k) (ECon (annotExplicit k))+ etaExpand pe t e+tiExp env (ESel e l) = do (t, t0:ps) <- inst (findType env l)+ (s,pe,e) <- tiExpT env t0 e+ let r = if explicit (annot l) then (tFun ps t,[]) else (t,ps)+ (pe',t',e') <- saturate r (ESel e (annotExplicit l))+ return (s, pe++pe', t', e')+tiExp env (ELam te e) = do (s,pe,t,e) <- tiExp (addTEnv te env) e+ return (s, pe, F (rng te) t, ELam te e)+tiExp env (EAp e es) = do (s,pe,t,e) <- tiExp env e+ tiAp env s pe t e es+tiExp env (ELet bs e) = do (s,pe,bs) <- tiBinds env bs+ (s',pe',t,e) <- tiExp (addTEnv (tsigsOf bs) env) e+ return (s++s',pe++pe', t, ELet bs e)+tiExp env (ERec c eqs) = do alphas <- mapM newTVar (kArgs (findKind env c))+ (t,ts,_) <- tiLhs env (foldl TAp (TId c) alphas) tiSel sels+ (s,pe,es') <- tiRhs env ts es+ -- tr ("RECORD " ++ render (pr t))+ -- tr (render (nest 4 (vpr (sels `zip` ts))))+ -- tr (" pe :\n" ++ render (nest 4 (vpr pe)))+ e <- mkRecTerm env c sels es'+ return (s, pe, R t, e)+ where (sels,es) = unzip eqs+ tiSel env x l = tiExp env (ESel (EVar x) l)+tiExp env (ECase e alts) = do alpha <- newTVar Star+ (t,ts,_) <- tiLhs env alpha tiPat pats+ (s,pe,es') <- tiRhs env ts es+ let TFun [t0] t1 = t+ (s1,pe1,e') <- tiExpT env (scheme t0) e+ e <- mkCaseTerm env e' (tId (tHead t0)) pats es'+ return (s++s1, pe++pe1, R t1, e)+ where (pats,es) = unzip alts+ tiPat env x (PLit l) = tiExp env (EAp (EVar x) [ELit l])+ tiPat env x (PCon k) = do (t,_) <- inst (findType env k)+ te <- newEnv paramSym (funArgs t)+ tiExp env (eLam te (EAp (EVar x) [eAp (ECon k) (map EVar (dom te))]))+ tiPat env x (PWild) = do y <- newName tempSym+ t <- newTVar Star+ tiExp (addTEnv [(y,scheme t)] env) (EAp (EVar x) [EVar y])+tiExp env (EReq e e') = do alpha <- newTVar Star+ beta <- newTVar Star+ (s,pe,e) <- tiExpT env (scheme (tRef alpha)) e+ (s',pe',e') <- tiExpT env (scheme (tCmd alpha beta)) e'+ return (s++s', pe++pe', R (tRequest beta), EReq e e')+tiExp env (EAct e e') = do alpha <- newTVar Star+ beta <- newTVar Star+ (s,pe,e) <- tiExpT env (scheme (tRef alpha)) e+ (s',pe',e') <- tiExpT env (scheme (tCmd alpha beta)) e'+ return (s++s', pe++pe', R tAction, EAct e e')+tiExp env (EDo x tx c)+ | isTVar tx = do (s,pe,t,c) <- tiCmd (setSelf x tx env) c+ let s' = case stateT env of Nothing -> []; Just t' -> [(t',tx)]+ return (s'++s, pe, R (tCmd tx t), EDo x tx c)+ | otherwise = internalError0 "Explicitly typed do expressions not yet implemented"+tiExp env (ETempl x tx te c)+ | isTVar tx = do n <- newName stateTypeSym+ let env' = setSelf x (TId n) (addTEnv te (addKEnv0 [(n,Star)] env))+ (s,pe,t,c) <- tiCmd env' c+ return ((TId n, tx):s, pe, R (tClass t), ETempl x (TId n) te c)+ | otherwise = internalError0 "Explicitly typed class expressions not yet implemented"+++tiCmd env (CRet e) = do alpha <- newTVar Star+ (s,pe,e) <- tiExpT env (scheme alpha) e+ return (s, pe, alpha, CRet e)+tiCmd env (CExp e) = do alpha <- newTVar Star+ (s,pe,e) <- tiExpT env (scheme (tCmd (fromJust (stateT env)) alpha)) e+ return (s, pe, alpha, CExp e)+tiCmd env (CGen x tx e c) = do (s,pe,e) <- tiExpT env (scheme (tCmd (fromJust (stateT env)) tx)) e+ (s',pe',t,c) <- tiCmd (addTEnv [(x,scheme tx)] env) c+ return (s++s', pe++pe', t, CGen x tx e c)+tiCmd env (CAss x e c) = do (s,pe,e) <- tiExpT env (findType env x) e+ (s',pe',t,c) <- tiCmd env c+ return (s++s', pe++pe', t, CAss x e c)+tiCmd env (CLet bs c) = do (s,pe,bs) <- tiBinds env bs+ (s',pe',t,c) <- tiCmd (addTEnv (tsigsOf bs) env) c+ return (s++s', pe++pe', t, CLet bs c)+++-- Compute a list of+tiLhs env alpha tiX xs = do x <- newName tempSym+ let env' = addTEnv [(x,scheme alpha)] env+ (_,pes,ts,es) <- fmap unzip4 (mapM (tiX env' x) xs) -- ignore returned substs (must be null)+ (s,_,f) <- resolve (target alpha env) (concat pes) -- ignore returned qe (filter pes instead)+ let ts1 = map scheme' (subst s ts)+ es1 = map f es+ pes1 = subst s (map (filter (not . isCoercion . fst)) pes) -- preserve non-coercions for each alt+ (es2,ts2) = unzip (zipWith3 qual pes1 es1 ts1)+ ts3 <- genL (tevars (subst s env')) ts2+ es2 <- mapM (redTerm (coercions env)) es2+ return (subst s alpha, ts3, es2)+++-- Build a record term ---------------------------------------------------------------------------------------------------+mkRecTerm env c sels es = return (mkOne c)+ where cs = map ltype sels+ groups = map (\c -> (c, [ (l,e) | (c',l,e) <- zip3 cs sels es, c == c' ])) (nub cs)+ graph = nodesFrom c+ nodesFrom c = (c,ns) : concatMap nodesFrom (rng ns)+ where ns = [ (sel w, snd (subsyms p)) | (w,p) <- nodes wg, w `notElem` indirect ]+ indirect = map snd (arcs wg)+ sel w = ff (lookup' (coercions env) w)+ wg = findAbove env c+ ff (ELam _ (ESel _ l)) = l+ ltype l = headsym (head (ctxt (findType env l)))+ mkOne c = ERec c (eqs0 ++ case lookup c groups of Just eqs -> eqs; Nothing -> [])+ where eqs0 = mapSnd mkOne (lookup' graph c)+++-- Build a case term -------------------------------------------------------------------------------------------------------+mkCaseTerm env e0 c pats0 es0+ | any isLitPat pats0 = return (ECase e0 (pats0 `zip` es0))+ | otherwise = mkOne e0 c+ where (altsK,altsW) = partition (isConPat . fst) (pats0 `zip` es0)+ (pats,es) = unzip altsK+ cs = map ptype pats+ groups = map (\c -> (c, [ (p,e) | (c',p,e) <- zip3 cs pats es, c == c' ])) (nub cs)+ graph = nodesFrom c+ nodesFrom c = (c,ns) : concatMap nodesFrom (rng ns)+ where ns = [ (con w, fst (subsyms p)) | (w,p) <- nodes wg, w `notElem` indirect ]+ indirect = map snd (arcs wg)+ con w = ff (lookup' (coercions env) w)+ wg = findBelow env c+ ff (ELam _ (EAp (ECon k) _)) = k+ ptype (PCon k) = tId (tHead (body (findType env k)))+ mkOne e0 c = do alts0 <- mapM mkAlt0 (lookup' graph c)+ return (ECase e0 (alts0 ++ (case lookup c groups of Just alts -> alts; Nothing -> []) ++ altsW))+ mkAlt0 (k,c) = do x <- newName tempSym+ (F [sc] _, _) <- inst (findType env k)+ e <- mkOne (EVar x) c+ return (PCon k, ELam [(x,sc)] e)++ ++-- data Pack m a = Pack (m a) \\ Eq a+-- data Exists m > Pack m a \\ a+-- = Test (m Int)++-- Translation 1:+-- data Pack m a = Pack (m a) \\ Eq a+-- data Exists m = Exists_from_Pack (Pack m a) \\ a+-- | Test (m Int)++-- Translation 2:+-- data Pack m a = Pack (Eq a) (m a)+-- data Exists m = Exists_from_Pack (Pack m a) \\ a+-- | Test (m Int)++-- Constructor types:+-- Pack :: Eq a -> m a -> Pack m a \\ a, m+-- Exists_from_Pack :: Pack (m a) -> Exists m \\ a, m+-- Test :: m Int -> Exists m \\ m++-- case e0 of+-- Pack -> (\w r -> e1)+-- Test -> (\q -> e2++-- case e0 of+-- Exixts_from_Pack -> (\x -> case x of+-- Pack -> (\w r -> e1)+-- _ -> fail+-- Test -> (\q -> e2)+++-- Formulation without subtyping: ------------------------------+--+-- data Exists m = Pack (m a) \\ Eq a, a+-- | Test (m Int)++-- Translation:+-- data Exists m = Pack (Eq a) (m a) \\ a+-- | Test (m Int)++-- Constructor types:+-- Pack :: Eq a -> m a -> Exists m \\ a, m+-- Test :: m Int -> Exists m \\ m++-- case e0 of+-- Pack -> (\(w :: Eq _) (r :: _ _) -> e1)+-- Test -> (\(q :: _ Int) -> e2)++++++{-+ + record A v+ a :: Eq v => v -> [v] w : Eq v |- (.a) : A v -> v -> [v] = \t -> t.a w++ record B v < A v =+ b :: v |- (.b) : B v -> v = \t -> t.b+++ { a v = [v], b = 0 }++ w : Eq v, ca : xx < A v |- (.a) x : v -> [v] = (\t -> t.a w) (ca x) ++ cb : xx < B v |- (.b) x : v = (\t -> t.b) (cb x)++ b2a/ca, id/cb, B v / xx++ w : Eq v |- (.a) x : v -> [v] = (\t -> t.a w) ((.b2a) x) = x.b2a.a w = (.a) . (.b2a) .++ |- (.b) x : v = (t -> t.b) (id x) = x.b+++-}++{-++record A =+ a :: Ta++record B < A =+ b :: Tb++record C < A =+ c :: Tc++record D < B,C =+ d :: Td++===>++record A =+ a :: Ta++record B =+ b2a :: A+ b :: Tb++record C =+ c2A :: A+ c :: Tc++record D =+ d2b :: B+ d2c :: C+ d :: Td+++D < B < A+D < C < A++{ a|b2a|d2b = Ma+ a|c2a|d2c = Ma+ b|d2b = Mb :: D+ c|d2c = Mc+ d = Md+}++{ d2b = { b2a = { a = Ma }+ b = Mb }+ d2c = { c2a = { a = Ma }+ c = Mc }+ d = Md }++ A+ / \+ B C+ \ /+ D++{ B2A -> { D2B -> { D -> \x.Md }+ B -> \x.Mb }+ C2A -> { D2C -> { D -> \x.Md }+ C -> \x.Mc }+ A -> \x.Ma }++{ B2A|D2B|D -> \x.Md+ C2A|D2C|D -> \x.Md+ B2A|B -> \x.Mb :: A -> t+ C2A|C -> \x.Mc+ A -> \x.Ma+}++A->t < B->t < D->t+A->t < C->t < D->t++data D =+ D Td++data C > D =+ C Tc++data B > D =+ B Rb++data A > B,C =+ a Ta++===>++data D =+ D Td++data C =+ D2C D+ C Tc++data B =+ D2B D+ B Tb++data A =+ B2A B+ C2A C+ A Ta++-}
+ src/Type2.hs view
@@ -0,0 +1,284 @@+-- The Timber compiler <timber-lang.org>+--+-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- +-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- +-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- +-- 3. Neither the names of the copyright holder and any identified+-- contributors, nor the names of their affiliations, may be used to +-- endorse or promote products derived from this software without +-- specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Type2 where+ +import Common+import Core+import Env+import Decls+import PP++typecheck2 e2 m = t2Module e2 m++t2Module (xs',ds',ws',bs') (Module v ns xs ds ws bss)+ = do bss <- t2BindsList env2 bss+ return (Module v ns xs ds ws bss)+ where env2 = addTEnv0 te2 (addKEnv0 ke2 env1)+ te2 = tenvSelsCons ds+ ke2 = ksigsOf ds+ env1 = addTEnv0 te1 (addKEnv0 ke1 env0)+ te1 = tsigsOf bs' ++ tenvSelsCons ds'+ ke1 = ksigsOf ds'+ env0 = addTEnv0 primPredEnv (initEnv v)++t2BindsList env [] = return []+t2BindsList env (bs:bss) = do bs <- t2Binds0 env bs+ bss <- t2BindsList (addTEnv (tsigsOf bs) env) bss+ return (bs:bss)++-- t2Binds0 is a variant of t2Binds that is optimized for use on the program top level, where the only free +-- occurrences of unification variables are in partial type signatures. After type-checking a right-hand side,+-- all unification variables that still remain will be generalized before a dependent binding group is checked.+-- Thus there is no need to propagate any substitution from one top-level binding group to the next; and+-- furthermore, the only fragment of a substitution that can possibly affect the type of a binding whithin+-- the *same* group must have the free unification variables of the corresponding type signature as its domain.+-- Hence the restriction of s1 to the tvars of sc below. Note: this optimization has considerable impact on+-- the efficiency of the Type2 pass!+-- Another difference between t2Binds0 and t2Binds is that t2Binds0 also applies the computed substitution to+-- the top-level *term* of a binding, so that nested signatures inside the right-hand side term may be properly +-- updated and named according to System F-like principles. Note that this is done as early as possible +-- (immediately after a right-hand side has been checked), in order to allow the computed substitution to be +-- restricted before it is applied to any sibling bindings.++t2Binds0 env (Binds r te eqs) = do (s,eqs') <- t2Eqs eqs+ scs' <- mapM (t2Gen (tevars env)) (subst s scs)+ return (Binds r (xs `zip` scs') eqs')+ where env1 = addTEnv te env+ (xs,scs) = unzip te+ t2Eqs [] = return (nullSubst, [])+ t2Eqs ((x,e):eqs) = do (s1,e) <- t2ExpTscoped env1 sc e+ (s2,eqs) <- t2Eqs eqs+ return (mergeSubsts [restrict s1 (tvars sc),s2], (x, subst s1 e):eqs)+ where sc = lookup' te x+++t2Binds env (Binds r te eqs) = do (s,eqs') <- t2Eqs eqs+ let scs1 = subst s scs+ tvs0 = concat [ tvars sc | (sc,eq) <- scs1 `zip` eqs, isNewAp (snd eq) ]+ scs2 <- mapM (t2Gen (tevars (subst s env) ++ tvs0)) (subst s scs1)+ return (s, Binds r (xs `zip` scs2) eqs')+ where env1 = addTEnv te env+ (xs,scs) = unzip te+ t2Eqs [] = return (nullSubst, [])+ t2Eqs ((x,e):eqs) = do (s1,e) <- t2ExpTscoped env1 sc e+ (s2,eqs) <- t2Eqs eqs+ return (mergeSubsts [s1,s2], (x,e):eqs)+ where sc = lookup' te x+++-- Note: the program is known to be typeable at this point, thus there is no need to generalize, freshly +-- instantiate, and then match an inferred type against a skolemized version of the expected type scheme +-- (together with checking for escaping skolem variables). Instead, all we need to ensure is that any +-- type equalities implied by the match are captured in the resulting substitution, treating all-quantified +-- variables as scoped constants once we are inside the scope of a type signature (t2ExpTscoped), or using+-- a freshly alpha-converted copy when matching against a polymorphic signature whose bound variables are+-- not in scope (t2ExpT).+-- +-- Moreover, in order to enable subsequent translation into the System F-like type system of Kindle, the+-- type abstraction and application points are encoded in the resulting terms as uniquely shaped let-bindings.++t2ExpTscoped env sc e = do (s1,rh,e) <- t2Exp env e+ s2 <- mgi rh (quickSkolem sc)+ e <- encodeTAbs env (quant sc) e+ return (mergeSubsts [s1,s2], e)+ ++t2ExpT env (Scheme t qs []) e = t2ExpTscoped env (Scheme t qs []) e+t2ExpT env sc e = do sc' <- ac nullSubst sc+ t2ExpTscoped env sc' e+++t2ExpTs env [] [] = return (nullSubst, [])+t2ExpTs env (sc:scs) (e:es) = do (s1,e) <- t2ExpT env sc e+ (s2,es) <- t2ExpTs env scs es + return (mergeSubsts [s1,s2], e:es)+++t2Exps env [] = return (nullSubst, [], [])+t2Exps env (e:es) = do (s1,t,e) <- t2Exp env e+ (s2,ts,es) <- t2Exps env es+ let s = mergeSubsts [s1,s2]+ return (s, subst s (t:ts), e:es)+ ++t2Exp env (ELit l) = return (nullSubst, R (litType l), ELit l)+t2Exp env (EVar x) = do (rh,ts) <- t2Inst (findType env x)+ e <- encodeTApp env ts (EVar x)+ return (nullSubst, rh, e)+t2Exp env (ECon k) = do (rh,ts) <- t2Inst (findType env k)+ e <- encodeTApp env ts (ECon k)+ return (nullSubst, rh, e)+t2Exp env (ESel e l) = do (F (sc:scs) rh,ts) <- t2Inst (findType env l)+ (s,e) <- t2ExpT env sc e+ e' <- encodeTApp env ts (ESel e l) -- NOTE: the *full* instantiation of l is remembered here,+ return (s, subst s (tFun scs rh), e') -- including the actual struct type arguments (C.f.: c2k.cExp)+t2Exp env (ELam te e) = do (s,rh,e) <- t2Exp (addTEnv te env) e+ return (s, F (subst s (rng te)) rh, ELam te e)+t2Exp env (EAp e es) = do (s,rh,e) <- t2Exp env e+ t2Ap env s rh e es+t2Exp env (ELet bs e) = do (s1,bs) <- t2Binds env bs+ (s2,rh,e) <- t2Exp (addTEnv (subst s1 (tsigsOf bs)) env) e+ return (mergeSubsts [s1,s2], rh, ELet bs e)+t2Exp env (ERec c eqs) = do alphas <- mapM newTVar (kArgs (findKind env c))+ (t,scs) <- t2Lhs env (foldl TAp (TId c) alphas) t2Sel ls+ (s,es) <- t2ExpTs env scs es+ e <- encodeTApp env (snd (tFlat t)) (ERec c (ls `zip` es))+ return (s, R (subst s t), e)+ where (ls,es) = unzip eqs+ t2Sel env x l = t2Exp env (ESel (EVar x) l)+t2Exp env (ECase e alts) = do alpha <- newTVar Star+ (TFun [t0] t1,scs) <- t2Lhs env alpha t2Pat ps+ (s0,e) <- t2ExpT env (scheme t0) e+ (s1,es) <- t2ExpTs env scs es+ let s = mergeSubsts [s0,s1]+ return (s, R (subst s t1), ECase e (ps `zip` es))+ where (ps,es) = unzip alts+ t2Pat env x (PLit l) = t2Exp env (EAp (EVar x) [ELit l])+ t2Pat env x (PCon k) = do (rh,_) <- t2Inst (findType env k)+ te <- newEnv paramSym (funArgs rh)+ t2Exp env (eLam te (EAp (EVar x) [eAp (ECon k) (map EVar (dom te))]))+ t2Pat env x (PWild) = do y <- newName tempSym+ t <- newTVar Star+ t2Exp (addTEnv [(y,scheme t)] env) (EAp (EVar x) [EVar y])+t2Exp env (EReq e1 e2) = do alpha <- newTVar Star+ beta <- newTVar Star+ (s1,e1) <- t2ExpT env (scheme (tRef alpha)) e1+ (s2,e2) <- t2ExpT env (scheme (tCmd alpha beta)) e2+ let s = mergeSubsts [s1,s2]+ return (s, R (tRequest (subst s beta)), EReq e1 e2)+t2Exp env (EAct e1 e2) = do alpha <- newTVar Star+ beta <- newTVar Star+ (s1,e1) <- t2ExpT env (scheme (tRef alpha)) e1+ (s2,e2) <- t2ExpT env (scheme (tCmd alpha beta)) e2+ let s = mergeSubsts [s1,s2]+ return (s, R tAction, EAct e1 e2)+t2Exp env (EDo x tx c) = do (s1,t,c) <- t2Cmd (setSelf x tx env) c+ let s2 = case stateT env of Nothing -> nullSubst; Just t' -> unif [(t',tx)]+ s = mergeSubsts [s1,s2]+ return (s, R (subst s (tCmd tx t)), EDo x tx c)+t2Exp env (ETempl x tx te c) = do (s,t,c) <- t2Cmd (setSelf x tx (addTEnv te env)) c+ return (s, R (tClass t), ETempl x tx te c)++ +t2Cmd env (CRet e) = do alpha <- newTVar Star+ (s,e) <- t2ExpT env (scheme alpha) e+ return (s, subst s alpha, CRet e)+t2Cmd env (CExp e) = do alpha <- newTVar Star+ (s,e) <- t2ExpT env (scheme (tCmd (fromJust (stateT env)) alpha)) e+ return (s, subst s alpha, CExp e)+t2Cmd env (CGen x tx e c) = do (s1,e) <- t2ExpT env (scheme (tCmd (fromJust (stateT env)) tx)) e+ (s2,t,c) <- t2Cmd (addTEnv [(x,scheme tx)] env) c+ let s = mergeSubsts [s1,s2]+ return (s, subst s t, CGen x tx e c)+t2Cmd env (CAss x e c) = do (s1,e) <- t2ExpT env (findType env x) e+ (s2,t,c) <- t2Cmd env c+ let s = mergeSubsts [s1,s2]+ return (s, subst s t, CAss x e c)+t2Cmd env (CLet bs c) = do (s1,bs) <- t2Binds env bs+ (s2,t,c) <- t2Cmd (addTEnv (tsigsOf bs) env) c+ let s = mergeSubsts [s1,s2]+ return (s, subst s t, CLet bs c)++ ++t2Ap env s1 (F scs rh) e es = do (s2,es) <- t2ExpTs env scs es+ let s = mergeSubsts [s1,s2]+ return (s, subst s rh, EAp e es)+t2Ap env s1 rh e es = do (s2,rhs,es) <- t2Exps env es+ t <- newTVar Star+ s3 <- mgi rh (F (map scheme' rhs) (R t))+ let s = mergeSubsts [s1,s2,s3]+ return (s, R (subst s t), EAp e es)+++t2Lhs env alpha t2X xs = do x <- newName tempSym+ let env' = addTEnv [(x,scheme alpha)] env+ (ss,rhs,_) <- fmap unzip3 (mapM (t2X env' x) xs)+ let s = mergeSubsts ss+ scs <- mapM (t2Gen (tevars (subst s env')) . scheme') (subst s rhs)+ return (subst s alpha, scs)+++t2Gen tvs0 (Scheme rh ps ke) = do ids <- newNames tyvarSym (length tvs)+ let s = tvs `zip` map TId ids+ return (Scheme (subst s rh) ps (ke ++ ids `zip` map tvKind tvs))+ where tvs = nub (filter (`notElem` tvs0) (tvars rh))+ ++t2Inst (Scheme rh ps ke) = do ts <- mapM newTVar ks+ return (subst (vs `zip` ts) (tFun ps rh), ts)+ where (vs,ks) = unzip ke++++-- Skolemize a type scheme, relying on the uniqueness of all bound type variables+quickSkolem (Scheme rh ps ke) = tFun ps rh+++mgi (R t) (R u) = return (unif [(t,u)])+mgi (F ts t) (F us u) = do s <- mgi t u+ ss <- mapM mgiSc (us `zip` ts)+ return (mergeSubsts (s:ss))+mgi (R (TFun ts t)) rh = mgi (F (map scheme ts) (R t)) rh+mgi rh (R (TFun us u)) = mgi rh (F (map scheme us) (R u))+mgi (R t) (F us u) = do (t':ts) <- mapM newTVar (replicate (length us + 1) Star)+ let s1 = unif [(t,TFun ts t')]+ s2 <- mgi (R (subst s1 t)) (F us u)+ return (s2@@s1)+mgi (F ts t) (R u) = do (u':us) <- mapM newTVar (replicate (length ts + 1) Star)+ let s1 = unif [(u,TFun us u')]+ s2 <- mgi (F ts t) (R (subst s1 u))+ return (s2@@s1)+++mgiSc (Scheme rh [] [], Scheme rh' [] [])+ = mgi rh rh'+mgiSc (sc, sc') = do (rh,_) <- t2Inst sc+ mgi rh (quickSkolem sc')+++unif [] = nullSubst+unif ((TVar n,t):eqs)+ | t == TVar n = unif eqs+ | otherwise = let s = n +-> t; s' = unif (subst s eqs) in s' @@ s+unif ((t,TVar n):eqs) = let s = n +-> t; s' = unif (subst s eqs) in s' @@ s+unif ((TAp t u, TAp t' u'):eqs) = unif ((t,t'):(u,u'):eqs)+unif ((TId c, TId c'):eqs)+ | c == c' = unif eqs+unif ((TFun ts t, TFun us u):eqs)+ | length ts == length us = unif ((t,u) : (ts `zip` us) ++ eqs)+unif eqs = internalError0 ("Type2.unif " ++ show eqs)+++mergeSubsts ss = unif (mapFst TVar (concat ss))
+ timberc.cabal view
@@ -0,0 +1,97 @@+Name: timberc+Version: 1.0.1+Synopsis: The Timber Compiler.+Description: This is a compiler for a strict and pure functional + language+License: BSD3+License-file: LICENSE+Author: Johan Nordlander+Maintainer: Johan Nordlander <nordland@csee.ltu.se>+Homepage: http://www.timber-lang.org+Build-type: Simple+Cabal-Version: >= 1.4+extra-tmp-files: config.log config.status +data-files: examples/Counter.t,+ examples/Echo.t,+ examples/Echo2.t,+ examples/Echo3.t,+ examples/EchoServer.t,+ examples/EchoServer2.t,+ examples/MasterMind.t,+ examples/PingTimeServers.t,+ examples/Primes.t,+ examples/Reflex.t,+ examples/TCPClient.t,+ examples/UnionFind.t,+ examples/Makefile,+ include/arrays.c,+ include/float.c,+ include/timber.c,+ include/timber.h,+ lib/BitOps.t,+ lib/Data.Functional.List.t,+ lib/Data.Objects.Dictionary.t,+ lib/Data.Objects.Stack.t, + lib/POSIX.t,+ lib/Prelude.t,+ lib/RandomGenerator.t++extra-source-files: rtsPOSIX/Makefile.in,+ rtsPOSIX/configure,+ rtsPOSIX/config.guess,+ rtsPOSIX/config.sub,+ rtsPOSIX/config.h.in,+ rtsPOSIX/cyclic.c,+ rtsPOSIX/env.c,+ rtsPOSIX/env.h,+ rtsPOSIX/gc.c,+ rtsPOSIX/install-sh,+ rtsPOSIX/main.c,+ rtsPOSIX/rts.c,+ rtsPOSIX/rts.h,+ rtsPOSIX/timberc.cfg.in,+ rtsPOSIX/timer.c,+ timberc.spec+++Executable timberc+ Main-is: Main.hs+ Build-Depends: base >= 4, haskell98, pretty >= 1.0.0.0, binary >= 0.4.2, + mtl >= 1.1, filepath >= 1.1, array >= 0.1,+ bzlib >= 0.4.0.0, bytestring >= 0.9+ build-tools: happy >= 1.18+ hs-source-dirs: src+ other-modules: Common,+ Config,+ Core,+ Core2Kindle,+ Decls,+ Depend,+ Derive,+ Desugar1,+ Desugar2,+ Env,+ Execution,+ Fixity,+ Interfaces,+ Kind,+ Kindle,+ Kindle2C,+ Kindlered,+ Lambdalift,+ Lexer,+ Match,+ Name,+ ParseMonad,+ Parser,+ PP,+ Prepare4C,+ Reduce,+ Rename,+ Syntax,+ Syntax2Core,+ Termred,+ Token,+ Type,+ Type2+
+ timberc.spec view
@@ -0,0 +1,83 @@+# RPM spec file for timberc -*-rpm-spec-*-+#+# This file is subject to the same free software license as timberc.+#+# Copyright 2008, Peter A. Jonsson+#+# This file was derived from ghc.spec.in++%define name timberc+%define version 1.0.1+%define release 1++Name: %{name}+Version: %{version}+Release: %{release}+License: BSD-like+Group: Development/Languages/Timber+URL: http://timber-lang.org+Source0: http://timber-lang.org/dist/timberc-%{version}.tar.gz+Packager: Peter A. Jonsson <pj@csee.ltu.se>+BuildRoot: %{_tmppath}/%{name}-%{version}-build+BuildRequires: happy >= 1.18, ghc >= 6.10.1 +Provides: timber+Summary: The Timber Compiler++%description++%prep+%setup -b0++%build++runhaskell Setup configure --prefix=%{_prefix}+runhaskell Setup build++%install++runhaskell Setup copy --destdir=%{_tmppath}/%{name}-%{version}-build+mv %{_tmppath}/%{name}-%{version}-build/%{_bindir}/timberc %{_tmppath}/%{name}-%{version}-build/%{_datadir}/timberc-%{version}/timberc+++# Ugly hack: construct a temporary bin/timberc by hand to build the RTS.+SCRIPT="%{_bindir}/timberc"+SCRIPT_TMP="%{_tmppath}/%{name}-%{version}-build/$SCRIPT"+DATADIR="%{_datadir}/timberc-%{version}"+DATADIR_TMP="%{_tmppath}/%{name}-%{version}-build/$DATADIR"++echo "#!/bin/sh" > $SCRIPT_TMP+echo " " >> $SCRIPT_TMP+echo "exec $DATADIR_TMP/timberc \${1+\"\$@\"} --datadir $DATADIR_TMP" >> $SCRIPT_TMP+chmod 755 $SCRIPT_TMP++cd rtsPOSIX+sh ./configure --prefix=$DATADIR --with-timberc=$SCRIPT_TMP+make DESTDIR=%{_tmppath}/%{name}-%{version}-build install+cd ..++# We're done with the temporary thing. Now make a real one.+rm $SCRIPT_TMP+echo "#!/bin/sh" > $SCRIPT_TMP+echo " " >> $SCRIPT_TMP+echo "exec $DATADIR/timberc \${1+\"\$@\"} --datadir $DATADIR" >> $SCRIPT_TMP+chmod 755 $SCRIPT_TMP++%clean+rm -rf ${RPM_BUILD_ROOT}++%post+# We should perhaps register as a Haskell package.++%preun+# If we register in post we should unregister here.++%files +%defattr(-,root,root)+%doc %{_prefix}/share/doc/timberc-%{version}/*+%{_prefix}/bin/timberc+%{_prefix}/share/timberc-%{version}/timberc+%{_prefix}/share/timberc-%{version}/rtsPOSIX/*+%{_prefix}/share/timberc-%{version}/examples/*+%{_prefix}/share/timberc-%{version}/include/*+%{_prefix}/share/timberc-%{version}/lib/*+