implementation module type_io_write import type_io_read import type_io_common import RWSDebugChoice // compiler //1.3 from syntax import StrictnessList from utilities import foldSt, mapSt, second_of_2_tuple from general import Optional, Yes, No from predef import PD_StringType, PD_ListType, PD_LazyArrayType, PD_StrictArrayType, PD_UnboxedArrayType // extended from ExtString import CharIndex, CharIndexBackwards, ends, starts from pdExtFile import path_separator from ExtFile import ExtractPathAndFile, ExtractPathFileAndExtension //import SymbolTable; from NamesTable import create_names_table, isEmptyNamesTableElement, insert_symbol_in_symbol_table,find_symbol_in_symbol_table; from ReadObject import decode_line_from_library_file; //3.1 /*2.0 from syntax import ::StrictnessList from utilities import foldSt, mapSt, second_of_2_tuple from general import ::Optional(..) from predef import PD_StringType, PD_ListType, PD_LazyArrayType, PD_StrictArrayType, PD_UnboxedArrayType // extended from ExtString import CharIndex, CharIndexBackwards, ends, starts from pdExtFile import path_separator from ExtFile import ExtractPathAndFile, ExtractPathFileAndExtension //import SymbolTable; from NamesTable import create_names_table, isEmptyNamesTableElement, insert_symbol_in_symbol_table,find_symbol_in_symbol_table; from ReadObject import decode_line_from_library_file; 0.2*/ //F a b :== b import DebugUtilities import type_io_static import StdMaybe; create_type_archive :: [String] [String] !String !*Files -> (!Bool,!*Files) create_type_archive objects dlls typ_name files /* // determine icl modules # (n_clean_modules,module_names) = filter_out_non_clean_modules objects 0 [] // read type information per module # (ok1,tio_common_defs,type_io_state,files) = collect_type_info module_names n_clean_modules files */ # (ok1,tio_common_defs,type_io_state,files) = collect_type_infoNEW objects files | not ok1 = (False,files) // write it back to disk # (ok,files) = write_type_information2 typ_name dlls tio_common_defs type_io_state files /* # (ok,_,tio_common_defs2,_,files) = read_type_information typ_name files | True = abort ("hhahaha" +++ toString (size tio_common_defs2)) */ = (ok,files) where filter_out_non_clean_modules :: [!String] !Int [!String] -> (!Int,[!String]) filter_out_non_clean_modules [] n_clean_modules accu = (n_clean_modules,accu) filter_out_non_clean_modules [file_name:file_names] n_clean_modules accu | (ends file_name "_options.o") || (ends file_name ".obj") = filter_out_non_clean_modules file_names n_clean_modules accu | ends ".o" (snd (ExtractPathAndFile file_name)) && fst (starts "_" (snd (ExtractPathAndFile file_name))) // WAS | fst (starts "_" (snd (ExtractPathAndFile file_name))) = filter_out_non_clean_modules file_names n_clean_modules accu # tcl_file_name = fst (ExtractPathFileAndExtension file_name) = filter_out_non_clean_modules file_names (inc n_clean_modules) [tcl_file_name:accu] write_type_information2 :: !String [String] !*{#TIO_CommonDefs} !*TypeIOState !*Files -> (!Bool,!*Files) write_type_information2 typ_file_name dlls tio_common_defs type_io_state files # (ok,typ_file,files) = fopen typ_file_name FWriteData files | not ok = (False,snd (fclose typ_file files)) // write contents of libraries # typ_file = fwritei (length dlls) typ_file # (ok,typ_file,_,files) = foldSt copy_library_files dlls (True,typ_file,create_names_table,files) | not ok = (False,snd (fclose typ_file files)) // write type information # (typ_file,_) = write_type_info tio_common_defs typ_file WriteTypeInfoState # typ_file = write_type_io_state type_io_state typ_file # (_,files) = fclose typ_file files = (True,files) where // copy_library_files :: !String (!Bool,!*File,!*NamesTable,!*Files) -> (!Bool,!*File,!*NamesTable,!*Files) copy_library_files library_file_name (True,typ_file,names_table,files) # (ok,library_file,files) = fopen library_file_name FReadText files | not ok = abort ("copy_library_files 1" +++ library_file_name) //(False,typ_file,snd (fclose library_file files)) # (library_file,contents,n_contents_lines,names_table) = copy_library_file library_file [] 0 names_table # typ_file = fwritei n_contents_lines typ_file # typ_file = foldSt /*fwrites*/ write_line contents typ_file # (_,files) = fclose library_file files = (True,typ_file,names_table,files) where copy_library_file :: !*File [{#Char}] !Int !*NamesTable -> (!*File,[{#Char}],!Int,!*NamesTable) copy_library_file library_file accu n_contents_lines names_table # (end_of_line,library_file) = fend library_file | end_of_line = (library_file,reverse accu,n_contents_lines,names_table) # (s,library_file) = freadline library_file # result = if (isEmpty accu) Nothing (decode_line_from_library_file s); # (skip_line,names_table) = case result of Nothing -> (False,names_table); (Just symbol_name) # (names_table_element,names_table) = find_symbol_in_symbol_table symbol_name names_table; | isEmptyNamesTableElement names_table_element # names_table = insert_symbol_in_symbol_table symbol_name 0 0 names_table; -> (False,names_table); // remove duplicate library symbols -> (True,names_table); | skip_line = copy_library_file library_file accu n_contents_lines names_table = copy_library_file library_file [s:accu] (inc n_contents_lines) names_table copy_library_files _ (False,typ_file,files) = (False,typ_file,files) write_line line typ_file # typ_file = fwritec (toChar (size line)) typ_file # typ_file = fwrites line typ_file = typ_file :: WriteTypeInfoState = WriteTypeInfoState; report_position s tcl_file :== tcl_file /* # (kk,tcl_file) = fposition tcl_file | F (s +++ " fp: " +++ toString kk) True = tcl_file */ class WriteTypeInfo a where write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState) instance WriteTypeInfo TIO_CommonDefs where write_type_info {tio_com_type_defs,tio_com_cons_defs,tio_com_selector_defs,tio_imported_modules,tio_n_exported_com_type_defs,tio_n_exported_com_cons_defs,tio_module,tio_pattern_matches} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_com_type_defs tcl_file wtis # tcl_file = report_position "na tio_com_type_defs (w)" tcl_file # (tcl_file,wtis) = write_type_info tio_com_cons_defs tcl_file wtis # tcl_file = report_position "na tio_com_cons_defs (w)" tcl_file # (tcl_file,wtis) = write_type_info tio_com_selector_defs tcl_file wtis # tcl_file = report_position "na tio_com_selector_defs (w)" tcl_file // additional # (tcl_file,wtis) = write_type_info tio_imported_modules tcl_file wtis # tcl_file = report_position "na tio_imported_modules (w)" tcl_file # (tcl_file,wtis) = write_type_info tio_pattern_matches tcl_file wtis # (tcl_file,wtis) = write_type_info tio_n_exported_com_type_defs tcl_file wtis # (tcl_file,wtis) = write_type_info tio_n_exported_com_cons_defs tcl_file wtis # (tcl_file,wtis) = write_type_info tio_module tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_SelectorDef where write_type_info {tio_sd_type} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_sd_type tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_ConsDef where write_type_info {tio_cons_symb,tio_cons_type,tio_cons_arg_vars,tio_cons_index,tio_cons_type_index,tio_cons_exi_vars} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_cons_symb tcl_file wtis # (tcl_file,wtis) = write_type_info tio_cons_type tcl_file wtis # (tcl_file,wtis) = write_type_info tio_cons_arg_vars tcl_file wtis // # (tcl_file,wtis) // = write_type_info tio_cons_priority tcl_file wtis # (tcl_file,wtis) = write_type_info tio_cons_index tcl_file wtis # (tcl_file,wtis) = write_type_info tio_cons_type_index tcl_file wtis # (tcl_file,wtis) = write_type_info tio_cons_exi_vars tcl_file wtis = (tcl_file,wtis) /* instance WriteTypeInfo TIO_Priority where write_type_info (Prio assoc i) tcl_file wtis # tcl_file = fwritec PrioCode tcl_file # (tcl_file,wtis) = write_type_info assoc tcl_file wtis # (tcl_file,wtis) = write_type_info i tcl_file wtis = (tcl_file,wtis) write_type_info NoPrio tcl_file wtis # tcl_file = fwritec NoPrioCode tcl_file = (tcl_file,wtis) instance WriteTypeInfo TIO_Assoc where write_type_info LeftAssoc tcl_file wtis # tcl_file = fwritec LeftAssocCode tcl_file = (tcl_file,wtis) write_type_info RightAssoc tcl_file wtis # tcl_file = fwritec RightAssocCode tcl_file = (tcl_file,wtis) write_type_info NoAssoc tcl_file wtis # tcl_file = fwritec NoAssocCode tcl_file = (tcl_file,wtis) */ //1.3 instance WriteTypeInfo TIO_TypeDef TIO_TypeRhs //3.1 /*2.0 instance WriteTypeInfo (TIO_TypeDef TIO_TypeRhs) 0.2*/ where write_type_info {tio_td_name,tio_td_arity,tio_td_args,tio_td_rhs} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_td_name tcl_file wtis # (tcl_file,wtis) = write_type_info tio_td_arity tcl_file wtis # (tcl_file,wtis) = write_type_info tio_td_args tcl_file wtis # (tcl_file,wtis) = write_type_info tio_td_rhs tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_ATypeVar where write_type_info {/*tio_atv_annotation,*/tio_atv_variable} tcl_file wtis // # (tcl_file,wtis) // = write_type_info tio_atv_annotation tcl_file wtis # (tcl_file,wtis) = write_type_info tio_atv_variable tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_Annotation where write_type_info TIO_AN_Strict tcl_file wtis = (fwritec '!' tcl_file,wtis) write_type_info TIO_AN_None tcl_file wtis = (fwritec ' ' tcl_file,wtis) instance WriteTypeInfo TIO_TypeVar where write_type_info {tio_tv_name} tcl_file wtis # tcl_file = fwritei tio_tv_name tcl_file = (tcl_file,wtis) instance WriteTypeInfo TIO_TypeRhs where write_type_info (TIO_AlgType defined_symbols) tcl_file wtis # tcl_file = fwritec AlgTypeCode tcl_file // # defined_symbols // = (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols) # (tcl_file,wtis) = write_type_info defined_symbols tcl_file wtis = (tcl_file,wtis) write_type_info (TIO_SynType _) tcl_file wtis # tcl_file = fwritec SynTypeCode tcl_file; // unimplemented = (tcl_file,wtis) write_type_info (TIO_RecordType {tio_rt_constructor,tio_rt_fields}) tcl_file wtis #! tcl_file = fwritec RecordTypeCode tcl_file; #! (tcl_file,wtis) = write_type_info tio_rt_constructor tcl_file wtis #! (tcl_file,wtis) = write_type_info tio_rt_fields tcl_file wtis = (tcl_file,wtis) write_type_info (TIO_AbstractType _) tcl_file wtis #! tcl_file = fwritec AbstractTypeCode tcl_file; // unimplemented = (tcl_file,wtis) instance WriteTypeInfo TIO_DefinedSymbol where write_type_info {tio_ds_ident,tio_ds_arity,tio_ds_index} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_ds_ident tcl_file wtis # (tcl_file,wtis) = write_type_info tio_ds_arity tcl_file wtis # (tcl_file,wtis) = write_type_info tio_ds_index tcl_file wtis = (tcl_file,wtis) /* instance WriteTypeInfo TIO_Ident where write_type_info {id_name} tcl_file wtis # tcl_file = fwritei (size id_name) tcl_file = (fwrites id_name tcl_file,wtis) */ instance WriteTypeInfo TIO_FieldSymbol where write_type_info {tio_fs_name,tio_fs_var,tio_fs_index} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_fs_name tcl_file wtis # (tcl_file,wtis) = write_type_info tio_fs_var tcl_file wtis # (tcl_file,wtis) = write_type_info tio_fs_index tcl_file wtis = (tcl_file,wtis) // NEW -> instance WriteTypeInfo TIO_SymbolType where write_type_info {tio_st_vars,tio_st_args,tio_st_args_strictness,tio_st_arity,tio_st_result} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_st_vars tcl_file wtis # (tcl_file,wtis) = write_type_info tio_st_args tcl_file wtis # (tcl_file,wtis) = write_type_info tio_st_args_strictness tcl_file wtis # (tcl_file,wtis) = write_type_info tio_st_arity tcl_file wtis # (tcl_file,wtis) = write_type_info tio_st_result tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo StrictnessList where write_type_info NotStrict tcl_file wtis # tcl_file = fwritec NotStrictCode tcl_file = (tcl_file,wtis) write_type_info (Strict i) tcl_file wtis # tcl_file = fwritec StrictCode tcl_file # tcl_file = fwritei i tcl_file = (tcl_file,wtis) write_type_info (StrictList i tail) tcl_file wtis # tcl_file = fwritec StrictListCode tcl_file # tcl_file = fwritei i tcl_file = write_type_info tail tcl_file wtis instance WriteTypeInfo TIO_AType where write_type_info {/*tio_at_annotation,*/tio_at_type} tcl_file wtis // # (tcl_file,wtis) // = write_type_info tio_at_annotation tcl_file wtis # (tcl_file,wtis) = write_type_info tio_at_type tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_Type where write_type_info (TIO_TAS type_symb_ident atypes strictness) tcl_file wtis # tcl_file = fwritec TypeTASCode tcl_file # (tcl_file,wtis) = write_type_info type_symb_ident tcl_file wtis # (tcl_file,wtis) = write_type_info atypes tcl_file wtis # (tcl_file,wtis) = write_type_info strictness tcl_file wtis = (tcl_file,wtis) write_type_info (atype1 ----> atype2) tcl_file wtis # tcl_file = fwritec TypeArrowCode tcl_file # (tcl_file,wtis) = write_type_info atype1 tcl_file wtis # (tcl_file,wtis) = write_type_info atype2 tcl_file wtis = (tcl_file,wtis) write_type_info (cons_variable :@@: atypes) tcl_file wtis # tcl_file = fwritec TypeConsApplyCode tcl_file # (tcl_file,wtis) = write_type_info cons_variable tcl_file wtis # (tcl_file,wtis) = write_type_info atypes tcl_file wtis = (tcl_file,wtis) write_type_info tb=:(TIO_TB basic_type) tcl_file wtis # (tcl_file,wtis) = case basic_type of TIO_BT_Int -> (fwritec BT_IntCode tcl_file,wtis) TIO_BT_Char -> (fwritec BT_CharCode tcl_file,wtis) TIO_BT_Real -> (fwritec BT_RealCode tcl_file,wtis) TIO_BT_Bool -> (fwritec BT_BoolCode tcl_file,wtis) TIO_BT_Dynamic -> (fwritec BT_DynamicCode tcl_file,wtis) TIO_BT_File -> (fwritec BT_FileCode tcl_file,wtis) TIO_BT_World -> (fwritec BT_WorldCode tcl_file,wtis) TIO_BT_String type # tcl_file = fwritec BT_StringCode tcl_file # (tcl_file,wtis) = write_type_info type tcl_file wtis -> (tcl_file,wtis) = (tcl_file,wtis) write_type_info (TIO_GTV type_var) tcl_file wtis # tcl_file = fwritec TypeGTVCode tcl_file # (tcl_file,wtis) = write_type_info type_var tcl_file wtis = (tcl_file,wtis) write_type_info (TIO_TV type_var) tcl_file wtis # tcl_file = fwritec TypeTVCode tcl_file # (tcl_file,wtis) = write_type_info type_var tcl_file wtis = (tcl_file,wtis) write_type_info (TIO_TQV type_var) tcl_file wtis # tcl_file = fwritec TypeTQVCode tcl_file # (tcl_file,wtis) = write_type_info type_var tcl_file wtis = (tcl_file,wtis) write_type_info TIO_TE tcl_file wtis # tcl_file = fwritec TypeTECode tcl_file = (tcl_file,wtis) instance WriteTypeInfo TIO_ConsVariable where write_type_info (TIO_CV type_var) tcl_file wtis # tcl_file = fwritec ConsVariableCVCode tcl_file # (tcl_file,wtis) = write_type_info type_var tcl_file wtis = (tcl_file,wtis) write_type_info (TIO_TempCV temp_var_id) tcl_file wtis # tcl_file = fwritec ConsVariableTempCVCode tcl_file # (tcl_file,wtis) = write_type_info temp_var_id tcl_file wtis = (tcl_file,wtis) write_type_info (TIO_TempQCV temp_var_id) tcl_file wtis # tcl_file = fwritec ConsVariableTempQCVCode tcl_file # (tcl_file,wtis) = write_type_info temp_var_id tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_TypeSymbIdent where write_type_info {tio_type_name_ref,tio_type_arity,tio_type_index} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_type_name_ref tcl_file wtis # (tcl_file,wtis) = write_type_info tio_type_arity tcl_file wtis # (tcl_file,wtis) = write_type_info tio_type_index tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo (TIO_Global object) | WriteTypeInfo object where write_type_info {tio_glob_object,tio_glob_module} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_glob_object tcl_file wtis # (tcl_file,wtis) = write_type_info tio_glob_module tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo TIO_TypeReference where write_type_info {tio_type_without_definition,tio_tr_module_n,tio_tr_type_def_n} tcl_file wtis # (tcl_file,wtis) = write_type_info tio_type_without_definition tcl_file wtis # tcl_file = fwritei tio_tr_module_n tcl_file # tcl_file = fwritei tio_tr_type_def_n tcl_file = (tcl_file,wtis) /*2.0 /* instance WriteTypeInfo TIO_String where write_type_info s tcl_file wtis # tcl_file = fwritei (size s) tcl_file = fwrites s tcl_file // warning: // Should be identical to the code in Ident */ 0.2*/ // basic and structural write_type_info's instance WriteTypeInfo Int where write_type_info i tcl_file wtis = (fwritei i tcl_file,wtis) //1.3 instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b //3.1 /*2.0 instance WriteTypeInfo {#b} | WriteTypeInfo b & Array {#} b 0.2*/ where write_type_info unboxed_array tcl_file wtis # s_unboxed_array = size unboxed_array # tcl_file = fwritei s_unboxed_array tcl_file = write_type_info_loop 0 s_unboxed_array tcl_file wtis where write_type_info_loop i limit tcl_file wtis | i == limit = (tcl_file,wtis) # (tcl_file,wtis) = write_type_info unboxed_array.[i] tcl_file wtis = write_type_info_loop (inc i) limit tcl_file wtis instance WriteTypeInfo [a] | WriteTypeInfo a where write_type_info l tcl_file wtis # tcl_file = fwritei (length l) tcl_file = write_type_info_loop l tcl_file wtis where write_type_info_loop [] tcl_file wtis = (tcl_file,wtis) write_type_info_loop [x:xs] tcl_file wtis # (tcl_file,wtis) = write_type_info x tcl_file wtis = write_type_info_loop xs tcl_file wtis instance WriteTypeInfo (Maybe a) | WriteTypeInfo a where write_type_info Nothing tcl_file wtis # tcl_file = fwritec MaybeNothingCode tcl_file = (tcl_file,wtis) write_type_info (Just a) tcl_file wtis # tcl_file = fwritec MaybeJustCode tcl_file # (tcl_file,wtis) = write_type_info a tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo (a,b) | WriteTypeInfo a & WriteTypeInfo b where write_type_info (a,b) tcl_file wtis # (tcl_file,wtis) = write_type_info a tcl_file wtis # (tcl_file,wtis) = write_type_info b tcl_file wtis = (tcl_file,wtis) instance WriteTypeInfo Char where write_type_info c tcl_file wtis # tcl_file = fwritec c tcl_file; = (tcl_file,wtis); // type_io_state write_type_io_state :: !*TypeIOState !*File -> !*File write_type_io_state type_io_state=:{tis_string_table,tis_equivalent_type_definitions} typ_file // string table # typ_file = fwritei (size tis_string_table) typ_file # typ_file = fwrites tis_string_table typ_file # (typ_file,_) = write_type_info tis_equivalent_type_definitions typ_file WriteTypeInfoState ->> ("hallo" ) = typ_file instance WriteTypeInfo EquivalentTypeDef where write_type_info {type_name,partitions} tcl_file wtis # (tcl_file,wtis) = write_type_info type_name tcl_file wtis # (tcl_file,wtis) = write_type_info partitions tcl_file wtis = (tcl_file,wtis)