summaryrefslogtreecommitdiff
path: root/devel/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'devel/compiler')
-rw-r--r--devel/compiler/Compile.hs36
-rw-r--r--devel/compiler/Env.hs56
-rw-r--r--devel/compiler/Eval.hs57
-rw-r--r--devel/compiler/Match.hs21
-rw-r--r--devel/compiler/Param.hs27
-rw-r--r--devel/compiler/PrEnv.hs48
-rw-r--r--devel/compiler/SMacros.hs16
-rw-r--r--devel/compiler/STM.hs94
-rw-r--r--devel/compiler/Src.cf68
-rw-r--r--devel/compiler/TMacros.hs20
-rw-r--r--devel/compiler/Tgt.cf18
-rw-r--r--devel/compiler/Top.hs34
-rw-r--r--devel/compiler/ex.src45
13 files changed, 0 insertions, 540 deletions
diff --git a/devel/compiler/Compile.hs b/devel/compiler/Compile.hs
deleted file mode 100644
index f21fca632..000000000
--- a/devel/compiler/Compile.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Compile where
-
-import AbsSrc
-import AbsTgt
-import SMacros
-import TMacros
-
-import Eval
-import Param
-
-import STM
-import Env
-
-import qualified Data.Map as M
-
-compile :: Grammar -> Env
-compile (Gr defs) = err error snd $ appSTM (mapM_ compDef defs) emptyEnv
-
-compDef :: Def -> STM Env ()
-compDef d = case d of
- DLin f ty exp -> do
- val <- eval exp
- addType f ty
- addVal f val
- DOper f ty exp -> do
- addType f ty
- addOper f exp
- DPar p cs -> do
- v <- sizeParType cs
- let ty = TBas p
- addParsize ty $ fst v
- vals <- allParVals cs
- addPartype ty vals
- mapM_ (uncurry addParVal) (zip vals (map VPar [0..]))
- DOpty a ty -> do
- addTypedef a ty
diff --git a/devel/compiler/Env.hs b/devel/compiler/Env.hs
deleted file mode 100644
index 7e1d23983..000000000
--- a/devel/compiler/Env.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module Env where
-
-import AbsSrc
-import AbsTgt
-
-import STM
-import qualified Data.Map as M
-
-data Env = Env {
- values :: M.Map Ident Val,
- types :: M.Map Ident Type,
- opers :: M.Map Ident Exp,
- typedefs :: M.Map Ident Type,
- parsizes :: M.Map Type Int,
- partypes :: M.Map Type [Exp],
- parvals :: M.Map Exp Val,
- vars :: M.Map Ident Val
---- constrs :: M.Map Ident ([Int] -> Int)
- }
-
-emptyEnv = Env M.empty M.empty M.empty M.empty M.empty M.empty M.empty M.empty
-
-lookEnv :: (Show i, Ord i) => (Env -> M.Map i a) -> i -> STM Env a
-lookEnv field c = do
- s <- readSTM
- maybe (raise $ "unknown " ++ show c) return $ M.lookup c $ field s
-
-addVal :: Ident -> Val -> STM Env ()
-addVal c v = updateSTM (\env -> (env{values = M.insert c v (values env)}))
-
-addType :: Ident -> Type -> STM Env ()
-addType c v = updateSTM (\env -> (env{types = M.insert c v (types env)}))
-
-addOper :: Ident -> Exp -> STM Env ()
-addOper c v = updateSTM (\env -> (env{opers = M.insert c v (opers env)}))
-
-addTypedef :: Ident -> Type -> STM Env ()
-addTypedef c v = updateSTM (\env -> (env{typedefs = M.insert c v (typedefs env)}))
-
-addParsize :: Type -> Int -> STM Env ()
-addParsize c v = updateSTM (\env -> (env{parsizes = M.insert c v (parsizes env)}))
-
-addPartype :: Type -> [Exp] -> STM Env ()
-addPartype c v = updateSTM (\env -> (env{partypes = M.insert c v (partypes env)}))
-
-addParVal :: Exp -> Val -> STM Env ()
-addParVal c v = updateSTM (\env -> (env{parvals = M.insert c v (parvals env)}))
-
----addEnv :: (Env -> M.Map Ident a) -> Ident -> a -> STM Env ()
----addEnv field c v = updateSTM (\env -> (env{field = M.insert c v (field env)},()))
-
-addVar :: Ident -> STM Env ()
-addVar x = do
- s <- readSTM
- let i = M.size $ vars s
- updateSTM (\env -> (env{vars = M.insert x (VArg $ toInteger i) (vars env)}))
diff --git a/devel/compiler/Eval.hs b/devel/compiler/Eval.hs
deleted file mode 100644
index f0c4f1303..000000000
--- a/devel/compiler/Eval.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-module Eval where
-
-import AbsSrc
-import AbsTgt
-import SMacros
-import TMacros
-import Match
-import Env
-
-import STM
-
-
-eval :: Exp -> STM Env Val
-eval e = case e of
- EAbs x b -> do
- addVar x ---- adds new VArg i
- eval b
- EApp _ _ -> do
- let (f,xs) = apps e
- xs' <- mapM eval xs
- case f of
- ECon c -> do
- v <- lookEnv values c
- return $ appVal v xs'
- EOpr c -> do
- e <- lookEnv opers c
- v <- eval e ---- not possible in general
- return $ appVal v xs'
- ECon c -> lookEnv values c
- EOpr c -> lookEnv opers c >>= eval ---- not possible in general
- EVar x -> lookEnv vars x
- ECst _ _ -> lookEnv parvals e
- EStr s -> return $ VTok s
- ECat x y -> do
- x' <- eval x
- y' <- eval y
- return $ VCat x' y'
- ERec fs -> do
- vs <- mapM eval [e | FExp _ e <- fs]
- return $ VRec vs
-
- ETab ty cs -> do
--- sz <- lookEnv parsizes ty
--- let ps = map (VPar . toInteger) [0..sz-1]
- ps <- lookEnv partypes ty
- vs <- mapM (\p -> match cs p >>= eval) ps
- return $ VRec vs
-
- ESel t v -> do
- t' <- eval t
- v' <- eval v
- ---- pattern match first
- return $ compVal [] $ VPro t' v' ---- []
-
- EPro t v@(Lab _ i) -> do
- t' <- eval t
- return $ compVal [] $ VPro t' (VPar i)
diff --git a/devel/compiler/Match.hs b/devel/compiler/Match.hs
deleted file mode 100644
index a9ac839ef..000000000
--- a/devel/compiler/Match.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Match where
-
-import AbsSrc
-import AbsTgt
-
-import Env
-import STM
-
-match :: [Case] -> Exp -> STM Env Exp
-match cs v = checks $ map (tryMatch v) cs
-
----- return substitution
-tryMatch :: Exp -> Case -> STM Env Exp
-tryMatch e (Cas p v) = if fit (e, p) then return v else raise "no fit" where
- fit (exp,patt) = case (exp,patt) of
- (ECst c es, PCon d ps) ->
- c == d &&
- length es == length ps &&
- all fit (zip es ps)
- (_,PVar _) -> True ---- not is exp contains variables
-
diff --git a/devel/compiler/Param.hs b/devel/compiler/Param.hs
deleted file mode 100644
index 5137faa7b..000000000
--- a/devel/compiler/Param.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Param where
-
-import AbsSrc
-import SMacros
-
-import Env
-import STM
-
-sizeParType :: [Constr] -> STM Env (Int,Int)
-sizeParType cs = do
- scs <- mapM sizeC cs
- return (sum scs, length cs)
- where
- sizeC (Con c ts) = do
- ats <- mapM (lookEnv parsizes) ts
- return $ product ats
-
-allParVals :: [Constr] -> STM Env [Exp]
-allParVals cs = do
- ess <- mapM alls cs
- return $ concat ess
- where
- alls (Con c []) = do
- return [constr c []]
- alls (Con c ts) = do
- ess <- mapM (lookEnv partypes) ts
- return [constr c es | es <- sequence ess]
diff --git a/devel/compiler/PrEnv.hs b/devel/compiler/PrEnv.hs
deleted file mode 100644
index 910626a42..000000000
--- a/devel/compiler/PrEnv.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module PrEnv where
-
-import Env
-
-import AbsSrc
-import AbsTgt
-
-import qualified PrintSrc as S
-import qualified PrintTgt as T
-
-import qualified Data.Map as M
-
-prEnv :: Env -> IO ()
-prEnv env = do
- putStrLn "--# types"
- mapM_ putStrLn
- [prs c ++ " : " ++ prs val | (c,val) <- M.toList $ types env]
- putStrLn "--# typedefs"
- mapM_ putStrLn
- [prs c ++ " = " ++ prs val | (c,val) <- M.toList $ typedefs env]
- putStrLn "--# partypes"
- mapM_ putStrLn
- [prs c ++ " = " ++ unwords (map prs val) | (c,val) <- M.toList $ partypes env]
- putStrLn "--# parvals"
- mapM_ putStrLn
- [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ parvals env]
- putStrLn "--# values"
- mapM_ putStrLn
- [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ values env]
-
-
-prs :: (S.Print a) => a -> String
-prs = S.printTree
-
-prt :: (T.Print a) => a -> String
-prt = T.printTree
-
-{-
-data Env = Env {
- values :: M.Map Ident Val,
- types :: M.Map Ident Type,
- opers :: M.Map Ident Exp,
- typedefs :: M.Map Ident Type,
- partypes :: M.Map Type [Exp],
- parvals :: M.Map Exp Val,
- vars :: M.Map Ident Val
- }
--}
diff --git a/devel/compiler/SMacros.hs b/devel/compiler/SMacros.hs
deleted file mode 100644
index 46d778234..000000000
--- a/devel/compiler/SMacros.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module SMacros where
-
-import AbsSrc
-
-apps :: Exp -> (Exp,[Exp])
-apps e = (f,reverse xs) where
- (f,xs) = aps e
- aps e = case e of
- EApp f x -> let (f',xs) = aps f in (f',x:xs)
- _ -> (e,[])
-
-constr :: Ident -> [Exp] -> Exp
-constr = ECst
-
-mkApp :: Exp -> [Exp] -> Exp
-mkApp f = foldl EApp f
diff --git a/devel/compiler/STM.hs b/devel/compiler/STM.hs
deleted file mode 100644
index c3eb38877..000000000
--- a/devel/compiler/STM.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-module STM where
-
-import Control.Monad
-
--- state monad
-
-
--- the Error monad
-
--- | like @Maybe@ type with error msgs
-data Err a = Ok a | Bad String
- deriving (Read, Show, Eq)
-
-instance Monad Err where
- return = Ok
- fail = Bad
- Ok a >>= f = f a
- Bad s >>= f = Bad s
-
--- | analogue of @maybe@
-err :: (String -> b) -> (a -> b) -> Err a -> b
-err d f e = case e of
- Ok a -> f a
- Bad s -> d s
-
--- state monad with error; from Agda 6/11/2001
-
-newtype STM s a = STM (s -> Err (a,s))
-
-appSTM :: STM s a -> s -> Err (a,s)
-appSTM (STM f) s = f s
-
-stm :: (s -> Err (a,s)) -> STM s a
-stm = STM
-
-stmr :: (s -> (a,s)) -> STM s a
-stmr f = stm (\s -> return (f s))
-
-instance Monad (STM s) where
- return a = STM (\s -> return (a,s))
- STM c >>= f = STM (\s -> do
- (x,s') <- c s
- let STM f' = f x
- f' s')
-
-readSTM :: STM s s
-readSTM = stmr (\s -> (s,s))
-
-updateSTM :: (s -> s) -> STM s ()
-updateSTM f = stmr (\s -> ((),f s))
-
-writeSTM :: s -> STM s ()
-writeSTM s = stmr (const ((),s))
-
-done :: Monad m => m ()
-done = return ()
-
-class Monad m => ErrorMonad m where
- raise :: String -> m a
- handle :: m a -> (String -> m a) -> m a
- handle_ :: m a -> m a -> m a
- handle_ a b = a `handle` (\_ -> b)
-
-instance ErrorMonad Err where
- raise = Bad
- handle a@(Ok _) _ = a
- handle (Bad i) f = f i
-
-instance ErrorMonad (STM s) where
- raise msg = STM (\s -> raise msg)
- handle (STM f) g = STM (\s -> (f s)
- `handle` (\e -> let STM g' = (g e) in
- g' s))
-
--- | if the first check fails try another one
-checkAgain :: ErrorMonad m => m a -> m a -> m a
-checkAgain c1 c2 = handle_ c1 c2
-
-checks :: ErrorMonad m => [m a] -> m a
-checks [] = raise "no chance to pass"
-checks cs = foldr1 checkAgain cs
-
-allChecks :: ErrorMonad m => [m a] -> m [a]
-allChecks ms = case ms of
- (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
- _ -> return []
-
-doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
-doUntil cond ms = case ms of
- a:as -> do
- v <- a
- if cond v then return v else doUntil cond as
- _ -> raise "no result"
-
diff --git a/devel/compiler/Src.cf b/devel/compiler/Src.cf
deleted file mode 100644
index 5a49b2341..000000000
--- a/devel/compiler/Src.cf
+++ /dev/null
@@ -1,68 +0,0 @@
-Gr. Grammar ::= [Def] ;
-
-DPar. Def ::= "param" Ident "=" [Constr] ;
-DOper. Def ::= "oper" Ident ":" Type "=" Exp ;
-DOpty. Def ::= "oper" Ident "=" Type ;
-DLin. Def ::= "lin" Ident ":" Type "=" Exp ;
-
-terminator Def ";" ;
-
-Con. Constr ::= Ident [Type] ;
-
-separator nonempty Constr "|" ;
-
-TBas. Type1 ::= Ident ;
-TVal. Type1 ::= "Ints" Integer ;
-TRec. Type1 ::= "{" [Typing] "}" ;
-TFun. Type ::= Type1 "->" Type ;
-
-coercions Type 1 ;
-
-terminator Type "" ;
-
-FTyp. Typing ::= Label ":" Type ;
-
-separator Typing ";" ;
-
-Lab. Label ::= Ident "#" Integer ;
-
-EVar. Exp2 ::= "$" Ident ;
-EOpr. Exp2 ::= "&" Ident ;
-ECon. Exp2 ::= Ident ;
-EVal. Exp2 ::= Integer ;
-EStr. Exp2 ::= String ;
-ECst. Exp2 ::= "(" Ident "@" [Exp] ")" ;
-ERec. Exp2 ::= "{" [Assign] "}" ;
-EApp. Exp1 ::= Exp1 Exp2 ;
-ESel. Exp1 ::= Exp1 "!" Exp2 ;
-EPro. Exp1 ::= Exp1 "." Label ;
-ETab. Exp1 ::= "table" Type "{" [Case] "}" ;
-ECat. Exp ::= Exp "++" Exp1 ;
-EAbs. Exp ::= "\\" Ident "->" Exp ;
-
-coercions Exp 2 ;
-
-separator Exp "," ;
-
-FExp. Assign ::= Label "=" Exp ;
-
-separator Assign ";" ;
-
-Cas. Case ::= Patt "=>" Exp ;
-
-separator Case ";" ;
-
-PVal. Patt ::= Integer ;
-PVar. Patt ::= "$" Ident ;
-PRec. Patt ::= "{" [AssPatt] "}" ;
-PCon. Patt ::= "(" Ident [Patt] ")" ;
-
-terminator Patt "" ;
-
-FPatt. AssPatt ::= Label "=" Patt ;
-
-separator AssPatt ";" ;
-
-comment "--" ;
-comment "{-" "-}" ;
-
diff --git a/devel/compiler/TMacros.hs b/devel/compiler/TMacros.hs
deleted file mode 100644
index f06c34d6d..000000000
--- a/devel/compiler/TMacros.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module TMacros where
-
-import AbsTgt
-
-appVal :: Val -> [Val] -> Val
-appVal v vs = compVal vs v
-
-compVal :: [Val] -> Val -> Val
-compVal args = comp where
- comp val = case val of
- VRec vs -> VRec $ map comp vs
- VPro r p -> case (comp r, comp p) of
- (VRec vs, VPar i) -> vs !! fromInteger i
- (r',p') -> VPro r' p' ---- not at runtime
- VArg j
- | i < length args -> args !! i ---- not needed at runtime
- | otherwise -> val ---- not the right thing at compiletime either
- where i = fromInteger j
- VCat x y -> VCat (comp x) (comp y)
- _ -> val
diff --git a/devel/compiler/Tgt.cf b/devel/compiler/Tgt.cf
deleted file mode 100644
index f44184a52..000000000
--- a/devel/compiler/Tgt.cf
+++ /dev/null
@@ -1,18 +0,0 @@
---- target language
-
-Tg. Object ::= [Fun] ;
-
-FVal. Fun ::= Id "=" Val ;
-
-terminator Fun ";" ;
-
-VRec. Val ::= "[" [Val] "]" ;
-VPro. Val ::= "(" Val "." Val ")" ;
-VTok. Val ::= String ;
-VArg. Val ::= "$" Integer ;
-VPar. Val ::= Integer ;
-VCat. Val ::= "(" Val Val ")" ;
-
-terminator Val "," ;
-
-token Id (letter | '_') (letter | digit | '_' | '\'')* ;
diff --git a/devel/compiler/Top.hs b/devel/compiler/Top.hs
deleted file mode 100644
index 64a8a6f70..000000000
--- a/devel/compiler/Top.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module Main where
-
-import IO ( stdin, hGetContents )
-import System ( getArgs, getProgName )
-
-import LexSrc
-import ParSrc
-import SkelSrc
-import PrintSrc
-import AbsSrc
-
-import Compile
-import PrEnv
-
-import ErrM
-
-type ParseFun a = [Token] -> Err a
-
-myLLexer = myLexer
-
-runFile :: ParseFun Grammar -> FilePath -> IO ()
-runFile p f = readFile f >>= run p
-
-run :: ParseFun Grammar -> String -> IO ()
-run p s = let ts = myLLexer s in case p ts of
- Bad s -> do putStrLn "Parse Failed...\n"
- putStrLn s
- Ok tree -> prEnv $ compile tree
-
-main :: IO ()
-main = do args <- getArgs
- case args of
- fs -> mapM_ (runFile pGrammar) fs
-
diff --git a/devel/compiler/ex.src b/devel/compiler/ex.src
deleted file mode 100644
index 241fd96b4..000000000
--- a/devel/compiler/ex.src
+++ /dev/null
@@ -1,45 +0,0 @@
-param Num = Sg | Pl ;
-param Gen = Masc | Fem ;
-
-param AG = A Num Gen ;
-
-oper Agr = {g#0 : Gen ; n#1 : Num} ;
-
-oper CN = {s#1 : Num -> Str ; g#0 : Gen} ;
-oper NP = {s#1 : Str ; a#0 : Agr} ;
-
-oper artDef : Gen -> Str = \g -> table Gen {
- (Masc) => "le" ;
- (Fem) => "la"
-} ! $g ;
-
-lin Voiture : CN = {
- s#1 = table Num {
- (Sg) => "voiture" ;
- (Pl) => "voitures"
- } ;
- g#0 = (Fem@)
-} ;
-
-
-lin Bus : CN = {
- s#1 = table Num {$x => "bus"} ;
- g#0 = (Masc@)
-} ;
-
-lin Indef : CN -> NP = \cn -> {
- s#1 = table Gen {
- (Masc) => "un" ;
- $x => "une"
- } ! $cn.g#0 ++ $cn.s#1 ! (Sg@) ;
- a#0 = {g#0 = $cn.g#0 ; n#1 = (Sg@)}
-} ;
-
-
-lin Def : CN -> NP = \cn -> {
- s#1 = &artDef $cn.g#0 ++ $cn.s#1 ! (Sg@) ;
- a#0 = {g#0 = $cn.g#0 ; n#1 = (Sg@)}
-} ;
-
-lin UneVoiture : NP = Indef Voiture ;
-lin LaVoiture : NP = Def Voiture ;
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:37:41 +0000