Commit cfe393c6 authored by John van Groningen's avatar John van Groningen
Browse files

add foreign export

parent 063b3206
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 =
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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