diff options
Diffstat (limited to 'frontend')
-rw-r--r-- | frontend/convertDynamics.icl | 2 | ||||
-rw-r--r-- | frontend/type_io.dcl | 7 | ||||
-rw-r--r-- | frontend/type_io.icl | 739 | ||||
-rw-r--r-- | frontend/type_io_common.dcl | 43 | ||||
-rw-r--r-- | frontend/type_io_common.icl | 43 |
5 files changed, 90 insertions, 744 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index e67724d..502c0ed 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -60,6 +60,8 @@ write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_modul = write_type_info directly_imported_dcl_modules tcl_file #! tcl_file = fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file + #! tcl_file + = fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file = (True,tcl_file) //---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs); diff --git a/frontend/type_io.dcl b/frontend/type_io.dcl index 25e5aee..1ab9684 100644 --- a/frontend/type_io.dcl +++ b/frontend/type_io.dcl @@ -22,10 +22,3 @@ instance WriteTypeInfo String instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b //3.1 -// read -// read -class ReadTypeInfo a -where - read_type_info :: !*File -> (!Bool,a,!*File) - -instance ReadTypeInfo CommonDefs //,TypeDef TypeRhs, ConsDef diff --git a/frontend/type_io.icl b/frontend/type_io.icl index ec58cf3..e9b45ea 100644 --- a/frontend/type_io.icl +++ b/frontend/type_io.icl @@ -7,6 +7,7 @@ implementation module type_io import StdEnv, compare_constructor import scanner, general, Heap, typeproperties, utilities, checksupport +import type_io_common // 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 @@ -81,9 +82,6 @@ where = tcl_file -PrioCode =: toChar 0 -NoPrioCode =: toChar 1 - instance WriteTypeInfo Priority where write_type_info (Prio assoc i) tcl_file @@ -99,10 +97,6 @@ where = fwritec NoPrioCode tcl_file = tcl_file -LeftAssocCode =: toChar 2 -RightAssocCode =: toChar 3 -NoAssocCode =: toChar 4 - instance WriteTypeInfo Assoc where write_type_info LeftAssoc tcl_file @@ -164,11 +158,6 @@ where // writing tv_name as number suffices = write_type_info tv_name tcl_file -AlgTypeCode =: (toChar 5) -SynTypeCode =: (toChar 6) -RecordTypeCode =: (toChar 7) -AbstractTypeCode =: (toChar 8) - instance WriteTypeInfo TypeRhs where write_type_info (AlgType defined_symbols) tcl_file @@ -250,25 +239,7 @@ where # 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 @@ -341,11 +312,6 @@ where # tcl_file = fwritec TypeTECode tcl_file = tcl_file - - -ConsVariableCVCode =: (toChar 25) -ConsVariableTempCVCode =: (toChar 26) -ConsVariableTempQCVCode =: (toChar 27) instance WriteTypeInfo ConsVariable where @@ -440,704 +406,3 @@ where # tcl_file = fwritec c tcl_file; = tcl_file; - -// read -class ReadTypeInfo a -where - read_type_info :: !*File -> (!Bool,a,!*File) - -instance ReadTypeInfo CommonDefs -where - read_type_info tcl_file - # (ok1,com_type_defs,tcl_file) - = read_type_info tcl_file - # (ok2,com_cons_defs,tcl_file) - = read_type_info tcl_file - - # common_defs - = { CommonDefs | - com_type_defs = com_type_defs - , com_cons_defs = com_cons_defs - , com_selector_defs = {} - , com_class_defs = {} - , com_member_defs = {} - , com_instance_defs = {} - , com_generic_defs = {} - } - = (ok1&&ok2,common_defs,tcl_file) - -//1.3 -instance ReadTypeInfo TypeDef TypeRhs -//3.1 -/*2.0 -instance ReadTypeInfo (TypeDef a) | ReadTypeInfo a & DefaultElem a -0.2*/ -where - read_type_info tcl_file - // td_name - #! (ok1,td_name,tcl_file) - = read_type_info tcl_file - | F ("TypeDef '" +++ td_name.id_name +++ "'") not ok1 - = (False,default_elem,tcl_file) - - // td_arity - #! (ok2,td_arity,tcl_file) - = read_type_info tcl_file - | not ok2 - = (False,default_elem,tcl_file) - - // td_args - #! (ok2,td_args,tcl_file) - = read_type_info tcl_file - | not ok2 - = (False,default_elem,tcl_file) - - - // td_rhs - #! (ok2,td_rhs,tcl_file) - = read_type_info tcl_file - | not ok2 - = (False,default_elem,tcl_file) - - - # type_def - = updateTypeDefRhs { default_elem & - td_name = td_name - , td_arity = td_arity - , td_args = td_args - } td_rhs - = (ok1,type_def,tcl_file) - -updateTypeDefRhs :: (TypeDef a) a -> (TypeDef a) -updateTypeDefRhs type_def rhs - = {type_def & td_rhs = rhs} - -instance ReadTypeInfo TypeRhs -where - read_type_info tcl_file - # (ok1,c,tcl_file) - = freadc tcl_file - | not ok1 - = (False,default_elem,tcl_file) - - | c == AlgTypeCode - # (ok,defined_symbols,tcl_file) - = read_type_info tcl_file - = (ok,AlgType defined_symbols,tcl_file) - - | c == SynTypeCode - = (True,UnknownType,tcl_file) - | c == RecordTypeCode - # (ok,rt_fields,tcl_file) - = read_type_info tcl_file - - # record_type - = { default_elem & - rt_fields = rt_fields - }; - = (True,RecordType record_type,tcl_file) - - | c == AbstractTypeCode - = (True,UnknownType,tcl_file) - -instance ReadTypeInfo Priority -where - read_type_info tcl_file - # (ok1,p,tcl_file) - = freadc tcl_file - | not ok1 - = (False,default_elem,tcl_file) - - | p == PrioCode - # (ok1,assoc,tcl_file) - = read_type_info tcl_file - # (ok2,i,tcl_file) - = read_type_info tcl_file - - # prio - = Prio assoc i - = (ok1&&ok2,prio,tcl_file) - - | p == NoPrioCode - = (ok1,NoPrio,tcl_file) - -instance ReadTypeInfo Assoc -where - read_type_info tcl_file - # (ok1,a,tcl_file) - = freadc tcl_file - | not ok1 - = (False,default_elem,tcl_file) - - | a == LeftAssocCode - = (ok1,LeftAssoc,tcl_file) - | a == RightAssocCode - = (ok1,RightAssoc,tcl_file) - | a == NoAssocCode - = (ok1,NoAssoc,tcl_file) - -instance ReadTypeInfo DefinedSymbol -where - read_type_info tcl_file - // ds_ident - # (ok1,ds_ident,tcl_file) - = read_type_info tcl_file - | not ok1 - = (False,default_elem,tcl_file) - - // ds_arity - # (ok2,ds_arity,tcl_file) - = read_type_info tcl_file - | not ok2 - = (False,default_elem,tcl_file) - - // ds_index - # (ok3,ds_index,tcl_file) - = read_type_info tcl_file - - # defined_symbol - = { default_elem & - ds_ident = ds_ident - , ds_arity = ds_arity - , ds_index = ds_index - } - = (ok3,defined_symbol,tcl_file) - - -instance ReadTypeInfo ConsDef -where - read_type_info tcl_file - # (ok1,cons_symb,tcl_file) - = read_type_info 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 - # (ok4,cons_priority,tcl_file) - = read_type_info tcl_file - - # (ok5,cons_index,tcl_file) - = read_type_info tcl_file - # (ok6,cons_type_index,tcl_file) - = read_type_info 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 - - , cons_index = cons_index - , cons_type_index = cons_type_index - , cons_exi_vars = cons_exi_vars - } - = (ok1&&ok2&&ok3&&ok4&&ok5&&ok6&&ok7,consdef,tcl_file) - -instance ReadTypeInfo Char -where - read_type_info :: !*File -> (!Bool,Char,!*File) - read_type_info tcl_file - = freadc tcl_file - -instance ReadTypeInfo Ident -where - read_type_info :: !*File -> (!Bool,Ident,!*File) - read_type_info tcl_file - # (ok1,i,tcl_file) - = freadi tcl_file - # (id_name,tcl_file) - = freads tcl_file i; - | F ("Ident " +++ toString i +++ " - " +++ id_name) True - - # ident - = { default_elem & - id_name = id_name - , id_info = nilPtr - } - = (ok1,ident,tcl_file) - -instance ReadTypeInfo ATypeVar -where - read_type_info tcl_file - // atv_annotation - # (ok1,atv_annotation,tcl_file) - = read_type_info tcl_file - | not ok1 - = (False,default_elem,tcl_file) - - // atv_variable - # (ok2,atv_variable,tcl_file) - = read_type_info tcl_file - | not ok2 - = (False,default_elem,tcl_file) - - # atypevar - = { default_elem & - atv_annotation = atv_annotation - , atv_variable = atv_variable - } - = (True,atypevar,tcl_file) - -instance ReadTypeInfo TypeVar -where - read_type_info tcl_file - # (ok1,tv_name,tcl_file) - = read_type_info tcl_file - - # typevar - = { default_elem & - tv_name = tv_name - } - = (ok1,typevar,tcl_file) - -instance ReadTypeInfo Annotation -where - read_type_info tcl_file - #! (ok1,c,tcl_file) - = freadc tcl_file - - # annotation - = if (c == '!') AN_Strict AN_None - = (ok1,annotation,tcl_file) - -instance ReadTypeInfo FieldSymbol -where - read_type_info tcl_file - # (ok1,fs_name,tcl_file) - = read_type_info tcl_file - # (ok2,fs_var,tcl_file) - = read_type_info tcl_file - # (ok3,fs_index,tcl_file) - = read_type_info tcl_file - - # field_symbol - = { FieldSymbol | - fs_name = fs_name - , fs_var = fs_var - , 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 - read_type_info tcl_file - = abort "instance ReadTypeInfo ConsVariable" - -instance ReadTypeInfo TypeSymbIdent -where - read_type_info tcl_file - # (ok1,type_name,tcl_file) - = read_type_info tcl_file - # (ok2,type_arity,tcl_file) - = read_type_info tcl_file - - # type_symb_ident - = { default_elem & - type_name = type_name - , type_arity = type_arity - } - - = (ok1&&ok2,type_symb_ident,tcl_file) - -// basic and structural write_type_info's -instance ReadTypeInfo Int -where - read_type_info :: !*File -> (!Bool,Int,!*File) - read_type_info tcl_file - = freadi tcl_file - -//1.3 -instance ReadTypeInfo {#b} | ReadTypeInfo b & DefaultElem b & ArrayElem b -//3.1 -/*2.0 -instance ReadTypeInfo {#b} | ReadTypeInfo b & DefaultElem b & Array {#} b -0.2*/ -where - read_type_info tcl_file - - # (ok,s_unboxed_array,tcl_file) - = freadi tcl_file - | F ("s_unboxed_array: " +++ toString s_unboxed_array) not ok - = (False,{default_elem},tcl_file) - - # unboxed_array - = { default_elem \\ i <- [1..s_unboxed_array] } - = read_type_info_loop 0 s_unboxed_array tcl_file unboxed_array - - where - read_type_info_loop i limit tcl_file unboxed_array - | F (" " +++ toString i) i == limit - = (True,unboxed_array,tcl_file) - - # (ok,elem,tcl_file) - = read_type_info tcl_file - | not ok - = (False,unboxed_array,tcl_file) - - = read_type_info_loop (inc i) limit tcl_file {unboxed_array & [i] = elem} - - -instance ReadTypeInfo [a] | ReadTypeInfo a -where - read_type_info tcl_file - # (ok1,limit,tcl_file) - = freadi tcl_file - | not ok1 - = (False,[],tcl_file) - - = read_type_info_loop 0 limit tcl_file [] - where - read_type_info_loop i limit tcl_file elems - | i == limit - = (True,reverse elems,tcl_file) - - # (ok,elem,tcl_file) - = read_type_info tcl_file - | not ok - = (False,[],tcl_file) - = read_type_info_loop (inc i) limit tcl_file [elem:elems] - -// defaults -class DefaultElem a -where - default_elem :: a - -//1.3 -instance DefaultElem (TypeDef TypeRhs) -//3.1 -/*2.0 -instance DefaultElem (TypeDef a) | DefaultElem a -0.2*/ -where - default_elem - = { TypeDef | - td_name = default_elem - , td_index = default_elem - , td_arity = default_elem - , td_args = default_elem - , td_attrs = default_elem - , td_context = default_elem - , td_rhs = default_elem - , td_attribute = default_elem - , td_pos = default_elem - } - -instance DefaultElem Position -where - default_elem - = NoPos - -instance DefaultElem TypeAttribute -where - default_elem - = TA_None - -instance DefaultElem TypeRhs -where - default_elem - = UnknownType - -instance DefaultElem ATypeVar -where - default_elem - = { ATypeVar | - atv_attribute = TA_None - , atv_annotation = AN_None - , atv_variable = default_elem - } - -instance DefaultElem TypeVar -where - default_elem - = { TypeVar | - tv_name = default_elem - , tv_info_ptr = default_elem - } - -instance DefaultElem (Ptr a) -where - default_elem - = nilPtr - -instance DefaultElem Ident -where - default_elem - = { Ident | - id_name = {} - , id_info = default_elem - } - - -instance DefaultElem TypeVarInfo -where - default_elem - = TVI_Empty - -instance DefaultElem SymbolTableEntry -where - default_elem - = { SymbolTableEntry | - ste_kind = STE_Empty - , ste_index = NoIndex - , ste_def_level = NotALevel - , ste_previous = abort "instance DefaultElem SymboltableEntry" - } - -instance DefaultElem [a] -where - default_elem - = [] - -instance DefaultElem Int -where - default_elem - = 0 - -instance DefaultElem DefinedSymbol -where - default_elem - = { DefinedSymbol | - ds_ident = default_elem - , ds_arity = default_elem - , ds_index = default_elem - } - -instance DefaultElem ConsDef -where - default_elem - = { ConsDef | - cons_symb = default_elem - , cons_type = default_elem - , cons_arg_vars = default_elem - , cons_priority = default_elem - , cons_index = default_elem - , cons_type_index = default_elem - , cons_exi_vars = default_elem - , cons_type_ptr = default_elem - , cons_pos = default_elem - } - -instance DefaultElem Priority -where - default_elem - = NoPrio - -instance DefaultElem SymbolType -where - default_elem - = { SymbolType | - st_vars = [] //default_elem - , st_args = [] //default_elem - , st_arity = 0 //default_elem - , st_result = default_elem - , st_context = [] //default_elem - , st_attr_vars = [] //default_elem - , st_attr_env = [] //default_elem - } - -instance DefaultElem VarInfo -where - default_elem - = VI_Empty - -instance DefaultElem AType -where - default_elem - = { AType | - at_attribute = default_elem - , at_annotation = default_elem - , at_type = default_elem - } - -instance DefaultElem Type -where - default_elem - = TE - -instance DefaultElem Annotation -where - default_elem - = AN_None - -instance DefaultElem Assoc -where - default_elem - = NoAssoc - - -instance DefaultElem RecordType -where - default_elem - = { RecordType | - rt_constructor = default_elem - , rt_fields = {} - } - -instance DefaultElem FieldSymbol -where - default_elem - = { FieldSymbol | - fs_name = default_elem - , fs_var = default_elem - , fs_index = default_elem - } - -//1.3 -instance DefaultElem {#a} | ArrayElem, DefaultElem a -//3.1 -/*2.0 -instance DefaultElem {#a} | Array {#} a & DefaultElem a -0.2*/ -where - default_elem - = {default_elem} - -instance DefaultElem TypeSymbIdent -where - default_elem - = { TypeSymbIdent | - type_name = default_elem - , type_arity = default_elem - , type_index = default_elem - , type_prop = default_elem - } - -instance DefaultElem TypeSymbProperties -where - default_elem - = { TypeSymbProperties | - tsp_sign = default_elem - , tsp_propagation = default_elem - , tsp_coercible = default_elem - } - -instance DefaultElem (Global a) | DefaultElem a -where - default_elem - = { Global | - glob_object = default_elem - , glob_module = default_elem - } - -instance DefaultElem Bool -where - default_elem - = False - -instance DefaultElem SignClassification -where - default_elem - = { SignClassification | - sc_pos_vect = default_elem - , sc_neg_vect = default_elem - } diff --git a/frontend/type_io_common.dcl b/frontend/type_io_common.dcl new file mode 100644 index 0000000..65b0225 --- /dev/null +++ b/frontend/type_io_common.dcl @@ -0,0 +1,43 @@ +definition module type_io_common + +from StdChar import toChar + +// Priority +PrioCode :== toChar 0 +NoPrioCode :== toChar 1 + +// Assoc +LeftAssocCode :== toChar 2 +RightAssocCode :== toChar 3 +NoAssocCode :== toChar 4 + +// TypeRhs +AlgTypeCode :== (toChar 5) +SynTypeCode :== (toChar 6) +RecordTypeCode :== (toChar 7) +AbstractTypeCode :== (toChar 8) + +// Type +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 + +// Type; TB +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) + +// ConsVariable +ConsVariableCVCode :== (toChar 25) +ConsVariableTempCVCode :== (toChar 26) +ConsVariableTempQCVCode :== (toChar 27) diff --git a/frontend/type_io_common.icl b/frontend/type_io_common.icl new file mode 100644 index 0000000..c64626c --- /dev/null +++ b/frontend/type_io_common.icl @@ -0,0 +1,43 @@ +implementation module type_io_common + +from StdChar import toChar + +// Priority +PrioCode :== toChar 0 +NoPrioCode :== toChar 1 + +// Assoc +LeftAssocCode :== toChar 2 +RightAssocCode :== toChar 3 +NoAssocCode :== toChar 4 + +// TypeRhs +AlgTypeCode :== (toChar 5) +SynTypeCode :== (toChar 6) +RecordTypeCode :== (toChar 7) +AbstractTypeCode :== (toChar 8) + +// Type +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 + +// Type; TB +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) + +// ConsVariable +ConsVariableCVCode :== (toChar 25) +ConsVariableTempCVCode :== (toChar 26) +ConsVariableTempQCVCode :== (toChar 27) |