diff options
| -rw-r--r-- | frontend/convertDynamics.icl | 5 | ||||
| -rw-r--r-- | frontend/type_io.dcl | 4 | ||||
| -rw-r--r-- | frontend/type_io.icl | 408 |
3 files changed, 307 insertions, 110 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 5f54bbb..495ec59 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -3,6 +3,9 @@ implementation module convertDynamics import syntax, transform, utilities, convertcases // Optional USE_TUPLES tuple b :== b; // change also StdDynamic.icl and recompile all applications + +APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== no + import type_io; :: *ConversionInfo = @@ -963,7 +966,7 @@ instance toString GlobalTCType where toString (GTT_Basic basic_type) = toString basic_type toString GTT_Function = " -> " - toString (GTT_Constructor type_symb_indent mod_name) = type_symb_indent.type_name.id_name +++ "'" +++ mod_name + toString (GTT_Constructor type_symb_indent mod_name) = type_symb_indent.type_name.id_name +++ (APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES ("'" +++ mod_name) "") instance toString BasicType where diff --git a/frontend/type_io.dcl b/frontend/type_io.dcl index 0ec2bda..8a84194 100644 --- a/frontend/type_io.dcl +++ b/frontend/type_io.dcl @@ -1,5 +1,9 @@ definition module type_io +// WARNING: It is essential to report changes in this module to martijnv@cs.kun.nl +// because the binary format for type-files is used by the dynamic run-time +// system. + import scanner, general, Heap, typeproperties, utilities, checksupport import StdEnv diff --git a/frontend/type_io.icl b/frontend/type_io.icl index f37a4a2..40908ea 100644 --- a/frontend/type_io.icl +++ b/frontend/type_io.icl @@ -1,76 +1,26 @@ implementation module type_io -import StdEnv, compare_constructor +// WARNING: It is essential to report changes in this module to martijnv@cs.kun.nl +// because the binary format for type-files is used by the dynamic run-time +// system. +import StdEnv, compare_constructor import scanner, general, Heap, typeproperties, utilities, checksupport -//import DebugUtilities; -F a b :== b; - -// Unsupported: -// - type synonyms, expanded version must be stored. Which function in the compiler -// expands synonyms correctly. -// - abstract data type, what should be written? +// normal form: +// - type variables in type definitions are normalized by checkTypeDef in the +// module checktypes.icl. The position of a type variable in the left-hand +// side of a type constructor is used. +// - algebraic datatypes; constructors are alphabetically ordered in this +// module // +// unsupported: +// - type synonyms +// - ADTs -// Records: -// - ordered fields -// -// Constructors: -// - unordered - - -/* -:: TypeRhs = AlgType ![DefinedSymbol] - | SynType !AType - | RecordType !RecordType - | AbstractType !BITVECT - | UnknownType - +//import DebugUtilities; +F a b :== b; - { ds_ident :: !Ident - , ds_arity :: !Int - , ds_index :: !Index - } - - -:: RecordType = - { rt_constructor :: !DefinedSymbol - , rt_fields :: !{# FieldSymbol} - } - -:: FieldSymbol = - { fs_name :: !Ident - , fs_var :: !Ident - , fs_index :: !Index - } - -:: ConsDef = - { cons_symb :: !Ident - , cons_type :: !SymbolType - , cons_arg_vars :: ![[ATypeVar]] - , cons_priority :: !Priority - , cons_index :: !Index - , cons_type_index :: !Index - , cons_exi_vars :: ![ATypeVar] -// , cons_exi_attrs :: ![AttributeVar] - , cons_type_ptr :: !VarInfoPtr - , cons_pos :: !Position - } - -:: TypeDef type_rhs = - { td_name :: !Ident - , td_index :: !Int - , td_arity :: !Int - , td_args :: ![ATypeVar] - , td_attrs :: ![AttributeVar] - , td_context :: ![TypeContext] - , td_rhs :: !type_rhs - , td_attribute :: !TypeAttribute - , td_pos :: !Position - } - -*/ class NormaliseTypeDef a where normalise_type_def :: a -> a @@ -90,42 +40,7 @@ instance NormaliseTypeDef TypeDef rhs | NormaliseTypeDef rhs where normalise_type_def type_def=:{td_args,td_arity} = type_def - - - - - -/* - -:: TypeVar = - { tv_name :: !Ident - , tv_info_ptr :: !TypeVarInfoPtr - } - -:: ATypeVar = - { atv_attribute :: !TypeAttribute - , atv_annotation :: !Annotation - , atv_variable :: !TypeVar - } - -:: TypeDef type_rhs = - { td_name :: !Ident - , td_index :: !Int - , td_arity :: !Int - , td_args :: ![ATypeVar] // example Tree a b = ... field is [a,b] - , td_attrs :: ![AttributeVar] - , td_context :: ![TypeContext] - , td_rhs :: !type_rhs - , td_attribute :: !TypeAttribute - , td_pos :: !Position - } -*/ -// CommonDefs -// TypeDef -loop [] - = "" -loop [{ds_ident={id_name}}:xs] - = id_name +++ ", " +++ (loop xs) + class WriteTypeInfo a where @@ -142,10 +57,12 @@ where instance WriteTypeInfo ConsDef where - write_type_info {cons_symb,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file + write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file # tcl_file = write_type_info cons_symb tcl_file # tcl_file + = write_type_info cons_type tcl_file + # tcl_file = write_type_info cons_arg_vars tcl_file # tcl_file = write_type_info cons_priority tcl_file @@ -303,7 +220,163 @@ where # tcl_file = write_type_info fs_index tcl_file = tcl_file - + +// NEW -> +instance WriteTypeInfo SymbolType +where + write_type_info {st_vars,st_args,st_arity,st_result} tcl_file + # tcl_file + = write_type_info st_vars tcl_file + # tcl_file + = write_type_info st_args tcl_file + # tcl_file + = write_type_info st_arity tcl_file + # tcl_file + = write_type_info st_result tcl_file + = tcl_file + +instance WriteTypeInfo AType +where + write_type_info {/*at_attribute,*/ at_annotation,at_type} tcl_file +// # tcl_file +// = write_type_info at_attribute tcl_file + # tcl_file + = write_type_info at_annotation tcl_file + # tcl_file + = write_type_info at_type tcl_file + = tcl_file + + +TypeTACode =: (toChar 9) // TA +TypeArrowCode =: (toChar 10) // --> +TypeConsApplyCode =: (toChar 11) // :@: +TypeTBCode =: (toChar 12) // TB +TypeGTVCode =: (toChar 13) // GTV +TypeTVCode =: (toChar 14) // TV +TypeTQVCode =: (toChar 15) // TempTQV +TypeTECode =: (toChar 16) // TE + +BT_IntCode =: (toChar 17) +BT_CharCode =: (toChar 18) +BT_RealCode =: (toChar 19) +BT_BoolCode =: (toChar 20) +BT_DynamicCode =: (toChar 21) +BT_FileCode =: (toChar 22) +BT_WorldCode =: (toChar 23) +BT_StringCode =: (toChar 24) + +instance WriteTypeInfo Type +where + write_type_info (TA type_symb_ident atypes) tcl_file + # tcl_file + = fwritec TypeTACode tcl_file + # tcl_file + = write_type_info type_symb_ident tcl_file + # tcl_file + = write_type_info atypes tcl_file + = tcl_file + + write_type_info (atype1 --> atype2) tcl_file + # tcl_file + = fwritec TypeArrowCode tcl_file + # tcl_file + = write_type_info atype1 tcl_file + # tcl_file + = write_type_info atype2 tcl_file + = tcl_file + + write_type_info (cons_variable :@: atypes) tcl_file + # tcl_file + = fwritec TypeConsApplyCode tcl_file + # tcl_file + = write_type_info cons_variable tcl_file + # tcl_file + = write_type_info atypes tcl_file + = tcl_file + + write_type_info tb=:(TB basic_type) tcl_file + # tcl_file + = case basic_type of + BT_Int -> fwritec BT_IntCode tcl_file + BT_Char -> fwritec BT_CharCode tcl_file + BT_Real -> fwritec BT_RealCode tcl_file + BT_Bool -> fwritec BT_BoolCode tcl_file + BT_Dynamic -> fwritec BT_DynamicCode tcl_file + BT_File -> fwritec BT_FileCode tcl_file + BT_World -> fwritec BT_WorldCode tcl_file + BT_String type + # tcl_file + = fwritec BT_StringCode tcl_file + # tcl_file + = write_type_info type tcl_file + -> tcl_file + _ + -> abort "mismatch" ---> tb + = tcl_file + + write_type_info (GTV type_var) tcl_file + # tcl_file + = fwritec TypeGTVCode tcl_file + # tcl_file + = write_type_info type_var tcl_file + = tcl_file + + write_type_info (TV type_var) tcl_file + # tcl_file + = fwritec TypeTVCode tcl_file + # tcl_file + = write_type_info type_var tcl_file + = tcl_file + + write_type_info (TQV type_var) tcl_file + # tcl_file + = fwritec TypeTQVCode tcl_file + # tcl_file + = write_type_info type_var tcl_file + = tcl_file + + write_type_info TE tcl_file + # tcl_file + = fwritec TypeTECode tcl_file + = tcl_file + + +ConsVariableCVCode =: (toChar 25) +ConsVariableTempCVCode =: (toChar 26) +ConsVariableTempQCVCode =: (toChar 27) + +instance WriteTypeInfo ConsVariable +where + write_type_info (CV type_var) tcl_file + # tcl_file + = fwritec ConsVariableCVCode tcl_file + # tcl_file + = write_type_info type_var tcl_file + = tcl_file + + write_type_info (TempCV temp_var_id) tcl_file + # tcl_file + = fwritec ConsVariableTempCVCode tcl_file + # tcl_file + = write_type_info temp_var_id tcl_file + = tcl_file + + write_type_info (TempQCV temp_var_id) tcl_file + # tcl_file + = fwritec ConsVariableTempQCVCode tcl_file + # tcl_file + = write_type_info temp_var_id tcl_file + = tcl_file + +instance WriteTypeInfo TypeSymbIdent +where + write_type_info {type_name,type_arity} tcl_file + # tcl_file + = write_type_info type_name tcl_file + # tcl_file + = write_type_info type_arity tcl_file + = tcl_file + // basic and structural write_type_info's instance WriteTypeInfo Int where @@ -507,21 +580,27 @@ where read_type_info tcl_file # (ok1,cons_symb,tcl_file) = read_type_info tcl_file - # (ok2,cons_arg_vars,tcl_file) + ok2 = True + cons_type = undef +// # (ok2,cons_type,tcl_file) +// = read_type_info tcl_file + + # (ok3,cons_arg_vars,tcl_file) = read_type_info tcl_file - # (ok3,cons_priority,tcl_file) + # (ok4,cons_priority,tcl_file) = read_type_info tcl_file - # (ok4,cons_index,tcl_file) + # (ok5,cons_index,tcl_file) = read_type_info tcl_file - # (ok5,cons_type_index,tcl_file) + # (ok6,cons_type_index,tcl_file) = read_type_info tcl_file - # (ok6,cons_exi_vars,tcl_file) + # (ok7,cons_exi_vars,tcl_file) = read_type_info tcl_file # consdef = { default_elem & cons_symb = cons_symb + , cons_type = cons_type , cons_arg_vars = cons_arg_vars , cons_priority = cons_priority @@ -529,7 +608,7 @@ where , cons_type_index = cons_type_index , cons_exi_vars = cons_exi_vars } - = (ok1&&ok2&&ok3&&ok4&&ok5&&ok6,consdef,tcl_file) + = (ok1&&ok2&&ok3&&ok4&&ok5&&ok6&&ok7,consdef,tcl_file) instance ReadTypeInfo Char where @@ -615,6 +694,117 @@ where , fs_index = fs_index } = (ok1&&ok2&&ok3,field_symbol,tcl_file) + +/* +instance ReadTypeInfo SymbolType +where + read_type_info tcl_file + # (ok1,st_vars,tcl_file) + = read_type_info tcl_file + # (ok2,st_args,tcl_file) + = read_type_info tcl_file + # (ok3,st_arity,tcl_file) + = read_type_info tcl_file + # (ok4,st_result,tcl_file) + = read_type_info tcl_file + + # symbol_type + = { default_elem & + st_vars = st_vars + , st_args = st_args + , st_arity = st_arity + , st_result = st_result + } + = (ok1&&ok2&&ok3&&ok4,symbol_type,tcl_file) + +instance ReadTypeInfo AType +where + read_type_info tcl_file + # (ok1,at_annotation,tcl_file) + = read_type_info tcl_file + # (ok2,at_type,tcl_file) + = read_type_info tcl_file + + # atype + = { default_elem & + at_annotation = at_annotation + , at_type = at_type + } + = (ok1&&ok2,atype,tcl_file) + + +instance ReadTypeInfo Type +where + read_type_info tcl_file + # (ok,c,tcl_file) + = freadc tcl_file + | not ok + = (False,default_elem,tcl_file) + + | c == TypeTACode + # (ok1,type_symb_ident,tcl_file) + = read_type_info tcl_file + # (ok2,atypes,tcl_file) + = read_type_info tcl_file + = (ok1&&ok2,TA type_symb_ident atypes,tcl_file) + + | c == TypeArrowCode + # (ok1,atype1,tcl_file) + = read_type_info tcl_file + # (ok2,atype2,tcl_file) + = read_type_info tcl_file + = (ok1&&ok2,atype1 --> atype2,tcl_file) + + | c == TypeConsApplyCode + # (ok1,cons_variable,tcl_file) + = read_type_info tcl_file + # (ok2,atypes,tcl_file) + = read_type_info tcl_file + = (ok1&&ok2,cons_variable :@: atypes,tcl_file) + + // TB BasicType + | c == BT_IntCode + = (True,TB BT_Int,tcl_file); + | c == BT_CharCode + = (True,TB BT_Char,tcl_file); + | c == BT_RealCode + = (True,TB BT_Real,tcl_file); + | c == BT_BoolCode + = (True,TB BT_Bool,tcl_file); + | c == BT_DynamicCode + = (True,TB BT_Dynamic,tcl_file); + | c == BT_FileCode + = (True,TB BT_File,tcl_file); + | c == BT_WorldCode + = (True,TB BT_World,tcl_file); + | c == BT_StringCode + # (ok,type,tcl_file) + = read_type_info tcl_file + = (ok,TB (BT_String type),tcl_file); + + | c == TypeGTVCode + # (ok,type_var,tcl_file) + = read_type_info tcl_file + = (ok,GTV type_var,tcl_file); + + | c == TypeTVCode + # (ok,type_var,tcl_file) + = read_type_info tcl_file + = (ok,TV type_var,tcl_file) + + | c == TypeTQVCode + # (ok,type_var,tcl_file) + = read_type_info tcl_file + = (ok,TQV type_var,tcl_file) + + | c == TypeTECode + = (True,TE,tcl_file) + +//instance ReadTypeInfo ConsVariable +//where + + */ + // basic and structural write_type_info's instance ReadTypeInfo Int |