implementation module graph_to_sapl_string import StdEnv import StdStrictLists import graph_to_string_with_descriptors import StdDebug //import sapldebug // Conversion of dynamic graph string to sapl code // JMJ 2007 // Simplified sapl representation :: DynamicSapl = IntS Int | BoolS Bool | CharS Char | RealS Real | StringS String | CstrS String String Int [DynamicSapl] | FunctionS String String Int [DynamicSapl] | ArrayS Int [DynamicSapl] | ListS [DynamicSapl] | TupleS Int [DynamicSapl] | RecS String String Int [DynamicSapl] cb :: Int cb =: fromChar '\b' cv :: Int cv =: fromChar '\v' escapeString :: Char String -> String escapeString qc str = toString [qc: flatten (escapeString` (fromString str))] where escapeString` :: [Char] -> [[Char]] escapeString` [] = [[qc]] escapeString` ['\'':chars] = [['\\\'']: escapeString` chars] escapeString` ['\"':chars] = [['\\\"']: escapeString` chars] escapeString` [c :chars] | isPrint c = [[c] : escapeString` chars] = [toHex (fromChar c): escapeString` chars] toHex i | i == 0 = ['\\0'] | i == 7 = ['\\a'] | i == cb = ['\\b'] | i == cv = ['\\v'] toHex i = ['\\x'] ++ ['0' \\ a <- [1..2-length letters]] ++ reverse (toHex` i) where letters = reverse (toHex` i) toHex` 0 = [] toHex` i = [hex.[i bitand 15]:toHex` (i >> 4)] where hex = "0123456789ABCDEF" makeSaplExpression :: !DynamicSapl -> String makeSaplExpression e = mkse e where mkse (IntS i) = toString i mkse (BoolS b) = toString b mkse (CharS c) = escapeString '\'' (toString c) mkse (RealS r) = toString r mkse (StringS s) = escapeString '"' s mkse (CstrS mod name _ []) = makePrintableName (mod +++ "." +++ makeSaplName name) mkse (CstrS mod name _ as) = "(" +++ makePrintableName (mod +++ "." +++ makeSaplName name) +++ args as +++ ")" mkse (FunctionS mod name _ []) = makePrintableName (mod +++ "." +++ makeSaplName name) mkse (FunctionS mod name _ as) = "(" +++ makePrintableName (mod +++ "." +++ makeSaplName name) +++ args as +++ ")" mkse (RecS mod name _ []) = makePrintableName (makeRecName mod name) mkse (RecS mod name _ as) = "(" +++ makePrintableName (makeRecName mod name) +++ args as +++ ")" mkse (ArrayS _ as) = mkl as mkse (ListS as) = mkl as mkse (TupleS n as) = "(_Tuple" +++ toString n +++ args as +++ ")" args [] = "" args [a:as] = " " +++ mkse a +++ args as mkl [] = "_predefined._Nil" mkl [a:as] = "(_predefined._Cons " +++ mkse a +++ " " +++ mkl as +++ ")" instance toString DynamicSapl where toString (IntS i) = "IntS " +++ toString i toString (BoolS i) = "BoolS " +++ toString i toString (CharS i) = "CharS " +++ toString i toString (RealS i) = "RealS " +++ toString i toString (StringS i) = "StringS " +++ toString i sapl_from_string :: !*{#Char} -> (.a,!Int) sapl_from_string str = (undef,3) graph_to_sapl_string :: !a -> String graph_to_sapl_string a = makeSaplExpression (graph_to_sapl_dynamic a) string_to_graph :: !String -> .a string_to_graph thread = abort "Cannot create Sapl graph while you are in Clean.\n" graph_to_sapl_dynamic :: !a -> DynamicSapl graph_to_sapl_dynamic graph # (g,d,m) = graph_to_string_with_descriptor_and_module_table graph # (v,_) = convertfromdyn g d m = v // Testing function, also gives decoding graph_to_sapl_dynamic_test :: !a -> (({#Int},Char,{#String},Char,{#String}),Char,DynamicSapl,Char,String) graph_to_sapl_dynamic_test graph # (g,d,m) = graph_to_string_with_descriptor_and_module_table graph # (v,_) = convertfromdyn g d m = (dyndesc graph,'\n',v,'\n',graph_to_sapl_string graph) dyndesc gg # (g,d,m) = graph_to_string_with_descriptor_and_module_table gg = (string_to_int_array g,'\n',d,'\n',m); // Decoding functions string_to_int_array :: !{#Char} -> {#Int} string_to_int_array s = {select_int_from_string i s\\i<-[0,IF_INT_64_OR_32 8 4..size s-IF_INT_64_OR_32 7 3]} select_int_from_string i s = IF_INT_64_OR_32 (toInt s.[i]+(toInt s.[i+1]<<8)+(toInt s.[i+2]<<16)+(toInt s.[i+3]<<24) +(toInt s.[i+4]<<32)+(toInt s.[i+5]<<40)+(toInt s.[i+6]<<48)+(toInt s.[i+7]<<56)) (toInt s.[i]+(toInt s.[i+1]<<8)+(toInt s.[i+2]<<16)+(toInt s.[i+3]<<24)); sifs = select_int_from_string sbfs i s = int2bool (sifs i s) scfs i s = toChar(sifs i s) srfs i s = IF_INT_64_OR_32 (make_real_from_int (select_int_from_string i s)) (make_real_from_2_ints (select_int_from_string i s) (select_int_from_string (i+4) s)) where make_real_from_int :: !Int -> Real make_real_from_int r = code { pop_b 0 } make_real_from_2_ints :: !Int !Int -> Real make_real_from_2_ints r0 r1 = code { pop_b 0 } int2bool 0 = False int2bool 1 = True arity c | '0' <= c && c <= '9' = toInt c - toInt '0' = toInt c - toInt 'A' + 10 selectmodnr i s = toInt s.[i]+(toInt s.[i+1]<<8) getName :: Int String -> String getName i s = s % (i,poszero-1) where poszero = hd [n\\ n <- [i+1..(size s)]| s.[n] == '\0'] convertfromdyn str ds md = decodeDyn 0 where decodeDyn pos # dnr = sifs pos str | dnr < 0 = getEarlierElem (pos + dnr - 1) (pos+IF_INT_64_OR_32 8 4) // shared node # desc = ds.[dnr-1] # desc_type = desc.[0] # next_pos = pos+IF_INT_64_OR_32 8 4 | desc_type == 'i' = (IntS (sifs next_pos str),pos+IF_INT_64_OR_32 16 8) // Int | desc_type == 'c' = (CharS (scfs next_pos str),pos+IF_INT_64_OR_32 16 8) // Char | desc_type == 'b' = (BoolS (sbfs next_pos str),pos+IF_INT_64_OR_32 16 8) // Bool | desc_type == 's' = readString pos // String in array | desc_type == 'r' = (RealS (srfs next_pos str),pos+IF_INT_64_OR_32 16 12) // Real //| desc_type == 'C' && size str > pos + 4 && sifs (pos+4) str < 0 // shared node in array //= getEarlierElem (pos + 4 + sifs (pos+4) str + 3) (pos+8) | desc_type == 'C' | desc.[1]=='0' // arity==0 = makeBoxedConstr desc pos | size str > next_pos && sifs next_pos str < 0 // shared node in constructor = makeBoxedConstr desc pos | size str > next_pos && ds.[sifs next_pos str - 1].[0] == 's' // String = readString next_pos | size str > next_pos && ds.[sifs next_pos str - 1].[0] == 'a' | sifs (pos+IF_INT_64_OR_32 24 12) str <> 0 // unboxed array # typedes = ds.[sifs (pos+IF_INT_64_OR_32 24 12) str-1] # ssize = sifs (pos+IF_INT_64_OR_32 16 8) str = makeUnboxedArray typedes ssize (pos+IF_INT_64_OR_32 32 16) //sifs (pos+IF_INT_64_OR_32 24 12) str == 0 // boxed array # ssize = sifs (pos+IF_INT_64_OR_32 16 8) str = makeBoxedArray ssize (pos+IF_INT_64_OR_32 32 16) // boxed constructor or partial application = makeBoxedConstr desc pos | desc_type == ':' // boxed list = makeBoxedList pos | desc_type == 'R' | ds.[dnr-1].[5] == 'l' && ds.[dnr-1].[6] == 'R'// unboxed list of records = makeUnBoxedListOfRecords pos | ds.[dnr-1].[5] == 'l'// unboxed list = makeUnBoxedList ds.[dnr-1].[6] pos // records constructor & unboxed constructors = makeRecord pos | desc_type == 'n' = (ListS [],next_pos)// empty list | desc_type == 't' // tuple = makeTuple (arity ds.[dnr-1].[1]) next_pos getEarlierElem pos newpos // backward ref # dnr = sifs (pos) str // descriptor is in word before # desc_type = ds.[dnr-1].[0] | desc_type == 's' = (fst (decodeDyn pos),newpos) // string case = (fst (decodeDyn pos),newpos) readString pos # strsize = sifs (pos+IF_INT_64_OR_32 8 4) str first_char_pos = pos + IF_INT_64_OR_32 16 8 newpos = first_char_pos + ((strsize + IF_INT_64_OR_32 7 3) bitand (IF_INT_64_OR_32 (-8) (-4))) = (StringS (str % (first_char_pos,first_char_pos + strsize - 1)), newpos) makeUnboxedArray typedes size pos # t=typedes.[0]; | t=='i' || t=='b' || t=='c' || t=='r' # (elems,rest) = readUMany typedes.[0] size pos [] = (ArrayS size elems,rest) | t=='R' = makeUnBoxedArrayOfRecords size (pos-IF_INT_64_OR_32 8 4) readUDMany types 0 pos res = (res,pos) readUDMany ['r':types] n pos res = readUDMany types (n-IF_INT_64_OR_32 1 2) (pos+8) (res ++ [makeRealType pos]) readUDMany [type:types] n pos res = readUDMany types (n-1) (pos+IF_INT_64_OR_32 8 4) (res ++ [makeType type pos]) readUMany type 0 pos res = (res,pos) readUMany type=:'r' n pos res = readUMany type (n-IF_INT_64_OR_32 1 2) (pos+8) (res ++ [makeRealType pos]) readUMany type n pos res = readUMany type (n-1) (pos+IF_INT_64_OR_32 8 4) (res ++ [makeType type pos]) makeBoxedArray size pos # (elems,pos) = (readMany size pos []) = (ArrayS size elems,pos) makeTuple size pos # (elems,pos) = (readMany size pos []) = (TupleS size elems,pos) makeRecord pos # dnr = sifs pos str # desc = ds.[dnr-1] #(name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) = makeRecordTypeDesc desc # (ubels,pos) = readUDMany ubtypes nrub (pos+IF_INT_64_OR_32 8 4) [] # (bels,pos) = readMany nrpointer pos [] # mergedelems = merge_elems alltypes ubels bels # typedelems = setTypes (makeRecordType typedesc) mergedelems = if (desc.[5]== 'd') (CstrS modname name tsize typedelems,pos)(RecS modname name tsize typedelems,pos) makeRecordTypeDesc desc # tsize = arity desc.[1] # nrpointer = arity desc.[2] # nrub = tsize - nrpointer # modnr = selectmodnr 3 desc # start_types = if (desc.[5] == 'd') 6 (if (desc.[5] == 'l' && desc.[6] == 'R') 7 5) # modname = md.[modnr-1] # typedesc = takeWhile (\a -> a <> '\0') [c\\ c <-: desc%(start_types,size str-1)] # alltypes = [t\\ t <- typedesc| (t <> '(') && (t <> ')') && (t <> ',')] # ubtypes = [c\\ c <- alltypes| c <> 'a'] # name = getName (start_types+length typedesc+1) desc | start_types <> 7 = (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) // normal record = (name,modname,tsize-1,nrpointer-1,nrub,droplast alltypes,ubtypes,droplast typedesc) // list: drop last of pointer part (= pointer to tail) merge_elems [] _ _ = [] merge_elems ['a':types] ubels bels = [hd bels : merge_elems types ubels (tl bels)] merge_elems [_:types] ubels bels = [hd ubels : merge_elems types (tl ubels) bels] readMany 0 pos res = (res,pos) readMany n pos res # (elem,newpos) = decodeDyn pos = readMany (n-1) newpos (res ++ [elem]) makeBoxedConstr desc pos # nrargs = arity desc.[1] # modnr = selectmodnr 3 desc # name = getName 5 desc # modname = md.[modnr-1] # (elems,newpos) = readMany nrargs (pos+IF_INT_64_OR_32 8 4) [] | name == "ARRAY" = (hd elems,newpos) // array or string = (CstrS modname name nrargs elems,newpos) makeBoxedList pos # (elems,newpos) = readListElems pos [] = (ListS elems,newpos) makeUnBoxedList type pos # (elems,newpos) = readUBListElems type pos [] = (ListS elems,newpos) readListElems pos elems # dnr = sifs pos str | dnr < 0 = (elems,pos+IF_INT_64_OR_32 8 4) // always nil # desc_type = ds.[dnr-1].[0] | desc_type == ':' # (elem,newpos) = decodeDyn (pos+IF_INT_64_OR_32 8 4) = readListElems newpos (elems++[elem]) = (elems,pos+IF_INT_64_OR_32 8 4) readUBListElems type pos elems # dnr = sifs pos str | dnr < 0 = (elems,pos+IF_INT_64_OR_32 8 4) // always nil # desc_type = ds.[dnr-1].[0] | desc_type == 'R' | type=='r' # elem = makeRealType (pos+IF_INT_64_OR_32 8 4) = readUBListElems type (pos+IF_INT_64_OR_32 16 12) (elems++[elem]) # elem = makeType type (pos+IF_INT_64_OR_32 8 4) = readUBListElems type (pos+IF_INT_64_OR_32 16 8) (elems++[elem]) = (elems,pos+IF_INT_64_OR_32 8 4) makeUnBoxedArrayOfRecords size pos # dnr = sifs pos str # desc = ds.[dnr-1] # typedes = makeRecordTypeDesc desc # (elems,pos) = readUBArrayRecordElems size (pos+IF_INT_64_OR_32 8 4) typedes [] = (ArrayS size elems,pos) makeUnBoxedListOfRecords pos # dnr = sifs pos str # desc = ds.[dnr-1] # typedes = makeRecordTypeDesc desc # (elems,pos) = readUBListRecordElems pos typedes [] = (ListS elems,pos) readUBListRecordElems pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) elems # dnr = sifs pos str | dnr < 0 = (elems,pos+IF_INT_64_OR_32 8 4) // always nil # desc_type = ds.[dnr-1].[0] | desc_type == 'R' # (ubels,pos) = readUDMany ubtypes nrub (pos+IF_INT_64_OR_32 8 4) [] # (bels,pos) = readMany nrpointer pos [] # mergedelems = merge_elems alltypes ubels bels # typedelems = setTypes (makeRecordType typedesc) mergedelems # elem = RecS modname name tsize typedelems = readUBListRecordElems pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) (elems++[elem]) = (elems,pos+IF_INT_64_OR_32 8 4) readUBArrayRecordElems 0 pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) elems = (elems,pos) readUBArrayRecordElems size pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) elems # (ubels,pos) = readUDMany ubtypes nrub pos [] # (bels,pos) = readMany nrpointer pos [] # mergedelems = merge_elems alltypes ubels bels # typedelems = setTypes (makeRecordType typedesc) mergedelems # elem = RecS modname name tsize typedelems = readUBArrayRecordElems (size-1) pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) (elems++[elem]) makeType 'i' pos = IntS (sifs pos str) makeType 'c' pos = CharS (scfs pos str) makeType 'b' pos = BoolS (sbfs pos str) makeRealType pos = RealS (srfs pos str) //Start = testmrt "(1(2))34" //testmrt str //# rt = [toString c\\ c <-: str] //# elems = [S c\\ c <- rt| c <> "(" && c <> ")" && c <> ","] //= setTypes rt elems // Setting the tuples and records correct in a record is quit compilcated // Records can have type descriptors of the form a(a,a)a // makeRecordType transforms this into: [[0],[2],[0],[0]] // The 2 at the second position indicated that a tuple of size 2 starts at this position // ((a),a)a is transformed in: [[2,1],[0],[0]] (nested tuple or records) // setTypes applies this to the sequential list of elements setTypes rtypes elems = mt rtypes elems where mt [[ ]:ts] [elem:elems] = [elem : mt ts elems] mt [[0]:ts] [elem:elems] = [elem : mt ts elems] mt [[1]:ts] [elem:elems] = [TupleS 1 [elem] : mt ts elems] mt [[a:as]:ts] elems = [TupleS (length rs) rs:mt (drop (a-1) ts) (drop a elems)] where rs = mt [as:take (a-1) ts] (take a elems) mt [] [] = [] makeRecordType ltypes = mrt [ltype\\ ltype <- ltypes| ltype <> ','] where mrt ['(':ltypes] = [first : mrt (tl rs)] where (first,rs) = dostartpars ['(':ltypes] mrt [')':ltypes] = mrt ltypes mrt [_ :ltypes] = [[0] : mrt ltypes] mrt [] = [] dostartpars ['(':ltypes] # f = gettuplength 1 0 ltypes # (fs,rs) = dostartpars ltypes = ([f:fs],rs) dostartpars rs = ([],rs) gettuplength 1 length [')':rs] = length gettuplength n length [')':rs] = gettuplength (n-1) length rs gettuplength n length ['(':rs] = gettuplength (n+1) length rs gettuplength n length [r:rs] = gettuplength n (length+1) rs droplast [x] = [] droplast [x:xs] = [x:droplast xs] makeSaplName :: String -> String makeSaplName str # lstr = [c\\ c <-: str] # revl = reverse lstr # (dgs,revrest) = span isDigit revl # initname = reverse (remsc revrest) // FIXME: heuristic for this case: _f703;703;703 -> _f703_703 # initname = if (dgs<>[]) (takeWhile (\r -> not (r == ';')) initname) initname # initstr = {c\\ c <- initname} # fname = makeName initstr | dgs <> [] && hd revrest == ';' = (fname +++ "_" +++ toString (reverse dgs)) | dgs <> [] = (fname +++ toString (reverse dgs)) = fname remsc [';':rs] = rs remsc rs = rs makePrintableName f | ss f = "<{" +++ f +++ "}>" = f where ss f = or [is_ss c\\ c <-: f] is_ss c = not (isAlphanum c || c == '_' || c == '.') makeRecName :: String String -> String makeRecName mod name | last [c\\ c <-: ("" +++ name)] == ';' = mod +++ "." +++ name = mod +++ "._" +++ makeSaplName {a\\ a<-: name| a <> '[' && a <> ']' && a <> '#'} makeName name | name.[0] == '\\' = "anon" | startsWith " Bool startsWith s1 s2 = s1 == s2%(0,size s1-1) print_graph :: !a -> String print_graph g = des2string (string_to_int_array a,"[" +++ printlist [b\\ b <-:bs],"[" +++ printlist [c\\ c <-:cs]) where (a,bs,cs) = (graph_to_string_with_descriptor_and_module_table g) des2string (ia,des,mods) = printintarray ia +++ "\n" +++ des +++ "\n" +++ mods +++ "\n" printintarray ia = "[" +++ printlist [toString a\\ a <-: ia] printlist [] = "]" printlist [a] = a +++ "]" printlist [a:as] = a +++ ", " +++ printlist as