mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-15 06:02:55 -06:00
full support for recursive def rules in the C runtime
This commit is contained in:
kr.angelov
@@ -136,24 +136,29 @@ instance Binary Equation where
|
||||
get = liftM2 Equ get get
|
||||
|
||||
instance Binary Instr where
|
||||
put (EVAL n) = putWord8 0 >> put n
|
||||
put (CASE id l ) = putWord8 1 >> put (id,l)
|
||||
put (CASE_INT n l ) = putWord8 2 >> put (n,l)
|
||||
put (CASE_STR s l ) = putWord8 3 >> put (s,l)
|
||||
put (CASE_FLT d l ) = putWord8 4 >> put (d,l)
|
||||
put (ALLOC n) = putWord8 5 >> put n
|
||||
put (PUT_CONSTR id) = putWord8 6 >> put id
|
||||
put (PUT_CLOSURE l) = putWord8 7 >> put l
|
||||
put (PUT_INT n) = putWord8 8 >> put n
|
||||
put (PUT_STR s) = putWord8 9 >> put s
|
||||
put (PUT_FLT d) = putWord8 10 >> put d
|
||||
put (SET_VALUE n) = putWord8 11 >> put n
|
||||
put (SET_VARIABLE n) = putWord8 12 >> put n
|
||||
put (PUSH_VALUE n)= putWord8 13 >> put n
|
||||
put (PUSH_VARIABLE n)= putWord8 14 >> put n
|
||||
put (TAIL_CALL id) = putWord8 15 >> put id
|
||||
put (FAIL ) = putWord8 16
|
||||
put (RET n) = putWord8 17 >> put n
|
||||
put (ENTER ) = putWord8 0
|
||||
put (EVAL_ARG_VAR n) = putWord8 1 >> put n
|
||||
put (EVAL_FREE_VAR n)= putWord8 2 >> put n
|
||||
put (CASE id l ) = putWord8 3 >> put (id,l)
|
||||
put (CASE_INT n l ) = putWord8 4 >> put (n,l)
|
||||
put (CASE_STR s l ) = putWord8 5 >> put (s,l)
|
||||
put (CASE_FLT d l ) = putWord8 6 >> put (d,l)
|
||||
put (ALLOC n) = putWord8 7 >> put n
|
||||
put (PUT_CONSTR id) = putWord8 8 >> put id
|
||||
put (PUT_FUN id) = putWord8 9 >> put id
|
||||
put (PUT_CLOSURE l) = putWord8 10 >> put l
|
||||
put (PUT_INT n) = putWord8 11 >> put n
|
||||
put (PUT_STR s) = putWord8 12 >> put s
|
||||
put (PUT_FLT d) = putWord8 13 >> put d
|
||||
put (SET_VALUE n) = putWord8 14 >> put n
|
||||
put (SET_ARG_VAR n) = putWord8 15 >> put n
|
||||
put (SET_FREE_VAR n) = putWord8 16 >> put n
|
||||
put (PUSH_VALUE n) = putWord8 17 >> put n
|
||||
put (PUSH_ARG_VAR n) = putWord8 18 >> put n
|
||||
put (PUSH_FREE_VAR n)= putWord8 19 >> put n
|
||||
put (TAIL_CALL id) = putWord8 20 >> put id
|
||||
put (FAIL ) = putWord8 21
|
||||
put (RET n) = putWord8 22 >> put n
|
||||
|
||||
|
||||
instance Binary Type where
|
||||
|
||||
@@ -6,46 +6,57 @@ import Text.PrettyPrint
|
||||
type CodeLabel = Int
|
||||
|
||||
data Instr
|
||||
= EVAL {-# UNPACK #-} !Int
|
||||
= ENTER
|
||||
| EVAL_ARG_VAR {-# UNPACK #-} !Int
|
||||
| EVAL_FREE_VAR {-# UNPACK #-} !Int
|
||||
| CASE CId {-# UNPACK #-} !CodeLabel
|
||||
| CASE_INT Int {-# UNPACK #-} !CodeLabel
|
||||
| CASE_STR String {-# UNPACK #-} !CodeLabel
|
||||
| CASE_FLT Double {-# UNPACK #-} !CodeLabel
|
||||
| ALLOC {-# UNPACK #-} !Int
|
||||
| PUT_CONSTR CId
|
||||
| PUT_FUN CId
|
||||
| PUT_CLOSURE {-# UNPACK #-} !CodeLabel
|
||||
| PUT_INT {-# UNPACK #-} !Int
|
||||
| PUT_STR String
|
||||
| PUT_FLT {-# UNPACK #-} !Double
|
||||
| SET_VALUE {-# UNPACK #-} !Int
|
||||
| SET_VARIABLE {-# UNPACK #-} !Int
|
||||
| PUSH_VALUE {-# UNPACK #-} !Int
|
||||
| PUSH_VARIABLE {-# UNPACK #-} !Int
|
||||
| SET_VALUE {-# UNPACK #-} !Int
|
||||
| SET_ARG_VAR {-# UNPACK #-} !Int
|
||||
| SET_FREE_VAR {-# UNPACK #-} !Int
|
||||
| PUSH_VALUE {-# UNPACK #-} !Int
|
||||
| PUSH_ARG_VAR {-# UNPACK #-} !Int
|
||||
| PUSH_FREE_VAR {-# UNPACK #-} !Int
|
||||
| TAIL_CALL CId
|
||||
| UPDATE
|
||||
| FAIL
|
||||
| RET {-# UNPACK #-} !Int
|
||||
|
||||
ppCode :: CodeLabel -> [Instr] -> Doc
|
||||
ppCode l [] = empty
|
||||
ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is
|
||||
ppCode :: Int -> [[Instr]] -> Doc
|
||||
ppCode l [] = empty
|
||||
ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
|
||||
|
||||
ppInstr l (EVAL n) = text "EVAL " <+> int n
|
||||
ppInstr l (CASE id o ) = text "CASE " <+> ppCId id <+> ppLabel (l+o+1)
|
||||
ppInstr l (CASE_INT n o ) = text "CASE_INT " <+> int n <+> ppLabel (l+o+1)
|
||||
ppInstr l (CASE_STR s o ) = text "CASE_STR " <+> text (show s) <+> ppLabel (l+o+1)
|
||||
ppInstr l (CASE_FLT d o ) = text "CASE_FLT " <+> double d <+> ppLabel (l+o+1)
|
||||
ppInstr l (ALLOC n) = text "ALLOC " <+> int n
|
||||
ppInstr l (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
|
||||
ppInstr l (PUT_CLOSURE c) = text "PUT_CLOSURE " <+> ppLabel c
|
||||
ppInstr l (PUT_INT n ) = text "PUT_INT " <+> int n
|
||||
ppInstr l (PUT_STR s ) = text "PUT_STR " <+> text (show s)
|
||||
ppInstr l (PUT_FLT d ) = text "PUT_FLT " <+> double d
|
||||
ppInstr l (SET_VALUE n) = text "SET_VALUE " <+> int n
|
||||
ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n
|
||||
ppInstr l (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n
|
||||
ppInstr l (PUSH_VARIABLE n)= text "PUSH_VARIABLE"<+> int n
|
||||
ppInstr l (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id
|
||||
ppInstr l (FAIL ) = text "FAIL"
|
||||
ppInstr l (RET n) = text "RET " <+> int n
|
||||
ppInstr (ENTER ) = text "ENTER"
|
||||
ppInstr (EVAL_ARG_VAR n) = text "EVAL_ARG_VAR " <+> int n
|
||||
ppInstr (EVAL_FREE_VAR n) = text "EVAL_FREE_VAR" <+> int n
|
||||
ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l
|
||||
ppInstr (CASE_INT n l ) = text "CASE_INT " <+> int n <+> ppLabel l
|
||||
ppInstr (CASE_STR str l ) = text "CASE_STR " <+> text (show str) <+> ppLabel l
|
||||
ppInstr (CASE_FLT d l ) = text "CASE_FLT " <+> double d <+> ppLabel l
|
||||
ppInstr (ALLOC n) = text "ALLOC " <+> int n
|
||||
ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
|
||||
ppInstr (PUT_FUN id) = text "PUT_FUN " <+> ppCId id
|
||||
ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE " <+> ppLabel l
|
||||
ppInstr (PUT_INT n ) = text "PUT_INT " <+> int n
|
||||
ppInstr (PUT_STR str ) = text "PUT_STR " <+> text (show str)
|
||||
ppInstr (PUT_FLT d ) = text "PUT_FLT " <+> double d
|
||||
ppInstr (SET_VALUE n) = text "SET_VALUE " <+> int n
|
||||
ppInstr (SET_ARG_VAR n) = text "SET_ARG_VAR " <+> int n
|
||||
ppInstr (SET_FREE_VAR n) = text "SET_FREE_VAR " <+> int n
|
||||
ppInstr (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n
|
||||
ppInstr (PUSH_ARG_VAR n) = text "PUSH_ARG_VAR " <+> int n
|
||||
ppInstr (PUSH_FREE_VAR n) = text "PUSH_FREE_VAR" <+> int n
|
||||
ppInstr (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id
|
||||
ppInstr (FAIL ) = text "FAIL"
|
||||
ppInstr (RET n) = text "RET " <+> int n
|
||||
|
||||
ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s)
|
||||
ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)
|
||||
|
||||
@@ -28,11 +28,11 @@ data PGF = PGF {
|
||||
|
||||
data Abstr = Abstr {
|
||||
aflags :: Map.Map CId Literal, -- ^ value of a flag
|
||||
funs :: Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double),-- ^ type, arrity and definition of function + probability
|
||||
cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category
|
||||
-- 2. functions of a category. The functions are stored
|
||||
-- in decreasing probability order.
|
||||
-- 3. probability
|
||||
funs :: Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double),-- ^ type, arrity and definition of function + probability
|
||||
cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category
|
||||
-- 2. functions of a category. The functions are stored
|
||||
-- in decreasing probability order.
|
||||
-- 3. probability
|
||||
}
|
||||
|
||||
data Concr = Concr {
|
||||
|
||||
@@ -325,8 +325,8 @@ data Value
|
||||
| VClosure Env Expr
|
||||
| VImplArg Value
|
||||
|
||||
type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- type and def of a fun
|
||||
, Int -> Maybe Expr -- lookup for metavariables
|
||||
type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
|
||||
, Int -> Maybe Expr -- lookup for metavariables
|
||||
)
|
||||
type Env = [Value]
|
||||
|
||||
|
||||
@@ -29,13 +29,13 @@ ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+>
|
||||
ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc
|
||||
ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
|
||||
|
||||
ppFun :: CId -> (Type,Int,Maybe ([Equation],[Instr]),Double) -> Doc
|
||||
ppFun :: CId -> (Type,Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
|
||||
ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
|
||||
if null eqs
|
||||
then empty
|
||||
else text "def" <+> vcat [let scope = foldl pattScope [] patts
|
||||
ds = map (ppPatt 9 scope) patts
|
||||
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] $$
|
||||
(if null eqs
|
||||
then empty
|
||||
else text "def" <+> vcat [let scope = foldl pattScope [] patts
|
||||
ds = map (ppPatt 9 scope) patts
|
||||
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$
|
||||
ppCode 0 code
|
||||
ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
|
||||
|
||||
|
||||
Reference in New Issue
Block a user