packages feed

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 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, &param);+    DISABLE(rts);+    while (1) {+        pthread_cond_wait(&current->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, &param);+        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, &param);+    // 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(&current->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, &param);++//    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(&current_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/*+