msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

-val optimization

Browse Source
This commit is contained in:
aarne
2005-01-11 15:06:12 +00:00
parent bb3d2e1d42
commit 87b55df10f
32 changed files with 825 additions and 581 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/GF/Source/AbsGF.hs
View File

@@ -167,6 +167,7 @@ data Exp =
| EQCons Ident Ident
| EApp Exp Exp
| ETable [Case]
| EVTable Exp [Exp]
| ETTable Exp [Case]
| ECase Exp [Case]
| EVariants [Exp]

1
src/GF/Source/GF.cf
View File

@@ -160,6 +160,7 @@ EQCons. Exp3 ::= "[" Ident "." Ident "]" ; -- qualified constant
EApp. Exp2 ::= Exp2 Exp3 ;
ETable. Exp2 ::= "table" "{" [Case] "}" ;
ETTable. Exp2 ::= "table" Exp4 "{" [Case] "}" ;
EVTable. Exp2 ::= "table" Exp4 "[" [Exp] "]" ;
ECase. Exp2 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp2 ::= "variants" "{" [Exp] "}" ;
EPre. Exp2 ::= "pre" "{" Exp ";" [Altern] "}" ;

1
src/GF/Source/GrammarToSource.hs
View File

@@ -129,6 +129,7 @@ trt trm = case trm of
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
V ty cc -> P.EVTable (trt ty) (map trt cc)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)

152
src/GF/Source/LexGF.hs
View File

File diff suppressed because one or more lines are too long

50
src/GF/Source/LexGF.x
View File

@@ -4,7 +4,6 @@
module LexGF where
import ErrM
import SharedString
}
@@ -23,30 +22,27 @@ $u = [\0-\255] -- universal: any character
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
@rsyms { tok (\p s -> PT p (TS s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent T_LString s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent TV s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ { tok (\p s -> PT p (TI s)) }
{
tok f p s = f p s
share :: String -> String
share = shareString
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
| T_LString !String
TS String -- reserved words
| TL String -- string literals
| TI String -- integer literals
| TV String -- identifiers
| TD String -- double precision float literals
| TC String -- character literals
| T_LString String
deriving (Eq,Show,Ord)
@@ -72,18 +68,20 @@ prToken t = case t of
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "lincat" (B "def" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "data" (B "concrete" N N) N))) (B "include" (B "fun" (B "fn" (B "flags" N N) N) (B "in" (B "grammar" N N) N)) (B "interface" (B "instance" (B "incomplete" N N) N) (B "lin" (B "let" N N) N)))) (B "resource" (B "out" (B "of" (B "lintype" (B "lindef" N N) N) (B "oper" (B "open" N N) N)) (B "pattern" (B "param" (B "package" N N) N) (B "printname" (B "pre" N N) N))) (B "union" (B "table" (B "strs" (B "reuse" N N) N) (B "transfer" (B "tokenizer" N N) N)) (B "where" (B "variants" (B "var" N N) N) (B "with" N N))))
resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
where b s = B s (TS s)
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where

432
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

1
src/GF/Source/PrintGF.hs
View File

@@ -334,6 +334,7 @@ instance Print Exp where
EApp exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , prt 3 exp])
ETable cases -> prPrec i 2 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
ETTable exp cases -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVTable exp exps -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
ECase exp cases -> prPrec i 2 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVariants exps -> prPrec i 2 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EPre exp alterns -> prPrec i 2 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])

1
src/GF/Source/SkelGF.hs
View File

@@ -206,6 +206,7 @@ transExp x = case x of
EApp exp0 exp -> failure x
ETable cases -> failure x
ETTable exp cases -> failure x
EVTable exp exps -> failure x
ECase exp cases -> failure x
EVariants exps -> failure x
EPre exp alterns -> failure x

2
src/GF/Source/SourceToGrammar.hs
View File

@@ -350,6 +350,8 @@ transExp x = case x of
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
EVTable exp cases ->
liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases

28
src/GF/Source/TestGF.hs
View File

@@ -18,22 +18,28 @@ type ParseFun a = [Token] -> Err a
myLLexer = myLexer
runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO ()
runFile p f = readFile f >>= run p
type Verbosity = Int
run :: (Print a, Show a) => ParseFun a -> String -> IO ()
run p s = case (p (myLLexer s)) of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run pGrammar
[f] -> runFile pGrammar f
_ -> do progName <- getProgName
putStrLn $ progName ++ ": excess arguments."
[] -> hGetContents stdin >>= run 2 pGrammar
"-s":fs -> mapM_ (runFile 0 pGrammar) fs
fs -> mapM_ (runFile 2 pGrammar) fs