diff options
| -rw-r--r-- | backend/backendconvert.icl | 11 | ||||
| -rw-r--r-- | frontend/check.dcl | 2 | ||||
| -rw-r--r-- | frontend/check.icl | 101 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 5 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 6 | ||||
| -rw-r--r-- | frontend/containers.dcl | 1 | ||||
| -rw-r--r-- | frontend/containers.icl | 18 | ||||
| -rw-r--r-- | frontend/frontend.icl | 10 | ||||
| -rw-r--r-- | frontend/parse.icl | 256 | ||||
| -rw-r--r-- | frontend/postparse.icl | 91 | ||||
| -rw-r--r-- | frontend/predef.icl | 2 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 3 | ||||
| -rw-r--r-- | frontend/scanner.icl | 9 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 |
14 files changed, 311 insertions, 206 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index 05dfd16..90aeec9 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -382,7 +382,7 @@ backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState backEndConvertModulesH predefs {fe_icl = - fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,icl_imported_objects,icl_used_module_numbers, icl_modification_time}, + fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time}, fe_components, fe_dcls, fe_arrayInstances} main_dcl_module_n backEnd // sanity check ... @@ -463,6 +463,7 @@ backEndConvertModulesH predefs {fe_icl = (convertStrings [imported.io_name \\ imported <- icl_imported_objects | not imported.io_is_library]) (convertStrings [imported.io_name \\ imported <- icl_imported_objects | imported.io_is_library]) (backEnd -*-> "beDefineImportedObjsAndLibs") + #! backEnd = appBackEnd (convertForeignExports icl_foreign_exports main_dcl_module_n) backEnd #! backEnd = markExports fe_dcls.[main_dcl_module_n] dcl_common.com_class_defs dcl_common.com_type_defs icl_common.com_class_defs icl_common.com_type_defs (backEnd -*-> "markExports") with @@ -2054,6 +2055,14 @@ getVariableSequenceNumber varInfoPtr be VI_AliasSequenceNumber {var_info_ptr} -> getVariableSequenceNumber var_info_ptr be +convertForeignExports :: [Int] Int BackEnd -> BackEnd +convertForeignExports [functionIndex:icl_foreign_exports] main_dcl_module_n backEnd + # backEnd = convertForeignExports icl_foreign_exports main_dcl_module_n backEnd + # (function_symbol_p,backEnd) = BEFunctionSymbol functionIndex main_dcl_module_n backEnd + = BEInsertForeignExport function_symbol_p backEnd +convertForeignExports [] main_dcl_module_n backEnd + = backEnd + foldStateWithIndex function n :== foldStateWithIndexTwice 0 where diff --git a/frontend/check.dcl b/frontend/check.dcl index 9501cd6..6977364 100644 --- a/frontend/check.dcl +++ b/frontend/check.dcl @@ -10,6 +10,8 @@ checkFunctions :: !Index !Level !Index !Index !Int !*{#FunDef} !*ExpressionInfo checkDclMacros :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo,!*Heaps,!*CheckState) + +checkForeignExportedFunctionTypes :: !*ErrorAdmin ![Int] !*{#FunDef} -> (!*ErrorAdmin,!*{#FunDef}) determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin -> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin) diff --git a/frontend/check.icl b/frontend/check.icl index ff9db8a..d7ee071 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2242,7 +2242,7 @@ renumber_icl_module mod_type icl_global_function_range icl_instance_range icl_ge checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !*{#*{#FunDef}} !*PredefinedSymbols !*SymbolTable !*File !*Heaps -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !*{#*{#FunDef}},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File, [String]) -checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache +checkModule {mod_defs,mod_ident,mod_type,mod_imports,mod_imported_objects,mod_foreign_exports,mod_modification_time} icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod scanned_modules dcl_modules cached_dcl_macros predef_symbols symbol_table err_file heaps # nr_of_cached_modules = size dcl_modules # (optional_pre_def_mod,predef_symbols) @@ -2250,13 +2250,13 @@ checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_m 0 # (predef_mod,predef_symbols) = buildPredefinedModule predef_symbols -> (Yes predef_mod,predef_symbols) _ -> (No,predef_symbols) - # (mod_ident,mod_imported_objects,mod_imports,mod_type,icl_global_function_range,nr_of_functions,first_inst_index,first_gen_inst_index, local_defs,icl_functions,macro_defs,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) - = check_module1 m icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules cached_dcl_macros dcl_module_n_in_cache predef_symbols symbol_table err_file + # (icl_global_function_range,nr_of_functions,first_inst_index,first_gen_inst_index, local_defs,icl_functions,macro_defs,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) + = check_module1 mod_defs icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules cached_dcl_macros dcl_module_n_in_cache predef_symbols symbol_table err_file # icl_instance_range = {ir_from = first_inst_index, ir_to = first_gen_inst_index/*AA nr_of_functions*/} # icl_generic_range = {ir_from = first_gen_inst_index, ir_to = nr_of_functions} //AA - = check_module2 mod_ident m.mod_modification_time mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range icl_generic_range nr_of_functions nr_of_cached_modules optional_pre_def_mod local_defs icl_functions macro_defs init_dcl_modules cdefs sizes heaps cs + = check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports mod_foreign_exports mod_type icl_global_function_range icl_instance_range icl_generic_range nr_of_functions nr_of_cached_modules optional_pre_def_mod local_defs icl_functions macro_defs init_dcl_modules cdefs sizes heaps cs -check_module1 {mod_type,mod_ident,mod_imports,mod_imported_objects,mod_defs = cdefs} icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules cached_dcl_macros dcl_module_n_in_cache predef_symbols symbol_table err_file +check_module1 cdefs icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules cached_dcl_macros dcl_module_n_in_cache predef_symbols symbol_table err_file # error = {ea_file = err_file, ea_loc = [], ea_ok = True } first_inst_index = length fun_defs @@ -2296,7 +2296,7 @@ check_module1 {mod_type,mod_ident,mod_imports,mod_imported_objects,mod_defs = cd dcl_modules.[i] init_new_dcl_modules.[i-size dcl_modules] \\ i<-[0..size dcl_modules+size init_new_dcl_modules-1]} - = (mod_ident,mod_imported_objects,mod_imports,mod_type,icl_global_function_range,nr_of_functions,first_inst_index,first_gen_inst_index,local_defs,icl_functions,macro_defs,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) + = (icl_global_function_range,nr_of_functions,first_inst_index,first_gen_inst_index,local_defs,icl_functions,macro_defs,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) where add_dcl_module_predef_module_and_modules_to_symbol_table (Yes dcl_mod) optional_predef_mod modules mod_index cs @@ -2425,11 +2425,11 @@ check_module1 {mod_type,mod_ident,mod_imports,mod_imported_objects,mod_defs = cd fill_macro_def_array i [dcl_macro_defs:macro_defs] a = fill_macro_def_array (i+1) macro_defs {a & [i]=dcl_macro_defs} -check_module2 :: Ident {#Char} [.ImportedObject] .[Import ImportDeclaration] .ModuleKind !.IndexRange !.IndexRange !.IndexRange !Int !Int +check_module2 :: Ident {#Char} [.ImportedObject] .[Import ImportDeclaration] [IdentPos] .ModuleKind !.IndexRange !.IndexRange !.IndexRange !Int !Int (Optional (Module a)) [Declaration] *{#FunDef} *{#*{#FunDef}} *{#DclModule} (CollectedDefinitions ClassInstance IndexRange) *{#.Int} *Heaps *CheckState -> (!Bool,.IclModule,!.{#DclModule},.{!Group},!*{#*{#FunDef}},!Int,!.Heaps,!.{#PredefinedSymbol},!.Heap SymbolTableEntry,!.File,[String]); -check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range icl_generic_range nr_of_functions nr_of_cached_modules optional_pre_def_mod local_defs icl_functions macro_defs init_dcl_modules cdefs sizes heaps cs +check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports mod_foreign_exports mod_type icl_global_function_range icl_instance_range icl_generic_range nr_of_functions nr_of_cached_modules optional_pre_def_mod local_defs icl_functions macro_defs init_dcl_modules cdefs sizes heaps cs # (main_dcl_module_n,cs)=cs!cs_x.x_main_dcl_module_n (copied_dcl_defs, dcl_conversions, dcl_modules, local_defs, cdefs, icl_sizes, cs) @@ -2493,9 +2493,6 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m heaps = { heaps & hp_expression_heap=hp_expression_heap } - icl_imported - = { el \\ el<-dcls_import_list } - icl_imported = { el \\ el<-dcls_import_list } (_,icl_common, dcl_modules, heaps=:{hp_var_heap, hp_type_heaps}, cs) @@ -2503,6 +2500,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m (instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs) = checkInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs + heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } e_info = { ef_type_defs = icl_common.com_type_defs, ef_selector_defs = icl_common.com_selector_defs, ef_class_defs = icl_common.com_class_defs, @@ -2520,6 +2518,8 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m (icl_functions, e_info, heaps, cs) = checkInstanceBodies icl_instances_ranges local_functions_index_offset icl_functions e_info heaps cs + (foreign_exports,icl_functions,cs) = checkForeignExports mod_foreign_exports icl_global_functions_ranges icl_functions cs + cs = check_needed_modules_are_imported mod_ident ".icl" cs {cs_symbol_table, cs_predef_symbols, cs_error,cs_x } = cs @@ -2551,11 +2551,11 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs, com_generic_defs = e_info.ef_generic_defs, com_instance_defs = class_instances } - icl_mod = { icl_name = mod_ident, icl_functions = icl_functions, icl_common = icl_common, - icl_global_functions = icl_global_functions_ranges, icl_instances = icl_instances_ranges, icl_specials = icl_specials, - icl_gencases = icl_generic_ranges, - icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, - icl_import = icl_imported, icl_modification_time = mod_modification_time} + icl_mod = { icl_name = mod_ident, icl_functions = icl_functions, icl_common = icl_common, icl_global_functions = icl_global_functions_ranges, + icl_instances = icl_instances_ranges, icl_specials = icl_specials, icl_gencases = icl_generic_ranges, + icl_import = icl_imported, icl_imported_objects = mod_imported_objects, icl_foreign_exports = foreign_exports, + icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, + icl_modification_time = mod_modification_time} heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} (main_dcl_module, dcl_modules) = dcl_modules![main_dcl_module_n] @@ -2576,10 +2576,10 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs, com_generic_defs = e_info.ef_generic_defs } icl_mod = { icl_name = mod_ident, icl_functions = icl_functions, icl_common = icl_common, icl_global_functions = icl_global_functions_ranges, icl_instances = icl_instances_ranges, - icl_specials = {ir_from = nr_of_functions, ir_to = nr_of_functions}, - icl_gencases = icl_generic_ranges, - icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, - icl_import = icl_imported ,icl_modification_time = mod_modification_time} + icl_specials = {ir_from = nr_of_functions, ir_to = nr_of_functions}, icl_gencases = icl_generic_ranges, + icl_import = icl_imported, icl_imported_objects = mod_imported_objects, icl_foreign_exports = foreign_exports, + icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, + icl_modification_time = mod_modification_time} = (False, icl_mod, dcl_modules, {}, {}, cs_x.x_main_dcl_module_n,heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file, directly_imported_dcl_modules) where check_start_rule mod_kind mod_ident icl_global_functions_ranges cs=:{cs_symbol_table,cs_x} @@ -2730,6 +2730,67 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m -> ( popErrorAdmin cs_error, type_heaps) = (icl_functions, type_heaps, cs_error) +checkForeignExports :: [IdentPos] [IndexRange] *{#FunDef} *CheckState -> (![Int],!*{#FunDef},!*CheckState) +checkForeignExports [ident_pos=:{ip_ident={id_name,id_info}}:foreign_exports] icl_global_functions_ranges fun_defs cs + # ({ste_kind,ste_index},cs_symbol_table) = readPtr id_info cs.cs_symbol_table + # cs = { cs & cs_symbol_table = cs_symbol_table } + # (foreign_export_fundef_index,fun_defs,cs) = check_foreign_export ste_kind icl_global_functions_ranges fun_defs cs + with + check_foreign_export (STE_FunctionOrMacro _) [{ir_from, ir_to}:_] fun_defs cs + | ste_index>=ir_from && ste_index<ir_to + # ({fun_type,fun_ident,fun_pos},fun_defs) = fun_defs![ste_index] + # (foreign_export_fundef_index,cs) = case fun_type of + No + -> ([],cs) + Yes {st_args,st_args_strictness,st_arity,st_result,st_context} + | not (isEmpty st_context) + -> ([],{cs & cs_error = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in type of foreign exported function (context not allowed)" cs.cs_error}) + | not (first_n_are_strict st_arity st_args_strictness) + -> ([],{cs & cs_error = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in type of foreign exported function (strictness annotation missing)" cs.cs_error}) + -> ([ste_index],cs) + = (foreign_export_fundef_index,fun_defs,cs) + check_foreign_export (STE_FunctionOrMacro _) [_,{ir_from, ir_to}:_] fun_defs cs + | ste_index>=ir_from && ste_index<ir_to + = ([],fun_defs,{cs & cs_error = checkErrorWithIdentPos ident_pos "has not been exported" cs.cs_error}) + check_foreign_export _ _ fun_defs cs + = ([],fun_defs,{cs & cs_error = checkErrorWithIdentPos ident_pos "has not been declared" cs.cs_error}) + # (foreign_export_fundef_indexes,fun_defs,cs) = checkForeignExports foreign_exports icl_global_functions_ranges fun_defs cs + = (foreign_export_fundef_index++foreign_export_fundef_indexes,fun_defs,cs) +checkForeignExports [] icl_global_functions_ranges fun_defs cs + = ([],fun_defs,cs) + +checkForeignExportedFunctionTypes :: !*ErrorAdmin ![Int] !*{#FunDef} -> (!*ErrorAdmin,!*{#FunDef}) +checkForeignExportedFunctionTypes error_admin [fun_def_index:icl_foreign_exports] fun_defs + # error_admin = if (check_foreign_export_result_type st_result.at_type) + error_admin + (checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in result type for foreign exported function" error_admin) + # error_admin = if (check_foreign_export_types st_args) + error_admin + (checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in argument type for foreign exported function" error_admin) + = checkForeignExportedFunctionTypes error_admin icl_foreign_exports fun_defs2 + where + ({fun_type=Yes {st_args,st_result},fun_ident,fun_pos},fun_defs2) = fun_defs![fun_def_index] + + check_foreign_export_result_type (TB BT_Int) + = True + check_foreign_export_result_type _ + = False + + check_foreign_export_types [{at_type}:argument_types] + = check_foreign_export_type at_type && check_foreign_export_types argument_types + check_foreign_export_types [] + = True + + check_foreign_export_type (TB BT_Int) + = True + check_foreign_export_type (TAS {type_arity,type_index={glob_object,glob_module}} arguments strictness) + = glob_module==cPredefinedModuleIndex && glob_object==PD_Arity2TupleTypeIndex+(type_arity-2) + && first_n_are_strict type_arity strictness && check_foreign_export_types arguments + check_foreign_export_type _ + = False +checkForeignExportedFunctionTypes error_admin [] fun_defs + = (error_admin,fun_defs) + check_needed_modules_are_imported mod_ident extension cs=:{cs_x={x_needed_modules}} # cs = case x_needed_modules bitand cNeedStdGeneric of 0 -> cs diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index e473b13..aac7976 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -87,6 +87,8 @@ cConversionTableSize :== 10 , copied_generic_defs :: {#Bool} } +:: FunDefIndex:==Int + :: IclModule = { icl_name :: !Ident , icl_functions :: !.{# FunDef } @@ -97,11 +99,10 @@ cConversionTableSize :== 10 , icl_common :: !.CommonDefs , icl_import :: !{!Declaration} , icl_imported_objects :: ![ImportedObject] + , icl_foreign_exports :: ![FunDefIndex] , icl_used_module_numbers :: !NumberSet , icl_copied_from_dcl :: !CopiedDefinitions -// RWS ... , icl_modification_time :: !{#Char} -// ... RWS } :: DclModule = diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index f015f73..77aa745 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -103,6 +103,8 @@ where , copied_generic_defs :: {#Bool} } +:: FunDefIndex:==Int + :: IclModule = { icl_name :: !Ident , icl_functions :: !.{# FunDef } @@ -113,11 +115,10 @@ where , icl_common :: !.CommonDefs , icl_import :: !{!Declaration} , icl_imported_objects :: ![ImportedObject] + , icl_foreign_exports :: ![FunDefIndex] , icl_used_module_numbers :: !NumberSet , icl_copied_from_dcl :: !CopiedDefinitions -// RWS ... , icl_modification_time :: !{#Char} -// ... RWS } :: DclModule = @@ -254,7 +255,6 @@ retrieveGlobalDefinition {ste_kind,ste_def_level,ste_index} requ_kind mod_index = (ste_index, mod_index) = (NotFound, mod_index) - getBelongingSymbols :: !Declaration !v:{#DclModule} -> (!BelongingSymbols, !v:{#DclModule}) getBelongingSymbols (Declaration {decl_kind=STE_Imported STE_Type def_mod_index, decl_index}) dcl_modules # ({td_rhs}, dcl_modules) diff --git a/frontend/containers.dcl b/frontend/containers.dcl index 587f884..6b8142e 100644 --- a/frontend/containers.dcl +++ b/frontend/containers.dcl @@ -41,6 +41,7 @@ equal_strictness_lists :: !StrictnessList !StrictnessList -> Bool add_next_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList) add_next_not_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList) append_strictness :: !Int !StrictnessList -> StrictnessList +first_n_are_strict :: !Int !StrictnessList -> Bool :: IntKey :== Int diff --git a/frontend/containers.icl b/frontend/containers.icl index fae67f1..eaaa08c 100644 --- a/frontend/containers.icl +++ b/frontend/containers.icl @@ -326,6 +326,24 @@ append_strictness strictness (Strict s) append_strictness strictness (StrictList s l) = StrictList s (append_strictness strictness l) +first_n_are_strict :: !Int !StrictnessList -> Bool +first_n_are_strict 0 _ + = True +first_n_are_strict n NotStrict + = False +first_n_are_strict n (Strict s) + | n>32 + = False + | n==32 + = s==0xffffffff + # m=(1<<n)-1 + = s bitand m==m +first_n_are_strict n (StrictList s l) + | n>=32 + = s==0xffffffff && first_n_are_strict (n-32) l + # m=(1<<n)-1 + = s bitand m==m + screw :== 80 :: IntKey :== Int diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 1cae9cc..12bd1f7 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -62,7 +62,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an select_and_remove_icl_functions_from_record :: !*IclModule -> (!.{#FunDef},!.IclModule) select_and_remove_icl_functions_from_record icl_mod=:{icl_functions} = (icl_functions,{icl_mod & icl_functions={}}) - # {icl_global_functions,icl_instances,icl_gencases, icl_specials, icl_common,icl_import,icl_name,icl_imported_objects,icl_used_module_numbers,icl_copied_from_dcl} = icl_mod + # {icl_global_functions,icl_instances,icl_gencases, icl_specials, icl_common,icl_name,icl_import,icl_imported_objects,icl_foreign_exports,icl_used_module_numbers,icl_copied_from_dcl} = icl_mod /* (_,f,files) = fopen "components" FWriteText files (components, icl_functions, f) = showComponents components 0 True icl_functions f @@ -200,6 +200,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an = (pds_def, predef_symbols) = (NoIndex, predef_symbols) + # (error_admin,fun_defs) = checkForeignExportedFunctionTypes error_admin icl_foreign_exports fun_defs + # [icl_exported_global_functions,icl_not_exported_global_functions:_] = icl_global_functions # exported_global_functions = case start_rule_index of NoIndex -> [icl_exported_global_functions] @@ -267,9 +269,9 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an # fe ={ fe_icl = // {icl_mod & icl_functions=fun_defs } {icl_functions=fun_defs,icl_global_functions=icl_global_functions,icl_instances=icl_instances,icl_specials=icl_specials, - icl_common=icl_common,icl_import=icl_import, - icl_gencases = icl_gencases ++ generic_ranges, - icl_name=icl_name,icl_imported_objects=icl_imported_objects,icl_used_module_numbers=icl_used_module_numbers, + icl_common=icl_common, icl_gencases = icl_gencases ++ generic_ranges, + icl_import=icl_import, icl_imported_objects=icl_imported_objects, icl_foreign_exports=icl_foreign_exports, + icl_name=icl_name,icl_used_module_numbers=icl_used_module_numbers, icl_copied_from_dcl=icl_copied_from_dcl,icl_modification_time=icl_mod.icl_modification_time} , fe_dcls = dcl_mods diff --git a/frontend/parse.icl b/frontend/parse.icl index f2357cb..22c45b5 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -292,7 +292,7 @@ wantModule iclmodule file_id=:{id_name} import_file_position support_generics ha # hash_table=set_hte_mark 0 hash_table ->(ok,mod,hash_table,file,files) (No, files) - -> let mod = { mod_ident = file_id, mod_modification_time = "", mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in + -> let mod = { mod_ident = file_id, mod_modification_time = "", mod_type = MK_None, mod_imports = [], mod_imported_objects = [],mod_foreign_exports=[],mod_defs = [] } in (False, mod, hash_table, error <<< "Error " <<< import_file_position <<< ": " <<< file_name <<< " could not be imported\n", files) where file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") @@ -317,7 +317,7 @@ where defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics" && id_name <> "StdGeneric") [PD_Import imports \\ PD_Import imports <- defs] defs - mod = { mod_ident = mod_ident, mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = defs } + mod = { mod_ident = mod_ident, mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_foreign_exports=[],mod_defs = defs } = ( ps_error.pea_ok , mod, ps_hash_table , ps_error.pea_file @@ -325,7 +325,7 @@ where ) // otherwise // ~ succ # ({fp_line}, scanState) = getPosition scanState - mod = { mod_ident = file_id, mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = [] } + mod = { mod_ident = file_id, mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [],mod_foreign_exports=[],mod_defs = [] } = (False, mod, hash_table, error <<< "Error [" <<< file_name <<< ',' <<< fp_line <<< "]: incorrect module header", closeScanner scanState files) @@ -414,147 +414,59 @@ where = (False,abort "no def(3)",parseError "definition" No "type definitions only at the global level" (tokenBack pState)) # (def, pState) = wantTypeDef parseContext pos pState = (True, def, pState) + try_definition parseContext (IdentToken name) pos pState + # (token, pState) = nextToken FunctionContext pState + = case token of + GenericOpenToken + // generic function + -> wantGenericFunctionDefinition name pos pState + _ // normal function + # pState = tokenBack pState + # (lhs, pState) = want_lhs_of_def (IdentToken name) pState + (token, pState) = nextToken FunctionContext pState + (def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState + -> (True, def, pState) try_definition _ ImportToken pos pState | ~(isGlobalContext parseContext) = (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState) # (token, pState) = nextToken FunctionContext pState | token == CodeToken && isIclContext parseContext - # (importedObjects, pState) = wantCodeImports pState - = (True, PD_ImportedObjects importedObjects, pState) - # pState = tokenBack pState - # (imports, pState) = wantImports pState - = (True, PD_Import imports, pState) + # (importedObjects, pState) = wantCodeImports pState + = (True, PD_ImportedObjects importedObjects, pState) + # pState = tokenBack pState + # (imports, pState) = wantImports pState + = (True, PD_Import imports, pState) try_definition _ FromToken pos pState | ~(isGlobalContext parseContext) = (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState) # (imp, pState) = wantFromImports pState = (True, PD_Import [imp], pState) -->> imp -/* try_definition _ ExportToken pos pState - # (exports, pState) = wantExportDef pState - = (True, PD_Export exports, pState) - try_definition _ ExportAllToken pos pState - = (True, PD_Export ExportAll, pState) -*/ try_definition parseContext ClassToken pos pState + try_definition parseContext ClassToken pos pState | ~(isGlobalContext parseContext) = (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState) # (classdef, pState) = wantClassDefinition parseContext pos pState = (True, classdef, pState) - // AA.. try_definition parseContext GenericToken pos pState | ~(isGlobalContext parseContext) = (False,abort "no def(2)",parseError "definition" No "generic definitions are only at the global level" pState) # (gendef, pState) = wantGenericDefinition parseContext pos pState = (True, gendef, pState) - try_definition parseContext DeriveToken pos pState | ~(isGlobalContext parseContext) = (False,abort "no def(2)",parseError "definition" No "derive declarations are only at the global level" pState) # (gendef, pState) = wantDeriveDefinition parseContext pos pState = (True, gendef, pState) - // ..AA - try_definition parseContext InstanceToken pos pState | ~(isGlobalContext parseContext) = (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState) # (instdef, pState) = wantInstanceDeclaration parseContext pos pState = (True, instdef, pState) - -// AA : new syntax for generics ... - try_definition parseContext (IdentToken name) pos pState - # (token, pState) = nextToken FunctionContext pState - = case token of - GenericOpenToken // generic function - //# (type, pState) = wantType pState - # (ok, {at_type=type}, pState) = trySimpleType TA_None pState - # (ident, pState) = stringToIdent name (IC_GenericCase type) pState - # (type_CONS_ident, pState) = stringToIdent "CONS" IC_Type pState - # (type_FIELD_ident, pState)= stringToIdent "FIELD" IC_Type pState - # (type_OBJECT_ident, pState)= stringToIdent "OBJECT" IC_Type pState - # (generic_ident, pState) = stringToIdent name IC_Generic pState - - # (type_cons, pState) = get_type_cons type pState - with - get_type_cons (TA type_symb []) pState - = (TypeConsSymb type_symb, pState) - get_type_cons (TA type_symb _) pState - # pState = parseError "generic type, no constructor arguments allowed" No " |}" pState - = (abort "no TypeCons", pState) - get_type_cons (TB tb) pState - = (TypeConsBasic tb, pState) - get_type_cons TArrow pState - = (TypeConsArrow, pState) - get_type_cons (TV tv) pState - = (TypeConsVar tv, pState) - get_type_cons _ pState - # pState = parseError "generic type" No " |}" pState - = (abort "no TypeCons", pState) - - # (token, pState) = nextToken GenericContext pState - # (geninfo_arg, pState) = case token of - GenericOfToken - # (ok, geninfo_arg, pState) = trySimpleLhsExpression pState - # pState = wantToken FunctionContext "type argument" GenericCloseToken pState - | ok - -> case type_cons of - (TypeConsSymb {type_ident}) - | type_ident == type_CONS_ident - # (cons_CONS_ident, pState) = stringToIdent "GenericConsInfo" IC_Expression pState - -> (PE_List [PE_Ident cons_CONS_ident, geninfo_arg], pState) - | type_ident == type_FIELD_ident - # (cons_FIELD_ident, pState) = stringToIdent "GenericFieldInfo" IC_Expression pState - -> (PE_List [PE_Ident cons_FIELD_ident, geninfo_arg], pState) - | type_ident == type_OBJECT_ident - # (cons_OBJECT_ident, pState) = stringToIdent "GenericTypeDefInfo" IC_Expression pState - -> (PE_List [PE_Ident cons_OBJECT_ident, geninfo_arg], pState) - _ - | otherwise - -> (geninfo_arg, pState) - | otherwise - # pState = parseError "generic case" No "simple lhs expression" pState - -> (PE_Empty, pState) - - GenericCloseToken - # (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState - -> (PE_Ident geninfo_ident, pState) - _ - # pState = parseError "generic type" (Yes token) "of or |}" pState - # (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState - -> (PE_Ident geninfo_ident, pState) - - //# pState = wantToken FunctionContext "type argument" GenericCloseToken pState - # (args, pState) = parseList trySimpleLhsExpression pState - - //# (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState - # args = SwitchGenericInfo [geninfo_arg : args] args - - // must be EqualToken or HashToken or ??? - //# pState = wantToken FunctionContext "generic definition" EqualToken pState - //# pState = tokenBack pState - - # (ss_useLayout, pState) = accScanState UseLayout pState - # localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout - # (rhs, _, pState) = wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState - - # generic_case = - { gc_ident = ident - , gc_gident = generic_ident - , gc_generic = {gi_module=NoIndex,gi_index=NoIndex} - , gc_arity = length args - , gc_pos = pos - , gc_type = type - , gc_type_cons = type_cons - , gc_body = GCB_ParsedBody args rhs - , gc_kind = KindError - } - -> (True, PD_GenericCase generic_case, pState) - _ // normal function - # pState = tokenBack pState - # (lhs, pState) = want_lhs_of_def (IdentToken name) pState - (token, pState) = nextToken FunctionContext pState - (def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState - -> (True, def, pState) -// ... AA - + try_definition parseContext ForeignToken pos pState + | not (isGlobalContext parseContext) + = (False,abort "no def",parseErrorSimple "definition" "foreign export definitions are only allowed at the global level" pState) + | isDclContext parseContext + = (False,abort "no def",parseErrorSimple "definition" "foreign export definitions are only allowed in implementation modules" pState) + = wantForeignExportDefinition pState try_definition parseContext token pos pState | isLhsStartToken token # (lhs, pState) = want_lhs_of_def token pState @@ -670,6 +582,111 @@ where | not is_infix && hasprio = (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState) = (name, is_infix, pState) + + wantGenericFunctionDefinition name pos pState + //# (type, pState) = wantType pState + # (ok, {at_type=type}, pState) = trySimpleType TA_None pState + # (ident, pState) = stringToIdent name (IC_GenericCase type) pState + # (type_CONS_ident, pState) = stringToIdent "CONS" IC_Type pState + # (type_FIELD_ident, pState)= stringToIdent "FIELD" IC_Type pState + # (type_OBJECT_ident, pState)= stringToIdent "OBJECT" IC_Type pState + # (generic_ident, pState) = stringToIdent name IC_Generic pState + + # (type_cons, pState) = get_type_cons type pState + with + get_type_cons (TA type_symb []) pState + = (TypeConsSymb type_symb, pState) + get_type_cons (TA type_symb _) pState + # pState = parseError "generic type, no constructor arguments allowed" No " |}" pState + = (abort "no TypeCons", pState) + get_type_cons (TB tb) pState + = (TypeConsBasic tb, pState) + get_type_cons TArrow pState + = (TypeConsArrow, pState) + get_type_cons (TV tv) pState + = (TypeConsVar tv, pState) + get_type_cons _ pState + # pState = parseError "generic type" No " |}" pState + = (abort "no TypeCons", pState) + + # (token, pState) = nextToken GenericContext pState + # (geninfo_arg, pState) = case token of + GenericOfToken + # (ok, geninfo_arg, pState) = trySimpleLhsExpression pState + # pState = wantToken FunctionContext "type argument" GenericCloseToken pState + | ok + -> case type_cons of + (TypeConsSymb {type_ident}) + | type_ident == type_CONS_ident + # (cons_CONS_ident, pState) = stringToIdent "GenericConsInfo" IC_Expression pState + -> (PE_List [PE_Ident cons_CONS_ident, geninfo_arg], pState) + | type_ident == type_FIELD_ident + # (cons_FIELD_ident, pState) = stringToIdent "GenericFieldInfo" IC_Expression pState + -> (PE_List [PE_Ident cons_FIELD_ident, geninfo_arg], pState) + | type_ident == type_OBJECT_ident + # (cons_OBJECT_ident, pState) = stringToIdent "GenericTypeDefInfo" IC_Expression pState + -> (PE_List [PE_Ident cons_OBJECT_ident, geninfo_arg], pState) + _ + | otherwise + -> (geninfo_arg, pState) + | otherwise + # pState = parseError "generic case" No "simple lhs expression" pState + -> (PE_Empty, pState) + + GenericCloseToken + # (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState + -> (PE_Ident geninfo_ident, pState) + _ + # pState = parseError "generic type" (Yes token) "of or |}" pState + # (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState + -> (PE_Ident geninfo_ident, pState) + + //# pState = wantToken FunctionContext "type argument" GenericCloseToken pState + # (args, pState) = parseList trySimpleLhsExpression pState + + //# (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState + # args = SwitchGenericInfo [geninfo_arg : args] args + + // must be EqualToken or HashToken or ??? + //# pState = wantToken FunctionContext "generic definition" EqualToken pState + //# pState = tokenBack pState + + # (ss_useLayout, pState) = accScanState UseLayout pState + # localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout + # (rhs, _, pState) = wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState + + # generic_case = + { gc_ident = ident + , gc_gident = generic_ident + , gc_generic = {gi_module=NoIndex,gi_index=NoIndex} + , gc_arity = length args + , gc_pos = pos + , gc_type = type + , gc_type_cons = type_cons + , gc_body = GCB_ParsedBody args rhs + , gc_kind = KindError + } + = (True, PD_GenericCase generic_case, pState) + + wantForeignExportDefinition pState + # (token, pState) = nextToken GeneralContext pState + # (file_name,line_nr,pState) = getFileAndLineNr pState + = case token of + IdentToken "export" + # (token, pState) = nextToken FunctionContext pState + -> case token of + IdentToken function_name + # pState = wantEndOfDefinition "foreign export" pState + # (ident,pState) = stringToIdent function_name IC_Expression pState + -> (True,PD_ForeignExport ident file_name line_nr,pState) + _ + -> foreign_export_error "function name" pState + _ + -> foreign_export_error "export" pState + where + foreign_export_error s pState + = (True,PD_Erroneous,tokenBack (parseError "foreign export" No s pState)) + /* isEqualToken :: !Token -> Bool isEqualToken EqualToken = True @@ -1189,15 +1206,6 @@ want_2_0_import_declaration token pState = (True, token, pState) = (False, token, pState) -/* -wantExportDef :: !ParseState -> (!Export, !ParseState) -wantExportDef pState - # (name, pState) = want pState - (ident, pState) = stringToIdent name IC_Class pState - (types, pState) = wantList "instance types" trySimpleType pState - pState = wantEndOfDefinition "exports" pState - = ({ export_class = ident, export_types = types}, pState) -*/ /* Classes and instances */ diff --git a/frontend/postparse.icl b/frontend/postparse.icl index fb10aeb..adcdfd5 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1050,7 +1050,7 @@ where = try_to_find mod_id pmods MakeEmptyModule name mod_type - :== { mod_ident = name, mod_modification_time = "", mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = + :== { mod_ident = name, mod_modification_time = "", mod_type = mod_type, mod_imports = [], mod_imported_objects = [],mod_foreign_exports=[],mod_defs = { def_types = [], def_constructors = [], def_selectors = [], def_classes = [], def_macro_indices={ir_from=0,ir_to=0}, def_macros=[],def_members = [], def_funtypes = [], def_instances = [], def_generics = [], def_generic_cases = []} } @@ -1067,7 +1067,7 @@ parseAndScanDclModule dcl_module import_file_position parsed_modules cached_modu where scan_dcl_module :: ParsedModule [ScannedModule] !SearchPaths (ModTimeFunction *Files) *Files *CollectAdmin -> (Bool, [ScannedModule],*Files, *CollectAdmin) scan_dcl_module mod=:{mod_defs = pdefs} parsed_modules searchPaths modtimefunction files ca - # (_, defs, imports, imported_objects, ca) + # (_, defs, imports, imported_objects,foreign_exports,ca) = reorganiseDefinitionsAndAddTypes support_dynamics False pdefs ca (def_macros, ca) = collectFunctions defs.def_macros False {ca & ca_fun_count=0,ca_rev_fun_defs=[]} (range, ca) = addFunctionsRange def_macros ca @@ -1089,7 +1089,7 @@ scanModule mod=:{mod_ident,mod_type,mod_defs = pdefs} cached_modules support_gen , ca_rev_fun_defs = [] , ca_hash_table = hash_table } - (fun_defs, defs, imports, imported_objects, ca) = reorganiseDefinitionsAndAddTypes support_dynamics True pdefs ca + (fun_defs, defs, imports, imported_objects,foreign_exports,ca) = reorganiseDefinitionsAndAddTypes support_dynamics True pdefs ca (reorganise_icl_ok, ca) = ca!ca_error.pea_ok @@ -1122,7 +1122,7 @@ scanModule mod=:{mod_ident,mod_type,mod_defs = pdefs} cached_modules support_gen (def_generic_cases, ca) = collectFunctions defs.def_generic_cases True ca { ca_error = {pea_file = err_file,pea_ok}, ca_rev_fun_defs, ca_hash_table } = ca - mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, + mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_foreign_exports = foreign_exports, mod_defs = { defs & def_instances = def_instances, def_generic_cases = def_generic_cases, def_macro_indices = macro_range }} @@ -1156,7 +1156,7 @@ where | not parse_ok = (False, No,NoIndex, [],cached_modules, files, ca) # pdefs = mod.mod_defs - # (_, defs, imports, imported_objects, ca) = reorganiseDefinitionsAndAddTypes support_dynamics False pdefs ca + # (_, defs, imports, imported_objects,foreign_exports,ca) = reorganiseDefinitionsAndAddTypes support_dynamics False pdefs ca # mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = defs} # cached_modules = [mod.mod_ident:cached_modules] # (import_ok, parsed_modules,files, ca) = scanModules imports [] cached_modules searchPaths support_generics support_dynamics modtimefunction files ca @@ -1241,16 +1241,16 @@ where # (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list = add_strictness_for_arguments fields strictness_index strictness strictness_list -reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index Index *CollectAdmin -> (![FunDef],!CollectedDefinitions (ParsedInstance FunDef) [FunDef], ![ParsedImport], ![ImportedObject], !*CollectAdmin) +reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index Index *CollectAdmin -> (![FunDef],!CollectedDefinitions (ParsedInstance FunDef) [FunDef], ![ParsedImport], ![ImportedObject],![IdentPos],!*CollectAdmin) reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_count type_count ca # prio = if is_infix (Prio NoAssoc 9) NoPrio fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca fun = MakeNewImpOrDefFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies] fun_kind prio No pos | fun_kind == FK_Macro - = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects, ca) - = ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) + = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects,foreign_exports, ca) + = ([ fun : fun_defs ], c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] cons_count sel_count mem_count type_count ca = case defs of [PD_Function pos name is_infix args rhs fun_kind : defs] @@ -1261,35 +1261,35 @@ reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials // | belongsToTypeSpec fun_name prio name is_infix # fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca fun = MakeNewImpOrDefFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No fun_pos | fun_kind == FK_Macro - -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects, ca) - -> ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) + -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects,foreign_exports, ca) + -> ([ fun : fun_defs ], c_defs, imports, imported_objects,foreign_exports, ca) // -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function body expected (1)" ca) _ -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count (postParseError fun_pos "function alternative expected (2)" ca) reorganiseDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_arity}) specials : defs] cons_count sel_count mem_count type_count ca # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca - (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca | isEmpty bodies # fun_type = MakeNewFunctionType name st_arity prio fun_type pos specials nilPtr c_defs = { c_defs & def_funtypes = [ fun_type : c_defs.def_funtypes ]} | icl_module - = (fun_defs, c_defs, imports, imported_objects, postParseError pos "function body expected" ca) - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, postParseError pos "function body expected" ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) # fun = MakeNewImpOrDefFunction name fun_type.st_arity bodies fun_kind prio (Yes fun_type) pos | icl_module | case fun_kind of FK_Macro -> True; _ -> False - = ([fun : fun_defs], c_defs, imports, imported_objects, postParseError pos "macro with function type not allowed" ca) - = ([fun : fun_defs], c_defs, imports, imported_objects, ca) - = ([fun : fun_defs], c_defs, imports, imported_objects, postParseError pos "function body not allowed in definition module" ca) + = ([fun : fun_defs], c_defs, imports, imported_objects,foreign_exports, postParseError pos "macro with function type not allowed" ca) + = ([fun : fun_defs], c_defs, imports, imported_objects,foreign_exports, ca) + = ([fun : fun_defs], c_defs, imports, imported_objects,foreign_exports, postParseError pos "function body not allowed in definition module" ca) reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs} : defs] cons_count sel_count mem_count type_count ca # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count - (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca type_def = { type_def & td_rhs = AlgType cons_symbs } c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) where determine_symbols_of_conses :: [ParsedConstructor] Index -> ([DefinedSymbol], Index) determine_symbols_of_conses [{pc_cons_ident,pc_cons_arity} : conses] next_cons_index @@ -1300,7 +1300,7 @@ where = ([], next_cons_index) reorganiseDefinitions icl_module [PD_Type type_def=:{td_ident, td_rhs = SelectorList rec_cons_id exivars is_boxed_record sel_defs, td_pos } : defs] cons_count sel_count mem_count type_count ca # (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count - (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs (inc cons_count) new_count mem_count (type_count+1) ca + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs (inc cons_count) new_count mem_count (type_count+1) ca cons_arity = new_count - sel_count pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ] cons_def = { pc_cons_ident = rec_cons_id, pc_cons_prio = NoPrio, pc_cons_arity = cons_arity, pc_cons_pos = td_pos, @@ -1309,7 +1309,7 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_ident, td_rhs = Selector rt_fields = { sel \\ sel <- sel_syms }, rt_is_boxed_record = is_boxed_record}} c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors], def_selectors = mapAppend (ParsedSelectorToSelectorDef type_count) sel_defs c_defs.def_selectors } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) where determine_symbols_of_selectors :: [ParsedSelector] Index -> ([FieldSymbol], Index) determine_symbols_of_selectors [{ps_field_ident,ps_field_var} : sels] next_selector_index @@ -1319,30 +1319,30 @@ where determine_symbols_of_selectors [] next_selector_index = ([], next_selector_index) reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = TypeSpec type} : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca type_def = { type_def & td_rhs = SynType type } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs properties} : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca type_def = { type_def & td_rhs = AbstractType properties } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = AbstractTypeSpec properties type} : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca type_def = { type_def & td_rhs = AbstractSynType properties type } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Class class_def=:{class_ident,class_arity,class_args} members : defs] cons_count sel_count mem_count type_count ca # type_context = { tc_class = TCClass {glob_module = NoIndex, glob_object = {ds_ident = class_ident, ds_arity = class_arity, ds_index = NoIndex }}, tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr} (mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca (mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count - (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count (mem_count + class_size) type_count ca + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count (mem_count + class_size) type_count ca class_def = { class_def & class_members = { member \\ member <- mem_symbs }} c_defs = { c_defs & def_classes = [class_def : c_defs.def_classes], def_macros = mem_macros ++ c_defs.def_macros, def_members = mem_defs ++ c_defs.def_members } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) where check_symbols_of_class_members :: ![ParsedDefinition] !TypeContext !*CollectAdmin -> (![MemberDef], ![FunDef], !*CollectAdmin) check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context ca @@ -1393,11 +1393,11 @@ where = ([], [], last_mem_offset) reorganiseDefinitions icl_module [PD_Instance class_instance=:{pi_members,pi_pos} : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca (mem_defs, ca) = collect_member_instances pi_members ca | icl_module || isEmpty mem_defs - = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = mem_defs} : c_defs.def_instances] }, imports, imported_objects, ca) - = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = []} : c_defs.def_instances] }, imports, imported_objects, + = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = mem_defs} : c_defs.def_instances] }, imports, imported_objects,foreign_exports, ca) + = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = []} : c_defs.def_instances] }, imports, imported_objects,foreign_exports, postParseError pi_pos "instance specifications of members not allowed" ca) where collect_member_instances :: [ParsedDefinition] *CollectAdmin -> ([FunDef], *CollectAdmin) @@ -1425,12 +1425,12 @@ reorganiseDefinitions icl_module [PD_Instances class_instances : defs] cons_coun = reorganiseDefinitions icl_module ([PD_Instance class_instance \\ class_instance <- class_instances] ++ defs) cons_count sel_count mem_count type_count ca // AA .. reorganiseDefinitions icl_module [PD_Generic gen : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca c_defs = {c_defs & def_generics = [gen : c_defs.def_generics]} - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_GenericCase gc : defs] cons_count sel_count mem_count type_count ca #! (bodies, defs, ca) = collectGenericBodies gc defs ca - #! (fun_defs, c_defs, imports, imported_objects, ca) + #! (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca # (GCB_ParsedBody args rhs) = gc.gc_body # body = @@ -1443,26 +1443,29 @@ reorganiseDefinitions icl_module [PD_GenericCase gc : defs] cons_count sel_count #! fun = MakeNewImpOrDefFunction fun_name gc.gc_arity bodies (FK_Function cNameNotLocationDependent) NoPrio No gc.gc_pos #! inst = { gc & gc_body = GCB_FunDef fun } #! c_defs = {c_defs & def_generic_cases = [inst : c_defs.def_generic_cases]} - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Derive derive_defs : defs] cons_count sel_count mem_count type_count ca - #! (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca + #! (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca #! c_defs = { c_defs & def_generic_cases = derive_defs ++ c_defs.def_generic_cases} - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) // .. AA reorganiseDefinitions icl_module [PD_Import new_imports : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca - = (fun_defs, c_defs, new_imports ++ imports, imported_objects, ca) + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + = (fun_defs, c_defs, new_imports ++ imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_ImportedObjects new_imported_objects : defs] cons_count sel_count mem_count type_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca - = (fun_defs, c_defs, imports, new_imported_objects ++ imported_objects, ca) + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + = (fun_defs, c_defs, imports, new_imported_objects ++ imported_objects,foreign_exports, ca) +reorganiseDefinitions icl_module [PD_ForeignExport new_foreign_export file_name line_n : defs] cons_count sel_count mem_count type_count ca + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count type_count ca + = (fun_defs, c_defs, imports, imported_objects,[{ip_ident=new_foreign_export,ip_file=file_name,ip_line=line_n}:foreign_exports], ca) reorganiseDefinitions icl_module [def:defs] _ _ _ _ ca = abort ("reorganiseDefinitions does not match" ---> def) reorganiseDefinitions icl_module [] _ _ _ _ ca = ([], { def_types = [], def_constructors = [], def_selectors = [], def_macros = [],def_macro_indices={ir_from=0,ir_to=0},def_classes = [], def_members = [], def_instances = [], def_funtypes = [], - def_generics = [], def_generic_cases = []}, [], [], ca) + def_generics = [], def_generic_cases = []}, [], [], [], ca) reorganiseDefinitionsAndAddTypes support_dynamics icl_module defs ca | support_dynamics diff --git a/frontend/predef.icl b/frontend/predef.icl index 393d1db..9090a07 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -515,7 +515,7 @@ buildPredefinedModule pre_def_symbols (type_defs, cons_defs, pre_def_symbols) = add_tuple_defs pre_mod_ident MaxTupleArity [array_def,strict_def,unboxed_def] [] pre_def_symbols alias_dummy_type = make_identity_fun_type alias_dummy_ident type_var (class_def, member_def, pre_def_symbols) = make_TC_class_def pre_def_symbols - = ({ mod_ident = pre_mod_ident, mod_modification_time = "", mod_type = MK_System, mod_imports = [], mod_imported_objects = [], + = ({ mod_ident = pre_mod_ident, mod_modification_time = "", mod_type = MK_System, mod_imports = [],mod_foreign_exports=[], mod_imported_objects = [], mod_defs = { def_types = [string_def, list_def,strict_list_def,unboxed_list_def,tail_strict_list_def,strict_tail_strict_list_def,unboxed_tail_strict_list_def,overloaded_list_def : type_defs], def_constructors = [cons_def,strict_cons_def,unboxed_cons_def,tail_strict_cons_def,strict_tail_strict_cons_def,unboxed_tail_strict_cons_def,overloaded_cons_def, diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl index 6ed0019..fcd8edc 100644 --- a/frontend/scanner.dcl +++ b/frontend/scanner.dcl @@ -68,6 +68,7 @@ instance <<< FilePosition | ImportToken // import | FromToken // from | SpecialToken // special + | ForeignToken // foreign | IntTypeToken // Int | CharTypeToken // Char @@ -77,8 +78,6 @@ instance <<< FilePosition | FileTypeToken // File | WorldTypeToken // World | VoidTypeToken // Void - | LeftAssocToken // left - | RightAssocToken // right | ClassToken // class | InstanceToken // instance | OtherwiseToken // otherwise diff --git a/frontend/scanner.icl b/frontend/scanner.icl index c27a546..e310836 100644 --- a/frontend/scanner.icl +++ b/frontend/scanner.icl @@ -1,6 +1,6 @@ implementation module scanner -import StdEnv, compare_constructor, StdCompare, general, compilerSwitches +import StdEnv, compare_constructor, general, compilerSwitches from utilities import revCharListToString, isSpecialChar @@ -154,6 +154,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4; | ImportToken // import | FromToken // from | SpecialToken // special + | ForeignToken // foreign | IntTypeToken // Int | CharTypeToken // Char @@ -163,8 +164,6 @@ ScanOptionNoNewOffsideForSeqLetBit:==4; | FileTypeToken // File | WorldTypeToken // World | VoidTypeToken // Void - | LeftAssocToken // left - | RightAssocToken // right | ClassToken // class | InstanceToken // instance | OtherwiseToken // otherwise @@ -834,6 +833,7 @@ CheckEveryContext s input Yes err -> (ErrorToken err , input) //-->> ("Error token generated: "+err) No -> (PriorityToken (Prio NoAssoc n) , input) "import" -> (ImportToken,input) + "foreign" -> (ForeignToken,input) s -> (IdentToken s , input) CheckTypeContext :: !String !Input -> (!Token, !Input) @@ -1387,6 +1387,7 @@ where toString ImportToken = "import" toString FromToken = "from" toString SpecialToken = "special" + toString ForeignToken = "foreign" toString IntTypeToken = "Int" toString CharTypeToken = "Char" @@ -1396,8 +1397,6 @@ where toString FileTypeToken = "File" toString WorldTypeToken = "World" toString VoidTypeToken = "Void" - toString LeftAssocToken = "left" - toString RightAssocToken = "right" toString ClassToken = "class" toString InstanceToken = "instance" toString OtherwiseToken = "otherwise" diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 4d703cc..0c4f25d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -96,6 +96,7 @@ instance == FunctionOrMacroIndex , mod_type :: !ModuleKind , mod_imports :: ![ParsedImport] , mod_imported_objects :: ![ImportedObject] + , mod_foreign_exports :: ![IdentPos] , mod_defs :: !defs } @@ -174,6 +175,7 @@ cIsNotAFunction :== False | PD_Instances [ParsedInstance ParsedDefinition] | PD_Import [ParsedImport] | PD_ImportedObjects [ImportedObject] + | PD_ForeignExport !Ident !{#Char} !Int | PD_Generic GenericDef // AA | PD_GenericCase GenericCaseDef // AA | PD_Derive [GenericCaseDef] // AA |