alpha 1.0.9 → 1.0.10
raw patch · 4 files changed
+51/−53 lines, 4 files
Files
- alpha.cabal +1/−1
- src/Alpha.hs +35/−26
- src/Context/Language.hs +14/−10
- src/My/Prelude.hs +1/−16
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 1.0.9+version: 1.0.10 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time
src/Alpha.hs view
@@ -85,6 +85,9 @@ writeFormat (outputFmt ?settings) entryName contents compileLanguage force name = do let langFile = languageFile name+ newerThan f1 f2 = liftM2 (>=) (modTime f1) (modTime f2)+ where modTime f = modificationTime $< getFileStatus f+ source <- findSource name skip <- return (not force) <&&> fileExist langFile <&&> maybe (return True) (langFile `newerThan`) source l <- if skip then either (\e -> error $ "Error reading language file "++langFile++": "++e)@@ -154,7 +157,8 @@ ("alpha/list" , Right $ exportAlpha callStub0 alpha_printList), ("alpha/lang" , Right $ exportAlpha callStub0 alpha_printLang), ("alpha/print-OK" , Right $ exportAlpha callStub0 alpha_printOK), - ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum)+ ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum),+ ("alpha/print-expr" , Right $ exportAlpha callStub1 alpha_printExpr) ] #define str(x) #x@@ -182,7 +186,12 @@ syms <- getting (language_ >>> syms_) putStrLn $ intercalate " " (map fst $ BM.toList syms) ALPHA_EXPORT(printLang,IO()) = getting language_ >>= print-+ALPHA_EXPORT(printExpr,Ptr() -> IO()) = readTree >=> transform >=> print+ where transform t = do+ smap <- getting (language_ >>> syms_)+ let symName s = fromMaybe (show s) $ BM.lookupR s smap+ return (fmap (Str . symName) t)+ ALPHA_EXPORT(import,ID -> IO()) sym = withSettings $ do name <- getting (language_ >>> f_ (lookupSymName sym)) void $ case name of@@ -259,27 +268,27 @@ root <- allocTree tree new <- unsafeUseAsCString initStub $ \stub -> mkFunTransform (castPtrToFunPtr stub) fun root readTree new- intS = sizeOf (undefined::Int) ; ptrS = sizeOf (undefined::Ptr())- pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e)- pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e)- allocTree (Group g) = do- p <- mallocBytes (intS+intS+(length g*ptrS))- p' <- pok (0::Int) p- p'' <- pok (length g) p'- mapM allocTree g >>= \l -> pokeArray (castPtr p'') l- return p- allocTree (Symbol (ID s)) = do- p <- mallocBytes (intS+intS)- p' <- pok (1::Int) p- pok s p'- return p- readTree p = do- (t,p') <- pik p- case t :: Int of- 0 -> do- (s,p'') <- pik p'- l <- peekArray s p''- liftM Group $ mapM readTree l- 1 -> do- liftM (Symbol . ID) $ peek p'- +intSize = sizeOf (undefined::Int) ; ptrSize = sizeOf (undefined::Ptr())+pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e)+pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e)+allocTree (Group g) = do+ p <- mallocBytes (intSize+intSize+(length g*ptrSize))+ p' <- pok (0::Int) p+ p'' <- pok (length g) p'+ mapM allocTree g >>= \l -> pokeArray (castPtr p'') l+ return p+allocTree (Symbol (ID s)) = do+ p <- mallocBytes (intSize+intSize)+ p' <- pok (1::Int) p+ pok s p'+ return p+readTree p = do+ (t,p') <- pik p+ case t :: Int of+ 0 -> do+ (s,p'') <- pik p'+ l <- peekArray s p''+ liftM Group $ mapM readTree l+ 1 -> do+ liftM (Symbol . ID) $ peek p'+
src/Context/Language.hs view
@@ -29,7 +29,7 @@ showTable "Values" (\(i,v) -> [show i++" -> "++show v]) $ M.toList (valuesL e), ["Exports: "++show (exportsL e)]] -translateFromTo l' l = \s' -> fromMaybe (tr s') $ M.lookup (tr s') (aliasesL l)+translateFromSub l' l = \s' -> fromMaybe (tr s') $ M.lookup (tr s') (aliasesL l) where tr s' = fromMaybe (s' + mi) $ do m <- lookupSymMod s' l' Range (r,_) <- BM.lookup m (languagesL l)@@ -50,18 +50,22 @@ languagesL = BM.insert (nameL l') (Range (mi,nmi)) (languagesL l) } modify $ \l -> let newVals = M.mapKeys tr $ M.map (translate tr) $ valuesL l'- tr = translateFromTo l' l+ tr = translateFromSub l' l in l { valuesL = M.unionWith (\_ a -> a) (valuesL l) newVals, exportsL = exportsL l S.\\ M.keysSet newVals } createSym l@(Language { maxIDL = m }) = (m,l { maxIDL = succ m })-setSymVal sym v l = l { valuesL = M.insert sym v (valuesL l) }+ lookupSymName sym l = BM.lookupR sym (symbolsL l)-lookupSymVal sym l = fromMaybe NoValue $ M.lookup sym (valuesL l) -lookupSymMod sym l = BM.lookupR (singleRange sym) (languagesL l) +lookupSymVal sym l = fromMaybe NoValue $ M.lookup sym (valuesL l) +lookupSymMod sym l = BM.lookupR (singleRange sym) (languagesL l) + addExport sym l = l { exportsL = S.insert sym (exportsL l) }-getImports l = map fst $ BM.toList $ languagesL l++getImports l = map fst $ BM.toList $ languagesL l isImport im l = BM.member im (languagesL l)++setSymVal sym v l = l { valuesL = M.insert sym v (valuesL l) } exportSymVal sym v = setSymVal sym v . addExport sym internSym s l = runState (st $ BM.lookup s (symbolsL l)) l @@ -80,7 +84,7 @@ merge imp = gets language >>= \l -> ifThenElse (imp`isImport`l) (return False) $ do (contents,(comp,recomp)) <- tryCompile False imp (l',init) <- if not comp && recomp then fst $< tryCompile True imp else return contents- init' <- viewing language_ $ modify (<>l') >> gets (\l -> translate (translateFromTo l' l) init)+ init' <- viewing language_ $ modify (<>l') >> gets (\l -> translate (translateFromSub l' l) init) loadImport init' return $ comp || recomp tryCompile force imp = do@@ -90,10 +94,10 @@ set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined)) purgeLanguage l = mempty {- maxIDL = maxIDL l,- symbolsL = BM.filter exportNameP (symbolsL l),+ maxIDL = maxIDL l,+ symbolsL = BM.filter exportNameP (symbolsL l), languagesL = languagesL l,- valuesL = vals'+ valuesL = vals' } where Language { exportsL = ex, equivsL = eqs } = l vals' = M.map (translate $ mapTranslate eqs) $ M.intersection (valuesL l) (set2Map ex)
src/My/Prelude.hs view
@@ -1,19 +1,14 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module My.Prelude where -import System.Posix.Files-import Data.Maybe import Debug.Trace as Tr-import My.Control.Monad import qualified Data.ByteString as B-import Data.List import Data.Char import Data.Word-import Data.Array+import Data.List debugMess mess x = Tr.trace (mess++show x) x debug x = traceShow x x-debugM = liftM debug trace = Tr.trace maybeToEither = maybe (Left undefined) Right@@ -22,17 +17,7 @@ ifThenElse b th el = if b then th else el swap (a,b) = (b,a)-thd (_,_,a) = a -lazyPair ~(a,b) = (a,b)--newerThan f1 f2 = liftM2 (>) (modTime f1) (modTime f2)- where modTime f = modificationTime $< getFileStatus f- showHex n = reverse $ map (intToDigit . fromIntegral . (`mod`16)) $ take 2 $ iterate (`div`16) (n :: Word8) showCode code = intercalate " " $ map showHex $ B.unpack $ code--a !# i | bounds a`inRange`i = a!i- | otherwise = error $ "undefined index "++show i++" in array "-