diff options
68 files changed, 27751 insertions, 0 deletions
diff --git a/frontend/Debug.dcl b/frontend/Debug.dcl new file mode 100644 index 0000000..2e0af9f --- /dev/null +++ b/frontend/Debug.dcl @@ -0,0 +1,17 @@ +definition module Debug + +:: DebugShowFunction a :== !a -> [{#Char}] + +debugBefore :: !.a !(DebugShowFunction .a) .b -> .b +debugAfter :: !.a !(DebugShowFunction .a) !.b -> .b +debugValue :: !(DebugShowFunction .a) !.a -> .a + +debugShow :: DebugShowFunction .a +debugShowWithOptions :: [DebugShowOption] -> DebugShowFunction .a + +:: DebugShowOption + = DebugMaxDepth !Int // default MaxInt + | DebugMaxBreadth !Int // default MaxInt + | DebugMaxChars !Int // default MaxInt + | DebugTerminator !{#Char} // default "\n" + diff --git a/frontend/Debug.icl b/frontend/Debug.icl new file mode 100644 index 0000000..75092ad --- /dev/null +++ b/frontend/Debug.icl @@ -0,0 +1,173 @@ +implementation module Debug + +import StdArray, StdEnum +from StdFile import <<<, ferror, stderr +from StdMisc import abort +from StdTuple import fst +from StdList import ++ +from StdBool import && +from StdString import % + +import Wrap, ShowWrapped + +print :: ![{#Char}] .b -> .b +print debugStrings value + | fst (ferror (stderr <<< debugStrings)) + = abort "Debug, print: couldn't write to stderr" + // otherwise + = value + +debugBefore :: !.a !(DebugShowFunction .a) .b -> .b +debugBefore debugValue show value + = print (show debugValue) value + +debugAfter :: !.a !(DebugShowFunction .a) !.b -> .b +debugAfter debugValue show value + = print (show debugValue) value + +debugValue :: !(DebugShowFunction .a) !.a -> .a +debugValue show value + = print (show copy1) copy2 + where + (copy1, copy2) + = copyUniqueValue value + + copyUniqueValue :: !.a -> (!.a, !.a) + copyUniqueValue value + = code { + .o 1 0 + push_a 0 + .d 2 0 + } + +:: DebugShowFunction a :== !a -> [{#Char}] + +debugShow :: DebugShowFunction .a +debugShow + = \debugValue -> ShowWrapped (Wrap debugValue) ++ ["\n"] + + +:: DebugOptionRecord + = {maxDepth :: !Int, maxBreadth :: !Int, maxChars :: !Int, terminator :: !{#Char}} +DebugDefaultOptions + :== {maxDepth = MaxInt, maxBreadth = MaxInt, maxChars = MaxInt, terminator = "\n"} + +MaxInt + :== (1<<31)-1 + +:: DebugShowOption + = DebugMaxDepth !Int // default MaxInt + | DebugMaxBreadth !Int // default MaxInt + | DebugMaxChars !Int // default MaxInt + | DebugTerminator !{#Char} // default "\n" + +debugShowWithOptions :: [DebugShowOption] -> DebugShowFunction .a +debugShowWithOptions debugOptions + = \debug -> chop maxChars (ShowWrapped (pruneWrappedNode maxDepth maxBreadth (Wrap debug))) ++ [terminator] + where + {maxDepth, maxBreadth, maxChars, terminator} + = set debugOptions DebugDefaultOptions + where + set [] options + = options + set [DebugMaxDepth maxDepth:t] options + = set t {options & maxDepth=maxDepth} + set [DebugMaxBreadth maxBreadth:t] options + = set t {options & maxBreadth=maxBreadth} + set [DebugMaxChars maxChars:t] options + = set t {options & maxChars=maxChars} + set [DebugTerminator terminator:t] options + = set t {options & terminator=terminator} + +:: Indicators + = ... + | .+. + +MaxCharsString + :== ".." +MaxBreadthString + :== "..." +MaxBreadthIndicator + :== Wrap ... +MaxDepthIndicator + :== Wrap .+. + +pruneWrappedNode :: !Int !Int !WrappedNode -> !WrappedNode +pruneWrappedNode maxDepth maxBreadth value + = prune 0 value + where + prune :: !Int WrappedNode -> WrappedNode + prune depth value + | depth == maxDepth + = MaxDepthIndicator + prune depth (WrappedIntArray a) + = pruneBasicArray depth a + prune depth (WrappedBoolArray a) + = pruneBasicArray depth a + prune depth (WrappedRealArray a) + = pruneBasicArray depth a + prune depth (WrappedFileArray a) + = pruneBasicArray depth a + prune depth (WrappedString a) + | size a > maxBreadth + = WrappedString ((a % (0, maxBreadth-1)) +++ MaxBreadthString) + prune depth (WrappedArray a) + = WrappedArray (pruneArray depth a) + prune depth (WrappedRecord descriptor args) + = WrappedRecord descriptor (pruneArray depth args) + prune depth (WrappedOther WrappedDescriptorCons args) + | size args == 2 + = WrappedOther WrappedDescriptorCons + {prune (depth+1) args.[0], prune depth args.[1]} + prune depth (WrappedOther WrappedDescriptorTuple args) + = WrappedOther WrappedDescriptorTuple (pruneArray depth args) + prune depth (WrappedOther descriptor args) + = WrappedOther descriptor (pruneArray depth args) + prune _ a + = a + + pruneArray :: !Int !{WrappedNode} -> {WrappedNode} + pruneArray depth a + | size a > maxBreadth + = {{prune (depth+1) e \\ e <-: a & i <- [0 .. maxBreadth]} + & [maxBreadth] = MaxBreadthIndicator} + // otherwise + = {prune (depth+1) e \\ e <-: a} + + pruneBasicArray :: !Int !(a b) -> WrappedNode | Array .a & ArrayElem b + pruneBasicArray depth a + | size a > maxBreadth + = WrappedArray (pruneArray depth {Wrap e \\ e <-: a & i <- [0 .. maxBreadth]}) + // otherwise + = WrappedArray {Wrap e \\ e <-: a} + +chop :: !Int ![{#Char}] -> [{#Char}] +chop _ [] + = [] +chop maxSize list=:[string:strings] + | maxSize < stringSize + sizeMaxCharsString + | fits maxSize list + = list + | stringSize > sizeMaxCharsString + = [string % (0, maxSize-sizeMaxCharsString-1), MaxCharsString] + // otherwise + = [MaxCharsString] + // otherwise + = [string : chop (maxSize - stringSize) strings] + where + fits _ [] + = True + fits maxSize [h : t] + = maxSize >= size h && fits (maxSize - size h) t + + stringSize + = size string + sizeMaxCharsString + = size MaxCharsString + +instance <<< [a] | <<< a where + (<<<) :: *File [a] -> *File | <<< a + (<<<) file [] + = file + (<<<) file [h:t] + = file <<< h <<< t diff --git a/frontend/Heap.dcl b/frontend/Heap.dcl new file mode 100644 index 0000000..bf855d9 --- /dev/null +++ b/frontend/Heap.dcl @@ -0,0 +1,31 @@ +definition module Heap + +import StdEnv + +:: Heap v = {heap::!.HeapN v} +:: HeapN v +:: Ptr v = {pointer::!.(PtrN v)}; +:: PtrN v = Ptr !v !(HeapN v); + +newHeap :: .Heap v + +nilPtr :: Ptr v + +isNilPtr :: !(Ptr v) -> Bool + +newPtr :: !v !*(Heap v) -> (!.Ptr v,!.Heap v) + +readPtr :: !(Ptr v) !*(Heap v) -> (!v,!.Heap v) + +writePtr :: !(Ptr v) !v !*(Heap v) -> .Heap v + +sreadPtr :: !(Ptr v) !(Heap v) -> v + +ptrToInt :: !(Ptr w) -> Int + +(<:=) infixl +(<:=) heap ptr_and_val :== writePtr ptr val heap +where + (ptr, val) = ptr_and_val + +instance == Ptr a diff --git a/frontend/Heap.icl b/frontend/Heap.icl new file mode 100644 index 0000000..a50b10a --- /dev/null +++ b/frontend/Heap.icl @@ -0,0 +1,139 @@ +implementation module Heap; + +import StdOverloaded; + +:: Heap v = {heap::!.(HeapN v)}; +:: HeapN v = Heap !Int; +:: Ptr v = {pointer::!.(PtrN v)}; +:: PtrN v = Ptr !v !(HeapN v); + +newHeap :: .Heap v; +newHeap = {heap=Heap 0}; + +newPtr :: !v !*(Heap v) -> (!.Ptr v,!.Heap v); +newPtr v h = code { + build_r e_Heap_kPtr 2 0 0 0 + update_a 0 1 + pop_a 1 +}; +/* +nilPtr :: !v -> .Ptr v; +nilPtr v = code { + build _Nil 0 _hnf + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + build_r e_Heap_kPtr 2 0 0 0 + update_a 0 2 + pop_a 2 +}; +*/ +nilPtr :: Ptr v; +nilPtr = code { + build _Nil 0 _hnf + push_a 0 + build_r e_Heap_kPtr 2 0 0 0 + update_a 0 2 + pop_a 2 +}; + +isNilPtr :: !(Ptr v) -> Bool; +isNilPtr p = code { + repl_args 2 2 + pop_a 1 + eq_desc _Nil 0 0 + pop_a 1 +}; + + +readPtr :: !(Ptr v) !*(Heap v) -> (!v,!.Heap v); +readPtr p h = code { + push_a_b 1 + push_r_args_b 0 1 1 1 1 + eqI + jmp_false read_heap_error + repl_r_args_a 2 0 1 1 +.d 2 0 + rtn +:read_heap_error + print "readPtr: Not a pointer of this heap" + halt +}; + +sreadPtr :: !(Ptr v) !(Heap v) -> v; +sreadPtr p h = code { + push_a_b 1 + push_r_args_b 0 1 1 1 1 + eqI + jmp_false sread_heap_error + repl_r_args_a 2 0 1 1 + update_a 0 1 + pop_a 1 +.d 1 0 + rtn +:sread_heap_error + print "sreadPtr: Not a pointer of this heap" + halt +}; + +writePtr :: !(Ptr v) !v !*(Heap v) -> .Heap v; +writePtr p v h = code { + push_a_b 2 + push_r_args_b 0 1 1 1 1 + eqI + jmp_false write_heap_error + push_a 1 + fill1_r e_Heap_kPtr 2 0 1 010 +.keep 0 2 + pop_a 2 +.d 1 0 + rtn +:write_heap_error + print "writePtr: Not a pointer of this heap" + halt +}; + +(<:=) infixl; +(<:=) heap ptr_and_val :== writePtr ptr val heap ; +{ + (ptr, val) = ptr_and_val; +} + +ptrToInt :: !(Ptr v) -> Int; +ptrToInt p = code { + push_a_b 0 + pop_a 1 + build _Nil 0 _hnf + push_a_b 0 + pop_a 1 + push_b 1 + eqI + jmp_false not_nil + pop_b 1 + pushI 0 +.d 0 1 b + rtn +:not_nil +.d 0 1 b + rtn +}; + +instance == Ptr a +where +{ (==) p1 p2 = code { + push_r_args_b 1 1 1 1 1 + push_r_args_b 0 1 1 1 1 + eqI + jmp_false equal_pointer_error + push_a_b 1 + push_a_b 0 + pop_a 2 + eqI +.d 0 1 b + rtn +:equal_pointer_error + print "equal_pointer: Pointers to different heaps" + halt + } +};
\ No newline at end of file diff --git a/frontend/RWSDebug.dcl b/frontend/RWSDebug.dcl new file mode 100644 index 0000000..b59baf6 --- /dev/null +++ b/frontend/RWSDebug.dcl @@ -0,0 +1,5 @@ +definition module RWSDebug + +(->>) :: !.a !.b -> .a +(<<-) :: .a !.b -> .a +<<->> :: !.a -> .a
\ No newline at end of file diff --git a/frontend/RWSDebug.icl b/frontend/RWSDebug.icl new file mode 100644 index 0000000..9d7639d --- /dev/null +++ b/frontend/RWSDebug.icl @@ -0,0 +1,18 @@ +implementation module RWSDebug + +import Debug + +show + = debugShowWithOptions [] // [DebugMaxChars 80, DebugMaxDepth 5] + +(->>) :: !.a !.b -> .a +(->>) value debugValue + = debugAfter debugValue show value + +(<<-) :: .a !.b -> .a +(<<-) value debugValue + = debugBefore debugValue show value + +<<->> :: !.a -> .a +<<->> value + = debugValue show value diff --git a/frontend/ShowWrapped.dcl b/frontend/ShowWrapped.dcl new file mode 100644 index 0000000..3bcc251 --- /dev/null +++ b/frontend/ShowWrapped.dcl @@ -0,0 +1,5 @@ +definition module ShowWrapped + +from Wrap import WrappedNode + +ShowWrapped :: WrappedNode -> [{#Char}]
\ No newline at end of file diff --git a/frontend/ShowWrapped.icl b/frontend/ShowWrapped.icl new file mode 100644 index 0000000..82b72a1 --- /dev/null +++ b/frontend/ShowWrapped.icl @@ -0,0 +1,80 @@ +implementation module ShowWrapped + +import StdEnv +import Wrap + +ShowWrapped :: WrappedNode -> [{#Char}] +ShowWrapped node + = Show False node + +Show _ (WrappedInt i) + = [toString i] +Show _ (WrappedChar c) + = ["\'" +++ toString c +++ "\'"] +Show _ (WrappedBool b) + = [toString b] +Show _ (WrappedReal r) + = [toString r] +Show _ (WrappedFile f) + = [toString f] +Show _ (WrappedString s) + = ["\"" +++ s +++ "\""] +Show _ (WrappedIntArray a) + = ShowBasicArray a +Show _ (WrappedBoolArray a) + = ShowBasicArray a +Show _ (WrappedRealArray a) + = ShowBasicArray a +Show _ (WrappedFileArray a) + = ShowBasicArray a +Show _ (WrappedArray a) + = ["{" : flatten (Separate [", "] [Show False el \\ el <-: a])] ++ ["}"] +Show _ (WrappedRecord descriptor args) + = ["{" : flatten (Separate [" "] [[ShowDescriptor descriptor] : [Show True arg \\ arg <-: args]])] ++ ["}"] +Show _ (WrappedOther WrappedDescriptorCons args) + | size args == 2 + = ["[" : flatten [Show False args.[0] : ShowTail args.[1]]] ++ ["]"] + where + ShowTail (WrappedOther WrappedDescriptorCons args) + | size args == 2 + = [[", "], Show False args.[0] : ShowTail args.[1]] + ShowTail (WrappedOther WrappedDescriptorNil args) + | size args == 0 + = [] + ShowTail graph // abnormal list + = [[" : " : Show False graph]] +Show _ (WrappedOther WrappedDescriptorTuple args) + = ["(" : flatten (Separate [", "] [Show False arg \\ arg <-: args])] ++ [")"] +Show pars (WrappedOther descriptor args) + | pars && size args > 0 + = ["(" : application] ++ [")"] + // otherwise + = application + where + application + = flatten (Separate [" "] [[ShowDescriptor descriptor] : [Show True arg \\ arg <-: args]]) + +ShowDescriptor (WrappedDescriptorOther id) + = toString id +ShowDescriptor WrappedDescriptorNil + = "[]" +ShowDescriptor WrappedDescriptorCons + = "[:]" +ShowDescriptor WrappedDescriptorTuple + = "(..)" + +ShowBasicArray a + = ["{" : Separate ", " [toString el \\ el <-: a]] ++ ["}"] +ShowWrappedArray a + = ["{" : flatten (Separate [", "] [Show False el \\ el <-: a])] ++ ["}"] + +Separate :: a [a] -> [a] +Separate separator [a : t=:[b : _]] + = [a, separator : Separate separator t] +Separate _ l + = l + +instance toString File +where + toString _ + = "File" diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl new file mode 100644 index 0000000..67fff22 --- /dev/null +++ b/frontend/StdCompare.dcl @@ -0,0 +1,21 @@ +definition module StdCompare + +import syntax, compare_constructor + +:: CompareValue :== Int +Smaller :== -1 +Greater :== 1 +Equal :== 0 + +class (=<) infix 4 a :: !a !a -> CompareValue + +instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, Global a | =< a + +instance =< Type + +instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue, FunKind, Global a | == a + +export == Int + +instance < MemberDef + diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl new file mode 100644 index 0000000..a8c3f92 --- /dev/null +++ b/frontend/StdCompare.icl @@ -0,0 +1,219 @@ +implementation module StdCompare + +import StdEnv, compare_constructor +import syntax + +instance == TypeVar +where + (==) varid1 varid2 = varid1.tv_name == varid2.tv_name + +instance == FunKind +where + (==) fk1 fk2 = equal_constructor fk1 fk2 + +instance == Global a | == a +where + (==) g1 g2 + = g1.glob_module == g2.glob_module && g1.glob_object == g2.glob_object + + +instance == TypeSymbIdent +where + (==) tsymb_id1 tsymb_id2 + = tsymb_id1.type_index == tsymb_id2.type_index + + +instance == AType +where + (==) atype1 atype2 = atype1.at_type == atype2.at_type + +instance == ConsVariable +where + (==) (CV tv1) (CV tv2) = tv1 == tv2 + (==) (TempCV tv1) (TempCV tv2) = tv1 == tv2 + (==) cv1 cv2 = False + + +instance == TypeContext +where + (==) tc1 tc2 = tc1.tc_class == tc2.tc_class && tc1.tc_types == tc2.tc_types + +instance == BasicType +where + (==) bt1 bt2 = equal_constructor bt1 bt2 + +instance == BasicValue +where + (==) (BVI int1) (BVI int2) = int1 == int2 + (==) (BVC char1) (BVC char2) = char1 == char2 + (==) (BVB bool1) (BVB bool2) = bool1 == bool2 + (==) (BVR real1) (BVR real2) = real1 == real2 + (==) (BVS string1) (BVS string2) = string1 == string2 + (==) _ _ = False + +instance == DefinedSymbol +where + (==) ds1 ds2 + = ds1.ds_ident == ds2.ds_ident && ds1.ds_index == ds2.ds_index + +instance == Type +where + (==) t1 t2 = equal_constructor t1 t2 && equal_constructor_args t1 t2 + where + equal_constructor_args (TV varid1) (TV varid2) + = varid1 == varid2 + equal_constructor_args (TempV varid1) (TempV varid2) + = varid1 == varid2 + equal_constructor_args (arg_type1 --> restype1) (arg_type2 --> restype2) + = arg_type1 == arg_type2 && restype1 == restype2 + equal_constructor_args (TA tc1 types1) (TA tc2 types2) + = tc1 == tc2 && types1 == types2 + equal_constructor_args (TB tb1) (TB tb2) + = tb1 == tb2 + equal_constructor_args (TA tc1 types1) (TA tc2 types2) + = tc1 == tc2 && types1 == types2 + equal_constructor_args (type1 :@: types1) (type2 :@: types2) + = type1 == type2 && types1 == types2 + equal_constructor_args (TQV varid1) (TQV varid2) + = varid1 == varid2 + equal_constructor_args type1 type2 + = True + +:: CompareValue :== Int +Smaller :== -1 +Greater :== 1 +Equal :== 0 + +class (=<) infix 4 a :: !a !a -> CompareValue + +instance =< Int +where + (=<) i1 i2 + | i1 == i2 + = Equal + | i1 < i2 + = Smaller + = Greater + +instance =< SymbKind +where + (=<) symb1 symb2 + | equal_constructor symb1 symb2 + = compare_indexes symb1 symb2 + with + compare_indexes (SK_Function i1) (SK_Function i2) = i1 =< i2 +// compare_indexes (SK_ClassRecord i1) (SK_ClassRecord i2) = i1 =< i2 + compare_indexes (SK_Constructor i1) (SK_Constructor i2) = i1 =< i2 +// compare_indexes (SK_DeltaFunction i1) (SK_DeltaFunction i2) = i1 =< i2 +// compare_indexes (SK_InternalFunction i1) (SK_InternalFunction i2) = i1 =< i2 + compare_indexes (SK_OverloadedFunction i1) (SK_OverloadedFunction i2) = i1 =< i2 + compare_indexes (SK_GeneratedFunction _ i1) (SK_GeneratedFunction _ i2) = i1 =< i2 + + | less_constructor symb1 symb2 + = Smaller + = Greater + +instance =< SymbIdent +where + (=<) {symb_kind=symb_kind1} {symb_kind=symb_kind2} = symb_kind1 =< symb_kind2 + + +instance =< App +where + (=<) app1 app2 + # cmp = app1.app_symb =< app2.app_symb + | cmp == Equal + = app1.app_args =< app2.app_args + = cmp + +instance =< (a,b) | =< a & =< b +where + (=<) (x1,y1) (x2,y2) + # cmp = x1 =< x2 + | cmp == Equal + = y1 =< y2 + = cmp + +instance =< [a] | =< a +where + (=<) [x:xs] [y:ys] = (x,xs) =< (y,ys) + (=<) [] [] = Equal + (=<) [] _ = Smaller + (=<) _ _ = Greater + +instance =< {# Char} +where + (=<) s1 s2 + | s1 == s2 + = Equal + | s1 < s2 + = Smaller + = Greater + +instance =< Expression +where + (=<) expr1 expr2 + | equal_constructor expr1 expr2 + = compare_arguments expr1 expr2 + with + compare_arguments (App app1) (App app2) = app1 =< app2 + compare_arguments (Var v1) (Var v2) = v1 =< v2 + compare_arguments (fun1 @ args1) (fun2 @ args2) = (fun1,args1) =< (fun2,args2) + compare_arguments (Lambda vars1 expr1) (Lambda vars2 expr2) = (vars1,expr1) =< (vars2,expr2) + compare_arguments EE EE = Equal + compare_arguments _ _ = Greater + | less_constructor expr1 expr2 + = Smaller + = Greater + +instance =< BoundVar +where + (=<) bv1 bv2 + = bv1.var_name =< bv2.var_name + +instance =< FreeVar +where + (=<) fv1 fv2 + = fv1.fv_name =< fv2.fv_name + +instance =< Ident +where + (=<) id1 id2 + = id1.id_name =< id2.id_name + +instance =< Global a | =< a +where + (=<) g1 g2 + = (g1.glob_module,g1.glob_object) =< (g2.glob_module,g2.glob_object) + +instance =< TypeSymbIdent +where + (=<) s1 s2 + = s1.type_name =< s2.type_name + +instance =< Type +where + (=<) t1 t2 + | equal_constructor t1 t2 + = compare_arguments t1 t2 + | less_constructor t1 t2 + = Smaller + = Greater + where + compare_arguments (TB tb1) (TB tb2) = tb1 =< tb2 + compare_arguments (TA tc1 _) (TA tc2 _) = tc1 =< tc2 + compare_arguments _ _ = Equal + +instance =< BasicType +where + (=<) bt1 bt2 + | equal_constructor bt1 bt2 + = Equal + | less_constructor bt1 bt2 + = Smaller + = Greater + +instance < MemberDef +where + (<) md1 md2 = md1.me_symb.id_name < md2.me_symb.id_name + diff --git a/frontend/Wrap.dcl b/frontend/Wrap.dcl new file mode 100644 index 0000000..e5c4b41 --- /dev/null +++ b/frontend/Wrap.dcl @@ -0,0 +1,43 @@ +definition module Wrap + +/* + Wrap arbitrary Clean nodes (for debugging purposes). +*/ + +from StdOverloaded import toString + +:: WrappedDescriptorId + +instance toString WrappedDescriptorId + +:: WrappedDescriptor + = WrappedDescriptorCons + | WrappedDescriptorNil + | WrappedDescriptorTuple + | WrappedDescriptorOther !WrappedDescriptorId + +:: WrappedNode + // basic types + = WrappedInt !Int + | WrappedChar !Char + | WrappedBool !Bool + | WrappedReal !Real + | WrappedFile !File + + // unboxed arrays of basic types + | WrappedString !{#Char} + | WrappedIntArray !{#Int} + | WrappedBoolArray !{#Bool} + | WrappedRealArray !{#Real} + | WrappedFileArray !{#File} + + // other arrays + | WrappedArray !{WrappedNode} + + // records + | WrappedRecord !WrappedDescriptor !{WrappedNode} + + // other nodes + | WrappedOther !WrappedDescriptor !{WrappedNode} + +Wrap :: !.a -> WrappedNode
\ No newline at end of file diff --git a/frontend/Wrap.icl b/frontend/Wrap.icl new file mode 100644 index 0000000..eeb36d8 --- /dev/null +++ b/frontend/Wrap.icl @@ -0,0 +1,659 @@ +implementation module Wrap + +import StdOverloaded + +:: WrappedDescriptorId = {descriptorId :: !Int} + +:: WrappedDescriptor + = WrappedDescriptorCons + | WrappedDescriptorNil + | WrappedDescriptorTuple + | WrappedDescriptorOther !WrappedDescriptorId + +:: WrappedNode + = WrappedInt !Int + | WrappedChar !Char + | WrappedBool !Bool + | WrappedReal !Real + | WrappedFile !File + | WrappedString !{#Char} + | WrappedIntArray !{#Int} + | WrappedBoolArray !{#Bool} + | WrappedRealArray !{#Real} + | WrappedFileArray !{#File} + | WrappedArray !{WrappedNode} + | WrappedRecord !WrappedDescriptor !{WrappedNode} + | WrappedOther !WrappedDescriptor !{WrappedNode} + +instance toString WrappedDescriptorId where + toString :: WrappedDescriptorId -> {#Char} + toString {descriptorId} + = descriptorIDtoString descriptorId + where + descriptorIDtoString :: !Int -> {#Char} + descriptorIDtoString id + = code + { + .d 0 1 i + jsr DtoAC + .o 1 0 + } + +Wrap :: !.a -> WrappedNode +Wrap node + = code + { + | A: <node> <result> + | B: + eq_desc BOOL 0 0 + jmp_false not_a_bool + pushB_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedBool 0 1 0 0 0 + pop_b 1 + .d 1 0 + rtn + :not_a_bool + + eq_desc INT 0 0 + jmp_false not_an_int + + pushI_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedInt 0 1 0 0 0 + pop_b 1 + .d 1 0 + rtn + :not_an_int + + eq_desc CHAR 0 0 + jmp_false not_a_char + + pushC_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedChar 0 1 0 0 0 + pop_b 1 + .d 1 0 + rtn + :not_a_char + + eq_desc REAL 0 0 + jmp_false not_a_real + + pushR_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedReal 0 2 0 0 0 + pop_b 2 + .d 1 0 + rtn + :not_a_real + + eq_desc FILE 0 0 + jmp_false not_a_file + + pushF_a 0 + pop_a 1 + fill_r e_Wrap_kWrappedFile 0 2 0 0 0 + pop_b 2 + .d 1 0 + rtn + :not_a_file + + eq_desc ARRAY 1 0 + jmp_true wrap_array + + eq_desc _ARRAY_ 0 0 + jmp_true wrap__array + + eq_desc _STRING_ 0 0 + jmp_true wrap__string + + is_record 0 + .d 2 0 + jmp_true wrap_record + + get_node_arity 0 + | B: <n> + eqI_b 0 0 + jmp_true wrap_no_args + + :wrap_args + push_a 0 + push_b 0 + push_b 0 + repl_args_b + | A: <arg_1 .. arg_n> <node> <result> + push_b 0 + create_array_ _ 1 0 + | A: <_{args}> <arg_1 .. arg_n> <node> <result> + pushI 0 + + :wrap_args_loop + | A: <_{args}> <arg_(i+1) .. arg_n> <node> <result> + | B: <i> <n> + | wrap arg + push_a 1 + build e_Wrap_sWrap 1 e_Wrap_nWrap + update_a 0 2 + pop_a 1 + + | update i-th element of _args array with wrapped arg + push_b 0 + update _ 1 0 + + | increment index + incI + + push_b 0 + push_b 2 + eqI + jmp_false wrap_args_loop + + pop_b 2 + | A: <_{args}> <node> <result> + | B: + .d 3 0 + jmp wrap_descriptor + + :wrap_no_args + | A: <node> <result> + | B: <0> + create_array_ _ 1 0 + + .o 3 0 + :wrap_descriptor + | A: <_{args}> <node> <result> + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + | A: <node> <_{args}> <result> + eq_nulldesc _Tuple 0 + jmp_false not_a_tuple + build e_Wrap_dWrappedDescriptorTuple 0 _hnf + .d 4 0 + jmp wrap_other + :not_a_tuple + + eq_nulldesc _Cons 0 + jmp_false not_a_cons + build e_Wrap_dWrappedDescriptorCons 0 _hnf + jmp wrap_other + :not_a_cons + + eq_desc _Nil 0 0 + jmp_false not_a_nil + build e_Wrap_dWrappedDescriptorNil 0 _hnf + jmp wrap_other + :not_a_nil + + | A: <node> <_{args}> <result> + pushD_a 0 + build_r e_Wrap_rWrappedDescriptorId 0 1 0 0 + pop_b 1 + + build_r e_Wrap_kWrappedDescriptorOther 1 0 0 0 + update_a 0 1 + pop_a 1 + .o 4 0 + :wrap_other + | A: <descriptor> <node> <_{args}> <result> + update_a 0 1 + pop_a 1 + | A: <descriptor> <_{args}> <result> + fill_r e_Wrap_kWrappedOther 2 0 2 0 0 + pop_a 2 + | A: <result> + .d 1 0 + rtn + + .o 2 0 + :wrap_record + pushI 0 + pushD_a 0 + | A: <node> <result> + | B: <desc> <return> + push_t_r_args + + :wrap_record_fields + | A: <afield_1 .. afield_m> <result> + | B: <l> <bfield_1 .. bfield_n> <desc> <return> + | (l: points to record layout, + | desc: record descriptor + | return: return selector) + push_b 0 + + :count_fields_loop + | A: <afield_1 .. afield_m> <result> + | B: <p> <l> <bfield_1 .. bfield_n> <desc> <return> + | (p=l+offset) + push_b 0 + push_r_arg_t + eqI_b 0 0 + jmp_true end_count_record_fields + pop_b 1 + incI + jmp count_fields_loop + + :end_count_record_fields + pop_b 1 + push_b 0 + update_b 2 1 + subI + | A: <afield_1 .. afield_m> <result> + | B: <n+m> <l> <bfield_1 .. bfield_n> <desc> <return> + create_array_ _ 1 0 + pushI 0 + push_b 1 + update_b 1 2 + update_b 0 1 + pop_b 1 + + :wrap_fields_loop + | A: <_{fields}> <afield_ .. afield_m> <result> + | B: <p> <i> <bfield_ .. bfield_n> <desc> <return> + push_b 0 + push_r_arg_t + eqI_b 0 0 + jmp_true end_wrap_record_fields + eqC_b 'i' 0 + jmp_true wrap_int_field + eqC_b 'c' 0 + jmp_true wrap_char_field + eqC_b 'r' 0 + jmp_true wrap_real_field + eqC_b 'b' 0 + jmp_true wrap_bool_field + eqC_b 'f' 0 + jmp_true wrap_file_field + eqC_b 'a' 0 + jmp_true wrap_graph_field + print_sc "Wrap: unimplemented record field type\n" + halt + + :wrap_int_field + pop_b 1 + + | create and fill int node + create + fillI_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 2 + update_b 0 1 + pop_b 1 + + jmp wrap_field + + :wrap_char_field + pop_b 1 + + | create and fill char node + create + fillC_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 2 + update_b 0 1 + pop_b 1 + + jmp wrap_field + + :wrap_bool_field + pop_b 1 + + | create and fill bool node + create + fillB_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 2 + update_b 0 1 + pop_b 1 + + jmp wrap_field + + + :wrap_real_field + pop_b 1 + + | create and fill real node + create + fillR_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 3 + update_b 0 2 + pop_b 2 + + jmp wrap_field + + :wrap_file_field + pop_b 1 + + | create and fill file node + create + fillF_b 2 0 + push_a 1 + update_a 1 2 + update_a 0 1 + pop_a 1 + + update_b 1 3 + update_b 0 2 + pop_b 2 + + jmp wrap_field + + :wrap_graph_field + pop_b 1 + jmp wrap_field + + :wrap_field + | A: <_{fields}> <field> <afield_ .. afield_m> + | wrap field + push_a 1 + build e_Wrap_sWrap 1 e_Wrap_nWrap + update_a 0 2 + pop_a 1 + + | update i-th element of _fields array with wrapped field + push_b 1 + update _ 1 0 + | A: <_{fields}> <afield_ .. afield_m> <result> + | B: <p> <i> <bfield_ .. bfield_n> <desc> <return> + + | increment index + push_b 1 + incI + update_b 0 2 + + | increment pointer in layout string + pop_b 1 + incI + + jmp wrap_fields_loop + + :end_wrap_record_fields + | A: <_{fields}> <result> + | B: <i=0> <p> <i> <desc> <return> + pop_b 3 + | A: <_{fields}> <result> + | B: <desc> <return> + + | create WrappedDescriptorOther node + build_r e_Wrap_rWrappedDescriptorId 0 1 0 0 + pop_b 1 + build_r e_Wrap_kWrappedDescriptorOther 1 0 0 0 + update_a 0 1 + pop_a 1 + | A: <descriptor> <{fields}> <result> + + | fill result node + fill_r e_Wrap_kWrappedRecord 2 0 2 0 0 + pop_a 2 + + | A: <result> + | B: <return> + | return to caller (determined by the return selector) + eqI_b 0 0 + jmp_true wrap_record_return_node + eqI_b 1 0 + jmp_true wrap_record_array_return + print_sc "Wrap: (record fields) unknown return selector\n" + halt + + :wrap_record_return_node + | A: <result> + | B: <return> + pop_b 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_array + | A: <array> <result> + | replace ARRAY by _ARRAY_ + pushA_a 0 + update_a 0 1 + pop_a 1 + + :wrap__array + | A: <_array> <result> + eq_desc _STRING_ 0 0 + jmp_false not_a_string + + :wrap__string + | fill result node + fill_r e_Wrap_kWrappedString 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + rtn + :not_a_string + + | push array element descriptor + push_r_args_b 0 0 2 2 1 + | A: <_array> <result> + | B: <desc> + push_b 0 + eq_desc_b BOOL 0 + jmp_true wrap_bool_array + push_b 0 + eq_desc_b INT 0 + jmp_true wrap_int_array + push_b 0 + eq_desc_b REAL 0 + jmp_true wrap_real_array + push_b 0 + eq_desc_b FILE 0 + jmp_true wrap_file_array + + pushI 0 + push_a 0 + push_arraysize _ 0 1 + | A: <_array> <result> + | B: <n> <i> <desc> + push_b 2 + update_b 2 3 + update_b 1 2 + update_b 0 1 + pop_b 1 + | B: <desc> <n> <i> + pushI 0 + eqI + | B: <n> <i> + jmp_false wrap_record_array + + push_b 0 + create_array_ _ 1 0 + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + .d 3 2 i i + jmp wrap_array_test + + .o 3 2 i i + :wrap_array_elements + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + + | wrap element + push_b 1 + push_a 1 + select _ 1 0 + build e_Wrap_sWrap 1 e_Wrap_nWrap + | A: <element> <_wrapped_array> <_array> <result> + | B: <n> <i> + | update i-th element of _wrapped_array with wrapped element + push_a 1 + push_b 1 + update _ 1 0 + update_a 0 1 + pop_a 1 + | B: <n> <i> + | increment index + push_b 1 + incI + update_b 0 2 + + | decrement n + pop_b 1 + decI + + .o 3 2 i i + :wrap_array_test + | B: <n> <i> + eqI_b 0 0 + .d 3 2 i i + jmp_false wrap_array_elements + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + pop_b 2 + update_a 0 1 + pop_a 1 + | A: <_wrapped_array> <result> + | B: + | fill result node + fill_r e_Wrap_kWrappedArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + + :wrap_bool_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedBoolArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_int_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedIntArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_real_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedRealArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_file_array + | A: <_array> <result> + | B: <desc> + pop_b 1 + + | fill result node + fill_r e_Wrap_kWrappedFileArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + + :wrap_record_array + | A: <_array> <result> + | B: <n> <i> + push_b 0 + create_array_ _ 1 0 + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + + jmp wrap_record_array_test + + :wrap_record_array_loop + | B: <n> <i> + pushI 1 + | push record element descriptor + push_r_args_b 1 0 2 2 1 + | B: <desc> <return> <n> <i> + + | create result node for wrap_record_fields + create + + | push fields from i-th array element + push_b 3 + push_a 2 + push_a_r_args + | A: <afield_1 .. afield_m> <elresult> <_wrapped_array> <_array> <result> + | B: <l> <bfieldb_1 .. bfield_n> <desc> <return> <n> <i> + | wrap record element + jmp wrap_record_fields + :wrap_record_array_return + | A: <element> <_wrapped_array> <_array> <result> + | B: <return> <n> <i> + pop_b 1 + | A: <element> <_wrapped_array> <_array> <result> + | B: <n> <i> + | update i-th of _wrapped_array with wrapped record element + push_a 1 + push_b 1 + update _ 1 0 + update_a 0 1 + pop_a 1 + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + | increment index + push_b 1 + incI + update_b 0 2 + pop_b 1 + + | decrement n + decI + + :wrap_record_array_test + eqI_b 0 0 + jmp_false wrap_record_array_loop + | A: <_wrapped_array> <_array> <result> + | B: <n> <i> + pop_b 2 + | B: + + update_a 0 1 + pop_a 1 + | A: <_wrapped_array> <result> + | fill result node + fill_r e_Wrap_kWrappedArray 1 0 1 0 0 + pop_a 1 + .d 1 0 + | A: <result> + | B: + rtn + } diff --git a/frontend/analtypes.dcl b/frontend/analtypes.dcl new file mode 100644 index 0000000..ae9b48d --- /dev/null +++ b/frontend/analtypes.dcl @@ -0,0 +1,8 @@ +definition module analtypes + +import checksupport, typesupport + + +analTypeDefs :: !{#CommonDefs} !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) + +instance <<< TypeKind diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl new file mode 100644 index 0000000..2793a43 --- /dev/null +++ b/frontend/analtypes.icl @@ -0,0 +1,487 @@ +implementation module analtypes + +import StdEnv +import syntax, checksupport, checktypes, check, typesupport, utilities, RWSDebug + +:: UnifyKindsInfo = + { uki_kind_heap ::!.KindHeap + , uki_error ::!.ErrorAdmin + } + +AS_NotChecked :== -1 + +instance <<< TypeKind +where + (<<<) file tk = file <<< toString (toKindInfo tk) + +instance toString KindInfo +where + toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr) + toString (KI_Const) = "*" + toString (KI_Arrow kinds) = kind_list_to_string kinds + where + kind_list_to_string [] = " ?????? " + kind_list_to_string [k] = "* -> *" + kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks + + +kindError kind1 kind2 error + = checkError "conflicting kinds: " (toString kind1 +++ " and " +++ toString kind2) error + +unifyKinds :: !KindInfo !KindInfo !*UnifyKindsInfo -> *UnifyKindsInfo +unifyKinds (KI_Indirection kind1) kind2 uni_info=:{uki_kind_heap} + = unifyKinds kind1 kind2 uni_info +unifyKinds kind1 (KI_Indirection kind2) uni_info=:{uki_kind_heap} + = unifyKinds kind1 kind2 uni_info +unifyKinds (KI_Var info_ptr1) kind=:(KI_Var info_ptr2) uni_info=:{uki_kind_heap} + | info_ptr1 == info_ptr2 + = uni_info + = { uni_info & uki_kind_heap = writePtr info_ptr1 (KI_Indirection kind) uki_kind_heap } +unifyKinds k1=:(KI_Var info_ptr1) kind uni_info=:{uki_kind_heap,uki_error} + | contains_kind_ptr info_ptr1 uki_kind_heap kind + = { uni_info & uki_error = kindError k1 kind uki_error } + = { uni_info & uki_kind_heap = writePtr info_ptr1 (KI_Indirection kind) uki_kind_heap } +where + contains_kind_ptr info_ptr uki_kind_heap (KI_Arrow kinds) + = any (contains_kind_ptr info_ptr uki_kind_heap) kinds + contains_kind_ptr info_ptr uki_kind_heap (KI_Indirection kind_info) + = contains_kind_ptr info_ptr uki_kind_heap kind_info + contains_kind_ptr info_ptr uki_kind_heap (KI_Var kind_info_ptr) + = info_ptr1 == kind_info_ptr + contains_kind_ptr info_ptr uki_kind_heap (KI_Const) + = False + +unifyKinds kind k1=:(KI_Var info_ptr1) uni_info + = unifyKinds k1 kind uni_info +unifyKinds kind1=:(KI_Arrow kinds1) kind2=:(KI_Arrow kinds2) uni_info=:{uki_error} + | length kinds1 == length kinds2 + = foldr2 unifyKinds uni_info kinds1 kinds2 + = { uni_info & uki_error = kindError kind1 kind2 uki_error } +unifyKinds KI_Const KI_Const uni_info + = uni_info +unifyKinds kind1 kind2 uni_info=:{uki_error} + = { uni_info & uki_error = kindError kind1 kind2 uki_error } + +class toKindInfo a :: !a -> KindInfo + +instance toKindInfo TypeKind +where + toKindInfo (KindVar info_ptr) + = KI_Var info_ptr + toKindInfo KindConst + = KI_Const + toKindInfo (KindArrow arity) + = KI_Arrow [ KI_Const \\ i <- [1 .. arity]] +// ---> ("toKindInfo", arity) + + +:: VarBind = + { vb_var :: !KindInfoPtr + , vb_vars :: ![KindInfoPtr] + } + +:: Conditions = + { con_top_var_binds :: ![KindInfoPtr] + , con_var_binds :: ![VarBind] + } + + + +:: AnalState = + { as_td_infos :: !.TypeDefInfos + , as_heaps :: !.TypeHeaps + , as_kind_heap :: !.KindHeap + , as_check_marks :: !.{# .{# Int}} + , as_next_num :: !Int + , as_deps :: ![Global Index] +// , as_groups :: ![[Global Index]] + , as_next_group_num :: !Int + , as_error :: !.ErrorAdmin + } + +:: TypeProperties :== BITVECT + +combineTypeProperties prop1 prop2 :== (combineHyperstrictness prop1 prop2) bitor (combineCoercionProperties prop1 prop2) + +condCombineTypeProperties has_root_attr prop1 prop2 + | has_root_attr + = combineTypeProperties prop1 prop2 + = combineTypeProperties prop1 (prop2 bitand (bitnot cIsNonCoercible)) + +combineCoercionProperties prop1 prop2 :== (prop1 bitor prop2) bitand cIsNonCoercible +combineHyperstrictness prop1 prop2 :== (prop1 bitand prop2) bitand cIsHyperStrict + +class analTypes type :: !Bool !{#CommonDefs} ![KindInfoPtr] !type !(!Conditions, !*AnalState) + -> (!Int, !KindInfo, TypeProperties, !(!Conditions, !*AnalState)) + +cDummyBool :== False + +instance analTypes AType +where + analTypes _ modules form_tvs atype=:{at_attribute,at_type} conds_as + = analTypes (has_root_attr at_attribute) modules form_tvs at_type conds_as + where + has_root_attr (TA_RootVar _) = True + has_root_attr _ = False + +instance analTypes TypeVar +where + analTypes has_root_attr modules form_tvs {tv_info_ptr} (conds=:{con_var_binds}, as=:{as_heaps, as_kind_heap}) + # (TVI_TypeKind kind_info_ptr, th_vars) = readPtr tv_info_ptr as_heaps.th_vars + (kind_info, as_kind_heap) = readPtr kind_info_ptr as_kind_heap + kind_info = skip_indirections kind_info + | isEmpty form_tvs + = (cMAXINT, kind_info, cIsHyperStrict, (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })) + = (cMAXINT, kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] }, + { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })) + where + skip_indirections (KI_Indirection kind) + = skip_indirections kind + skip_indirections kind + = kind + +instance analTypes Type +where + analTypes has_root_attr modules form_tvs (TV tv) conds_as + = analTypes has_root_attr modules form_tvs tv conds_as + analTypes has_root_attr modules form_tvs type=:(TA {type_index={glob_module,glob_object},type_arity} types) conds_as + # (ldep, (conds, as)) = anal_type_def modules glob_module glob_object conds_as + {td_arity} = modules.[glob_module].com_type_defs.[glob_object] + ({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object] + kind = if (td_arity == type_arity) KI_Const (KI_Arrow [ toKindInfo tk \\ tk <- drop type_arity tdi_kinds ]) + | ldep < cMAXINT /* hence we have a recursive type application */ // ---> ("analTypes", toString kind) + # (ldep2, type_props, conds_as) + = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as) + = (min ldep ldep2, kind, type_props, conds_as) + # (ldep2, type_props, conds_as) + = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as) +// ---> (types, tdi_kinds) + = (min ldep ldep2, kind, condCombineTypeProperties has_root_attr type_props tdi_properties, conds_as) + where + anal_types_of_rec_type_cons modules form_tvs [] _ conds_as + = (cMAXINT, cIsHyperStrict, conds_as) + anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as + # (ldep, type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as + (kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap + {uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error} + | is_type_var type + # (min_dep, other_type_props, conds_as) = + anal_types_of_rec_type_cons modules form_tvs types tvs (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) + = (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as) + # (min_dep, other_type_props, conds_as) = + anal_types_of_rec_type_cons modules form_tvs types tvs + ({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) + + # (min_dep, other_type_props, conds_as) = + anal_types_of_rec_type_cons modules form_tvs types tvs + ({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) + = (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as) + where + is_type_var {at_type = TV _} + = True + is_type_var _ + = False + + anal_types_of_type_cons modules form_tvs [] _ conds_as + = (cMAXINT, cIsHyperStrict, conds_as) + anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as + # (ldep, type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as + {uki_kind_heap, uki_error} = unifyKinds type_kind (toKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error} + (min_dep, other_type_props, conds_as) + = anal_types_of_type_cons modules form_tvs types tks (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) + = (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as) + anal_types_of_type_cons modules form_tvs types tks conds_as + = abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks)) + + anal_type_def modules module_index type_index (conds, as=:{as_check_marks}) + #! mark = as_check_marks.[module_index].[type_index] + | mark == AS_NotChecked + # (mark, ({con_var_binds,con_top_var_binds}, as)) = analTypeDef modules module_index type_index as + = (mark, ({con_top_var_binds = con_top_var_binds ++ conds.con_top_var_binds, con_var_binds = con_var_binds ++ conds.con_var_binds}, as)) + = (mark, (conds, as)) + + analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as + # (arg_ldep, arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as + (res_ldep, res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as + {uki_kind_heap, uki_error} = unifyKinds res_kind KI_Const (unifyKinds arg_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}) + type_props = if has_root_attr + (combineCoercionProperties arg_type_props res_type_props bitor cIsNonCoercible) + (combineCoercionProperties arg_type_props res_type_props) + = (min arg_ldep res_ldep, KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) + analTypes has_root_attr modules form_tvs (CV tv :@: types) conds_as + # (ldep1, type_kind, cv_props, conds_as) = analTypes has_root_attr modules form_tvs tv conds_as + (ldep2, type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) = check_type_list modules form_tvs types conds_as + {uki_kind_heap, uki_error} = unifyKinds type_kind (KI_Arrow type_kinds) {uki_kind_heap = as_kind_heap, uki_error = as_error} + type_props = if (is_non_coercible || has_root_attr) cIsNonCoercible (cv_props bitand cIsNonCoercible) + = (min ldep1 ldep2, KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) + + where + check_type_list modules form_tvs [] conds_as + = (cMAXINT, [], False, conds_as) + check_type_list modules form_tvs [type : types] conds_as + # (ldep1, tk, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as + {uki_kind_heap, uki_error} = unifyKinds tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} + (ldep2, tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }) + = (min ldep1 ldep2, [tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as) + analTypes has_root_attr modules form_tvs type conds_as + = (cMAXINT, KI_Const, cIsHyperStrict, conds_as) + +/* +analTypesOfConstructor :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !Bool !Index !Level !TypeAttribute !Conditions !*TypeSymbols !*TypeInfo !*CheckState + -> *(!TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) +*/ +analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_heaps,as_kind_heap}) + # {cons_exi_vars,cons_type} = cons_defs.[ds_index] + (coercible, th_vars, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_heaps.th_vars, as_kind_heap) + (cons_ldep, cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args + (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }) + (conses_ldep, other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as + properties = combineTypeProperties cons_properties other_properties + = (min cons_ldep conses_ldep, if coercible properties (properties bitor cIsNonCoercible), conds_as) +where +/* + check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState + -> *(![AType], ![[ATypeVar]], ![AttrInequality], !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) +*/ + new_local_kind_variables td_args (type_var_heap, as_kind_heap) + = foldSt new_kind td_args (True, type_var_heap, as_kind_heap) + where + new_kind {atv_variable={tv_info_ptr},atv_attribute} (coercible, type_var_heap, kind_heap) + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + = (coercible && is_not_a_variable atv_attribute, type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), + kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) + + is_not_a_variable (TA_RootVar var) = False + is_not_a_variable attr = True + + anal_types_of_cons modules [] conds_as + = (cMAXINT, cIsHyperStrict, conds_as) + anal_types_of_cons modules [type : types] conds_as + # (ldep1, other_type_props, conds_as) = anal_types_of_cons modules types conds_as + (ldep2, type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as + {uki_kind_heap, uki_error} = unifyKinds type_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} + cons_props = if (type_is_strict type.at_annotation) + (combineTypeProperties cv_props other_type_props) + (combineCoercionProperties cv_props other_type_props) + = (min ldep1 ldep2, cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })) + + where + type_is_strict AN_Strict + = True + type_is_strict annot + = False + +analTypesOfConstructor _ _ [] conds_as + = (cMAXINT, cIsHyperStrict, conds_as) + +/* +analRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !Bool !Index !Level !TypeAttribute !Index !Conditions !*TypeSymbols !*TypeInfo !*CheckState + -> (!TypeRhs, !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) +*/ + +analRhsOfTypeDef modules com_cons_defs (AlgType conses) conds_as + = analTypesOfConstructor modules com_cons_defs conses conds_as +analRhsOfTypeDef modules com_cons_defs (RecordType {rt_constructor}) conds_as + = analTypesOfConstructor modules com_cons_defs [rt_constructor] conds_as +analRhsOfTypeDef modules _ (SynType type) conds_as + # (ldep, type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as + {uki_kind_heap, uki_error} = unifyKinds type_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} + = (ldep, cv_props, (conds, { as & as_kind_heap = as_kind_heap, as_error = as_error })) + +emptyIdent name :== { id_name = name, id_info = nilPtr } + +newKindVariables td_args (type_var_heap, as_kind_heap) + = mapSt new_kind td_args (type_var_heap, as_kind_heap) +where + new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + = (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))) + + +/* +checkTypeDef :: !Bool !Index !Index !Level !*TypeSymbols !*TypeInfo !*CheckState -> (!Int, !Conditions, !*TypeSymbols, !*TypeInfo, !*CheckState); +checkTypeDef is_main_dcl type_index module_index level ts=:{ts_type_defs} ti=:{ti_kind_heap,ti_heaps} cs=:{cs_error} +*/ +analTypeDef modules type_module type_index as=:{as_error,as_heaps,as_kind_heap,as_td_infos} + # {com_type_defs,com_cons_defs} = modules.[type_module] + {td_name,td_pos,td_args,td_rhs} = com_type_defs.[type_index] + (is_abs_type, abs_type_properties) = is_abstract_type td_rhs + | is_abs_type + # (tdi, as_td_infos) = as_td_infos![type_module].[type_index] + = (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, + { as & as_td_infos = { as_td_infos & [type_module].[type_index] = { tdi & tdi_kinds = [ KindConst \\ _ <- td_args ], tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], + tdi_properties = abs_type_properties }}})) + # position = newPosition td_name td_pos + as_error = pushErrorAdmin position as_error + (tdi_kinds, (th_vars, as_kind_heap)) = newKindVariables td_args (as_heaps.th_vars, as_kind_heap) + (ldep, type_properties, (conds, as)) = analRhsOfTypeDef modules com_cons_defs td_rhs ({ con_top_var_binds = [], con_var_binds = [] }, + push_on_dep_stack type_module type_index + { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap, as_error = as_error, + as_td_infos = { as_td_infos & [type_module].[type_index].tdi_kinds = tdi_kinds }}) +// ---> (td_name, td_args, tdi_kinds) + = try_to_close_group modules type_module type_index ldep (conds, + { as & as_error = popErrorAdmin as.as_error, as_td_infos = { as.as_td_infos & [type_module].[type_index].tdi_properties = type_properties }}) +// ---> ("analTypeDef", td_name, type_module, type_index) +where + is_abstract_type (AbstractType properties) + = (True, properties) + is_abstract_type _ + = (False, cAllBitsClear) + + push_on_dep_stack module_index type_index as=:{as_deps,as_check_marks,as_next_num} + = { as & + as_deps = [{glob_module = module_index, glob_object = type_index } : as_deps], + as_check_marks = { as_check_marks & [module_index].[type_index] = as_next_num }, + as_next_num = inc as_next_num } + + try_to_close_group modules type_module type_index ldep (conds=:{con_top_var_binds,con_var_binds}, + as=:{as_check_marks,as_deps,as_next_group_num,as_kind_heap,as_heaps,as_td_infos}) + #! my_mark = as_check_marks.[type_module].[type_index] + | (ldep == cMAXINT || ldep == my_mark) + # (as_deps, as_check_marks, group) = close_group type_module type_index as_deps as_check_marks [] + (kinds, (type_properties, as_kind_heap, as_td_infos)) = determine_kinds_and_properties_of_group group as_kind_heap as_td_infos + kind_heap = unify_var_binds con_var_binds as_kind_heap + (normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars con_top_var_binds 0 as_kind_heap + (as_kind_heap, as_td_infos) = update_type_group_info group kinds type_properties normalized_top_vars group as_next_group_num kind_var_store as_kind_heap as_td_infos + = (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, + { as & as_check_marks = as_check_marks, as_deps = as_deps, as_kind_heap = as_kind_heap, + as_td_infos = as_td_infos, as_next_group_num = inc as_next_group_num })) + = (min my_mark ldep, (conds, as)) + + close_group first_module first_index [d:ds] marks group + # marks = { marks & [d.glob_module].[d.glob_object] = cMAXINT } + | d.glob_module == first_module && d.glob_object == first_index + = (ds, marks, [d : group]) + = close_group first_module first_index ds marks [d : group] + + determine_kinds_and_properties_of_group group kind_heap as_td_infos + = mapSt determine_kinds group (cIsHyperStrict, kind_heap, as_td_infos) + where + determine_kinds {glob_module,glob_object} (type_properties, kind_heap, as_td_infos) + # ({tdi_properties,tdi_kinds}, as_td_infos) = as_td_infos![glob_module].[glob_object] + (kinds, kind_heap) = mapSt retrieve_kind tdi_kinds kind_heap + = (kinds, (combineTypeProperties type_properties tdi_properties, kind_heap, as_td_infos)) + + retrieve_kind (KindVar kind_info_ptr) kind_heap + #! kind_info = sreadPtr kind_info_ptr kind_heap + = (determine_kind kind_info, kind_heap) + where + determine_kind (KI_Indirection kind) + = determine_kind kind + determine_kind (KI_Arrow kinds) + = KindArrow (length kinds) + determine_kind kind + = KindConst + + unify_var_binds :: ![VarBind] !*KindHeap -> *KindHeap + unify_var_binds binds kind_heap + = foldr unify_var_bind kind_heap binds + + unify_var_bind :: !VarBind !*KindHeap -> *KindHeap + unify_var_bind {vb_var, vb_vars} kind_heap + #! kind_info = sreadPtr vb_var kind_heap + # (vb_var, kind_heap) = determine_var_bind vb_var kind_info kind_heap + = redirect_vars vb_var vb_vars kind_heap + where + redirect_vars kind_info_ptr [var_info_ptr : var_info_ptrs] kind_heap + #! kind_info = sreadPtr var_info_ptr kind_heap + # (var_info_ptr, kind_heap) = determine_var_bind var_info_ptr kind_info kind_heap + | kind_info_ptr == var_info_ptr + = redirect_vars kind_info_ptr var_info_ptrs kind_heap + = redirect_vars kind_info_ptr var_info_ptrs (writePtr kind_info_ptr (KI_VarBind var_info_ptr) kind_heap) + redirect_vars kind_info_ptr [] kind_heap + = kind_heap + + determine_var_bind _ (KI_VarBind kind_info_ptr) kind_heap + #! kind_info = sreadPtr kind_info_ptr kind_heap + = determine_var_bind kind_info_ptr kind_info kind_heap + determine_var_bind kind_info_ptr kind_info kind_heap + = (kind_info_ptr, kind_heap) + + nomalize_var :: !KindInfoPtr !KindInfo !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) + nomalize_var orig_kind_info (KI_VarBind kind_info_ptr) (kind_store, kind_heap) + #! kind_info = sreadPtr kind_info_ptr kind_heap + = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) + nomalize_var kind_info_ptr (KI_NormVar var_number) (kind_store, kind_heap) + = (var_number, (kind_store, kind_heap)) + nomalize_var kind_info_ptr kind (kind_store, kind_heap) + = (kind_store, (inc kind_store, writePtr kind_info_ptr (KI_NormVar kind_store) kind_heap)) + + normalize_top_vars top_vars kind_store kind_heap + = mapSt normalize_top_var top_vars (kind_store, kind_heap) + where + normalize_top_var :: !KindInfoPtr !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) + normalize_top_var kind_info_ptr (kind_store, kind_heap) + #! kind_info = sreadPtr kind_info_ptr kind_heap + = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) + +// update_type_group_info :: ![Index] ![[TypeKind]] !TypeProperties ![Int] ![Int] !Int !*KindHeap !*{# CheckedTypeDef} -> (!*KindHeap,!*{# CheckedTypeDef}) + update_type_group_info [td:tds] [td_kinds : tds_kinds] type_properties top_vars group group_nr kind_store kind_heap td_infos + # (kind_store, kind_heap, td_infos) = update_type_def_info td td_kinds type_properties top_vars group group_nr kind_store kind_heap td_infos + = update_type_group_info tds tds_kinds type_properties top_vars group group_nr kind_store kind_heap td_infos + update_type_group_info [] [] type_properties top_vars group group_nr kind_store kind_heap td_infos + = (kind_heap, td_infos) + +// update_type_def_info :: !Int ![TypeKind] !TypeProperties ![Int] ![Int] !Int !*KindHeap !*{# CheckedTypeDef} -> (!Int,!*KindHeap,!*{# CheckedTypeDef}) + update_type_def_info {glob_module,glob_object} td_kinds type_properties top_vars group group_nr kind_store kind_heap td_infos + # (td_info=:{tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] + # (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds td_kinds top_vars kind_store kind_heap + = (kind_store, kind_heap, { td_infos & [glob_module].[glob_object] = + {td_info & tdi_properties = type_properties, tdi_kinds = td_kinds, tdi_group = group, + tdi_group_vars = group_vars, tdi_cons_vars = cons_vars, tdi_group_nr = group_nr } }) +// ---> ("update_type_def_info", glob_module, glob_object, group_nr) + where + determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap + #! kind_info = sreadPtr kind_info_ptr kind_heap + # (var_number, (kind_store, kind_heap)) = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) + (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info kind_vars kinds top_vars kind_store kind_heap + = case kind of + KindArrow _ + | is_a_top_var var_number top_vars + -> ([ var_number : group_vars ], [ encodeTopConsVar var_number : cons_vars ], kind_store, kind_heap) + -> ([ var_number : group_vars ], [ var_number : cons_vars ], kind_store, kind_heap) + _ + -> ([ var_number : group_vars ], cons_vars, kind_store, kind_heap) + determine_type_def_info [] [] top_vars kind_store kind_heap + = ([], [], kind_store, kind_heap) + + is_a_top_var var_number [ top_var_number : top_var_numbers] + = var_number == top_var_number || is_a_top_var var_number top_var_numbers + is_a_top_var var_number [] + = False + + +analTypeDefs :: !{#CommonDefs} !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) +analTypeDefs modules heaps error +// #! modules = modules ---> "analTypeDefs" + # sizes = [ size mod.com_type_defs - size mod.com_class_defs \\ mod <-: modules ] + + check_marks = { createArray nr_of_types AS_NotChecked \\ nr_of_types <- sizes } + type_def_infos = { createArray nr_of_types EmptyTypeDefInfo \\ nr_of_types <- sizes } + + as = { as_check_marks = check_marks, as_kind_heap = newHeap, as_heaps = heaps, as_td_infos = type_def_infos, + as_next_num = 0, as_deps = [], as_next_group_num = 0, as_error = error } + + {as_td_infos,as_heaps,as_error} = anal_type_defs modules 0 sizes as + = (as_td_infos, as_heaps, as_error) +where + anal_type_defs modules mod_index [ size : sizes ] as + # as = iFoldSt (anal_type_def modules mod_index) 0 size as + = anal_type_defs modules (inc mod_index) sizes as + anal_type_defs _ _ [] as + = as + + + anal_type_def modules mod_index type_index as=:{as_check_marks} + | as_check_marks.[mod_index].[type_index] == AS_NotChecked + # (_, (_, as)) = analTypeDef modules mod_index type_index as + = as + = as + +instance == AttributeVar +where + (==) av1 av2 = av1.av_info_ptr == av2.av_info_ptr + +instance <<< DynamicType +where + (<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type diff --git a/frontend/analunitypes.dcl b/frontend/analunitypes.dcl new file mode 100644 index 0000000..8afc662 --- /dev/null +++ b/frontend/analunitypes.dcl @@ -0,0 +1,14 @@ +definition module analunitypes + +import StdEnv +import syntax, checksupport + +typeProperties :: !Index !Index ![SignClassification] ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos + -> (!TypeSymbProperties, !*TypeVarHeap, !*TypeDefInfos) + +signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos + -> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos) + +propClassification :: !Index !Index ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos + -> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos) + diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl new file mode 100644 index 0000000..08cb748 --- /dev/null +++ b/frontend/analunitypes.icl @@ -0,0 +1,402 @@ +implementation module analunitypes + +import StdEnv +import syntax, checksupport, analtypes, check, typesupport, checktypes, utilities + +instance + SignClassification +where + (+) {sc_pos_vect=sc_pos_vect1,sc_neg_vect=sc_neg_vect1} {sc_pos_vect=sc_pos_vect2,sc_neg_vect=sc_neg_vect2} + = { sc_pos_vect = sc_pos_vect1 bitor sc_pos_vect2, sc_neg_vect = sc_neg_vect1 bitor sc_neg_vect2 } + +(*+) infixl 7 :: !Sign !SignClassification -> SignClassification +(*+) {pos_sign,neg_sign} {sc_pos_vect,sc_neg_vect} + = { sc_pos_vect = (if pos_sign sc_pos_vect 0) bitor (if neg_sign sc_neg_vect 0), + sc_neg_vect = (if neg_sign sc_pos_vect 0) bitor (if pos_sign sc_neg_vect 0) } + +sign_class_to_sign :: !SignClassification !Int -> Sign +sign_class_to_sign {sc_pos_vect,sc_neg_vect} index + = { pos_sign = sc_pos_vect bitand (1 << index) <> 0, neg_sign = sc_neg_vect bitand (1 << index) <> 0} + +set_sign_in_sign_class :: !Sign !Int !SignClassification -> SignClassification +set_sign_in_sign_class {pos_sign,neg_sign} index {sc_pos_vect,sc_neg_vect} + = { sc_pos_vect = sc_pos_vect bitor (if pos_sign (1 << index) 0), sc_neg_vect = sc_neg_vect bitor (if neg_sign (1 << index) 0) } + +typeProperties :: !Index !Index ![SignClassification] ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos + -> (!TypeSymbProperties, !*TypeVarHeap, !*TypeDefInfos) +typeProperties type_index module_index hio_signs hio_props defs type_var_heap td_infos + # {td_args} = defs.[module_index].com_type_defs.[type_index] + (td_info, td_infos) = td_infos![module_index].[type_index] + (tsp_sign, type_var_heap, td_infos) = determineSignClassOfTypeDef type_index module_index td_args td_info hio_signs defs type_var_heap td_infos + (tsp_propagation, type_var_heap, td_infos) = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos + tsp_coercible = (td_info.tdi_properties bitand cIsNonCoercible) == 0 + = ({tsp_sign = tsp_sign, tsp_propagation = tsp_propagation, tsp_coercible = tsp_coercible }, type_var_heap, td_infos) + +signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos + -> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos) +signClassification type_index module_index hio_signs defs type_var_heap td_infos + # {td_args} = defs.[module_index].com_type_defs.[type_index] + (td_info, td_infos) = td_infos![module_index].[type_index] + = determineSignClassOfTypeDef type_index module_index td_args td_info hio_signs defs type_var_heap td_infos + +removeTopClasses [cv : cvs] [tc : tcs] + | isATopConsVar cv + = removeTopClasses cvs tcs + = [tc : removeTopClasses cvs tcs] +removeTopClasses _ _ + = [] + +determineSignClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![SignClassification] {# CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos) +determineSignClassOfTypeDef type_index module_index td_args {tdi_classification,tdi_cons_vars,tdi_group_vars,tdi_group,tdi_group_nr} + hio_signs ci type_var_heap td_infos + # hio_signs = removeTopClasses tdi_cons_vars hio_signs + result = retrieveSignClassification hio_signs tdi_classification + = case result of + Yes {ts_type_sign} + -> (ts_type_sign, type_var_heap, td_infos) + No + # type_var_heap = bind_type_vars_to_signs td_args tdi_group_vars tdi_cons_vars hio_signs type_var_heap + (sign_class, type_var_heap, td_infos) + = newSignClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} + tdi_group hio_signs ci type_var_heap td_infos + -> (sign_class, foldSt restore_binds_of_type_var td_args type_var_heap, td_infos) + +where + bind_type_vars_to_signs [{atv_variable={tv_info_ptr}}: tvs] [gv : gvs] cons_vars hio_signs type_var_heap + # sign = determine_classification gv cons_vars hio_signs BottomSignClass + # (var_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + = bind_type_vars_to_signs tvs gvs cons_vars hio_signs (type_var_heap <:= (tv_info_ptr, TVI_SignClass gv sign var_info)) + bind_type_vars_to_signs [] group_vars cons_vars hio_signs type_var_heap + = type_var_heap + + determine_classification gv [cv : cvs] hio_signs=:[tc : tcs] cumm_sign_class + | isATopConsVar cv + | gv == decodeTopConsVar cv + = TopSignClass + = determine_classification gv cvs tcs cumm_sign_class + | gv == cv + = determine_classification gv cvs tcs (tc + cumm_sign_class) + = determine_classification gv cvs tcs cumm_sign_class + determine_classification gv cons_vars [] cumm_sign_class + = cumm_sign_class + + restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap + # (TVI_SignClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + = type_var_heap <:= (tv_info_ptr, old_info) + +newSignClassOfTypeDefGroup :: !Int !(Global Int) ![Global Int] ![SignClassification] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> *(!SignClassification,!*TypeVarHeap,!*TypeDefInfos) +newSignClassOfTypeDefGroup group_nr this_type group hio_signs ci type_var_heap td_infos + # (cumm_sign_env, type_var_heap, td_infos) = collect_sign_class_of_type_defs group_nr group ci BottomSignClass type_var_heap td_infos + (sign_class, td_infos) = update_sign_class_of_group this_type group cumm_sign_env hio_signs td_infos + = (sign_class, type_var_heap, td_infos) +where + update_sign_class_of_group my_index [] cumm_sign_env hio_signs td_infos + = (BottomSignClass, td_infos) + update_sign_class_of_group my_index [{glob_module,glob_object} : group] cumm_sign_env hio_signs td_infos + # (tdi=:{tdi_classification, tdi_group_vars},td_infos) = td_infos![glob_module].[glob_object] + sign_class = determine_sign_class tdi_group_vars cumm_sign_env BottomSignClass 0 + tdi_classification = addSignClassification hio_signs sign_class tdi_classification + td_infos = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} + (my_sign_class, td_infos) = update_sign_class_of_group my_index group cumm_sign_env hio_signs td_infos + = (if (my_index.glob_module == glob_module && my_index.glob_object == glob_object) sign_class my_sign_class, td_infos) + + determine_sign_class [gv : gvs] cumm_sign_env sign_class var_index + # sign_class = set_sign_in_sign_class (sign_class_to_sign cumm_sign_env gv) var_index sign_class + = determine_sign_class gvs cumm_sign_env sign_class (inc var_index) + determine_sign_class [] cumm_sign_env sign_class var_index + = sign_class + + collect_sign_class_of_type_defs group_nr [] ci cumm_sign_env type_var_heap td_infos + = (cumm_sign_env, type_var_heap, td_infos) + collect_sign_class_of_type_defs group_nr [{glob_module,glob_object} : group] ci cumm_sign_env type_var_heap td_infos + # {td_rhs} = ci.[glob_module].com_type_defs.[glob_object] + # (cumm_sign_env, type_var_heap, td_infos) = sign_class_of_type_def glob_module td_rhs group_nr ci cumm_sign_env type_var_heap td_infos + = collect_sign_class_of_type_defs group_nr group ci cumm_sign_env type_var_heap td_infos + + sign_class_of_type_def :: !Int !TypeRhs !Int !{#CommonDefs} !SignClassification !*TypeVarHeap *TypeDefInfos + -> (!SignClassification,!*TypeVarHeap,!*TypeDefInfos) + sign_class_of_type_def module_index (AlgType conses) group_nr ci cumm_sign_env type_var_heap td_infos + = sign_class_of_type_conses module_index conses group_nr ci cumm_sign_env type_var_heap td_infos + sign_class_of_type_def _ (SynType {at_type}) group_nr ci cumm_sign_env type_var_heap td_infos + # (sign_class, _, type_var_heap, td_infos) = signClassOfType at_type group_nr ci type_var_heap td_infos + = (cumm_sign_env + sign_class, type_var_heap, td_infos) + sign_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci cumm_sign_env type_var_heap td_infos + = sign_class_of_type_conses module_index [rt_constructor] group_nr ci cumm_sign_env type_var_heap td_infos + sign_class_of_type_def _ (AbstractType properties) _ _ _ type_var_heap td_infos + | properties bitand cIsNonCoercible == 0 + = (PosSignClass, type_var_heap, td_infos) + = (TopSignClass, type_var_heap, td_infos) + + sign_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_sign_class type_var_heap td_infos + #! cons_def = ci.[module_index].com_cons_defs.[ds_index] + # (cumm_sign_class, type_var_heap, td_infos) = sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class type_var_heap td_infos + = sign_class_of_type_conses module_index conses group_nr ci cumm_sign_class type_var_heap td_infos + sign_class_of_type_conses module_index [] _ _ cumm_sign_class type_var_heap td_infos + = (cumm_sign_class, type_var_heap, td_infos) + + sign_class_of_type_of_list [{at_type} : types] group_nr ci cumm_sign_class type_var_heap td_infos + # (sign_class, _, type_var_heap, td_infos) = signClassOfType at_type group_nr ci type_var_heap td_infos + = sign_class_of_type_of_list types group_nr ci (cumm_sign_class + sign_class) type_var_heap td_infos + sign_class_of_type_of_list [] _ _ cumm_sign_class type_var_heap td_infos + = (cumm_sign_class, type_var_heap, td_infos) + +IsAHioType :== True +IsNotAHioType :== False + +IsArrowKind (KindArrow _) = True +IsArrowKind _ = False + +signClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> *(!SignClassification,!SignClassification,!*TypeVarHeap,!*TypeDefInfos); +signClassOfTypeVariable {tv_info_ptr} ci type_var_heap td_infos + #! var_info = sreadPtr tv_info_ptr type_var_heap + = case var_info of + TVI_SignClass group_var_index var_class _ + -> (var_index_to_sign_class group_var_index, var_class, type_var_heap, td_infos) + _ + -> (BottomSignClass, TopSignClass, type_var_heap, td_infos) +where + var_index_to_sign_class :: !Int -> SignClassification + var_index_to_sign_class var_index + = { sc_pos_vect = 1 << var_index, sc_neg_vect = 0} + + +signClassOfType :: !Type !Int !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos -> *(!SignClassification,!SignClassification,!*TypeVarHeap,!*TypeDefInfos); +signClassOfType (TV tv) _ ci type_var_heap td_infos + = signClassOfTypeVariable tv ci type_var_heap td_infos + +signClassOfType (TA {type_index = {glob_module, glob_object}} types) group_nr ci type_var_heap td_infos + # ({tdi_group_nr,tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] + | tdi_group_nr == group_nr + = sign_class_of_type_list_of_rec_type types BottomSignClass ci type_var_heap td_infos + # {td_args,td_arity} = ci.[glob_module].com_type_defs.[glob_object] + (td_info, td_infos) = td_infos![glob_module].[glob_object] + (sign_classes, hio_signs, type_var_heap, td_infos) = collect_sign_classes_of_type_list types tdi_kinds ci type_var_heap td_infos + (type_class, type_var_heap, td_infos) = determineSignClassOfTypeDef glob_object glob_module td_args td_info hio_signs ci type_var_heap td_infos + sign_class = determine_cummulative_sign sign_classes type_class 0 BottomSignClass + = (sign_class, adjust_sign_class type_class td_arity, type_var_heap, td_infos) +where + + sign_class_of_type_list_of_rec_type [t : ts] cumm_sign_class ci type_var_heap td_infos + # (sign_class, type_class, type_var_heap, td_infos) = signClassOfType t.at_type group_nr ci type_var_heap td_infos + cumm_sign_class = { cumm_sign_class & sc_neg_vect = cumm_sign_class.sc_neg_vect bitor sign_class.sc_neg_vect } + = sign_class_of_type_list_of_rec_type ts cumm_sign_class ci type_var_heap td_infos + sign_class_of_type_list_of_rec_type [] cumm_sign_class ci type_var_heap td_infos + = (cumm_sign_class, TopSignClass, type_var_heap, td_infos) + + collect_sign_classes_of_type_list [t : ts] [tk : tks] ci type_var_heap td_infos + # (sign_class, type_class, type_var_heap, td_infos) = signClassOfType t.at_type group_nr ci type_var_heap td_infos + (sign_classes, hio_signs, type_var_heap, td_infos) = collect_sign_classes_of_type_list ts tks ci type_var_heap td_infos + sign_classes = [sign_class : sign_classes] + | IsArrowKind tk + = (sign_classes, [type_class:hio_signs], type_var_heap, td_infos) + = (sign_classes, hio_signs, type_var_heap, td_infos) + collect_sign_classes_of_type_list [] _ ci type_var_heap td_infos + = ([], [], type_var_heap, td_infos) + + determine_cummulative_sign [sc : scs] sign_class type_index cumm_class + # cumm_class = sign_class_to_sign sign_class type_index *+ sc + cumm_class + = determine_cummulative_sign scs sign_class (inc type_index) cumm_class + determine_cummulative_sign [] _ _ cumm_class + = cumm_class + + adjust_sign_class {sc_pos_vect,sc_neg_vect} arity + = { sc_pos_vect = sc_pos_vect >> arity, sc_neg_vect = sc_neg_vect >> arity } + +signClassOfType (CV tv :@: types) group_nr ci type_var_heap td_infos + # (sign_class, type_class, type_var_heap, td_infos) = signClassOfTypeVariable tv ci type_var_heap td_infos + (sign_class, type_var_heap, td_infos) = sign_class_of_type_list types group_nr type_class 0 sign_class ci type_var_heap td_infos + = (sign_class, BottomSignClass, type_var_heap, td_infos) +where + sign_class_of_type_list [{at_type} : ts] group_nr cv_sign_class type_index cumm_class ci type_var_heap td_infos + # (sign_class, _, type_var_heap, td_infos) = signClassOfType at_type group_nr ci type_var_heap td_infos + cumm_class = (sign_class_to_sign cv_sign_class type_index *+ sign_class) + cumm_class + = sign_class_of_type_list ts group_nr sign_class (inc type_index) cumm_class ci type_var_heap td_infos + sign_class_of_type_list [] _ _ _ cumm_class ci type_var_heap td_infos + = (cumm_class, type_var_heap, td_infos) + +signClassOfType (arg_type --> res_type) group_nr ci type_var_heap td_infos + # (arg_class, _, type_var_heap, td_infos) = signClassOfType arg_type.at_type group_nr ci type_var_heap td_infos + (res_class, _, type_var_heap, td_infos) = signClassOfType res_type.at_type group_nr ci type_var_heap td_infos + = (NegativeSign *+ arg_class + PositiveSign *+ res_class, BottomSignClass, type_var_heap, td_infos) + +signClassOfType type _ _ type_var_heap td_infos + = (BottomSignClass, BottomSignClass, type_var_heap, td_infos) + +propClassification :: !Index !Index ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos + -> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos) +propClassification type_index module_index hio_props defs type_var_heap td_infos + # {td_args, td_name} = defs.[module_index].com_type_defs.[type_index] + (td_info, td_infos) = td_infos![module_index].[type_index] + = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos + +determinePropClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![PropClassification] {# CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> (!PropClassification,!*TypeVarHeap, !*TypeDefInfos) +determinePropClassOfTypeDef type_index module_index td_args {tdi_classification, tdi_kinds, tdi_group, tdi_group_vars, tdi_cons_vars, tdi_group_nr} + hio_props ci type_var_heap td_infos + # hio_props = removeTopClasses tdi_cons_vars hio_props + result = retrievePropClassification hio_props tdi_classification + // ---> (td_args, tdi_kinds, tdi_group_vars) + = case result of + Yes {ts_type_prop} + -> (ts_type_prop, type_var_heap, td_infos) + No + # type_var_heap = bind_type_vars_to_props td_args tdi_group_vars tdi_cons_vars hio_props type_var_heap + (ts_type_prop, type_var_heap, td_infos) = newPropClassOfTypeDefGroup type_index module_index tdi_group hio_props + tdi_group_nr ci type_var_heap td_infos + -> (ts_type_prop, foldSt restore_binds_of_type_var td_args type_var_heap, td_infos) +// ---> ("determinePropClassOfTypeDef", ci.[module_index].com_type_defs.[type_index].td_name, ts_type_prop) +where + bind_type_vars_to_props [{atv_variable={tv_info_ptr}} : tvs] [gv : gvs] cons_vars hio_props type_var_heap + #! old_info = sreadPtr tv_info_ptr type_var_heap + # sign = determine_classification gv cons_vars hio_props NoPropClass + = bind_type_vars_to_props tvs gvs cons_vars hio_props (writePtr tv_info_ptr (TVI_PropClass gv sign old_info) type_var_heap) + bind_type_vars_to_props [] group_vars cons_vars hio_props type_var_heap + = type_var_heap + + determine_classification gv [cv : cvs] hio_props=:[tc : tcs] cumm_prop_class + | isATopConsVar cv + | gv == decodeTopConsVar cv + = PropClass + = determine_classification gv cvs tcs cumm_prop_class + | gv == cv + = determine_classification gv cvs tcs (tc bitor cumm_prop_class) + = determine_classification gv cvs tcs cumm_prop_class + determine_classification gv cons_vars [] cumm_prop_class + = cumm_prop_class + + restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap + # (TVI_PropClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + = type_var_heap <:= (tv_info_ptr, old_info) + +newPropClassOfTypeDefGroup :: !Int !Int ![Global Int] ![PropClassification] !Int !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> *(!PropClassification, !*TypeVarHeap, !*TypeDefInfos) +newPropClassOfTypeDefGroup type_index module_index group hio_props group_nr ci type_var_heap td_infos + # (cumm_prop_env, type_var_heap, td_infos) = collect_prop_class_of_type_defs group group_nr ci NoPropClass type_var_heap td_infos + (prop_class, td_infos) = update_prop_class_of_group type_index module_index group cumm_prop_env hio_props ci td_infos +// ---> ("newPropClassOfTypeDefGroup", (type_index, module_index), cumm_prop_env) + = (prop_class, type_var_heap, td_infos) +where + update_prop_class_of_group my_index module_index [] cumm_prop_env hio_props ci td_infos + = (NoPropClass, td_infos) + update_prop_class_of_group my_index module_index [{glob_module,glob_object} : group] cumm_prop_env hio_props ci td_infos + # (tdi=:{tdi_group_vars,tdi_classification},td_infos) = td_infos![glob_module].[glob_object] + prop_class = determine_prop_class tdi_group_vars cumm_prop_env NoPropClass 0 + tdi_classification = addPropClassification hio_props prop_class tdi_classification + td_infos = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} + (my_prop_class, td_infos) = update_prop_class_of_group my_index module_index group cumm_prop_env hio_props ci td_infos + | glob_module == module_index && my_index == glob_object +// ---> ("update_prop_class_of_group", (my_index, module_index), (glob_object, glob_module), prop_class) + = (prop_class, td_infos) + = (my_prop_class, td_infos) + + determine_prop_class [gv : gvs] cumm_prop_env prop_class var_index + | IsPropagating cumm_prop_env gv + = determine_prop_class gvs cumm_prop_env (prop_class bitor (IndexToPropClass var_index)) (inc var_index) + = determine_prop_class gvs cumm_prop_env prop_class (inc var_index) + determine_prop_class [] cumm_prop_env prop_class var_index + = prop_class + + collect_prop_class_of_type_defs [] group_nr ci cumm_prop_env type_var_heap td_infos + = (cumm_prop_env, type_var_heap, td_infos) + collect_prop_class_of_type_defs [{glob_module,glob_object} : group] group_nr ci cumm_prop_env type_var_heap td_infos + # {td_rhs} = ci.[glob_module].com_type_defs.[glob_object] + # (cumm_prop_env, type_var_heap, td_infos) = prop_class_of_type_def glob_module td_rhs group_nr ci cumm_prop_env type_var_heap td_infos + = collect_prop_class_of_type_defs group group_nr ci cumm_prop_env type_var_heap td_infos + + prop_class_of_type_def :: !Int !TypeRhs !Int !{#CommonDefs} !PropClassification !*TypeVarHeap *TypeDefInfos + -> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos) + prop_class_of_type_def module_index (AlgType conses) group_nr ci cumm_prop_env type_var_heap td_infos + = prop_class_of_type_conses module_index conses group_nr ci cumm_prop_env type_var_heap td_infos + prop_class_of_type_def module_index (SynType {at_type}) group_nr ci cumm_prop_env type_var_heap td_infos + # (prop_class, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos + = (cumm_prop_env bitor prop_class, type_var_heap, td_infos) + prop_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci cumm_prop_env type_var_heap td_infos + = prop_class_of_type_conses module_index [rt_constructor] group_nr ci cumm_prop_env type_var_heap td_infos + prop_class_of_type_def module_index (AbstractType _) _ _ _ type_var_heap td_infos + = (PropClass, type_var_heap, td_infos) + + prop_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_prop_class type_var_heap td_infos + #! cons_def = ci.[module_index].com_cons_defs.[ds_index] + # (cumm_prop_class, type_var_heap, td_infos) = prop_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_prop_class type_var_heap td_infos + = prop_class_of_type_conses module_index conses group_nr ci cumm_prop_class type_var_heap td_infos + prop_class_of_type_conses module_index [] _ _ cumm_prop_class type_var_heap td_infos + = (cumm_prop_class, type_var_heap, td_infos) + + prop_class_of_type_of_list [{at_type} : types] group_nr ci cumm_prop_class type_var_heap td_infos + # (prop_class, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos + = prop_class_of_type_of_list types group_nr ci (cumm_prop_class bitor prop_class) type_var_heap td_infos + prop_class_of_type_of_list [] _ _ cumm_prop_class type_var_heap td_infos + = (cumm_prop_class, type_var_heap, td_infos) + + +IndexToPropClass index :== 1 << index +IsPropagating prop_class_of_type type_index :== prop_class_of_type == (prop_class_of_type bitor IndexToPropClass type_index) +AdjustPropClass prop_class arity :== prop_class >> arity + + +propClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> *(!PropClassification,!PropClassification, !*TypeVarHeap, !*TypeDefInfos) +propClassOfTypeVariable {tv_info_ptr} ci type_var_heap td_infos + #! var_info = sreadPtr tv_info_ptr type_var_heap + = case var_info of + TVI_PropClass group_var_index var_class _ + -> (IndexToPropClass group_var_index, var_class, type_var_heap, td_infos) + _ + -> (NoPropClass, PropClass, type_var_heap, td_infos) + +propClassOfType :: !Type !Int !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos -> *(!PropClassification,!PropClassification, !*TypeVarHeap, !*TypeDefInfos) +propClassOfType (TV tv) _ ci type_var_heap td_infos + = propClassOfTypeVariable tv ci type_var_heap td_infos + +propClassOfType (TA {type_name,type_index = {glob_module, glob_object}} types) group_nr ci type_var_heap td_infos + # ({tdi_group_nr,tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] + | tdi_group_nr == group_nr + = (NoPropClass, PropClass, type_var_heap, td_infos ) + # {td_args,td_arity} = ci.[glob_module].com_type_defs.[glob_object] + (td_info, td_infos) = td_infos![glob_module].[glob_object] + (prop_classes, hio_signs, type_var_heap, td_infos) = collect_prop_classes_of_hio_types types tdi_kinds group_nr ci type_var_heap td_infos + (type_class, type_var_heap, td_infos) = determinePropClassOfTypeDef glob_object glob_module td_args td_info hio_signs ci type_var_heap td_infos + (prop_class, type_var_heap, td_infos) = prop_classes_of_type_list types tdi_kinds prop_classes type_class 0 group_nr ci NoPropClass type_var_heap td_infos + = (prop_class, AdjustPropClass type_class td_arity, type_var_heap, td_infos) +// ---> ("propClassOfType (TA ...)", type_name, prop_class) + +where + collect_prop_classes_of_hio_types [{at_type} : types] [ KindArrow _ : tks ] group_nr ci type_var_heap td_infos + # (prop_class, type_class, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos + (prop_classes, hio_signs, type_var_heap, td_infos) = collect_prop_classes_of_hio_types types tks group_nr ci type_var_heap td_infos + = ([prop_class : prop_classes], [type_class : hio_signs], type_var_heap, td_infos) + collect_prop_classes_of_hio_types [_ : types] [ _ : tks ] _ _ type_var_heap td_infos + = ([], [], type_var_heap, td_infos) + collect_prop_classes_of_hio_types [] _ _ _ type_var_heap td_infos + = ([], [], type_var_heap, td_infos) + + prop_classes_of_type_list [ _ : types ] [ KindArrow _ : tks] [pc : pcs] prop_class_of_type type_index group_nr ci cumm_class type_var_heap td_infos + | IsPropagating prop_class_of_type type_index + = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci (cumm_class bitor pc) type_var_heap td_infos + = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci cumm_class type_var_heap td_infos + prop_classes_of_type_list [ {at_type} : types] [ _ : tks] pcs prop_class_of_type type_index group_nr ci cumm_class type_var_heap td_infos + | IsPropagating prop_class_of_type type_index + # (pc, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos + = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci (cumm_class bitor pc) type_var_heap td_infos + = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci cumm_class type_var_heap td_infos + prop_classes_of_type_list [] [] _ _ _ _ _ cumm_class type_var_heap td_infos + = (cumm_class, type_var_heap, td_infos) + +propClassOfType (CV tv :@: types) group_nr ci type_var_heap td_infos + # (prop_class, type_class, type_var_heap, td_infos) = propClassOfTypeVariable tv ci type_var_heap td_infos + (prop_class, type_var_heap, td_infos) = prop_class_of_type_list types type_class 0 group_nr ci prop_class type_var_heap td_infos + = (prop_class, NoPropClass, type_var_heap, td_infos) +where + prop_class_of_type_list [{at_type} : types] cv_prop_class type_index group_nr ci cumm_class type_var_heap td_infos + | IsPropagating cv_prop_class type_index + # (pc, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos + = prop_class_of_type_list types cv_prop_class (inc type_index) group_nr ci (cumm_class bitor pc) type_var_heap td_infos + = prop_class_of_type_list types cv_prop_class (inc type_index) group_nr ci cumm_class type_var_heap td_infos + prop_class_of_type_list [] _ _ _ _ cumm_class type_var_heap td_infos + = (cumm_class, type_var_heap, td_infos) + +propClassOfType _ _ _ type_var_heap td_infos + = (NoPropClass, NoPropClass, type_var_heap, td_infos) + diff --git a/frontend/cheat.dcl b/frontend/cheat.dcl new file mode 100644 index 0000000..9ec0617 --- /dev/null +++ b/frontend/cheat.dcl @@ -0,0 +1,3 @@ +system module cheat + +i :: !b -> a diff --git a/frontend/cheat.icl b/frontend/cheat.icl new file mode 100644 index 0000000..776f323 --- /dev/null +++ b/frontend/cheat.icl @@ -0,0 +1,10 @@ +implementation module cheat + +i :: !a -> b +i x = + code + { .inline i + no_op + .end + } + diff --git a/frontend/check.dcl b/frontend/check.dcl new file mode 100644 index 0000000..c91ac95 --- /dev/null +++ b/frontend/check.dcl @@ -0,0 +1,20 @@ +definition module check + +import syntax, transform, checksupport, typesupport, predef + +//MOVE +//cIclModIndex :== 0 +cPredefinedModuleIndex :== 1 + +checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File + -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) + +retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index) + +newFreeVariable :: !FreeVar ![FreeVar] ->(!Bool, ![FreeVar]) + +convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index + +determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps -> (!SymbolType, !Specials, !*TypeHeaps) + + diff --git a/frontend/check.icl b/frontend/check.icl new file mode 100644 index 0000000..06d4f34 --- /dev/null +++ b/frontend/check.icl @@ -0,0 +1,3037 @@ +implementation module check + +import StdEnv + +import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug + +import explicitimports + +// MW moved cIclModIndex :== 0 +cPredefinedModuleIndex :== 1 + +convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index +convertIndex index table_index (Yes tables) + = tables.[table_index].[index] +convertIndex index table_index No + = index + +getPredefinedGlobalSymbol symb_index module_index req_ste_kind arity cs=:{cs_predef_symbols,cs_symbol_table} + #! pre_def_mod = cs_predef_symbols.[module_index] + # mod_id = pre_def_mod.pds_ident + #! mod_entry = sreadPtr mod_id.id_info cs_symbol_table + | mod_entry.ste_kind == STE_ClosedModule + # (glob_object, cs) = get_predefined_symbol symb_index req_ste_kind arity mod_entry.ste_index cs + = ({ glob_object = glob_object, glob_module = mod_entry.ste_index }, cs) + = ({ glob_object = { ds_ident = { id_name = "** ERRONEOUS **", id_info = nilPtr }, ds_index = NoIndex, ds_arity = arity }, glob_module = NoIndex}, + { cs & cs_error = checkError mod_id "not imported" cs.cs_error}) +where + get_predefined_symbol symb_index req_ste_kind arity mod_index cs=:{cs_predef_symbols,cs_symbol_table,cs_error} + #! pre_def_symb = cs_predef_symbols.[symb_index] + # symb_id = pre_def_symb.pds_ident + #! symb_entry = sreadPtr symb_id.id_info cs_symbol_table + | symb_entry.ste_kind == req_ste_kind + = ({ ds_ident = symb_id, ds_index = symb_entry.ste_index, ds_arity = arity }, cs) + = case symb_entry.ste_kind of + STE_Imported kind module_index + | mod_index == module_index && kind == req_ste_kind + -> ({ ds_ident = symb_id, ds_index = symb_entry.ste_index, ds_arity = arity }, cs) + _ + -> ({ ds_ident = symb_id, ds_index = NoIndex, ds_arity = arity }, { cs & cs_error = checkError symb_id "undefined" cs.cs_error }) + +checkTypeClasses :: !Index !Index !Int !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState + -> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState) +checkTypeClasses class_index module_index upper_limit class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error} + | class_index == size class_defs + = (class_defs, member_defs, type_defs, modules, type_heaps, cs) + #! class_def = class_defs.[class_index] + # {class_name,class_pos,class_args,class_context,class_members} = class_def + position = newPosition class_name class_pos + cs_error = setErrorAdmin position cs_error + (rev_class_args, cs_symbol_table, th_vars, cs_error) + = add_variables_to_symbol_table cGlobalScope class_args [] cs_symbol_table th_vars cs_error + cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error } + (class_context, type_defs, class_defs, modules, type_heaps, cs) + = checkTypeContexts class_context module_index type_defs class_defs modules { type_heaps & th_vars = th_vars } cs + (class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table + class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }} + member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs +// MW was = checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table } + = checkTypeClasses (inc class_index) module_index upper_limit class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table } +where + add_variables_to_symbol_table :: !Level ![TypeVar] ![TypeVar] !*SymbolTable !*TypeVarHeap !*ErrorAdmin + -> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin) + add_variables_to_symbol_table level [] rev_class_args symbol_table th_vars error + = (rev_class_args, symbol_table, th_vars, error) + add_variables_to_symbol_table level [var=:{tv_name={id_name,id_info}} : vars] rev_class_args symbol_table th_vars error + #! entry = sreadPtr id_info symbol_table + | entry.ste_kind == STE_Empty || entry.ste_def_level < level + # (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars + # symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex level entry + = add_variables_to_symbol_table level vars [{ var & tv_info_ptr = new_var_ptr} : rev_class_args] symbol_table th_vars error + = add_variables_to_symbol_table level vars rev_class_args symbol_table th_vars (checkError id_name "(variable) already defined" error) + + retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table + #! entry = sreadPtr id_info symbol_table + = retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous)) + retrieve_variables_from_symbol_table [] class_args symbol_table + = (class_args, symbol_table) + + set_classes_in_member_defs mem_offset class_members glob_class_index member_defs + | mem_offset == size class_members + = member_defs + # {ds_index} = class_members.[mem_offset] + #! member_def = member_defs.[ds_index] + = set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }} + + +checkSpecial :: !Index !FunType !Index !SpecialSubstitution (!Index, ![FunType], !*Heaps, !*ErrorAdmin) + -> (!Special, (!Index, ![FunType], !*Heaps, !*ErrorAdmin)) +checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, special_types, heaps, error) + # (special_type, hp_type_heaps) = substitute_type ft_type subst heaps.hp_type_heaps + (spec_types, error) = checkAndCollectTypesOfContexts special_type.st_context error + ft_type = { special_type & st_context = [] } + (new_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap + = ( { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types, spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs }, + ((inc next_inst_index), [{ fun_type & ft_type = ft_type, ft_specials = SP_FunIndex fun_index, ft_type_ptr = new_info_ptr} : special_types ], + { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }, error)) +where + substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps + # (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps) + = instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment [] type_heaps + = ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars, + st_context = st_context, st_attr_env = st_attr_env }, type_heaps) + +checkDclFunctions :: !Index !Index ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !u:{#.DclModule} !*Heaps !*CheckState + -> (!Index, ![FunType], ![FunType], !z:{#CheckedTypeDef}, !y:{#ClassDef}, !w:{#DclModule}, !.Heaps, !.CheckState), [u v <= w, x <= y, u v <= z] +checkDclFunctions module_index first_inst_index fun_types type_defs class_defs modules heaps cs + = check_dcl_functions module_index fun_types 0 first_inst_index [] [] type_defs class_defs modules heaps cs +where + check_dcl_functions module_index [] fun_index next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs + = (next_inst_index, collected_funtypes, collected_instances, type_defs, class_defs, modules, heaps, cs) + check_dcl_functions module_index [fun_type=:{ft_symb,ft_type,ft_pos,ft_specials} : fun_types] fun_index + next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs + # position = newPosition ft_symb ft_pos + cs = { cs & cs_error = setErrorAdmin position cs.cs_error } + (ft_type, ft_specials, type_defs, class_defs, modules, hp_type_heaps, cs) + = checkSymbolType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs + (spec_types, next_inst_index, collected_instances, heaps, cs_error) + = check_specials module_index { fun_type & ft_type = ft_type } fun_index ft_specials next_inst_index collected_instances + { heaps & hp_type_heaps = hp_type_heaps } cs.cs_error + (new_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap + = check_dcl_functions module_index fun_types (inc fun_index) next_inst_index [ + { fun_type & ft_type = ft_type, ft_specials = spec_types, ft_type_ptr = new_info_ptr } : collected_funtypes] + collected_instances type_defs class_defs modules { heaps & hp_var_heap = hp_var_heap } { cs & cs_error = cs_error } + + check_specials :: !Index !FunType !Index !Specials !Index ![FunType] !*Heaps !*ErrorAdmin + -> (!Specials, !Index, ![FunType], !*Heaps, !*ErrorAdmin) + check_specials mod_index fun_type fun_index (SP_Substitutions substs) next_inst_index all_instances heaps error + # (list_of_specials, (next_inst_index, all_instances, heaps, cs_error)) + = mapSt (checkSpecial mod_index fun_type fun_index) substs (next_inst_index, all_instances, heaps, error) + = (SP_ContextTypes list_of_specials, next_inst_index, all_instances, heaps, cs_error) + check_specials mod_index fun_type fun_index SP_None next_inst_index all_instances heaps error + = (SP_None, next_inst_index, all_instances, heaps, error) + + +checkSpecialsOfInstances :: !Index !Index ![ClassInstance] !Index ![ClassInstance] ![FunType] {# FunType} *{! [Special] } !*Heaps !*ErrorAdmin + -> (!Index, ![ClassInstance], ![FunType], !*{! [Special]}, !*Heaps, !*ErrorAdmin) +checkSpecialsOfInstances mod_index first_mem_index [class_inst=:{ins_members,ins_specials} : class_insts] next_inst_index all_class_instances all_specials + new_inst_defs all_spec_types heaps error + = case ins_specials of + SP_TypeOffset type_offset + # (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, error) + = check_and_build_members mod_index first_mem_index 0 ins_members type_offset next_inst_index [] all_specials new_inst_defs all_spec_types heaps error + class_inst = { class_inst & ins_members = { mem \\ mem <- reverse rev_mem_specials } } + -> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances] + all_specials new_inst_defs all_spec_types heaps error + SP_None + -> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances] + all_specials new_inst_defs all_spec_types heaps error +where + check_and_build_members mod_index first_mem_index member_offset ins_members type_offset next_inst_index rev_mem_specials all_specials inst_spec_defs + all_spec_types heaps error + | member_offset < size ins_members + # member = ins_members.[member_offset] + member_index = member.ds_index + spec_member_index = member_index - first_mem_index + #! spec_types = all_spec_types.[spec_member_index] + # mem_inst = inst_spec_defs.[spec_member_index] + (SP_Substitutions specials) = mem_inst.ft_specials + env = specials !! type_offset + member = { member & ds_index = next_inst_index } + (spec_type, (next_inst_index, all_specials, heaps, error)) + = checkSpecial mod_index mem_inst member_index env (next_inst_index, all_specials, heaps, error) + all_spec_types = { all_spec_types & [spec_member_index] = [ spec_type : spec_types] } + = check_and_build_members mod_index first_mem_index (inc member_offset) ins_members type_offset next_inst_index [ member : rev_mem_specials ] + all_specials inst_spec_defs all_spec_types heaps error + = (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, error) + +checkSpecialsOfInstances mod_index first_mem_index [] next_inst_index all_class_instances all_specials inst_spec_defs all_spec_types heaps error + = (next_inst_index, all_class_instances, all_specials, all_spec_types, heaps, error) + +/* MW was +checkMemberTypes :: !Index !*{#MemberDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState + -> (!*{#MemberDef}, !*{#CheckedTypeDef}, !*{#ClassDef}, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) +checkMemberTypes module_index member_defs type_defs class_defs modules type_heaps var_heap cs + #! nr_of_members = size member_defs + = iFoldSt (check_class_member module_index) 0 nr_of_members (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs) +*/ +checkMemberTypes :: !Index !Int !*{#MemberDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState + -> (!*{#MemberDef}, !*{#CheckedTypeDef}, !*{#ClassDef}, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) +checkMemberTypes module_index nr_of_members member_defs type_defs class_defs modules type_heaps var_heap cs + = iFoldSt (check_class_member module_index) 0 nr_of_members (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs) +where + check_class_member module_index member_index (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs) + # (member_def=:{me_symb,me_type,me_pos}, member_defs) = member_defs![member_index] + position = newPosition me_symb me_pos + cs = { cs & cs_error = setErrorAdmin position cs.cs_error } + (me_type, _, type_defs, class_defs, modules, type_heaps, cs) + = checkSymbolType module_index me_type SP_None type_defs class_defs modules type_heaps cs + me_class_vars = map (\(TV type_var) -> type_var) (hd me_type.st_context).tc_types + (me_type_ptr, var_heap) = newPtr VI_Empty var_heap + = ({ member_defs & [member_index] = { member_def & me_type = me_type, me_class_vars = me_class_vars, me_type_ptr = me_type_ptr }}, + type_defs, class_defs, modules, type_heaps, var_heap, cs) + +:: InstanceSymbols = + { is_type_defs :: !.{# CheckedTypeDef} + , is_class_defs :: !.{# ClassDef} + , is_member_defs :: !.{# MemberDef} + , is_modules :: !.{# DclModule} + } + +checkInstanceDefs :: !Index !*{#ClassInstance} !u:{#CheckedTypeDef} !u:{#ClassDef} !u:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*CheckState + -> (!.{#ClassInstance},!u:{#CheckedTypeDef},!u:{#ClassDef},!u:{#MemberDef},!u:{#DclModule},!.TypeHeaps,!.CheckState) +checkInstanceDefs mod_index instance_defs type_defs class_defs member_defs modules type_heaps cs + # is = { is_type_defs = type_defs, is_class_defs = class_defs, is_member_defs = member_defs, is_modules = modules } + (instance_defs, is, type_heaps, cs) = check_instance_defs 0 mod_index instance_defs is type_heaps cs + = (instance_defs, is.is_type_defs, is.is_class_defs, is.is_member_defs, is.is_modules, type_heaps, cs) +where + check_instance_defs :: !Index !Index !*{# ClassInstance} !u:InstanceSymbols !*TypeHeaps !*CheckState + -> (!*{# ClassInstance},!u:InstanceSymbols,!*TypeHeaps,!*CheckState) + check_instance_defs inst_index mod_index instance_defs is type_heaps cs + | inst_index < size instance_defs + #! instance_def = instance_defs.[inst_index] + # (instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs + = check_instance_defs (inc inst_index) mod_index { instance_defs & [inst_index] = instance_def } is type_heaps cs + = (instance_defs, is, type_heaps, cs) + + check_instance :: !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState) + check_instance module_index + ins=:{ins_members,ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident} + is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # (class_index, class_mod_index, class_def, is_class_defs, is_modules) = get_class_def entry module_index is_class_defs is_modules + is = { is & is_class_defs = is_class_defs, is_modules = is_modules } + cs = pushErrorAdmin (newPosition ins_ident ins_pos) cs + | class_index <> NotFound + | class_def.class_arity == ds_arity + # (ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs) = checkInstanceType module_index ins_type ins_specials + is.is_type_defs is.is_class_defs is.is_modules type_heaps cs + ins_class = { glob_object = { class_name & ds_index = class_index }, glob_module = class_mod_index} + is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules } + = ({ins & ins_class = ins_class, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, popErrorAdmin cs) + = ( ins + , is + , type_heaps + , popErrorAdmin { cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ds_arity) cs.cs_error } + ) + = (ins, is, type_heaps, popErrorAdmin { cs & cs_error = checkError id_name "class undefined" cs.cs_error }) + + get_class_def :: !SymbolTableEntry !Index v:{# ClassDef} u:{# DclModule} -> (!Index,!Index,ClassDef,!v:{# ClassDef},!u:{# DclModule}) + get_class_def {ste_kind = STE_Class, ste_index} mod_index class_defs modules + #! class_def = class_defs.[ste_index] + = (ste_index, mod_index, class_def, class_defs, modules) + get_class_def {ste_kind = STE_Imported STE_Class dcl_index, ste_index, ste_def_level} mod_index class_defs modules + #! dcl_mod = modules.[dcl_index] + # class_def = dcl_mod.dcl_common.com_class_defs.[ste_index] + = (ste_index, dcl_index, class_def, class_defs, modules) + get_class_def _ mod_index class_defs modules + = (NotFound, cIclModIndex, abort "no class definition", class_defs, modules) + +checkInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState + -> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState) +checkInstances mod_index icl_common=:{com_instance_defs,com_class_defs,com_member_defs} modules var_heap type_heaps cs=:{cs_error} + | cs_error.ea_ok + # (instance_types, com_instance_defs, com_class_defs, com_member_defs, modules, var_heap, type_heaps, cs) + = check_instances 0 mod_index [] com_instance_defs com_class_defs com_member_defs modules var_heap type_heaps cs + = (instance_types, { icl_common & com_instance_defs = com_instance_defs,com_class_defs = com_class_defs,com_member_defs = com_member_defs }, + modules, var_heap, type_heaps, cs) + = ([], icl_common, modules, var_heap, type_heaps, cs) +where + check_instances :: !Index !Index ![(Index,SymbolType)] !x:{# ClassInstance} !w:{# ClassDef} !v:{# MemberDef} !u:{# DclModule} + !*VarHeap !*TypeHeaps !*CheckState + -> (![(Index,SymbolType)], !x:{# ClassInstance}, !w:{# ClassDef}, !v:{# MemberDef}, !u:{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) + check_instances inst_index mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs + | inst_index < size instance_defs + #! {ins_class,ins_members,ins_type} = instance_defs.[inst_index] + # ({class_members,class_name}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules + class_size = size class_members + | class_size == size ins_members + # (instance_types, member_defs, modules, var_heap, type_heaps, cs) = check_member_instances mod_index ins_class.glob_module + 0 class_size ins_members class_members ins_type instance_types member_defs modules var_heap type_heaps cs + = check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs + = check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps + { cs & cs_error = checkError class_name "different number of members specified" cs.cs_error } + = (instance_types, instance_defs, class_defs, member_defs, modules, var_heap, type_heaps, cs) +/* + check_member_instances :: !Index !Index ![DefinedSymbol] ![DefinedSymbol] !InstanceType ![TypeVar] ![(Index,SymbolType)] !v:{# MemberDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (![(Index,SymbolType)], !v:{# MemberDef},!u:{# DclModule},!*TypeHeaps,!*CheckState) + +*/ + + check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members + ins_type instance_types member_defs modules var_heap type_heaps cs + | mem_offset == class_size + = (instance_types, member_defs, modules, var_heap, type_heaps, cs) + # ins_member = ins_members.[mem_offset] + class_member = class_members.[mem_offset] + | ins_member.ds_ident <> class_member.ds_ident + = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type + instance_types member_defs modules var_heap type_heaps + { cs & cs_error = checkError class_member.ds_ident "instance of class member expected" cs.cs_error} + | ins_member.ds_arity <> class_member.ds_arity + = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type + instance_types member_defs modules var_heap type_heaps + { cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error} + # ({me_type,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules + (instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps + (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap + = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type + [ (ins_member.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs modules var_heap type_heaps cs + +getClassDef :: !(Global DefinedSymbol) !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule}) +getClassDef {glob_module, glob_object={ds_ident, ds_index}} mod_index class_defs modules + | glob_module == mod_index + #! class_def = class_defs.[ds_index] + = (class_def, class_defs, modules) + #! dcl_mod = modules.[glob_module] + = (dcl_mod.dcl_common.com_class_defs.[ds_index], class_defs, modules) + +getMemberDef :: !Int Int !Int !u:{#MemberDef} !v:{#DclModule} -> (!MemberDef,!u:{#MemberDef},!v:{#DclModule}) +getMemberDef mem_mod mem_index mod_index member_defs modules + | mem_mod == mod_index + #! member_def = member_defs.[mem_index] + = (member_def, member_defs, modules) + #! dcl_mod = modules.[mem_mod] + = (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules) + +instantiateTypes :: ![TypeVar] ![AttributeVar] !types ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps + -> (![TypeVar], ![AttributeVar], !types , ![TypeContext], ![AttrInequality], ![SpecialSubstitution], !*TypeHeaps) | substitute types +instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_environ, ss_vars, ss_attrs, ss_context} special_subst_list type_heaps=:{th_vars, th_attrs} + # th_vars = clear_vars old_type_vars th_vars + + (new_type_vars, th_vars) = foldSt build_var_subst ss_vars ([], th_vars) + (new_attr_vars, th_attrs) = foldSt build_attr_subst ss_attrs ([], th_attrs) + + type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (new_ss_context, type_heaps) = substitute ss_context type_heaps + + (inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars) + (inst_attr_vars, th_attrs) = foldSt build_attr_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs) + + (inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (inst_contexts, type_heaps) = substitute type_contexts type_heaps + (inst_attr_env, type_heaps) = substitute attr_env type_heaps + + (special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars + + = (inst_vars, inst_attr_vars, inst_types, inst_contexts ++ new_ss_context, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }) +where + clear_vars type_vars type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) type_vars type_var_heap + + determine_free_var tv=:{tv_info_ptr} (free_vars, type_var_heap) + # (type_var_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + = case type_var_info of + TVI_Empty + -> build_var_subst tv (free_vars, type_var_heap) + _ + -> (free_vars, type_var_heap) + + build_type_subst {bind_src,bind_dst} type_heaps + # (bind_src, type_heaps) = substitute bind_src type_heaps + = { type_heaps & th_vars = writePtr bind_dst.tv_info_ptr (TVI_Type bind_src) type_heaps.th_vars} + + build_var_subst var (free_vars, type_var_heap) + # (new_info_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap + new_fv = { var & tv_info_ptr = new_info_ptr} + = ([ new_fv : free_vars ], writePtr var.tv_info_ptr (TVI_Type (TV new_fv)) type_var_heap) + + build_attr_subst attr (free_attrs, attr_var_heap) + # (new_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_attr = { attr & av_info_ptr = new_info_ptr} + = ([new_attr : free_attrs], writePtr attr.av_info_ptr (AVI_Attr (TA_Var new_attr)) attr_var_heap) + + adjust_special_subst special_subst=:{ss_environ} type_var_heap + # (ss_environ, type_var_heap) = mapSt adjust_special_bind ss_environ type_var_heap + = ({ special_subst & ss_environ = ss_environ }, type_var_heap) + + adjust_special_bind bind=:{bind_dst={tv_info_ptr}} type_var_heap + # (TVI_Type (TV new_tv), type_var_heap) = readPtr tv_info_ptr type_var_heap + = ({ bind & bind_dst = new_tv }, type_var_heap) + +substituteInstanceType :: !InstanceType !SpecialSubstitution !*TypeHeaps -> (!InstanceType,!*TypeHeaps) +substituteInstanceType it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps + # (it_vars, it_attr_vars, it_types, it_context, _, _, type_heaps) + = instantiateTypes it_vars it_attr_vars it_types it_context [] environment [] type_heaps + = ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps) + +hasTypeVariables [] + = False +hasTypeVariables [TV tvar : types] + = True +hasTypeVariables [ _ : types] + = hasTypeVariables types + +determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps -> (!SymbolType, !Specials, !*TypeHeaps) +determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps + # env = { ss_environ = foldl2 (\binds var type -> [ {bind_src = type, bind_dst = var} : binds]) [] class_vars it_types, + ss_context = it_context, ss_vars = it_vars, ss_attrs = it_attr_vars} + = determine_type_of_member_instance mem_st env specials type_heaps +where + determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps + # (mem_st, substs, type_heaps) = substitute_symbol_type { mem_st & st_context = tl st_context } env substs type_heaps + = (mem_st, SP_Substitutions substs, type_heaps) + determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps + # (mem_st, _, type_heaps) = substitute_symbol_type { mem_st & st_context = tl st_context } env [] type_heaps + = (mem_st, SP_None, type_heaps) + + substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps + # (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps) + = instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment specials type_heaps + = ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars, + st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps) + +determineTypesOfInstances :: !Index !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState + -> (![FunType], !Index, ![ClassInstance], !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) +determineTypesOfInstances first_memb_inst_index mod_index dcl_common=:{com_instance_defs,com_class_defs,com_member_defs} + modules type_heaps var_heap cs=:{cs_error} + | cs_error.ea_ok + #! nr_of_class_instances = size com_instance_defs + # (memb_inst_defs, next_mem_inst_index, all_class_specials, com_class_defs, com_member_defs, modules, com_instance_defs, type_heaps, var_heap, cs_error) + = determine_types_of_instances 0 nr_of_class_instances first_memb_inst_index mod_index [] com_class_defs com_member_defs + modules com_instance_defs type_heaps var_heap cs_error + = (memb_inst_defs, next_mem_inst_index, all_class_specials, + { dcl_common & com_instance_defs = com_instance_defs,com_class_defs = com_class_defs, com_member_defs = com_member_defs }, + modules, type_heaps, var_heap, { cs & cs_error = cs_error }) + = ([], first_memb_inst_index, [], dcl_common, modules, type_heaps, var_heap, cs) +where + + determine_types_of_instances :: !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef} + !x:{#DclModule} !*{#ClassInstance} !*TypeHeaps !*VarHeap !*ErrorAdmin + -> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*ErrorAdmin) + determine_types_of_instances inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials + class_defs member_defs modules instance_defs type_heaps var_heap error + | inst_index < size instance_defs + #! instance_def = instance_defs.[inst_index] + # {ins_class,ins_pos,ins_type,ins_specials} = instance_def + ({class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules + class_size = size class_members + (ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap) + = determine_instance_symbols_and_types next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members + ins_type ins_specials ins_pos member_defs modules type_heaps var_heap + instance_def = { instance_def & ins_members = { member \\ member <- ins_members }} + (ins_specials, next_class_inst_index, all_class_specials, type_heaps, error) + = check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps error + (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error) + = determine_types_of_instances (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials + class_defs member_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap error + + = (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error) + = ([], next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error) + + determine_instance_symbols_and_types :: !Index !Index !Index !Index !Int !{#DefinedSymbol} !InstanceType !Specials !Position + !w:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*VarHeap + -> (![DefinedSymbol], ![FunType], !w:{#MemberDef}, !u:{#DclModule}, !*TypeHeaps, !*VarHeap) + determine_instance_symbols_and_types first_inst_index mem_offset module_index member_mod_index class_size class_members + ins_type ins_specials ins_pos member_defs modules type_heaps var_heap + | mem_offset == class_size + = ([], [], member_defs, modules, type_heaps, var_heap) + # class_member = class_members.[mem_offset] + ({me_symb,me_type,me_priority,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules + (instance_type, new_ins_specials, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps + (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + inst_def = MakeNewFunctionType me_symb me_type.st_arity me_priority instance_type ins_pos new_ins_specials new_info_ptr + (inst_symbols, memb_inst_defs, member_defs, modules, type_heaps, var_heap) + = determine_instance_symbols_and_types first_inst_index (inc mem_offset) module_index member_mod_index + class_size class_members ins_type ins_specials ins_pos member_defs modules type_heaps var_heap + = ([{ class_member & ds_index = first_inst_index + mem_offset } : inst_symbols], [inst_def : memb_inst_defs], member_defs, modules, type_heaps, var_heap) + + check_instance_specials :: !Index !ClassInstance !Index !Specials !Index ![ClassInstance] !*TypeHeaps !*ErrorAdmin + -> (!Specials, !Index, ![ClassInstance], !*TypeHeaps, !*ErrorAdmin) + check_instance_specials mod_index inst_type inst_index (SP_Substitutions substs) next_inst_index all_instances type_heaps error + # (list_of_specials, next_inst_index, all_instances, type_heaps, error) + = check_specials mod_index inst_type 0 substs [] next_inst_index all_instances type_heaps error + = (SP_ContextTypes list_of_specials, next_inst_index, all_instances, type_heaps, error) + where + check_specials mod_index inst=:{ins_type} type_offset [ subst : substs ] list_of_specials next_inst_index all_instances type_heaps error + # (special_type, type_heaps) = substituteInstanceType ins_type subst type_heaps + (spec_types, error) = checkAndCollectTypesOfContexts special_type.it_context error + special = { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types, + spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs } + = check_specials mod_index inst (inc type_offset) substs [ special : list_of_specials ] (inc next_inst_index) + [{ inst & ins_type = { special_type & it_context = [] }, ins_specials = SP_TypeOffset type_offset} : all_instances ] type_heaps error + check_specials mod_index inst=:{ins_type} type_offset [] list_of_specials next_inst_index all_instances type_heaps error + = (list_of_specials, next_inst_index, all_instances, type_heaps, error) + + check_instance_specials mod_index fun_type fun_index SP_None next_inst_index all_instances type_heaps error + = (SP_None, next_inst_index, all_instances, type_heaps, error) + +checkAndCollectTypesOfContexts type_contexts error + = mapSt check_and_collect_context_types type_contexts error +where + check_and_collect_context_types {tc_class={glob_object={ds_ident}},tc_types} error + | hasTypeVariables tc_types + = (tc_types, checkError ds_ident.id_name "illegal specialization" error) + = (tc_types, error) + +/* +retrieveSelectorIndexes mod_index {ste_kind = STE_Selector selector_list, ste_index, ste_previous } + # imported_selectors = retrieveSelectorIndexes mod_index ste_previous + = mapAppend (\ sel -> { sel & glob_module = mod_index }) selector_list [{glob_module = mod_index, glob_object = ste_index } : imported_selectors ] +retrieveSelectorIndexes mod_index {ste_kind = STE_Imported (STE_Selector selector_list) dcl_mod_index, ste_index } + = [ { glob_object = ste_index, glob_module = dcl_mod_index } : selector_list ] +retrieveSelectorIndexes mod_index off_kind + = [] +*/ + +retrieveSelectorIndexes mod_index {ste_kind = STE_Selector selector_list, ste_index, ste_previous } + = map (adjust_mod_index mod_index) selector_list +where + adjust_mod_index mod_index selector=:{glob_module} + | glob_module == NoIndex + = { selector & glob_module = mod_index } + = selector +retrieveSelectorIndexes mod_index off_kind + = [] + +checkFields :: !Index ![FieldAssignment] !(Optional Ident) !u:ExpressionInfo !*CheckState + -> (!Optional ((Global DefinedSymbol), Index, [Bind ParsedExpr (Global FieldSymbol)]), !u:ExpressionInfo, !*CheckState) +checkFields mod_index field_ass opt_type e_info=:{ef_selector_defs,ef_type_defs,ef_modules} cs + # (ok, field_ass, cs) = check_fields field_ass cs + | ok + # (opt_type_def, ef_selector_defs, ef_type_defs, ef_modules, cs) + = determine_record_type mod_index opt_type field_ass ef_selector_defs ef_type_defs ef_modules cs + e_info = { e_info & ef_selector_defs = ef_selector_defs, ef_type_defs = ef_type_defs, ef_modules = ef_modules} + = case opt_type_def of + Yes ({td_index,td_rhs = RecordType {rt_constructor,rt_fields}}, type_mod_index) + # (field_exprs, cs_error) = check_and_rearrange_fields type_mod_index 0 rt_fields field_ass cs.cs_error + -> (Yes ({ glob_object = rt_constructor, glob_module = type_mod_index }, td_index, field_exprs), e_info, { cs & cs_error = cs_error }) + No + -> (No, e_info, cs) + = (No, e_info, cs) +where + + check_fields [ bind=:{bind_dst} : field_ass ] cs=:{cs_symbol_table,cs_error} + #! entry = sreadPtr bind_dst.id_info cs_symbol_table + # fields = retrieveSelectorIndexes mod_index entry + | isEmpty fields + = (False, [], { cs & cs_error = checkError bind_dst "not defined as a record field" cs_error }) + # (ok, field_ass, cs) = check_fields field_ass cs + = (ok, [{bind & bind_dst = (bind_dst, fields)} : field_ass], cs) + check_fields [] cs + = (True, [], cs) + + try_to_get_unique_field [] + = No + try_to_get_unique_field [ {bind_dst = (field_id, [field])} : fields ] + = Yes field + try_to_get_unique_field [ _ : fields ] + = try_to_get_unique_field fields + + determine_record_type mod_index (Yes type_id=:{id_info}) _ selector_defs type_defs modules cs=:{cs_symbol_table, cs_error} + #! entry = sreadPtr id_info cs_symbol_table + # (type_index, type_mod_index) = retrieveGlobalDefinition entry STE_Type mod_index + | type_index <> NotFound + | mod_index == type_mod_index + #! type_def = type_defs.[type_index] + = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, cs) + # (type_def, modules) = modules![type_mod_index].dcl_common.com_type_defs.[type_index] + = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, cs) + = (No, selector_defs, type_defs, modules, { cs & cs_error = checkError type_id " not defined" cs_error}) + determine_record_type mod_index No fields selector_defs type_defs modules cs=:{cs_error} + # succ = try_to_get_unique_field fields + = case succ of + Yes {glob_module, glob_object} + | glob_module == mod_index + #! selector_def = selector_defs.[glob_object] + type_def = type_defs.[selector_def.sd_type_index] + -> (Yes (type_def, glob_module), selector_defs, type_defs, modules, cs) + #! {dcl_common={com_selector_defs,com_type_defs}} = modules.[glob_module] + #! selector_def = com_selector_defs.[glob_object] + type_def = com_type_defs.[selector_def.sd_type_index] + -> (Yes (type_def,glob_module), selector_defs, type_defs, modules, cs) + No + -> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "" " could not determine the type of this record" cs.cs_error }) + + + check_and_rearrange_fields mod_index field_index fields field_ass cs_error + | field_index < size fields + # (field_expr, field_ass) = look_up_field mod_index fields.[field_index] field_ass + (field_exprs, cs_error) = check_and_rearrange_fields mod_index (inc field_index) fields field_ass cs_error + = ([field_expr : field_exprs], cs_error) + | isEmpty field_ass + = ([], cs_error) + = ([], foldSt field_error field_ass cs_error) + + where + look_up_field mod_index field [] + = ({bind_src = PE_WildCard, bind_dst = { glob_object = field, glob_module = mod_index }}, []) + look_up_field mod_index field=:{fs_index} [ass=:{bind_src, bind_dst = (_, fields)} : field_ass] + | field_list_contains_field mod_index fs_index fields + = ({bind_src = bind_src, bind_dst = { glob_module = mod_index, glob_object = field}}, field_ass) + # (field_expr, field_ass) = look_up_field mod_index field field_ass + = (field_expr, [ass : field_ass]) + + field_list_contains_field mod_index fs_index [] + = False + field_list_contains_field mod_index fs_index [{glob_object,glob_module} : fields] + = mod_index == glob_module && fs_index == glob_object || field_list_contains_field mod_index fs_index fields + + field_error {bind_dst=(field_id,_)} error + = checkError field_id " field is either multiply used or not a part of this record" error + +:: ExpressionInfo = + { ef_type_defs :: !.{# CheckedTypeDef} + , ef_selector_defs :: !.{# SelectorDef} + , ef_cons_defs :: !.{# ConsDef} + , ef_member_defs :: !.{# MemberDef} + , ef_class_defs :: !.{# ClassDef} + , ef_modules :: !.{# DclModule} + } + +:: ExpressionState = + { es_expression_heap :: !.ExpressionHeap + , es_var_heap :: !.VarHeap + , es_type_heaps :: !.TypeHeaps + , es_calls :: ![FunCall] + , es_dynamics :: ![ExprInfoPtr] + , es_fun_defs :: !.{# FunDef} + } + +:: ExpressionInput = + { ei_expr_level :: !Level + , ei_fun_index :: !Index + , ei_fun_level :: !Level + , ei_mod_index :: !Index +// , ei_fun_kind :: !FunKind + } + + +cIsInExpressionList :== True +cIsNotInExpressionList :== False + + +:: UnfoldMacroState = + { ums_var_heap :: !.VarHeap + , ums_modules :: !.{# DclModule} + , ums_cons_defs :: !.{# ConsDef} + , ums_error :: !.ErrorAdmin + } + +unfoldPatternMacro mod_index macro_index macro_args opt_var ps=:{ps_var_heap, ps_fun_defs} modules cons_defs error + # (macro, ps_fun_defs) = ps_fun_defs![macro_index] + = case macro.fun_body of + TransformedBody {tb_args,tb_rhs} + | no_sharing tb_args + # ums = { ums_var_heap = fold2St bind_var tb_args macro_args ps_var_heap, ums_modules = modules, ums_cons_defs = cons_defs, ums_error = error } + (pattern, {ums_var_heap,ums_modules,ums_cons_defs,ums_error}) = unfold_pattern_macro mod_index macro.fun_symb opt_var tb_rhs ums + -> (pattern, { ps_fun_defs = ps_fun_defs, ps_var_heap = ums_var_heap}, ums_modules, ums_cons_defs, ums_error) + -> (AP_Empty macro.fun_symb, { ps_fun_defs = ps_fun_defs, ps_var_heap = ps_var_heap}, + modules, cons_defs, checkError macro.fun_symb " sharing not allowed" error) + _ + -> (AP_Empty macro.fun_symb, { ps_fun_defs = ps_fun_defs, ps_var_heap = ps_var_heap}, + modules, cons_defs, checkError macro.fun_symb " illegal macro in pattern" error) + +where + no_sharing [{fv_count} : args] + = fv_count <= 1 && no_sharing args + no_sharing [] + = True + + bind_var {fv_info_ptr} pattern ps_var_heap + = ps_var_heap <:= (fv_info_ptr, VI_Pattern pattern) + + unfold_pattern_macro mod_index macro_ident _ (Var {var_name,var_info_ptr}) ums=:{ums_var_heap} + # (VI_Pattern pattern, ums_var_heap) = readPtr var_info_ptr ums_var_heap + = (pattern, { ums & ums_var_heap = ums_var_heap}) + unfold_pattern_macro mod_index macro_ident opt_var (App {app_symb,app_args}) ums + = unfold_application mod_index macro_ident opt_var app_symb app_args ums + where + unfold_application mod_index macro_ident opt_var {symb_kind=SK_Constructor {glob_module,glob_object},symb_name,symb_arity} args + ums=:{ums_cons_defs, ums_modules,ums_error} + # (cons_def, cons_index, ums_cons_defs, ums_modules) = get_cons_def mod_index glob_module glob_object ums_cons_defs ums_modules + | cons_def.cons_type.st_arity == symb_arity + # (patterns, ums) = mapSt (unfold_pattern_macro mod_index macro_ident No) app_args { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules } + cons_symbol = { glob_object = MakeDefinedSymbol symb_name cons_index symb_arity, glob_module = glob_module } + = (AP_Algebraic cons_symbol cons_def.cons_type_index patterns opt_var, ums) + = (AP_Empty cons_def.cons_symb, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules, + ums_error = checkError cons_def.cons_symb " missing argument(s)" ums_error }) + + get_cons_def mod_index cons_mod cons_index cons_defs modules + | mod_index == cons_mod + # (cons_def, cons_defs) = cons_defs![cons_index] + = (cons_def, cons_index, cons_defs, modules) + #! {dcl_common,dcl_conversions} = modules.[cons_mod] + #! cons_def = dcl_common.com_cons_defs.[cons_index] + = (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules) + + unfold_pattern_macro mod_index macro_ident opt_var (BasicExpr bv bt) ums + = (AP_Basic bv opt_var, ums) + unfold_pattern_macro mod_index macro_ident opt_var expr ums=:{ums_error} + = (AP_Empty macro_ident, { ums & ums_error = checkError macro_ident " illegal rhs for a pattern macro" ums_error }) + + + +checkPatternVariable :: !Level !SymbolTableEntry !Ident !VarInfoPtr !*CheckState -> !*CheckState +checkPatternVariable def_level entry=:{ste_def_level,ste_kind} ident=:{id_info} var_info cs=:{cs_symbol_table,cs_error} + | ste_kind == STE_Empty || def_level > ste_def_level + # entry = {ste_kind = STE_Variable var_info, ste_index = NoIndex, ste_def_level = def_level, ste_previous = entry } + = { cs & cs_symbol_table = cs_symbol_table <:= (id_info,entry)} + = { cs & cs_error = checkError ident "(pattern variable) already defined" cs_error } + +checkPatternConstructor :: !Index !Bool !SymbolTableEntry !Ident !(Optional (Bind Ident VarInfoPtr)) !*PatternState !*ExpressionInfo !*CheckState + -> (!AuxiliaryPattern, !*PatternState, !*ExpressionInfo, !*CheckState); +checkPatternConstructor _ _ {ste_kind = STE_Empty} ident _ ps e_info cs=:{cs_error} + = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident " not defined" cs_error }) +checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var ps=:{ps_fun_defs} e_info cs=:{cs_error} + # ({fun_symb,fun_arity,fun_kind,fun_priority},ps_fun_defs) = ps_fun_defs![ste_index] + ps = { ps & ps_fun_defs = ps_fun_defs } + | fun_kind == FK_Macro + | is_expr_list + # macro_symbol = { glob_object = MakeDefinedSymbol fun_symb ste_index fun_arity, glob_module = cIclModIndex } + = (AP_Constant APK_Macro macro_symbol fun_priority, ps, e_info, cs) + | fun_arity == 0 + # (pattern, ps, ef_modules, ef_cons_defs, cs_error) + = unfoldPatternMacro mod_index ste_index [] opt_var ps e_info.ef_modules e_info.ef_cons_defs cs_error + = (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error }) + = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident " not defined" cs_error }) + = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError fun_symb " not allowed in a pattern" cs_error }) +checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_symb opt_var ps + e_info=:{ef_cons_defs,ef_modules} cs=:{cs_error} + # (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, ef_cons_defs, ef_modules, cs_error) + = determine_pattern_symbol mod_index ste_index ste_kind cons_symb.id_name ef_cons_defs ef_modules cs_error + e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules } + cons_symbol = { glob_object = MakeDefinedSymbol cons_symb cons_index cons_arity, glob_module = cons_module } + | is_expr_list + = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) + | cons_arity == 0 + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError cons_symb " constructor arguments are missing" cs_error }) +where + determine_pattern_symbol mod_index id_index STE_Constructor id_name cons_defs modules error + #! cons_def = cons_defs.[id_index] + # {cons_type={st_arity},cons_priority, cons_type_index} = cons_def + = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) id_name cons_defs modules error + #! {dcl_common,dcl_conversions} = modules.[import_mod_index] + #! cons_def = dcl_common.com_cons_defs.[id_index] + # {cons_type={st_arity},cons_priority, cons_type_index} = cons_def + id_index = convertIndex id_index (toInt STE_Constructor) dcl_conversions + = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error + = (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name " constructor expected" error) + + +checkIdentPattern :: !Level !Index !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) ![Ident] !*PatternState !*ExpressionInfo !*CheckState + -> (!AuxiliaryPattern, ![Ident], !*PatternState, !*ExpressionInfo, !*CheckState) +checkIdentPattern def_level mod_index is_expr_list id=:{id_name,id_info} opt_var var_env ps e_info cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + | isLowerCaseName id_name + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap + cs = checkPatternVariable def_level entry id new_info_ptr cs + = (AP_Variable id new_info_ptr opt_var, [ id : var_env ], { ps & ps_var_heap = ps_var_heap}, e_info, cs) + # (pattern, ps, e_info, cs) = checkPatternConstructor mod_index is_expr_list entry id opt_var ps e_info cs + = (pattern, var_env, ps, e_info, cs) + +:: PatternState = + { ps_var_heap :: !.VarHeap + , ps_fun_defs :: !.{# FunDef} + } + + +buildPattern mod_index (APK_Constructor type_index) cons_symb args opt_var ps e_info cs + = (AP_Algebraic cons_symb type_index args opt_var, ps, e_info, cs) +buildPattern mod_index APK_Macro {glob_object} args opt_var ps e_info=:{ef_modules,ef_cons_defs} cs=:{cs_error} + # (pattern, ps, ef_modules, ef_cons_defs, cs_error) + = unfoldPatternMacro mod_index glob_object.ds_index args opt_var ps ef_modules ef_cons_defs cs_error + = (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error }) + +checkPattern :: !Level !Index !ParsedExpr !(Optional (Bind Ident VarInfoPtr)) ![Ident] !*PatternState !*ExpressionInfo !*CheckState + -> (!AuxiliaryPattern, ![Ident], !*PatternState, !*ExpressionInfo, !*CheckState) +checkPattern def_level mod_index (PE_List [exp]) opt_var var_env ps e_info cs=:{cs_symbol_table} + = case exp of + PE_Ident ident + -> checkIdentPattern def_level mod_index cIsNotInExpressionList ident opt_var var_env ps e_info cs + _ + -> checkPattern def_level mod_index exp opt_var var_env ps e_info cs + +checkPattern def_level mod_index (PE_List [exp1, exp2 : exps]) opt_var var_env ps e_info cs + # (exp_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index exp1 var_env ps e_info cs + = check_patterns def_level mod_index [exp_pat] exp2 exps opt_var var_env ps e_info cs + where + check_patterns def_level mod_index left middle [] opt_var var_env ps e_info cs + # (mid_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs + (pat, ps, e_info, cs) = combine_patterns opt_var [mid_pat : left] [] 0 ps e_info cs + = (pat, var_env, ps, e_info, cs) + check_patterns def_level mod_index left middle [right:rest] opt_var var_env ps e_info cs + # (mid_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index middle var_env ps e_info cs + = case mid_pat of + AP_Constant kind constant=:{glob_object={ds_arity,ds_ident}} prio + | ds_arity == 0 + # (pattern, ps, e_info, cs) = buildPattern mod_index kind constant [] No ps e_info cs + -> check_patterns def_level mod_index [pattern: left] right rest opt_var var_env ps e_info cs + | is_infix_constructor prio + # (left_arg, ps, e_info, cs) = combine_patterns No left [] 0 ps e_info cs + -> check_infix_pattern def_level mod_index [] left_arg kind constant prio right rest + opt_var var_env ps e_info cs + -> (AP_Empty ds_ident, var_env, ps, e_info, + { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error }) + _ + -> check_patterns def_level mod_index [mid_pat : left] right rest opt_var var_env ps e_info cs + + + check_pattern def_level mod_index (PE_Ident id) var_env ps e_info cs + = checkIdentPattern def_level mod_index cIsInExpressionList id No var_env ps e_info cs + check_pattern def_level mod_index expr var_env ps e_info cs + = checkPattern def_level mod_index expr No var_env ps e_info cs + + check_infix_pattern def_level mod_index left_args left kind cons prio middle [] opt_var var_env ps e_info cs + # (mid_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs + (pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,mid_pat] opt_var ps e_info cs + (pattern, ps, e_info, cs) = build_final_pattern mod_index left_args pattern ps e_info cs + = (pattern, var_env, ps, e_info, cs) + check_infix_pattern def_level mod_index left_args left kind cons prio middle [right] opt_var var_env ps e_info cs + # (mid_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index middle var_env ps e_info cs + (right_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs + (right_arg, ps, e_info, cs) = combine_patterns No [right_pat, mid_pat] [] 0 ps e_info cs + (pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,right_arg] opt_var ps e_info cs + (pattern, ps, e_info, cs) = build_final_pattern mod_index left_args pattern ps e_info cs + = (pattern, var_env, ps, e_info, cs) + check_infix_pattern def_level mod_index left_args left kind1 cons1 prio1 middle [inf_cons, arg : rest] opt_var var_env ps e_info cs + # (inf_cons_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index inf_cons var_env ps e_info cs + = case inf_cons_pat of + AP_Constant kind2 cons2=:{glob_object={ds_ident,ds_arity}} prio2 + | ds_arity == 0 + # (mid_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index middle var_env ps e_info cs + (pattern2, ps, e_info, cs) = buildPattern mod_index kind2 cons2 [] No ps e_info cs + (pattern1, ps, e_info, cs) = buildPattern mod_index kind1 cons1 [left,mid_pat] No ps e_info cs + (pattern1, ps, e_info, cs) = build_final_pattern mod_index left_args pattern1 ps e_info cs + -> check_patterns def_level mod_index [pattern2,pattern1] arg rest opt_var var_env ps e_info cs + | is_infix_constructor prio2 + | prio1 > prio2 + # (mid_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index middle var_env ps e_info cs + (pattern, ps, e_info, cs) = buildPattern mod_index kind1 cons1 [left,mid_pat] No ps e_info cs + (left_args, pattern, ps, e_info, cs) = build_left_pattern mod_index left_args prio2 pattern ps e_info cs + -> check_infix_pattern def_level mod_index left_args pattern kind2 cons2 prio2 arg rest opt_var var_env ps e_info cs + # (mid_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs + -> check_infix_pattern def_level mod_index [(kind1, cons1, prio1, left) : left_args] + mid_pat kind2 cons2 prio2 arg rest No var_env ps e_info cs + -> (AP_Empty ds_ident, var_env, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error }) + _ + # (right_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs + (pattern, ps, e_info, cs) = buildPattern mod_index kind1 cons1 [left,right_pat] No ps e_info cs + (pattern, ps, e_info, cs) = build_final_pattern mod_index left_args pattern ps e_info cs + -> check_patterns def_level mod_index [inf_cons_pat, pattern] arg rest opt_var var_env ps e_info cs + + is_infix_constructor (Prio _ _) = True + is_infix_constructor _ = False + + build_left_pattern mod_index [] _ result_pattern ps e_info cs + = ([], result_pattern, ps, e_info, cs) + build_left_pattern mod_index la=:[(kind, cons, priol, left) : left_args] prior result_pattern ps e_info cs + | priol > prior + # (result_pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,result_pattern] No ps e_info cs + = build_left_pattern mod_index left_args prior result_pattern ps e_info cs + = (la, result_pattern, ps, e_info, cs) + + build_final_pattern mod_index [] result_pattern ps e_info cs + = (result_pattern, ps, e_info, cs) + build_final_pattern mod_index [(kind, cons, priol, left) : left_appls] result_pattern ps e_info cs + # (result_pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,result_pattern] No ps e_info cs + = build_final_pattern mod_index left_appls result_pattern ps e_info cs + + combine_patterns opt_var [first_expr] args nr_of_args ps e_info cs + = case first_expr of + AP_Constant kind constant=:{glob_object={ds_ident,ds_arity}} _ + | ds_arity == nr_of_args + # (pattern, ps, e_info, cs) = buildPattern mod_index kind constant args opt_var ps e_info cs + -> (pattern, ps, e_info, cs) + -> (AP_Empty ds_ident, ps, e_info, { cs & cs_error = checkError ds_ident "used with wrong arity" cs.cs_error}) + _ + | nr_of_args == 0 + -> (first_expr, ps, e_info, cs) + -> (first_expr, ps, e_info, { cs & cs_error = checkError "<pattern>" "(curried) application not allowed " cs.cs_error }) + combine_patterns opt_var [rev_arg : rev_args] args arity ps e_info cs + = combine_patterns opt_var rev_args [rev_arg : args] (inc arity) ps e_info cs +/* + combine_optional_variables (Yes var1) (Yes var2) error + = (Yes var1, checkError var2.bind_dst "pattern already bound" error) + combine_optional_variables No opt_var error + = (opt_var, error) + combine_optional_variables opt_var _ error + = (opt_var, error) +*/ + +checkPattern def_level mod_index (PE_DynamicPattern pattern type) opt_var var_env ps e_info cs + # (dyn_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index pattern No var_env ps e_info cs + = (AP_Dynamic dyn_pat type opt_var, var_env, ps, e_info, cs) +checkPattern def_level mod_index (PE_Basic basic_value) opt_var var_env ps e_info cs + = (AP_Basic basic_value opt_var, var_env, ps, e_info, cs) + +checkPattern def_level mod_index (PE_Tuple tuple_args) opt_var var_env ps e_info cs + # (patterns, arity, var_env, ps, e_info, cs) = check_tuple_patterns def_level mod_index tuple_args var_env ps e_info cs + (tuple_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs + #! {cons_type_index} = e_info.ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index] + = (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, var_env, ps, e_info, cs) +where + check_tuple_patterns def_level mod_index [] var_env ps e_info cs + = ([], 0, var_env, ps, e_info, cs) + check_tuple_patterns def_level mod_index [expr : exprs] var_env ps e_info cs + # (pattern, var_env, ps, e_info, cs) = checkPattern def_level mod_index expr No var_env ps e_info cs + (patterns, length, var_env, ps, e_info, cs) = check_tuple_patterns def_level mod_index exprs var_env ps e_info cs + = ([pattern : patterns], inc length, var_env, ps, e_info, cs) +checkPattern def_level mod_index (PE_Record record opt_type fields) opt_var var_env ps e_info cs + # (opt_record_and_fields, e_info, cs) = checkFields mod_index fields opt_type e_info cs + = case opt_record_and_fields of + Yes (record_symbol, type_index, new_fields) + # (patterns, (var_env, ps, e_info, cs)) = mapSt (check_field_pattern def_level mod_index) new_fields (var_env, ps, e_info, cs) + (patterns, ps_var_heap) = bind_opt_record_variable opt_var patterns new_fields ps.ps_var_heap + -> (AP_Algebraic record_symbol type_index patterns opt_var, var_env, { ps & ps_var_heap = ps_var_heap }, e_info, cs) + No + -> (AP_Empty (hd fields).bind_dst, var_env, ps, e_info, cs) +where + + check_field_pattern def_level mod_index {bind_src = PE_Empty, bind_dst = {glob_object={fs_var}}} (var_env, ps, e_info, cs) + #! entry = sreadPtr fs_var.id_info cs.cs_symbol_table + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap + cs = checkPatternVariable def_level entry fs_var new_info_ptr cs + = (AP_Variable fs_var new_info_ptr No, ([ fs_var : var_env ], { ps & ps_var_heap = ps_var_heap }, e_info, cs)) + check_field_pattern def_level mod_index {bind_src = PE_WildCard, bind_dst={glob_object={fs_var}}} (var_env, ps, e_info, cs) + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap + = (AP_WildCard (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), (var_env, { ps & ps_var_heap = ps_var_heap }, e_info, cs)) + check_field_pattern def_level mod_index {bind_src,bind_dst} (var_env, ps, e_info, cs) + # (pattern, var_env, ps, e_info, cs) = checkPattern def_level mod_index bind_src No var_env ps e_info cs + = (pattern, (var_env, ps, e_info, cs)) + + + add_bound_variable (AP_Algebraic symbol index patterns No) {bind_dst = {glob_object={fs_var}}} ps_var_heap + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap + = (AP_Algebraic symbol index patterns (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) + add_bound_variable (AP_Basic bas_val No) {bind_dst = {glob_object={fs_var}}} ps_var_heap + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap + = (AP_Basic bas_val (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) + add_bound_variable (AP_Dynamic dynamic dynamic_type No) {bind_dst = {glob_object={fs_var}}} ps_var_heap + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap + = (AP_Dynamic dynamic dynamic_type (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) + add_bound_variable pattern _ ps_var_heap + = (pattern, ps_var_heap) + + add_bound_variables [] _ var_heap + = ([] , var_heap) + add_bound_variables [ap : aps] [field : fields] var_heap + # (ap, var_heap) = add_bound_variable ap field var_heap + (aps, var_heap) = add_bound_variables aps fields var_heap + = ([ap : aps], var_heap) + + bind_opt_record_variable (Yes {bind_dst}) patterns fields var_heap + # (patterns, var_heap) = add_bound_variables patterns fields var_heap + = (patterns, var_heap <:= (bind_dst, VI_Record patterns)) + bind_opt_record_variable No patterns _ var_heap + = (patterns, var_heap) + +checkPattern def_level mod_index (PE_Bound bind) opt_var var_env ps e_info cs + = checkBoundPattern def_level mod_index bind opt_var var_env ps e_info cs + +checkPattern def_level mod_index (PE_Ident id) opt_var var_env ps e_info cs + = checkIdentPattern def_level mod_index cIsNotInExpressionList id opt_var var_env ps e_info cs +checkPattern def_level mod_index PE_WildCard opt_var var_env ps e_info cs + = (AP_WildCard No, var_env, ps, e_info, cs) +checkPattern def_level mod_index expr opt_var var_env ps e_info cs + = abort "checkPattern: do not know how to handle pattern" ---> expr + +checkBoundPattern def_level mod_index {bind_src,bind_dst} opt_var var_env ps e_info cs=:{cs_symbol_table} + | isLowerCaseName bind_dst.id_name + #! entry = sreadPtr bind_dst.id_info cs_symbol_table + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap + cs = checkPatternVariable def_level entry bind_dst new_info_ptr cs + ps = { ps & ps_var_heap = ps_var_heap } + var_env = [ bind_dst : var_env ] + = case opt_var of + Yes bind + -> checkPattern def_level mod_index bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) var_env ps + e_info { cs & cs_error = checkError bind.bind_src "pattern already bound" cs.cs_error } + No + -> checkPattern def_level mod_index bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) var_env ps e_info cs + = checkPattern def_level mod_index bind_src opt_var var_env ps e_info { cs & cs_error = checkError bind_dst "variable expected" cs.cs_error } + +instance <<< AuxiliaryPattern +where + (<<<) file (AP_Algebraic symbol index patterns var) + = file <<< symbol <<< ' ' <<< patterns + (<<<) file (AP_Variable ident var_ptr var) + = file <<< ident + (<<<) file (AP_Basic val var) + = file <<< val + (<<<) file (AP_Constant kind symbol prio) + = file <<< symbol + (<<<) file (AP_WildCard _) + = file <<< '_' + (<<<) file (AP_Empty ident) + = file <<< "<?" <<< ident <<< "?>" + +newFreeVariable :: !FreeVar ![FreeVar] ->(!Bool, ![FreeVar]) +newFreeVariable new_var vars=:[free_var=:{fv_def_level,fv_info_ptr}: free_vars] + | new_var.fv_def_level > fv_def_level + = (True, [new_var : vars]) + | new_var.fv_def_level == fv_def_level + | new_var.fv_info_ptr == fv_info_ptr + = (False, vars) + #! (free_var_added, free_vars) = newFreeVariable new_var free_vars + = (free_var_added, [free_var : free_vars]) + #! (free_var_added, free_vars) = newFreeVariable new_var free_vars + = (free_var_added, [free_var : free_vars]) +newFreeVariable new_var [] + = (True, [new_var]) + + +buildTypeCase type_case_dynamic type_case_patterns type_case_default type_case_info_ptr :== + Case { case_expr = type_case_dynamic, case_guards = DynamicPatterns type_case_patterns, case_default = type_case_default, + case_info_ptr = type_case_info_ptr, case_ident = No } + + +consOptional (Yes thing) things + = [ thing : things] +consOptional No things + = things + +buildApplication :: !SymbIdent !Int !Int !Bool ![Expression] !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin) +buildApplication symbol form_arity act_arity is_fun args e_state=:{es_expression_heap} error + | is_fun + # (new_info_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap + | form_arity < act_arity + # app = { app_symb = { symbol & symb_arity = form_arity }, app_args = take form_arity args, app_info_ptr = new_info_ptr } + = (App app @ drop form_arity args, { e_state & es_expression_heap = es_expression_heap }, error) + # app = { app_symb = { symbol & symb_arity = act_arity }, app_args = take form_arity args, app_info_ptr = new_info_ptr } + = (App app, { e_state & es_expression_heap = es_expression_heap }, error) + # app = App { app_symb = { symbol & symb_arity = act_arity }, app_args = args, app_info_ptr = nilPtr } + | form_arity < act_arity + = (app, e_state, checkError symbol.symb_name " used with too many arguments" error) + = (app, e_state, error) + +checkIdentExpression :: !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState + -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) +checkIdentExpression is_expr_list free_vars id=:{id_info} e_input e_state e_info cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + = check_id_expression entry is_expr_list free_vars id e_input e_state e_info cs +where + check_id_expression :: !SymbolTableEntry !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState + -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) + check_id_expression {ste_kind = STE_Empty} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error} + = (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id " undefined" cs_error }) + check_id_expression {ste_kind = STE_Variable info_ptr,ste_def_level} is_expr_list free_vars id e_input=:{ei_fun_level} e_state=:{es_expression_heap} e_info cs + | ste_def_level < ei_fun_level + # free_var = { fv_def_level = ste_def_level, fv_name = id, fv_info_ptr = info_ptr, fv_count = 0 } + (free_var_added, free_vars) = newFreeVariable free_var free_vars + = (FreeVar free_var, free_vars, e_state, e_info, cs) + #! (var_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap + = (Var {var_name = id, var_info_ptr = info_ptr, var_expr_ptr = var_expr_ptr}, free_vars, + {e_state & es_expression_heap = es_expression_heap}, e_info, cs) + check_id_expression entry is_expr_list free_vars id=:{id_info} e_input e_state e_info cs + # (symb_kind, arity, priority, is_a_function, e_state, e_info, cs) = determine_info_of_symbol entry id_info e_input e_state e_info cs + symbol = { symb_name = id, symb_kind = symb_kind, symb_arity = 0 } + | is_expr_list + = (Constant symbol arity priority is_a_function, free_vars, e_state, e_info, cs) + # (app_expr, e_state, cs_error) = buildApplication symbol arity 0 is_a_function [] e_state cs.cs_error + = (app_expr, free_vars, e_state, e_info, { cs & cs_error = cs_error }) + + determine_info_of_symbol :: !SymbolTableEntry !SymbolPtr !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState + -> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState) + determine_info_of_symbol entry=:{ste_kind=STE_FunctionOrMacro calls,ste_index,ste_def_level} symb_info + e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_fun_defs,es_calls} e_info cs=:{cs_symbol_table} + #! {fun_symb,fun_arity,fun_kind,fun_priority} = es_fun_defs.[ste_index] + # index = { glob_object = ste_index, glob_module = cIclModIndex } + | is_called_before ei_fun_index calls + | fun_kind == FK_Macro + = (SK_Macro index, fun_arity, fun_priority, cIsNotAFunction, e_state, e_info, cs) + = (SK_Function index, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})} + e_state = { e_state & es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} + = (if (fun_kind == FK_Macro) (SK_Macro index) (SK_Function index), fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + where + is_called_before caller_index [] + = False + is_called_before caller_index [called_index : calls] + = caller_index == called_index || is_called_before caller_index calls + + determine_info_of_symbol entry=:{ste_kind=STE_Imported kind mod_index,ste_index} symb_index e_input e_state e_info=:{ef_modules} cs + #! mod_def = ef_modules.[mod_index] + # (kind, arity, priotity, is_fun) = ste_kind_to_symbol_kind kind ste_index mod_index mod_def + = (kind, arity, priotity, is_fun, e_state, e_info, cs) + where + ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule -> (!SymbKind, !Int, !Priority, !Bool); + ste_kind_to_symbol_kind STE_DclFunction def_index mod_index {dcl_functions,dcl_conversions} + #! {ft_type={st_arity},ft_priority} = dcl_functions.[def_index] + # def_index = convertIndex def_index (toInt STE_DclFunction) dcl_conversions + = (SK_Function { glob_object = def_index, glob_module = mod_index }, st_arity, ft_priority, cIsAFunction) + ste_kind_to_symbol_kind STE_Member def_index mod_index {dcl_common={com_member_defs},dcl_conversions} + #! {me_type={st_arity},me_priority} = com_member_defs.[def_index] + # def_index = convertIndex def_index (toInt STE_Member) dcl_conversions + = (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority, cIsAFunction) + ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs},dcl_conversions} + #! {cons_type={st_arity},cons_priority} = com_cons_defs.[def_index] + # def_index = convertIndex def_index (toInt STE_Constructor) dcl_conversions + = (SK_Constructor { glob_object = def_index, glob_module = mod_index }, st_arity, cons_priority, cIsNotAFunction) + + determine_info_of_symbol {ste_kind=STE_Member, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_member_defs} cs + #! {me_type={st_arity},me_priority} = ef_member_defs.[ste_index] + = (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority, cIsAFunction, e_state, e_info, cs) + determine_info_of_symbol {ste_kind=STE_Constructor, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_cons_defs} cs + #! {cons_type={st_arity},cons_priority} = ef_cons_defs.[ste_index] + = (SK_Constructor { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, cIsNotAFunction, e_state, e_info, cs) + determine_info_of_symbol {ste_kind=STE_DclFunction, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_modules} cs + #! mod_def = ef_modules.[ei_mod_index] + # {ft_type={st_arity},ft_priority} = mod_def.dcl_functions.[ste_index] + def_index = convertIndex ste_index (toInt STE_DclFunction) mod_def.dcl_conversions + = (SK_Function { glob_object = def_index, glob_module = ei_mod_index}, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + +:: RecordKind = RK_Constructor | RK_Update | RK_UpdateToConstructor ![AuxiliaryPattern] + +checkExpression :: ![FreeVar] !ParsedExpr !ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState + -> *(!Expression, ![FreeVar], !*ExpressionState, !*ExpressionInfo, !*CheckState); +checkExpression free_vars (PE_List exprs) e_input e_state e_info cs + # (exprs, free_vars, e_state, e_info, cs) = check_expressions free_vars exprs e_input e_state e_info cs + (expr, e_state, cs_error) = build_expression exprs e_state cs.cs_error + = (expr, free_vars, e_state, e_info, { cs & cs_error = cs_error }) + +where + check_expressions free_vars [expr : exprs] e_input e_state e_info cs + # (exprs, free_vars, e_state, e_info, cs) = check_expressions free_vars exprs e_input e_state e_info cs + = case expr of + PE_Ident id + # (expr, free_vars, e_state, e_info, cs) = checkIdentExpression cIsInExpressionList free_vars id e_input e_state e_info cs + -> ([expr : exprs], free_vars, e_state, e_info, cs) + _ + # (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs + -> ([expr : exprs], free_vars, e_state, e_info, cs) + check_expressions free_vars [] e_input e_state e_info cs + = ([], free_vars, e_state, e_info, cs) + + build_expression [Constant symb arity _ is_fun] e_state cs_error + = buildApplication symb arity 0 is_fun [] e_state cs_error + build_expression [expr] e_state cs_error + = (expr, e_state, cs_error) + build_expression [expr : exprs] e_state cs_error + # (opt_opr, left, e_state, cs_error) = split_at_operator [expr] exprs e_state cs_error + (left_expr, e_state, cs_error) = combine_expressions left [] 0 e_state cs_error + = case opt_opr of + Yes (symb, prio, is_fun, right) + -> build_operator_expression [] left_expr (symb, prio, is_fun) right e_state cs_error + No + -> (left_expr, e_state, cs_error) + where + split_at_operator left [Constant symb arity NoPrio is_fun : exprs] e_state cs_error + # (appl_exp, e_state, cs_error) = buildApplication symb arity 0 is_fun [] e_state cs_error + = split_at_operator [appl_exp : left] exprs e_state cs_error + split_at_operator left [Constant symb arity prio is_fun] e_state cs_error + # (appl_exp, e_state, cs_error) = buildApplication symb arity 0 is_fun [] e_state cs_error + = (No, [appl_exp : left], e_state, cs_error) + split_at_operator left [expr=:(Constant symb _ prio is_fun) : exprs] e_state cs_error + = (Yes (symb, prio, is_fun, exprs), left, e_state, cs_error) + split_at_operator left [expr : exprs] e_state cs_error + = split_at_operator [expr : left] exprs e_state cs_error + split_at_operator exp [] e_state cs_error + = (No, exp, e_state, cs_error) + + combine_expressions [first_expr] args arity e_state cs_error + = case first_expr of + Constant symb form_arity _ is_fun + # (app_exp, e_state, cs_error) = buildApplication symb form_arity arity is_fun args e_state cs_error + -> (app_exp, e_state, cs_error) + _ + | arity == 0 + -> (first_expr, e_state, cs_error) + -> (first_expr @ args, e_state, cs_error) + combine_expressions [rev_arg : rev_args] args arity e_state cs_error + = combine_expressions rev_args [rev_arg : args] (inc arity) e_state cs_error + + + build_operator_expression left_appls left1 (symb1, prio1, is_fun1) [re : res] e_state cs_error + # (opt_opr, left2, e_state, cs_error) = split_at_operator [re] res e_state cs_error + = case opt_opr of + Yes (symb2, prio2, is_fun2, right) + | prio1 > prio2 + # (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error + (new_left, e_state, cs_error) = buildApplication symb1 2 2 is_fun1 [left1,middle_exp] e_state cs_error + (left_appls, new_left, e_state, cs_error) = build_left_operand left_appls prio2 new_left e_state cs_error + -> build_operator_expression left_appls new_left (symb2, prio2, is_fun2) right e_state cs_error + # (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error + -> build_operator_expression [(symb1, prio1, is_fun1, left1) : left_appls] + middle_exp (symb2, prio2, is_fun2) right e_state cs_error + No + # (right, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error + (result_expr, e_state, cs_error) = buildApplication symb1 2 2 is_fun1 [left1,right] e_state cs_error + -> build_final_expression left_appls result_expr e_state cs_error + + build_left_operand [] _ result_expr e_state cs_error + = ([], result_expr, e_state, cs_error) + build_left_operand la=:[(symb, priol, is_fun, left) : left_appls] prior result_expr e_state cs_error + | priol > prior + # (result_expr, e_state, cs_error) = buildApplication symb 2 2 is_fun [left,result_expr] e_state cs_error + = build_left_operand left_appls prior result_expr e_state cs_error + = (la, result_expr, e_state, cs_error) + + build_final_expression [] result_expr e_state cs_error + = (result_expr, e_state, cs_error) + build_final_expression [(symb, _, is_fun, left) : left_appls] result_expr e_state cs_error + # (result_expr, e_state, cs_error) = buildApplication symb 2 2 is_fun [left,result_expr] e_state cs_error + = build_final_expression left_appls result_expr e_state cs_error + +checkExpression free_vars (PE_Let strict let_locals expr) e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # ei_expr_level = inc ei_expr_level + (loc_defs, var_env, e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index let_locals e_state e_info cs + e_input = { e_input & ei_expr_level = ei_expr_level } + (let_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs + (let_expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs let_expr e_input e_state e_info cs + (es_fun_defs, e_info, heaps, cs) + = checkLocalFunctions ei_mod_index ei_expr_level let_locals e_state.es_fun_defs e_info + { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs + (es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable ei_expr_level var_env let_locals es_fun_defs cs.cs_symbol_table + = (let_expr, free_vars, { e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expression_heap = heaps.hp_expression_heap, + es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table }) + +checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info cs + # (pattern_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs + (guards, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] e_input e_state e_info cs + (pattern_expr, binds, es_expression_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expression_heap + (case_expr, es_expression_heap) = build_case guards defaul pattern_expr case_ident es_expression_heap + (result_expr, es_expression_heap) = buildLetExpression binds cIsNotStrict case_expr es_expression_heap + = (result_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs) + +where + check_guarded_expressions free_vars [g] pattern_variables e_input=:{ei_expr_level} e_state e_info cs + # e_input = { e_input & ei_expr_level = inc ei_expr_level } + = check_guarded_expression free_vars g NoPattern pattern_variables No e_input e_state e_info cs + check_guarded_expressions free_vars [g : gs] pattern_variables e_input=:{ei_expr_level} e_state e_info cs + # e_input = { e_input & ei_expr_level = inc ei_expr_level } + (gs, pattern_variables, defaul, free_vars, e_state, e_info, cs) + = check_guarded_expressions free_vars gs pattern_variables e_input e_state e_info cs + = check_guarded_expression free_vars g gs pattern_variables defaul e_input e_state e_info cs + + check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals}} patterns pattern_variables defaul e_input=:{ei_expr_level,ei_mod_index} + e_state=:{es_fun_defs,es_var_heap} e_info cs + # (pattern, var_env, {ps_fun_defs,ps_var_heap}, e_info, cs) + = checkPattern ei_expr_level ei_mod_index calt_pattern No [] {ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs + e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs} + (expr, free_vars, e_state=:{es_dynamics,es_expression_heap,es_var_heap}, e_info, cs) = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs + cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table + (guarded_expr, pattern_variables, defaul, es_var_heap, es_expression_heap, dynamics_in_patterns, cs) + = transform_pattern pattern patterns pattern_variables defaul expr es_var_heap es_expression_heap es_dynamics { cs & cs_symbol_table = cs_symbol_table } + = (guarded_expr, pattern_variables, defaul, free_vars, + { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap, es_dynamics = dynamics_in_patterns }, + e_info, cs) + + transform_pattern :: !AuxiliaryPattern !CasePatterns !(Env Ident VarInfoPtr) !(Optional (Optional FreeVar, Expression)) !Expression + !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState + -> (!CasePatterns, !Env Ident VarInfoPtr, !Optional (Optional FreeVar,Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) + transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs + # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs + type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index} + pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr} + pattern_variables = cons_optional opt_var pattern_variables + = case patterns of + AlgebraicPatterns alg_type alg_patterns + | type_symbol == alg_type + -> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error }) + NoPattern + -> (AlgebraicPatterns type_symbol [pattern], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + _ + -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "illegal combination of patterns" cs.cs_error }) + transform_pattern (AP_Basic basic_val opt_var) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs + # pattern = { bp_value = basic_val, bp_expr = result_expr} + pattern_variables = cons_optional opt_var pattern_variables + (type_symbol, cs) = typeOfBasicValue basic_val cs + = case patterns of + BasicPatterns basic_type basic_patterns + | type_symbol == basic_type + -> (BasicPatterns basic_type [pattern : basic_patterns], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError basic_val "incompatible types of patterns" cs.cs_error }) + NoPattern + -> (BasicPatterns type_symbol [pattern], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + _ + -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError basic_val "illegal combination of patterns" cs.cs_error}) + transform_pattern (AP_Dynamic pattern type opt_var) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs + (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap + pattern = { dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty } + pattern_variables = cons_optional opt_var pattern_variables + = case patterns of + DynamicPatterns dyn_patterns + -> (DynamicPatterns [pattern : dyn_patterns], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs) + NoPattern + -> (DynamicPatterns [pattern], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs) + _ + -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError "<dynamic pattern>""illegal combination of patterns" cs.cs_error }) + transform_pattern (AP_Variable name var_info opt_var) NoPattern pattern_variables No result_expr var_store expr_heap opt_dynamics cs + = (NoPattern, cons_optional opt_var pattern_variables, Yes (Yes { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr), + var_store, expr_heap, opt_dynamics, cs) + transform_pattern (AP_Variable name var_info opt_var) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs + = (patterns, cons_optional opt_var pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError name "illegal combination of patterns" cs.cs_error }) + transform_pattern (AP_WildCard _) NoPattern pattern_variables No result_expr var_store expr_heap opt_dynamics cs + = (NoPattern, pattern_variables, Yes (No, result_expr), var_store, expr_heap, opt_dynamics, cs) + transform_pattern (AP_WildCard _) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs + = (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError "_" "illegal combination of patterns" cs.cs_error }) + transform_pattern (AP_Empty name) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs + = (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + + + build_case NoPattern defaul expr case_ident expr_heap + = case defaul of + Yes (opt_var, result) + -> case opt_var of + Yes var + # (let_expression, expr_heap) = bind_default_variable expr var result expr_heap + -> (let_expression, expr_heap) + No + -> (result, expr_heap) + No + -> (abort "incorrect case expression in build_case", expr_heap) + build_case (DynamicPatterns patterns) defaul expr case_ident expr_heap + = case defaul of + Yes (opt_var, result) + -> case opt_var of + Yes var + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = var.fv_name, var_info_ptr = var.fv_info_ptr, var_expr_ptr = var_expr_ptr } + result = buildTypeCase (Var bound_var) patterns (Yes result) type_case_info_ptr + (case_expression, expr_heap) = bind_default_variable expr var result expr_heap + -> (case_expression, expr_heap) + No + # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (buildTypeCase expr patterns (Yes result) type_case_info_ptr, expr_heap) + No + # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (buildTypeCase expr patterns No type_case_info_ptr, expr_heap) + build_case patterns (Yes (defaul,result)) expr case_ident expr_heap + = case defaul of + Yes var + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = var.fv_name, var_info_ptr = var.fv_info_ptr, var_expr_ptr = var_expr_ptr } + result = Case {case_expr = Var bound_var, case_guards = patterns, case_default = Yes result, + case_ident = Yes case_ident, case_info_ptr = case_expr_ptr} + (case_expression, expr_heap) = bind_default_variable expr var result expr_heap + -> (case_expression, expr_heap) + No + # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result, + case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap) + build_case patterns No expr case_ident expr_heap + # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Case {case_expr = expr, case_guards = patterns, case_default = No, case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap) + + bind_default_variable bind_src bind_dst result_expr expr_heap + # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Let {let_strict = cIsNotStrict, let_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap) + + cons_optional (Yes var) variables + = [ var : variables ] + cons_optional No variables + = variables + + bind_pattern_variables [] pattern_expr expr_heap + = (pattern_expr, [], expr_heap) + bind_pattern_variables [{bind_src,bind_dst} : variables] this_pattern_expr expr_heap + # free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr } + (pattern_expr, binds, expr_heap) = bind_pattern_variables variables (Var bound_var) expr_heap + = (pattern_expr, [{bind_src = this_pattern_expr, bind_dst = free_var} : binds], expr_heap) + + +checkExpression free_vars (PE_Selection is_unique expr selectors) e_input e_state e_info cs + # (selectors, free_vars, e_state, e_info, cs) = checkSelectors free_vars selectors e_input e_state e_info cs + (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs + | is_unique + # (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs + = (Selection (Yes tuple_type) expr selectors, free_vars, e_state, e_info, cs) + = (Selection No expr selectors, free_vars, e_state, e_info, cs) +checkExpression free_vars (PE_Update expr1 selectors expr2) e_input e_state e_info cs + # (expr1, free_vars, e_state, e_info, cs) = checkExpression free_vars expr1 e_input e_state e_info cs + (selectors, free_vars, e_state, e_info, cs) = checkSelectors free_vars selectors e_input e_state e_info cs + (expr2, free_vars, e_state, e_info, cs) = checkExpression free_vars expr2 e_input e_state e_info cs + = (Update expr1 selectors expr2, free_vars, e_state, e_info, cs) +checkExpression free_vars (PE_Tuple exprs) e_input e_state e_info cs + # (exprs, arity, free_vars, e_state, e_info, cs) = check_expression_list free_vars exprs e_input e_state e_info cs + ({glob_object={ds_ident,ds_index, ds_arity},glob_module}, cs) + = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs + = (App { app_symb = { symb_name = ds_ident, symb_arity = ds_arity, + symb_kind = SK_Constructor { glob_object = ds_index, glob_module = glob_module }}, + app_args = exprs, app_info_ptr = nilPtr }, free_vars, e_state, e_info, cs) +where + check_expression_list free_vars [] e_input e_state e_info cs + = ([], 0, free_vars, e_state, e_info, cs) + check_expression_list free_vars [expr : exprs] e_input e_state e_info cs + # (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs + (exprs, length, free_vars, e_state, e_info, cs) = check_expression_list free_vars exprs e_input e_state e_info cs + = ([expr : exprs], inc length, free_vars, e_state, e_info, cs) + +checkExpression free_vars rec=:(PE_Record record opt_type fields) e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # (opt_record_and_fields, e_info, cs) = checkFields ei_mod_index fields opt_type e_info cs + = case opt_record_and_fields of + Yes (cons=:{glob_module, glob_object}, _, new_fields) + # {ds_ident,ds_index,ds_arity} = glob_object + rec_cons = { symb_name = ds_ident, symb_kind = SK_Constructor { glob_object = ds_index, glob_module = glob_module }, symb_arity = ds_arity } + -> case record of + PE_Empty + # (exprs, free_vars, e_state, e_info, cs) = check_field_exprs free_vars new_fields 0 RK_Constructor e_input e_state e_info cs + -> (App { app_symb = rec_cons, app_args = remove_fields exprs, app_info_ptr = nilPtr }, free_vars, e_state, e_info, cs) + _ + # (rec_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars record e_input e_state e_info cs + -> case rec_expr of + Var {var_info_ptr,var_name} + # (var_info, es_var_heap) = readPtr var_info_ptr e_state.es_var_heap + e_state = { e_state & es_var_heap = es_var_heap } + -> case var_info of + VI_Record fields + # (exprs, free_vars, e_state, e_info, cs) + = check_field_exprs free_vars new_fields 0 (RK_UpdateToConstructor fields) e_input e_state e_info cs + -> (App { app_symb = rec_cons, app_args = remove_fields exprs, app_info_ptr = nilPtr }, free_vars, e_state, e_info, cs) + _ + # (exprs, free_vars, e_state, e_info, cs) + = check_field_exprs free_vars new_fields 0 RK_Update e_input e_state e_info cs + -> (RecordUpdate cons rec_expr exprs, free_vars, e_state, e_info, cs) + _ + # (exprs, free_vars, e_state, e_info, cs) + = check_field_exprs free_vars new_fields 0 RK_Update e_input e_state e_info cs + -> (RecordUpdate cons rec_expr exprs, free_vars, e_state, e_info, cs) + No + -> (EE, free_vars, e_state, e_info, cs) +where + remove_fields binds = [ bind_src \\ {bind_src} <- binds ] + + check_field_exprs free_vars [] field_nr record_kind e_input e_state e_info cs + = ([], free_vars, e_state, e_info, cs) + check_field_exprs free_vars [field_expr : field_exprs] field_nr record_kind e_input e_state e_info cs + # (expr, free_vars, e_state, e_info, cs) + = check_field_expr free_vars field_expr field_nr record_kind e_input e_state e_info cs + (exprs, free_vars, e_state, e_info, cs) = check_field_exprs free_vars field_exprs (inc field_nr) record_kind e_input e_state e_info cs + = ([expr : exprs], free_vars, e_state, e_info, cs) + + check_field_expr free_vars field=:{bind_src = PE_Empty, bind_dst={glob_object={fs_var,fs_name,fs_index},glob_module}} field_nr record_kind e_input e_state e_info cs + # (expr, free_vars, e_state, e_info, cs) + = checkIdentExpression cIsNotInExpressionList free_vars fs_var e_input e_state e_info cs + = ({ field & bind_src = expr }, free_vars, e_state, e_info, cs) + check_field_expr free_vars field=:{bind_src = PE_WildCard, bind_dst={glob_object=fs_name}} field_nr RK_Constructor e_input e_state e_info cs + = ({ field & bind_src = EE }, free_vars, e_state, e_info, { cs & cs_error = checkError fs_name "field not specified" cs.cs_error }) + check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr RK_Update e_input e_state e_info cs + = ({ field & bind_src = EE }, free_vars, e_state, e_info, cs) + check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr (RK_UpdateToConstructor fields) e_input e_state=:{es_expression_heap} e_info cs + # (var_name, var_info_ptr) = get_field_var (fields !! field_nr) + (var_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap + = ({ field & bind_src = Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr }}, free_vars, + { e_state & es_expression_heap = es_expression_heap }, e_info, cs) + check_field_expr free_vars field=:{bind_src} field_nr upd_record e_input e_state e_info cs + # (expr, free_vars, e_state, e_info, cs) + = checkExpression free_vars bind_src e_input e_state e_info cs + = ({ field & bind_src = expr }, free_vars, e_state, e_info, cs) + + get_field_var (AP_Algebraic _ _ _ (Yes {bind_src,bind_dst})) + = (bind_src, bind_dst) + get_field_var (AP_Basic _ (Yes {bind_src,bind_dst})) + = (bind_src, bind_dst) + get_field_var (AP_Dynamic _ _ (Yes {bind_src,bind_dst})) + = (bind_src, bind_dst) + get_field_var (AP_Variable id var_ptr _) + = (id, var_ptr) + get_field_var (AP_WildCard (Yes {bind_src,bind_dst})) + = (bind_src, bind_dst) + get_field_var _ + = ({ id_name = "** ERRONEOUS **", id_info = nilPtr }, nilPtr) + +checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expression_heap,es_dynamics} e_info cs + # (dyn_info_ptr, es_expression_heap) = newPtr (EI_Dynamic opt_type) es_expression_heap + (dyn_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input + {e_state & es_dynamics = [dyn_info_ptr : es_dynamics], es_expression_heap = es_expression_heap } e_info cs + = (DynamicExpr { dyn_expr = dyn_expr, dyn_opt_type = opt_type, dyn_info_ptr = dyn_info_ptr, dyn_type_code = TCE_Empty, dyn_uni_vars = [] }, + free_vars, e_state, e_info, cs) + +checkExpression free_vars (PE_Basic basic_value) e_input e_state e_info cs + # (basic_type, cs) = typeOfBasicValue basic_value cs + = (BasicExpr basic_value basic_type, free_vars, e_state, e_info, cs) + +checkExpression free_vars (PE_ABC_Code code_sequence do_inline) e_input e_state e_info cs + = (ABCCodeExpr code_sequence do_inline, free_vars, e_state, e_info, cs) +checkExpression free_vars (PE_Any_Code ins outs code_sequence) e_input e_state e_info cs + # (ins, (free_vars, e_state, e_info, cs)) = check_in_parameters e_input ins (free_vars, e_state, e_info, cs) + (new_outs, (e_state, cs)) = check_out_parameters e_input.ei_expr_level outs (e_state, cs) + cs_symbol_table = remove_out_parameters_from_symbol_table e_input.ei_expr_level outs cs.cs_symbol_table + = (AnyCodeExpr ins new_outs code_sequence, free_vars, e_state, e_info, { cs & cs_symbol_table = cs_symbol_table }) +where + check_in_parameters e_input params fv_es_ei_cs + = mapSt (check_in_parameter e_input) params fv_es_ei_cs + + check_in_parameter e_input { bind_src, bind_dst } (free_vars, e_state, e_info, cs) + # (id_expr, free_vars, e_state, e_info, cs) = checkIdentExpression cIsNotInExpressionList free_vars bind_dst e_input e_state e_info cs + = case id_expr of + Var var + -> ({ bind_dst = var, bind_src = bind_src }, (free_vars, e_state, e_info, cs)) + _ + -> ({ bind_dst = { var_name = bind_dst, var_info_ptr = nilPtr, var_expr_ptr = nilPtr }, bind_src = bind_src }, (free_vars, e_state, e_info, + { cs & cs_error = checkError bind_src "bound variable expected" cs.cs_error })) + + check_out_parameters expr_level params es_cs + = mapSt (check_out_parameter expr_level) params es_cs + + check_out_parameter expr_level bind=:{ bind_src, bind_dst } (e_state, cs) + | isLowerCaseName bind_dst.id_name + #! entry = sreadPtr bind_dst.id_info cs.cs_symbol_table + # (new_info_ptr, es_var_heap) = newPtr VI_Empty e_state.es_var_heap + cs = checkPatternVariable expr_level entry bind_dst new_info_ptr cs + + = ( { bind & bind_dst = { fv_def_level = expr_level, fv_name = bind_dst, fv_info_ptr = new_info_ptr, fv_count = 0 }}, + ( { e_state & es_var_heap = es_var_heap }, cs)) + = ( { bind & bind_dst = { fv_def_level = expr_level, fv_name = bind_dst, fv_info_ptr = nilPtr, fv_count = 0 }}, + ( e_state, { cs & cs_error = checkError bind_src "variable expected" cs.cs_error })) + + remove_out_parameters_from_symbol_table expr_level idents symbol_table + = foldSt (\{bind_dst} -> removeIdentFromSymbolTable expr_level bind_dst) idents symbol_table + +checkExpression free_vars (PE_Ident id) e_input e_state e_info cs + = checkIdentExpression cIsNotInExpressionList free_vars id e_input e_state e_info cs +checkExpression free_vars expr e_input e_state e_info cs + = abort "checkExpression (check.icl, line 1433)" <<- expr + +checkSelectors free_vars [] e_input e_state e_info cs + = ([], free_vars, e_state, e_info, cs) +checkSelectors free_vars [ selector : selectors ] e_input e_state e_info cs + # (selector, free_vars, e_state, e_info, cs) = check_selector free_vars selector e_input e_state e_info cs + (selectors, free_vars, e_state, e_info, cs) = checkSelectors free_vars selectors e_input e_state e_info cs + = ([ selector : selectors ], free_vars, e_state, e_info, cs) +where + check_selector free_vars (PS_Record selector=:{id_info,id_name} opt_type) e_input=:{ei_mod_index} e_state + e_info=:{ef_selector_defs, ef_modules} cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # selectors = retrieveSelectorIndexes ei_mod_index entry + (field_module, field_index, field_nr, ef_selector_defs, ef_modules, cs) + = get_field_nr ei_mod_index selector opt_type selectors ef_selector_defs ef_modules cs + = (RecordSelection { glob_object = MakeDefinedSymbol selector field_index 1, glob_module = field_module } field_nr, free_vars, e_state, + {e_info & ef_selector_defs = ef_selector_defs, ef_modules = ef_modules }, cs) + where + get_field_nr :: !Index !Ident !(Optional Ident) ![Global Index] !u:{#SelectorDef} !v:{# DclModule} !*CheckState + -> (!Index, !Index, !Index, u:{#SelectorDef}, v:{#DclModule}, !*CheckState) + get_field_nr mod_index sel_id _ [] selector_defs modules cs=:{cs_error} + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name " selector not defined" cs_error }) + get_field_nr mod_index sel_id (Yes type_id=:{id_info}) selectors selector_defs modules cs=:{cs_symbol_table,cs_error} + #! entry = sreadPtr id_info cs_symbol_table + # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index + | type_index <> NotFound + #! (selector_index, selector_offset, selector_defs, modules) + = determine_selector mod_index type_module type_index selectors selector_defs modules + | selector_offset <> NoIndex + = (type_module, selector_index, selector_offset, selector_defs, modules, cs) + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name " selector not defined" cs_error }) + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError type_id " type not defined" cs_error }) + get_field_nr mod_index sel_id No [{glob_object,glob_module}] selector_defs modules cs + | mod_index == glob_module + #! selector_offset = selector_defs.[glob_object].sd_field_nr + = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) + #! selector_offset = modules.[glob_module].dcl_common.com_selector_defs.[glob_object].sd_field_nr + = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) + get_field_nr mod_index sel_id No _ selector_defs modules cs=:{cs_error} + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError sel_id " ambiguous selector specified" cs_error }) + + determine_selector :: !Index !Index !Index ![Global Index] !u:{# SelectorDef} !v:{# DclModule} -> (!Int, !Int, !u:{# SelectorDef}, !v:{# DclModule}) + determine_selector mod_index type_mod_index type_index [] selector_defs modules + = (NoIndex, NoIndex, selector_defs, modules) + determine_selector mod_index type_mod_index type_index [{glob_module, glob_object} : selectors] selector_defs modules + | type_mod_index == glob_module + | type_mod_index == mod_index + #! selector_def = selector_defs.[glob_object] + | selector_def.sd_type_index == type_index + = (glob_object, selector_def.sd_field_nr, selector_defs, modules) + = determine_selector mod_index type_mod_index type_index selectors selector_defs modules + #! {dcl_common={com_selector_defs}} = modules.[glob_module] + #! selector_def = com_selector_defs.[glob_object] + | selector_def.sd_type_index == type_index + = (glob_object, selector_def.sd_field_nr, selector_defs, modules) + = determine_selector mod_index type_mod_index type_index selectors selector_defs modules + = determine_selector mod_index type_mod_index type_index selectors selector_defs modules + + check_selector free_vars (PS_Array index_expr) e_input=:{ei_mod_index} e_state e_info cs + # (index_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars index_expr e_input e_state e_info cs + (glob_select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs + (new_info_ptr, es_expression_heap) = newPtr EI_Empty e_state.es_expression_heap + = (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs) + + +buildLetExpression :: !(Env Expression FreeVar) !Bool !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) +buildLetExpression [] is_strict expr expr_heap + = (expr, expr_heap) +buildLetExpression binds is_strict expr expr_heap + # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Let {let_strict = is_strict, let_binds = binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap) + +checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_from,ir_to},loc_nodes}) e_state=:{es_var_heap,es_fun_defs} e_info cs + # (loc_defs, var_env, {ps_fun_defs,ps_var_heap}, e_info, cs) + = check_patterns def_level mod_index loc_nodes [] {ps_fun_defs = es_fun_defs, ps_var_heap = es_var_heap} e_info cs + (es_fun_defs, cs_symbol_table, cs_error) = addLocalFunctionDefsToSymbolTable def_level ir_from ir_to ps_fun_defs cs.cs_symbol_table cs.cs_error + = (loc_defs, var_env, { e_state & es_fun_defs = es_fun_defs, es_var_heap = ps_var_heap }, e_info, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }) +where + check_patterns def_level mod_index [ (_,node_def) : node_defs ] var_env var_store e_info cs + # (pattern, var_env, var_store, e_info, cs) = checkPattern def_level mod_index node_def.nd_dst No var_env var_store e_info cs + (patterns, var_env, var_store, e_info, cs) = check_patterns def_level mod_index node_defs var_env var_store e_info cs + = ([{ node_def & nd_dst = pattern } : patterns], var_env, var_store, e_info, cs) + check_patterns def_level mod_index [] var_env var_store e_info cs + = ([], var_env, var_store, e_info, cs) + + +checkRhssAndTransformLocalDefs free_vars [] rhs_expr e_input e_state e_info cs + = (rhs_expr, free_vars, e_state, e_info, cs) +checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs + # (binds, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars loc_defs e_input e_state e_info cs + (rhs_expr, es_expression_heap) = buildLetExpression binds cIsNotStrict rhs_expr e_state.es_expression_heap + = (rhs_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs) + +checkAndTransformPatternIntoBind free_vars [{nd_dst,nd_alts,nd_locals} : local_defs] e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # (bind_src, free_vars, e_state, e_info, cs) = checkRhs free_vars nd_alts nd_locals e_input e_state e_info cs + (binds_of_bind, es_var_heap, es_expression_heap, e_info, cs) + = transfromPatternIntoBind ei_mod_index ei_expr_level nd_dst bind_src e_state.es_var_heap e_state.es_expression_heap e_info cs + e_state = { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap } + (binds_of_local_defs, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars local_defs e_input e_state e_info cs + = (binds_of_bind ++ binds_of_local_defs, free_vars, e_state, e_info, cs) +checkAndTransformPatternIntoBind free_vars [] e_input e_state e_info cs + = ([], free_vars, e_state, e_info, cs) + +transfromPatternIntoBind :: !Index !Level !AuxiliaryPattern !Expression !*VarHeap !*ExpressionHeap !*ExpressionInfo !*CheckState + -> *(![Bind Expression FreeVar], !*VarHeap, !*ExpressionHeap, !*ExpressionInfo, !*CheckState) +transfromPatternIntoBind mod_index def_level (AP_Variable name var_info _) src_expr var_store expr_heap e_info cs + # bind = {bind_src = src_expr, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = def_level, fv_count = 0 }} + = ([bind], var_store, expr_heap, e_info, cs) +transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_module,glob_object=ds_cons=:{ds_arity, ds_index, ds_ident}} type_index args opt_var) + src_expr var_store expr_heap e_info=:{ef_type_defs,ef_modules} cs + # (src_expr, opt_var_bind, var_store, expr_heap) = bind_opt_var opt_var src_expr var_store expr_heap + | ds_arity == 0 + = ([], var_store, expr_heap, e_info, { cs & cs_error = checkError ds_ident " constant not allowed in a node pattern" cs.cs_error}) + # (is_tuple, cs) = is_tuple_symbol glob_module ds_index cs + | is_tuple + # (tuple_var, tuple_bind, var_store, expr_heap) = bind_match_expr src_expr opt_var_bind var_store expr_heap + = transform_sub_patterns mod_index def_level args ds_cons 0 tuple_var tuple_bind var_store expr_heap e_info cs + # ({td_rhs}, ef_type_defs, ef_modules) = get_type_def mod_index glob_module type_index ef_type_defs ef_modules + e_info = { e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules } + = case td_rhs of + RecordType {rt_fields} + | size rt_fields == 1 + -> transform_sub_patterns_of_record mod_index def_level args rt_fields glob_module 0 src_expr opt_var_bind var_store expr_heap e_info cs + # (record_var, record_bind, var_store, expr_heap) + = bind_match_expr src_expr opt_var_bind var_store expr_heap + -> transform_sub_patterns_of_record mod_index def_level args rt_fields glob_module 0 record_var record_bind var_store expr_heap e_info cs + _ + | ds_arity == 1 + # (binds, var_store, expr_heap, e_info, cs) + = transfromPatternIntoBind mod_index def_level (hd args) (MatchExpr No cons_symbol src_expr) var_store expr_heap e_info cs + -> (opt_var_bind ++ binds, var_store, expr_heap, e_info, cs) + # (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex ds_arity) PD_PredefinedModule STE_Type ds_arity cs + (tuple_cons, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex ds_arity) PD_PredefinedModule STE_Constructor ds_arity cs + (match_var, match_bind, var_store, expr_heap) + = bind_match_expr (MatchExpr (Yes tuple_type) cons_symbol src_expr) opt_var_bind var_store expr_heap + -> transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind var_store expr_heap e_info cs + + +where + get_type_def mod_index type_mod_index type_index ef_type_defs ef_modules + | mod_index == type_mod_index + # (type_def, ef_type_defs) = ef_type_defs![type_index] + = (type_def, ef_type_defs, ef_modules) + # ({dcl_common}, ef_modules) = ef_modules![type_mod_index] + = (dcl_common.com_type_defs.[type_index], ef_type_defs, ef_modules) + + is_tuple_symbol cons_module cons_index cs + # (tuple_2_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex 2) PD_PredefinedModule STE_Constructor 2 cs + = (tuple_2_symbol.glob_module == cons_module && + tuple_2_symbol.glob_object.ds_index <= cons_index && cons_index <= tuple_2_symbol.glob_object.ds_index + 30, cs) + + transform_sub_patterns mod_index def_level [pattern : patterns] tup_id tup_index arg_var all_binds var_store expr_heap e_info cs + # match_expr = TupleSelect tup_id tup_index arg_var + (binds, var_store, expr_heap, e_info, cs) = transfromPatternIntoBind mod_index def_level pattern match_expr var_store expr_heap e_info cs + = transform_sub_patterns mod_index def_level patterns tup_id (inc tup_index) arg_var (binds ++ all_binds) var_store expr_heap e_info cs + transform_sub_patterns mod_index _ [] _ _ _ binds var_store expr_heap e_info cs + = (binds, var_store, expr_heap, e_info, cs) + + transform_sub_patterns_of_record mod_index def_level [pattern : patterns] fields field_module field_index record_expr + all_binds var_store expr_heap e_info cs + # {fs_name, fs_index} = fields.[field_index] + selector = { glob_module = field_module, glob_object = MakeDefinedSymbol fs_name fs_index 1} + (binds, var_store, expr_heap, e_info, cs) + = transfromPatternIntoBind mod_index def_level pattern (Selection No record_expr [ RecordSelection selector field_index ]) + var_store expr_heap e_info cs + = transform_sub_patterns_of_record mod_index def_level patterns fields field_module (inc field_index) record_expr + (binds ++ all_binds) var_store expr_heap e_info cs + transform_sub_patterns_of_record mod_index _ [] _ _ _ _ binds var_store expr_heap e_info cs + = (binds, var_store, expr_heap, e_info, cs) + + bind_opt_var (Yes {bind_src,bind_dst}) src_expr var_heap expr_heap + # free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr } + = (Var bound_var, [{bind_src = src_expr, bind_dst = free_var}], var_heap, expr_heap) + bind_opt_var No src_expr var_heap expr_heap + = (src_expr, [], var_heap, expr_heap) + + bind_match_expr var_expr=:(Var var) opt_var_bind var_heap expr_heap + = (var_expr, opt_var_bind, var_heap, expr_heap) + bind_match_expr match_expr opt_var_bind var_heap expr_heap + # new_name = newVarId "_x" + (var_info_ptr, var_heap) = newPtr VI_Empty var_heap + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = new_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } + free_var = { fv_name = new_name, fv_info_ptr = var_info_ptr, fv_def_level = def_level, fv_count = 0 } + = (Var bound_var, [{bind_src = match_expr, bind_dst = free_var} : opt_var_bind], var_heap, expr_heap) + +transfromPatternIntoBind mod_index def_level (AP_WildCard _) src_expr var_store expr_heap e_info cs + = ([], var_store, expr_heap, e_info, cs) +transfromPatternIntoBind _ _ pattern src_expr var_store expr_heap e_info cs + = ([], var_store, expr_heap, e_info, { cs & cs_error = checkError "<pattern>" " illegal node pattern" cs.cs_error}) + +checkLocalFunctions mod_index level (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) fun_defs e_info heaps cs + = checkFunctions mod_index level ir_from ir_to fun_defs e_info heaps cs + +checkRhs free_vars rhs_alts rhs_locals e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # ei_expr_level = inc ei_expr_level + (loc_defs, var_env, e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index rhs_locals e_state e_info cs + (es_fun_defs, e_info, heaps, cs) + = checkLocalFunctions ei_mod_index ei_expr_level rhs_locals e_state.es_fun_defs e_info + { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs + (rhs_expr, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars rhs_alts { e_input & ei_expr_level = ei_expr_level } + { e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expression_heap = heaps.hp_expression_heap, + es_type_heaps = heaps.hp_type_heaps } e_info cs + (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs + (es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable ei_expr_level var_env rhs_locals e_state.es_fun_defs cs.cs_symbol_table + = (expr, free_vars, { e_state & es_fun_defs = es_fun_defs}, e_info, { cs & cs_symbol_table = cs_symbol_table }) +where + check_opt_guarded_alts free_vars (GuardedAlts guarded_alts default_expr) e_input e_state e_info cs + # (let_vars_list, rev_guarded_exprs, last_expr_level, free_vars, e_state, e_info, cs) + = check_guarded_expressions free_vars guarded_alts [] [] e_input e_state e_info cs + (default_expr, free_vars, e_state, e_info, cs) + = check_default_expr free_vars default_expr { e_input & ei_expr_level = last_expr_level } e_state e_info cs + cs = { cs & cs_symbol_table = remove_seq_let_vars e_input.ei_expr_level let_vars_list cs.cs_symbol_table } + (result_expr, es_expression_heap) = convert_guards_to_cases rev_guarded_exprs default_expr e_state.es_expression_heap + = (result_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs) + check_opt_guarded_alts free_vars (UnGuardedExpr unguarded_expr) e_input e_state e_info cs + = check_unguarded_expression free_vars unguarded_expr e_input e_state e_info cs + + check_default_expr free_vars (Yes default_expr) e_input e_state e_info cs + # (expr, free_vars, e_state, e_info, cs) = check_unguarded_expression free_vars default_expr e_input e_state e_info cs + = (Yes expr, free_vars, e_state, e_info, cs) + check_default_expr free_vars No e_input e_state e_info cs + = (No, free_vars, e_state, e_info, cs) + + convert_guards_to_cases [(let_binds, guard, expr)] result_expr es_expression_heap + # (case_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap + case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [{bp_value = (BVB True), bp_expr = expr}], + case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr } + = build_sequential_lets let_binds case_expr es_expression_heap + convert_guards_to_cases [(let_binds, guard, expr) : rev_guarded_exprs] result_expr es_expression_heap + # (case_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap + case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [{bp_value = (BVB True), bp_expr = expr}], + case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr } + (result_expr, es_expression_heap) = build_sequential_lets let_binds case_expr es_expression_heap + = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expression_heap + + check_guarded_expressions free_vars [gexpr : gexprs] let_vars_list rev_guarded_exprs e_input e_state e_info cs + # (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs) + = check_guarded_expression free_vars gexpr let_vars_list rev_guarded_exprs e_input e_state e_info cs + = check_guarded_expressions free_vars gexprs let_vars_list rev_guarded_exprs { e_input & ei_expr_level = ei_expr_level } e_state e_info cs + check_guarded_expressions free_vars [] let_vars_list rev_guarded_exprs {ei_expr_level} e_state e_info cs + = (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs) + + check_guarded_expression free_vars {alt_nodes,alt_guard,alt_expr} + let_vars_list rev_guarded_exprs e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # (let_binds, let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars alt_nodes let_vars_list + { e_input & ei_expr_level = inc ei_expr_level } e_state e_info cs + e_input = { e_input & ei_expr_level = ei_expr_level } + (guard, free_vars, e_state, e_info, cs) = checkExpression free_vars alt_guard e_input e_state e_info cs + (expr, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars alt_expr e_input e_state e_info cs + = (let_vars_list, [(let_binds, guard, expr) : rev_guarded_exprs], ei_expr_level, free_vars, e_state, e_info, cs ) + + check_unguarded_expression free_vars {ewl_nodes,ewl_expr,ewl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # this_expr_level = inc ei_expr_level + (loc_defs, var_env, e_state, e_info, cs) = checkLhssOfLocalDefs this_expr_level ei_mod_index ewl_locals e_state e_info cs + (binds, let_vars_list, rhs_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars ewl_nodes [] { e_input & ei_expr_level = this_expr_level } e_state e_info cs + (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars ewl_expr { e_input & ei_expr_level = rhs_expr_level } e_state e_info cs + cs = { cs & cs_symbol_table = remove_seq_let_vars rhs_expr_level let_vars_list cs.cs_symbol_table } + (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs expr e_input e_state e_info cs + (es_fun_defs, e_info, heaps, cs) + = checkLocalFunctions ei_mod_index rhs_expr_level ewl_locals e_state.es_fun_defs e_info + { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs + (es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable this_expr_level var_env ewl_locals es_fun_defs cs.cs_symbol_table + (seq_let_expr, es_expression_heap) = build_sequential_lets binds expr heaps.hp_expression_heap + = (seq_let_expr, free_vars, {e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, + es_expression_heap = es_expression_heap, es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table} ) + + remove_seq_let_vars level [] symbol_table + = symbol_table + remove_seq_let_vars level [let_vars : let_vars_list] symbol_table + = remove_seq_let_vars (dec level) let_vars_list (removeLocalIdentsFromSymbolTable level let_vars symbol_table) + + check_sequential_lets free_vars [seq_let:seq_lets] let_vars_list e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # ei_expr_level = inc ei_expr_level + e_input = { e_input & ei_expr_level = ei_expr_level } + (src_expr, pattern_expr, let_vars, free_vars, e_state, e_info, cs) = check_sequential_let free_vars seq_let e_input e_state e_info cs + (binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs) + = check_sequential_lets free_vars seq_lets [let_vars : let_vars_list] e_input e_state e_info cs + (let_binds, es_var_heap, es_expression_heap, e_info, cs) + = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr e_state.es_var_heap e_state.es_expression_heap e_info cs + = ([(seq_let.ndwl_strict, let_binds) : binds], loc_envs, max_expr_level, free_vars, { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap }, e_info, cs) + check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs + = ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) + + check_sequential_let free_vars {ndwl_def={bind_src,bind_dst},ndwl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs + # (loc_defs, loc_env, e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index ndwl_locals e_state e_info cs + (src_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars bind_src e_input e_state e_info cs + (src_expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs src_expr e_input e_state e_info cs + (es_fun_defs, e_info, {hp_var_heap,hp_expression_heap,hp_type_heaps}, cs) + = checkLocalFunctions ei_mod_index ei_expr_level ndwl_locals e_state.es_fun_defs e_info + { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs + (es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable ei_expr_level loc_env ndwl_locals es_fun_defs cs.cs_symbol_table + (pattern, let_vars, {ps_fun_defs,ps_var_heap}, e_info, cs) = checkPattern ei_expr_level ei_mod_index bind_dst No [] + {ps_var_heap = hp_var_heap, ps_fun_defs = es_fun_defs } e_info { cs & cs_symbol_table = cs_symbol_table } + = (src_expr, pattern, let_vars, free_vars, + { e_state & es_var_heap = ps_var_heap, es_expression_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, es_fun_defs = ps_fun_defs }, + e_info, cs) + + build_sequential_lets :: ![(Bool,[Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) + build_sequential_lets [] expr expr_heap + = (expr, expr_heap) + build_sequential_lets [(nd_strict,[]) : seq_lets] expr expr_heap + = build_sequential_lets seq_lets expr expr_heap + build_sequential_lets [(nd_strict,binds) : seq_lets] expr expr_heap + # (let_expr, expr_heap) = build_sequential_lets seq_lets expr expr_heap + = buildLetExpression binds nd_strict let_expr expr_heap + +newVarId name = { id_name = name, id_info = nilPtr } + +determinePatternVariable (Yes bind) var_heap + = (bind, var_heap) +determinePatternVariable No var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ({ bind_src = newVarId "_x", bind_dst = new_info_ptr }, var_heap) + +convertSubPatterns [] result_expr var_store expr_heap opt_dynamics cs + = ([], result_expr, var_store, expr_heap, opt_dynamics, cs) +convertSubPatterns [pattern : patterns] result_expr var_store expr_heap opt_dynamics cs + # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns patterns result_expr var_store expr_heap opt_dynamics cs + (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs + = ([var_arg : var_args], result_expr, var_store, expr_heap, opt_dynamics, cs) + +convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_expr var_store expr_heap opt_dynamics cs + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr } + free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } + (let_expr, expr_heap) = buildLetExpression [{ bind_src = Var bound_var, + bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] cIsNotStrict result_expr expr_heap + = (free_var, let_expr, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Variable name var_info No) result_expr var_store expr_heap opt_dynamics cs + = ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Algebraic cons_symbol type_index args opt_var) result_expr var_store expr_heap opt_dynamics cs + # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs + type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index } + case_guards = AlgebraicPatterns type_symbol [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr }] + ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, + Case { case_expr = Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }, + case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Basic basic_val opt_var) result_expr var_store expr_heap opt_dynamics cs + # (basic_type, cs) = typeOfBasicValue basic_val cs + case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr }] + ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, + Case { case_expr = Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }, + case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Dynamic pattern type opt_var) result_expr var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs + ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap + (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap + type_case_patterns = [{ dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty }] + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, + buildTypeCase (Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }) type_case_patterns No type_case_info_ptr, + var_store, expr_heap, [dynamic_info_ptr], cs) +convertSubPattern (AP_WildCard opt_var) result_expr var_store expr_heap opt_dynamics cs + # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern ap result_expr var_store expr_heap opt_dynamics cs + = abort ("convertSubPattern: unknown pattern " ---> ap) + + +typeOfBasicValue :: !BasicValue !*CheckState -> (!BasicType, !*CheckState) +typeOfBasicValue (BVI _) cs = (BT_Int, cs) +typeOfBasicValue (BVC _) cs = (BT_Char, cs) +typeOfBasicValue (BVB _) cs = (BT_Bool, cs) +typeOfBasicValue (BVR _) cs = (BT_Real, cs) +typeOfBasicValue (BVS _) cs + # ({glob_module,glob_object={ds_ident,ds_index,ds_arity}}, cs) = getPredefinedGlobalSymbol PD_StringType PD_PredefinedModule STE_Type 0 cs + = (BT_String (TA (MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity) []), cs) + +checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies]) e_input=:{ei_expr_level,ei_mod_index} + e_state=:{es_var_heap, es_fun_defs} e_info cs + # (aux_patterns, var_env, {ps_var_heap, ps_fun_defs}, e_info, cs) + = check_patterns ei_expr_level ei_mod_index pb_args [] {ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs + (rhs_expr, free_vars, e_state=:{es_dynamics=dynamics_in_rhs}, e_info, cs) + = checkRhs [] rhs_alts rhs_locals e_input { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs } e_info cs + cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table + (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns e_state.es_var_heap + (rhss, free_vars, e_state=:{es_dynamics,es_expression_heap,es_var_heap}, e_info, cs) + = check_function_bodies free_vars cb_args bodies e_input { e_state & es_var_heap = es_var_heap, es_dynamics = [] } e_info + { cs & cs_symbol_table = cs_symbol_table } + (rhs, es_var_heap, es_expression_heap, dynamics_in_patterns, cs) + = transform_patterns_into_cases aux_patterns cb_args rhs_expr es_var_heap es_expression_heap dynamics_in_rhs cs + = (CheckedBody { cb_args = cb_args, cb_rhs = [rhs : rhss] }, free_vars, + { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs) + +where + check_patterns def_level mod_index [pattern : patterns] var_env var_store e_info cs + # (aux_pat, var_env, var_store, e_info, cs) = checkPattern def_level mod_index pattern No var_env var_store e_info cs + (aux_pats, var_env, var_store, e_info, cs) = check_patterns def_level mod_index patterns var_env var_store e_info cs + = ([aux_pat : aux_pats], var_env, var_store, e_info, cs) + check_patterns def_level mod_index [] var_env var_store e_info cs + = ([], var_env, var_store, e_info, cs) + + determine_function_arg (AP_Variable name var_info (Yes {bind_src, bind_dst})) var_store + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) + determine_function_arg (AP_Variable name var_info No) var_store + = ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, var_store) + determine_function_arg (AP_Algebraic _ _ _ opt_var) var_store + # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) + determine_function_arg (AP_Basic _ opt_var) var_store + # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) + determine_function_arg (AP_Dynamic _ _ opt_var) var_store + # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) + determine_function_arg _ var_store + # ({bind_src,bind_dst}, var_store) = determinePatternVariable No var_store + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) + + check_function_bodies free_vars fun_args [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies] e_input=:{ei_expr_level,ei_mod_index} + e_state=:{es_var_heap,es_fun_defs} e_info cs + # (aux_patterns, var_env, {ps_var_heap, ps_fun_defs}, e_info, cs) + = check_patterns ei_expr_level ei_mod_index pb_args [] {ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs + e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs} + (rhs_expr, free_vars, e_state=:{es_dynamics=dynamics_in_rhs}, e_info, cs) = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs + cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table + (rhs_exprs, free_vars, e_state=:{es_dynamics,es_expression_heap,es_var_heap}, e_info, cs) + = check_function_bodies free_vars fun_args bodies e_input { e_state & es_dynamics = [] } e_info { cs & cs_symbol_table = cs_symbol_table } + (rhs_expr, es_var_heap, es_expression_heap, dynamics_in_patterns, cs) + = transform_patterns_into_cases aux_patterns fun_args rhs_expr es_var_heap es_expression_heap dynamics_in_rhs cs + = ([rhs_expr : rhs_exprs], free_vars, { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap, + es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs) + check_function_bodies free_vars fun_args [] e_input e_state e_info cs + = ([], free_vars, e_state, e_info, cs) + + transform_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr var_store expr_heap opt_dynamics cs + # (patterns_expr, var_store, expr_heap, opt_dynamics, cs) + = transform_succeeding_patterns_into_cases patterns fun_args result_expr var_store expr_heap opt_dynamics cs + = transform_pattern_into_cases pattern fun_arg patterns_expr var_store expr_heap opt_dynamics cs + where + transform_succeeding_patterns_into_cases [] _ result_expr var_store expr_heap opt_dynamics cs + = (result_expr, var_store, expr_heap, opt_dynamics, cs) + transform_succeeding_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr var_store expr_heap opt_dynamics cs + # (patterns_expr, var_store, expr_heap, opt_dynamics, cs) + = transform_succeeding_patterns_into_cases patterns fun_args result_expr var_store expr_heap opt_dynamics cs + = transform_pattern_into_cases pattern fun_arg patterns_expr var_store expr_heap opt_dynamics cs + transform_patterns_into_cases [] _ result_expr var_store expr_heap opt_dynamics cs + = (result_expr, var_store, expr_heap, opt_dynamics, cs) + + transform_pattern_into_cases :: !AuxiliaryPattern !FreeVar !Expression !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState + -> (!Expression, !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) + transform_pattern_into_cases (AP_Variable name var_info opt_var) fun_arg=:{fv_info_ptr,fv_name} result_expr var_store expr_heap opt_dynamics cs + = case opt_var of + Yes {bind_src, bind_dst} + | bind_dst == fv_info_ptr + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (Let { let_strict = cIsStrict, let_binds = [ + { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, + bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], + let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + # (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap + (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap + (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (Let { let_strict = cIsStrict, let_binds = [ + { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 }, + bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}, + { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, + bind_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }}], + let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + No + | var_info == fv_info_ptr + -> (result_expr, var_store, expr_heap, opt_dynamics, cs) + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (Let { let_strict = cIsStrict, let_binds = + [{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, + bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], + let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs + # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs + type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} + (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap + case_guards = AlgebraicPatterns type_symbol [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr }] + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, + var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_Basic basic_val opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs + # (basic_type, cs) = typeOfBasicValue basic_val cs + (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap + case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr }] + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, + var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs + (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap + (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap + (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap + type_case_patterns = [{ dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty }] + = (buildTypeCase act_var type_case_patterns No type_case_info_ptr, var_store, expr_heap, [dynamic_info_ptr], cs) + transform_pattern_into_cases (AP_WildCard _) fun_arg result_expr var_store expr_heap opt_dynamics cs + = (result_expr, var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_Empty name) fun_arg result_expr var_store expr_heap opt_dynamics cs + = (result_expr, var_store, expr_heap, opt_dynamics, cs) + + transform_pattern_variable :: !FreeVar !(Optional !(Bind Ident VarInfoPtr)) !Expression !*ExpressionHeap + -> (!Expression, !Expression, !*ExpressionHeap) + transform_pattern_variable {fv_info_ptr,fv_name} (Yes {bind_src,bind_dst}) result_expr expr_heap + | bind_dst == fv_info_ptr + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap) + # (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap + (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap + (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 }, + Let { let_strict = cIsNotStrict, let_binds = + [{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, + bind_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }}], + let_expr = result_expr, let_info_ptr = let_expr_ptr}, expr_heap) + transform_pattern_variable {fv_info_ptr,fv_name} No result_expr expr_heap + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap) + +initializeContextVariables :: ![TypeContext] !*VarHeap -> (![TypeContext], !*VarHeap) +initializeContextVariables contexts var_heap + = mapSt add_variable_to_context contexts var_heap +where + add_variable_to_context context var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ({ context & tc_var = new_info_ptr}, var_heap) + +checkFunction :: !Index !Index !Level !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo, !*Heaps, !*CheckState); +checkFunction mod_index fun_index def_level fun_defs + e_info=:{ef_type_defs,ef_modules,ef_class_defs} heaps=:{hp_var_heap,hp_expression_heap,hp_type_heaps} cs=:{cs_error} + #! fun_def = fun_defs.[fun_index] + # {fun_symb,fun_pos,fun_body,fun_type} = fun_def + position = newPosition fun_symb fun_pos + cs = { cs & cs_error = pushErrorAdmin position cs_error } + (fun_type, ef_type_defs, ef_class_defs, ef_modules, hp_var_heap, hp_type_heaps, cs) + = check_function_type fun_type mod_index ef_type_defs ef_class_defs ef_modules hp_var_heap hp_type_heaps cs + e_info = { e_info & ef_type_defs = ef_type_defs, ef_class_defs = ef_class_defs, ef_modules = ef_modules } + e_state = { es_var_heap = hp_var_heap, es_expression_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, + es_dynamics = [], es_calls = [], es_fun_defs = fun_defs } + e_input = { ei_expr_level = inc def_level, ei_fun_index = fun_index, ei_fun_level = inc def_level, ei_mod_index = mod_index } + (fun_body, free_vars, e_state, e_info, cs) = checkFunctionBodies fun_body e_input e_state e_info cs + + # {es_fun_defs,es_calls,es_var_heap,es_expression_heap,es_type_heaps,es_dynamics} = e_state + (ef_type_defs, ef_modules, es_type_heaps, es_expression_heap, cs) = + checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expression_heap cs + cs = { cs & cs_error = popErrorAdmin cs.cs_error } + fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics } + fun_defs = { es_fun_defs & [fun_index] = { fun_def & fun_body = fun_body, fun_index = fun_index, fun_info = fun_info, fun_type = fun_type}} + (fun_defs, cs_symbol_table) = remove_calls_from_symbol_table fun_index def_level es_calls fun_defs cs.cs_symbol_table + = (fun_defs, + { e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules }, + { heaps & hp_var_heap = es_var_heap, hp_expression_heap = es_expression_heap, hp_type_heaps = es_type_heaps }, + { cs & cs_symbol_table = cs_symbol_table }) + +where + check_function_type (Yes ft) module_index type_defs class_defs modules var_heap type_heaps cs + # (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkSymbolType module_index ft SP_None type_defs class_defs modules type_heaps cs + (st_context, var_heap) = initializeContextVariables ft.st_context var_heap + = (Yes { ft & st_context = st_context } , type_defs, class_defs, modules, var_heap, type_heaps, cs) + + check_function_type No module_index type_defs class_defs modules var_heap type_heaps cs + = (No, type_defs, class_defs, modules, var_heap, type_heaps, cs) + + remove_calls_from_symbol_table fun_index fun_level [{fc_index, fc_level} : fun_calls] fun_defs symbol_table + | fc_level <= fun_level + #! {fun_symb={id_info}} = fun_defs.[fc_index] + #! entry = sreadPtr id_info symbol_table + # (c,cs) = get_calls entry.ste_kind + | fun_index == c + = remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs (symbol_table <:= (id_info,{ entry & ste_kind = STE_FunctionOrMacro cs})) + = abort " Error in remove_calls_from_symbol_table" + = remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs symbol_table + remove_calls_from_symbol_table fun_index fun_level [] fun_defs symbol_table + = (fun_defs, symbol_table) + + get_calls (STE_FunctionOrMacro [x:xs]) = (x,xs) + + +checkFunctions :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState) +checkFunctions mod_index level from_index to_index fun_defs e_info heaps cs + | from_index == to_index + = (fun_defs, e_info, heaps, cs) + # (fun_defs, e_info, heaps, cs) = checkFunction mod_index from_index level fun_defs e_info heaps cs + = checkFunctions mod_index level (inc from_index) to_index fun_defs e_info heaps cs + +checkMacros :: !Index !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState + -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState); +checkMacros mod_index range fun_defs e_info heaps cs + # (fun_defs, e_info=:{ef_modules}, heaps=:{hp_var_heap, hp_expression_heap}, cs=:{cs_symbol_table,cs_error}) + = checkFunctions mod_index cGlobalScope range.ir_from range.ir_to fun_defs e_info heaps cs + (fun_defs, ef_modules, hp_var_heap, hp_expression_heap, cs_symbol_table, cs_error) + = partitionateMacros range mod_index fun_defs ef_modules hp_var_heap hp_expression_heap cs_symbol_table cs_error + = (fun_defs, { e_info & ef_modules = ef_modules }, {heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap}, + { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }) + +checkInstanceBodies :: !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo,!*Heaps, !*CheckState); +checkInstanceBodies {ir_from, ir_to} fun_defs e_info heaps cs + = checkFunctions cIclModIndex cGlobalScope ir_from ir_to fun_defs e_info heaps cs + +instance < FunDef +where + (<) fd1 fd2 = fd1.fun_symb.id_name < fd2.fun_symb.id_name + + +//createCommonDefinitions :: !(CollectedDefinitions ClassInstance) -> *CommonDefs +createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} var_heap + # (cons_defs, var_heap) = mapSt new_constructor def_constructors var_heap + (sel_defs, var_heap) = mapSt new_selector def_selectors var_heap + = ({ com_type_defs = { type \\ type <- def_types } + , com_cons_defs = { cons \\ cons <- cons_defs } + , com_selector_defs = { sel \\ sel <- sel_defs } +// , com_macro_defs = { macro \\ macro <- def_macros } + , com_class_defs = { class_def \\ class_def <- def_classes } + , com_member_defs = { member \\ member <- def_members } + , com_instance_defs = { next_instance \\ next_instance <- def_instances } + }, var_heap) + where + new_constructor cons var_heap + # (new_type_ptr, var_heap) = newPtr VI_Empty var_heap + = (ParsedConstructorToConsDef cons new_type_ptr, var_heap) + + new_selector sel var_heap + # (new_type_ptr, var_heap) = newPtr VI_Empty var_heap + = (ParsedSelectorToSelectorDef sel new_type_ptr, var_heap) + + +IsMainDclMod is_dcl module_index :== is_dcl && module_index == cIclModIndex + +/* MW was +checkCommonDefinitions :: !Bool !Index !*CommonDefs !*{# DclModule} !*TypeHeaps !*VarHeap !*CheckState + -> (!*CommonDefs, !*{# DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) +checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs + # (com_type_defs, com_cons_defs, com_selector_defs, modules, type_heaps, cs) + = checkTypeDefs (IsMainDclMod is_dcl module_index) common.com_type_defs module_index common.com_cons_defs common.com_selector_defs modules type_heaps cs + (com_class_defs, com_member_defs, com_type_defs, modules, type_heaps, cs) + = checkTypeClasses 0 module_index common.com_class_defs common.com_member_defs com_type_defs modules type_heaps cs + (com_member_defs, com_type_defs, com_class_defs, modules, type_heaps, var_heap, cs) + = checkMemberTypes module_index com_member_defs com_type_defs com_class_defs modules type_heaps var_heap cs + (com_instance_defs, com_type_defs, com_class_defs, com_member_defs, modules, type_heaps, cs) + = checkInstanceDefs module_index common.com_instance_defs com_type_defs com_class_defs com_member_defs modules type_heaps cs + (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs) + = createClassDictionaries module_index com_class_defs modules (size com_type_defs) (size com_selector_defs) + (size com_cons_defs) type_heaps.th_vars var_heap cs + com_type_defs = { type_def \\ type_def <- [ type_def \\ type_def <-: com_type_defs ] ++ new_type_defs } + com_selector_defs = { sel_def \\ sel_def <- [ sel_def \\ sel_def <-: com_selector_defs ] ++ new_selector_defs } + com_cons_defs = { cons_def \\ cons_def <- [ cons_def \\ cons_def <-: com_cons_defs ] ++ new_cons_defs } + = ({common & com_type_defs = com_type_defs, com_cons_defs = com_cons_defs, com_selector_defs = com_selector_defs, com_class_defs = com_class_defs, + com_member_defs = com_member_defs, com_instance_defs = com_instance_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs) +*/ + +checkCommonDefinitions :: !Bool !Index !{#Int} !*CommonDefs !*{# DclModule} !*TypeHeaps !*VarHeap !*CheckState + -> (!*CommonDefs, !*{# DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) +checkCommonDefinitions is_dcl module_index upper_limits common modules type_heaps var_heap cs + # (com_type_defs, com_cons_defs, com_selector_defs, modules, type_heaps, cs) + = checkTypeDefs (IsMainDclMod is_dcl module_index) common.com_type_defs module_index upper_limits.[cTypeDefs] + common.com_cons_defs common.com_selector_defs modules type_heaps cs + (com_class_defs, com_member_defs, com_type_defs, modules, type_heaps, cs) + = checkTypeClasses 0 module_index upper_limits.[cClassDefs] common.com_class_defs common.com_member_defs com_type_defs modules type_heaps cs + (com_member_defs, com_type_defs, com_class_defs, modules, type_heaps, var_heap, cs) + = checkMemberTypes module_index upper_limits.[cMemberDefs] com_member_defs com_type_defs com_class_defs modules type_heaps var_heap cs + (com_instance_defs, com_type_defs, com_class_defs, com_member_defs, modules, type_heaps, cs) + = checkInstanceDefs module_index common.com_instance_defs com_type_defs com_class_defs com_member_defs modules type_heaps cs + (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs) + = createClassDictionaries module_index com_class_defs modules (size com_type_defs) (size com_selector_defs) + (size com_cons_defs) upper_limits.[cClassDefs] type_heaps.th_vars var_heap cs + com_type_defs = { type_def \\ type_def <- [ type_def \\ type_def <-: com_type_defs ] ++ new_type_defs } + com_selector_defs = { sel_def \\ sel_def <- [ sel_def \\ sel_def <-: com_selector_defs ] ++ new_selector_defs } + com_cons_defs = { cons_def \\ cons_def <- [ cons_def \\ cons_def <-: com_cons_defs ] ++ new_cons_defs } + = ({common & com_type_defs = com_type_defs, com_cons_defs = com_cons_defs, com_selector_defs = com_selector_defs, com_class_defs = com_class_defs, + com_member_defs = com_member_defs, com_instance_defs = com_instance_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs) + +strictMapAppendi :: !(Index -> a -> b) !Index ![a] ![b] -> [b] +strictMapAppendi f i [] t = t +strictMapAppendi f i [x : xs] t + #! t = strictMapAppendi f (inc i) xs t + el = f i x + = [el : t] + +collectCommonfinitions :: !(CollectedDefinitions ClassInstance a) ![Declaration] -> [Declaration] +collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} defs + # defs = strictMapAppendi (\dcl_index {td_name} -> { dcl_ident = td_name, dcl_kind = STE_Type, dcl_index = dcl_index }) 0 def_types defs + defs = strictMapAppendi (\dcl_index {pc_cons_name} -> { dcl_ident = pc_cons_name, dcl_kind = STE_Constructor, dcl_index = dcl_index }) 0 def_constructors defs + defs = strictMapAppendi (\dcl_index {ps_selector_name,ps_field_name} -> { dcl_ident = ps_field_name, dcl_kind = STE_Field ps_selector_name, dcl_index = dcl_index }) 0 def_selectors defs + defs = strictMapAppendi (\dcl_index {class_name} -> { dcl_ident = class_name, dcl_kind = STE_Class, dcl_index = dcl_index }) 0 def_classes defs + defs = strictMapAppendi (\dcl_index {me_symb} -> { dcl_ident = me_symb, dcl_kind = STE_Member, dcl_index = dcl_index }) 0 def_members defs + defs = strictMapAppendi (\dcl_index {ins_ident} -> { dcl_ident = ins_ident, dcl_kind = STE_Instance, dcl_index = dcl_index }) 0 def_instances defs + = defs + +collectMacros {ir_from,ir_to} defs macro_defs + = collectGlobalFunctions ir_from ir_to defs macro_defs + +collectFunctionTypes fun_types defs + = strictMapAppendi (\dcl_index {ft_symb} -> { dcl_ident = ft_symb, dcl_kind = STE_DclFunction, dcl_index = dcl_index }) 0 fun_types defs + +collectGlobalFunctions from_index to_index defs fun_defs + | from_index == to_index + = (defs, fun_defs) + #! fun_def = fun_defs.[from_index] + (defs, fun_defs) = collectGlobalFunctions (inc from_index) to_index defs fun_defs + = ([{ dcl_ident = fun_def.fun_symb, dcl_kind = STE_FunctionOrMacro [], dcl_index = from_index } : defs], fun_defs) + +combineDclAndIclModule MK_Main modules icl_defs cs +// MW was = (modules, cs) + = (modules, createArray cConversionTableSize [], cs) +combineDclAndIclModule _ modules icl_defs cs +/* MW was + #! dcl_mod = modules.[cIclModIndex] + # {dcl_declared={dcls_local},dcl_macros} = dcl_mod + cs = addGlobalDefinitionsToSymbolTable icl_defs cs + conversion_table = { createArray size NoIndex \\ size <-: count_defs (createArray cConversionTableSize 0) dcls_local } + (conversion_table, cs) = build_conversion_table conversion_table dcls_local dcl_macros.ir_from cs + cs_symbol_table = removeDeclarationsFromSymbolTable icl_defs cGlobalScope cs.cs_symbol_table + = ( { modules & [cIclModIndex] = { dcl_mod & dcl_conversions = Yes conversion_table }}, { cs & cs_symbol_table = cs_symbol_table }) +*/ + #! dcl_mod = modules.[cIclModIndex] + # {dcl_declared={dcls_local},dcl_macros} = dcl_mod + cs = addGlobalDefinitionsToSymbolTable icl_defs cs + sizes = count_defs (createArray cConversionTableSize 0) dcls_local + conversion_table = { createArray size NoIndex \\ size <-: sizes } + defs_only_in_dcl = { (size, []) \\ size <-: sizes } + (conversion_table, defs_only_in_dcl_l, cs) + = build_conversion_table conversion_table dcls_local dcl_macros.ir_from defs_only_in_dcl cs + # cs_symbol_table = removeDeclarationsFromSymbolTable icl_defs cGlobalScope cs.cs_symbol_table + = ( { modules & [cIclModIndex] = { dcl_mod & dcl_conversions = Yes conversion_table }} + , defs_only_in_dcl_l + , { cs & cs_symbol_table = cs_symbol_table } + ) +where +// MW was build_conversion_table conversion_table [{dcl_ident=ident=:{id_info},dcl_kind,dcl_index} : local_defs] first_macro_index cs=:{cs_symbol_table, cs_error} + build_conversion_table conversion_table [decl=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index} : local_defs] + first_macro_index defs_only_in_dcl cs=:{cs_symbol_table, cs_error} + #! entry = sreadPtr id_info cs_symbol_table + # {ste_kind,ste_index,ste_def_level} = entry +/* MW was + | ste_def_level == cGlobalScope && ste_kind == dcl_kind + # def_index = toInt dcl_kind + dcl_index = if (def_index == cMacroDefs) (dcl_index - first_macro_index) dcl_index + # conversion_table = { conversion_table & [def_index].[dcl_index] = ste_index } + = build_conversion_table conversion_table local_defs first_macro_index cs + = build_conversion_table conversion_table local_defs first_macro_index { cs & cs_error = checkError ident "inconsistently defined" cs_error } + = build_conversion_table conversion_table local_defs first_macro_index { cs & cs_error = checkError ident "inconsistently defined" cs_error } + build_conversion_table conversion_table [] first_macro_index cs + = (conversion_table, cs) +*/ + def_index = toInt dcl_kind + dcl_index = if (def_index == cMacroDefs) (dcl_index - first_macro_index) dcl_index + | ste_kind == STE_Empty && can_be_only_in_dcl dcl_kind + # ((top,defs), defs_only_in_dcl) = defs_only_in_dcl![def_index] + defs_only_in_dcl = { defs_only_in_dcl & [def_index] = (inc top, [decl:defs])} + conversion_table = { conversion_table & [def_index].[dcl_index] = top } + = build_conversion_table conversion_table local_defs first_macro_index defs_only_in_dcl cs + | ste_def_level == cGlobalScope && ste_kind == dcl_kind + # conversion_table = { conversion_table & [def_index].[dcl_index] = ste_index } + = build_conversion_table conversion_table local_defs first_macro_index defs_only_in_dcl cs + = build_conversion_table conversion_table local_defs first_macro_index defs_only_in_dcl + { cs & cs_error = checkError ident "inconsistently defined" cs_error } + build_conversion_table conversion_table [] first_macro_index defs_only_in_dcl cs + = (conversion_table, {reverse decls \\ (_,decls) <-: defs_only_in_dcl}, cs) + +// MW.. + can_be_only_in_dcl STE_Type = True + can_be_only_in_dcl STE_Constructor = True + can_be_only_in_dcl (STE_Field _) = True + can_be_only_in_dcl STE_Class = True + can_be_only_in_dcl STE_Member = True + can_be_only_in_dcl (STE_FunctionOrMacro _) = True + can_be_only_in_dcl STE_DclFunction = False + can_be_only_in_dcl _ = False +// .. MW + + count_defs :: !*{# Int} ![Declaration] -> *{# Int} + count_defs def_counts [] + = def_counts + count_defs def_counts [{dcl_kind} : local_defs] + # def_index = toInt dcl_kind + #! count = def_counts.[def_index] + = count_defs { def_counts & [def_index] = inc count } local_defs + +/* MW moved +cIsNotADclModule :== False +cIsADclModule :== True +*/ + +(<=<) infixl +(<=<) state fun :== fun state + + +checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File + -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) +checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} nr_of_global_funs fun_defs dcl_mod pre_def_mod scanned_modules predef_symbols symbol_table err_file + # error = {ea_file = err_file, ea_loc = [], ea_ok = True } + + first_inst_index = length fun_defs + + (inst_fun_defs, def_instances) = convert_class_instances cdefs.def_instances first_inst_index + icl_functions = { next_fun \\ next_fun <- fun_defs ++ inst_fun_defs } + cdefs = { cdefs & def_instances = def_instances } + #! nr_of_functions = size icl_functions + + # local_defs = collectCommonfinitions cdefs [] + (local_defs, icl_functions) = collectGlobalFunctions 0 nr_of_global_funs local_defs icl_functions + (local_defs, icl_functions) = collectMacros cdefs.def_macros local_defs icl_functions + + (scanned_modules, icl_functions, cs) + = add_modules_to_symbol_table [ dcl_mod, pre_def_mod : scanned_modules ] 0 icl_functions + { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error } + + (init_dcl_modules, hp_var_heap) = mapSt initialDclModule scanned_modules newHeap +// MW was (dcl_modules, cs) + (dcl_modules, defs_only_in_main_dcl, cs) + = combineDclAndIclModule mod_type { dcl_module \\ dcl_module <- init_dcl_modules } local_defs cs + + heaps = { hp_var_heap = hp_var_heap, hp_expression_heap = newHeap, hp_type_heaps = { th_vars = newHeap, th_attrs = newHeap }} + + (dcl_modules, icl_functions, heaps, cs) + = check_predefined_module pre_def_mod.mod_name dcl_modules icl_functions heaps cs + + iinfo = { ii_modules = dcl_modules, ii_funs_and_macros = icl_functions, ii_next_num = 0, ii_deps = [] } + + (iinfo, heaps, cs) = check_dcl_module iinfo heaps cs + + (_, {ii_modules,ii_funs_and_macros = icl_functions}, heaps, cs) = checkImports mod_imports iinfo heaps cs + + (nr_of_modules, (f_consequences, ii_modules, icl_functions, hp_expression_heap, cs)) + = check_completeness_of_all_dcl_modules ii_modules icl_functions heaps.hp_expression_heap cs + + all_defs_only_in_main_dcl = defs_only_in_main_dcl.[cTypeDefs]++defs_only_in_main_dcl.[cConstructorDefs] + ++defs_only_in_main_dcl.[cSelectorDefs]++defs_only_in_main_dcl.[cClassDefs] + ++defs_only_in_main_dcl.[cMemberDefs]++defs_only_in_main_dcl.[cMacroDefs] + + (dcls_explicit, dcl_modules, cs) = addImportsToSymbolTable mod_imports [] ii_modules cs + cs = addGlobalDefinitionsToSymbolTable (local_defs++all_defs_only_in_main_dcl) cs + + (_, dcl_modules, icl_functions, hp_expression_heap, cs) + = check_completeness_of_module nr_of_modules dcls_explicit (mod_name.id_name+++".icl") + (f_consequences, dcl_modules, icl_functions, hp_expression_heap, cs) + + heaps = { heaps & hp_expression_heap=hp_expression_heap } + + (icl_common, hp_var_heap) = createCommonDefinitions cdefs heaps.hp_var_heap + + (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex] + + (upper_limits, icl_common) = get_upper_limits icl_common + + icl_common = add_defs_only_in_main_dcl defs_only_in_main_dcl main_dcl_module icl_common + + (icl_common, dcl_modules, hp_type_heaps, hp_var_heap, cs) + = checkCommonDefinitions cIsNotADclModule cIclModIndex upper_limits icl_common dcl_modules heaps.hp_type_heaps hp_var_heap cs + + (instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs) + = checkInstances cIclModIndex 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, + ef_cons_defs = icl_common.com_cons_defs, ef_member_defs = icl_common.com_member_defs, ef_modules = dcl_modules } + + (icl_functions, e_info, heaps, cs) = checkMacros cIclModIndex cdefs.def_macros icl_functions e_info heaps cs + (icl_functions, e_info, heaps, cs) = checkFunctions cIclModIndex cGlobalScope 0 nr_of_global_funs icl_functions e_info heaps cs + + (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error}) + = checkInstanceBodies {ir_from = first_inst_index, ir_to = nr_of_functions} icl_functions e_info heaps cs + (icl_imported, dcl_modules, cs_symbol_table) = retrieveImportsFromSymbolTable mod_imports [] e_info.ef_modules cs_symbol_table + | cs_error.ea_ok + # {hp_var_heap,hp_type_heaps,hp_expression_heap} = heaps + (spec_functions, dcl_modules, class_instances, icl_functions, new_nr_of_functions, dcl_icl_conversions, var_heap, th_vars, expr_heap) + = collect_specialized_functions_in_dcl_module dcl_modules icl_common.com_instance_defs icl_functions nr_of_functions + hp_var_heap hp_type_heaps.th_vars hp_expression_heap + icl_global_function_range = {ir_from = 0, ir_to = nr_of_global_funs} + icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions} + icl_specials = {ir_from = nr_of_functions, ir_to = new_nr_of_functions} + icl_functions = copy_instance_types instance_types { icl_fun \\ icl_fun <- [ icl_fun \\ icl_fun <-: icl_functions ] ++ spec_functions } + + (dcl_modules, class_instances, icl_functions, cs_predef_symbols) + = adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances icl_functions cs_predef_symbols + + (groups, icl_functions, dcl_modules, var_heap, expr_heap, cs_symbol_table, cs_error) + = partitionateAndLiftFunctions [icl_global_function_range, icl_instances] cIclModIndex icl_functions + dcl_modules var_heap expr_heap cs_symbol_table cs_error + 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_instance_defs = class_instances } + icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, icl_instances = icl_instances, icl_specials = icl_specials, +// MW was icl_declared = {dcls_local = local_defs, dcls_import = icl_imported} } +// RWS ... + icl_imported_objects = mod_imported_objects, +// ... RWS + icl_declared = {dcls_local = local_defs, dcls_import = icl_imported, dcls_explicit=dcls_explicit} } + = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, + { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = { hp_type_heaps & th_vars = th_vars }}, + cs_predef_symbols, cs_symbol_table, cs_error.ea_file) + # 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 } + icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, + icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions}, + icl_specials = {ir_from = nr_of_functions, ir_to = nr_of_functions}, +// MW was icl_declared = {dcls_local = local_defs, dcls_import = icl_imported} } +// RWS ... + icl_imported_objects = mod_imported_objects, +// ... RWS + icl_declared = {dcls_local = local_defs, dcls_import = icl_imported, dcls_explicit=dcls_explicit} } + = (False, icl_mod, dcl_modules, {}, No, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file) + where + convert_class_instances [pi=:{pi_members} : pins] next_fun_index + # ins_members = sort pi_members + (member_symbols, next_fun_index) = determine_indexes_of_members ins_members next_fun_index + (next_fun_defs, cins) = convert_class_instances pins next_fun_index + = (ins_members ++ next_fun_defs, [ParsedInstanceToClassInstance pi { member \\ member <- member_symbols} : cins]) + convert_class_instances [] next_fun_index + = ([], []) + + determine_indexes_of_members [{fun_symb,fun_arity}:members] next_fun_index + #! (member_symbols, last_fun_index) = determine_indexes_of_members members (inc next_fun_index) + = ([{ds_ident = fun_symb, ds_index = next_fun_index, ds_arity = fun_arity} : member_symbols], last_fun_index) + determine_indexes_of_members [] next_fun_index + = ([], next_fun_index) + + add_modules_to_symbol_table [] mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table} + # (cs_predef_symbols, cs_symbol_table) = (cs_predef_symbols, cs_symbol_table) + <=< adjust_predefined_module_symbol PD_StdArray + <=< adjust_predefined_module_symbol PD_StdEnum + <=< adjust_predefined_module_symbol PD_StdBool + <=< adjust_predefined_module_symbol PD_StdDynamics + <=< adjust_predefined_module_symbol PD_PredefinedModule + = ([], macro_and_fun_defs, { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table}) + where + adjust_predefined_module_symbol :: !Index !(!*PredefinedSymbols, !*SymbolTable) -> (!*PredefinedSymbols, !*SymbolTable) + adjust_predefined_module_symbol predef_index (pre_def_symbols, symbol_table) + # (mod_symb, pre_def_symbols) = pre_def_symbols![predef_index] + #! mod_entry = sreadPtr mod_symb.pds_ident.id_info symbol_table + = case mod_entry.ste_kind of + STE_Module _ + -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cIclModIndex, pds_def = mod_entry.ste_index }}, symbol_table) + _ + -> (pre_def_symbols, symbol_table) + + add_modules_to_symbol_table [mod=:{mod_defs} : mods] mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table, cs_error} + # def_instances = convert_class_instances mod_defs.def_instances + mod_defs = { mod_defs & def_instances = def_instances } + defs = collectFunctionTypes mod_defs.def_funtypes (collectCommonfinitions mod_defs []) + (defs, macro_and_fun_defs) = collectMacros mod_defs.def_macros defs macro_and_fun_defs + mod = { mod & mod_defs = mod_defs } + (cs_symbol_table, cs_error) = addDefToSymbolTable cGlobalScope mod_index mod.mod_name (STE_Module mod) cs_symbol_table cs_error + (mods, macro_and_fun_defs, cs) + = add_modules_to_symbol_table mods (inc mod_index) macro_and_fun_defs { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error } + = ([(mod, defs) : mods], macro_and_fun_defs, cs) + where + convert_class_instances :: ![ParsedInstance a] -> [ClassInstance] + convert_class_instances [pi : pins] + = [ParsedInstanceToClassInstance pi {} : convert_class_instances pins] + convert_class_instances [] + = [] + + check_predefined_module {id_info} modules macro_and_fun_defs heaps cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # cs = { cs & cs_symbol_table = cs_symbol_table <:= (id_info, { entry & ste_kind = STE_ClosedModule })} + {ste_kind = STE_Module mod, ste_index} = entry + (modules, macro_and_fun_defs, heaps, cs) + = checkDclModule mod ste_index modules macro_and_fun_defs heaps cs + ({dcl_declared={dcls_import,dcls_local}}, modules) = modules![ste_index] + = (modules, macro_and_fun_defs, heaps, addDeclaredSymbolsToSymbolTable cIsADclModule ste_index dcls_local dcls_import cs) + + check_dcl_module iinfo=:{ii_modules} heaps cs=:{cs_symbol_table} + #! dcl_mod = ii_modules.[cIclModIndex] + # dcl_info = dcl_mod.dcl_name.id_info + #! entry = sreadPtr dcl_info cs_symbol_table + # (_, iinfo, heaps, cs) = checkImport dcl_info entry iinfo heaps cs + = (iinfo, heaps, cs) + + collect_specialized_functions_in_dcl_module :: !w:{# DclModule} !v:{# ClassInstance} !u:{# FunDef} !Index !*VarHeap !*TypeVarHeap !*ExpressionHeap + -> (![FunDef], !w:{# DclModule}, !v:{# ClassInstance}, !u:{# FunDef}, !Index, !(Optional {# Index}), !*VarHeap, !*TypeVarHeap, !*ExpressionHeap) + collect_specialized_functions_in_dcl_module modules icl_instances icl_functions first_free_index var_heap type_var_heap expr_heap + #! dcl_mod = modules.[cIclModIndex] + # {dcl_specials,dcl_functions,dcl_common,dcl_class_specials,dcl_conversions} = dcl_mod + = case dcl_conversions of + Yes conversion_table + # (new_conversion_table, icl_instances) + = build_conversion_table_for_instances_of_dcl_mod dcl_specials first_free_index + dcl_functions dcl_common.com_instance_defs conversion_table icl_instances + (spec_fun_defs, (icl_functions, last_index, (var_heap, type_var_heap, expr_heap))) + = collect_specialized_functions dcl_specials.ir_from dcl_specials.ir_to dcl_functions new_conversion_table + (icl_functions, first_free_index, (var_heap, type_var_heap, expr_heap)) + -> (spec_fun_defs, modules, icl_instances, icl_functions, last_index, Yes new_conversion_table, var_heap, type_var_heap, expr_heap) + No + -> ([], modules, icl_instances, icl_functions, first_free_index, No, var_heap, type_var_heap, expr_heap) + where + build_conversion_table_for_instances_of_dcl_mod {ir_from,ir_to} first_free_index dcl_functions dcl_instances conversion_table icl_instances + #! nr_of_dcl_functions = size dcl_functions + # dcl_instances_table = conversion_table.[toInt STE_Instance] + dcl_function_table = conversion_table.[toInt STE_DclFunction] + new_table = { createArray nr_of_dcl_functions NoIndex & [i] = icl_index \\ icl_index <-: dcl_function_table & i <- [0..] } + index_diff = first_free_index - ir_from + new_table = { new_table & [i] = i + index_diff \\ i <- [ir_from .. ir_to - 1] } + = build_conversion_table_for_instances 0 dcl_instances dcl_instances_table icl_instances new_table + + build_conversion_table_for_instances dcl_class_inst_index dcl_instances class_instances_table icl_instances new_table + | dcl_class_inst_index < size class_instances_table + # icl_index = class_instances_table.[dcl_class_inst_index] + #! icl_instance = icl_instances.[icl_index] + dcl_instance = dcl_instances.[dcl_class_inst_index] + # new_table = build_conversion_table_for_instances_of_members 0 dcl_instance.ins_members icl_instance.ins_members new_table + = build_conversion_table_for_instances (inc dcl_class_inst_index) dcl_instances class_instances_table icl_instances new_table + = (new_table, icl_instances) + + build_conversion_table_for_instances_of_members mem_index dcl_members icl_members new_table + | mem_index < size dcl_members + # dcl_member = dcl_members.[mem_index] + icl_member = icl_members.[mem_index] + = build_conversion_table_for_instances_of_members (inc mem_index) dcl_members icl_members + { new_table & [dcl_member.ds_index] = icl_member.ds_index } + = new_table + + collect_specialized_functions spec_index last_index dcl_fun_types conversion_table (icl_functions, next_fun_index, heaps) + | spec_index < last_index + # {ft_type,ft_specials = SP_FunIndex dcl_index} = dcl_fun_types.[spec_index] + icl_index = conversion_table.[dcl_index] + #! icl_fun = icl_functions.[icl_index] + (new_fun_def, heaps) = build_function next_fun_index icl_fun ft_type heaps + (new_fun_defs, funs_index_heaps) + = collect_specialized_functions (inc spec_index) last_index dcl_fun_types conversion_table (icl_functions, inc next_fun_index, heaps) + = ([new_fun_def : new_fun_defs], funs_index_heaps) + = ([], (icl_functions, next_fun_index, heaps)) + + build_function new_fun_index fun_def=:{fun_symb, fun_arity, fun_index, fun_body = CheckedBody {cb_args}, fun_info} fun_type + (var_heap, type_var_heap, expr_heap) + # (tb_args, var_heap) = mapSt new_free_var cb_args var_heap + (app_args, expr_heap) = mapSt new_bound_var tb_args expr_heap + (app_info_ptr, expr_heap) = newPtr EI_Empty expr_heap + tb_rhs = App { app_symb = { symb_name = fun_symb, symb_arity = fun_arity, + symb_kind = SK_Function { glob_module = cIclModIndex, glob_object = fun_index }}, + app_args = app_args, + app_info_ptr = app_info_ptr } + = ({ fun_def & fun_index = new_fun_index, fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_type = Yes fun_type, + fun_info = { EmptyFunInfo & fi_calls = [ { fc_index = fun_index, fc_level = cGlobalScope }] }}, + (var_heap, type_var_heap, expr_heap)) + + new_bound_var :: !FreeVar !*ExpressionHeap -> (!Expression, !*ExpressionHeap) + new_bound_var {fv_name,fv_info_ptr} expr_heap + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, expr_heap) + + new_free_var :: !FreeVar *VarHeap -> (!FreeVar, !*VarHeap) + new_free_var fv var_heap + # (fv_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ({ fv & fv_info_ptr = fv_info_ptr, fv_def_level = NotALevel, fv_count = 0}, var_heap) + + copy_instance_types :: [(Index,SymbolType)] !*{# FunDef} -> !*{# FunDef} + copy_instance_types types fun_defs + = foldl copy_instance_type fun_defs types + copy_instance_type fun_defs (index, symbol_type) + #! inst_def = fun_defs.[index] + = { fun_defs & [index] = { inst_def & fun_type = Yes symbol_type }} + + adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances fun_defs predef_symbols + # ({pds_def}, predef_symbols) = predef_symbols![PD_StdArray] + | pds_def == cIclModIndex + #! nr_of_instances = size class_instances + # ({dcl_common, dcl_conversions = Yes conversion_table}, dcl_modules) = dcl_modules![cIclModIndex] + ({pds_def}, predef_symbols) = predef_symbols![PD_ArrayClass] + (offset_table, _, predef_symbols) = arrayFunOffsetToPD_IndexTable dcl_common.com_member_defs predef_symbols + array_class_index = conversion_table.[cClassDefs].[pds_def] + (class_instances, fun_defs, predef_symbols) + = iFoldSt (adjust_instance_types_of_array_functions array_class_index offset_table) 0 nr_of_instances + (class_instances, fun_defs, predef_symbols) + = (dcl_modules, class_instances, fun_defs, predef_symbols) + = (dcl_modules, class_instances, fun_defs, predef_symbols) + where + adjust_instance_types_of_array_functions array_class_index offset_table inst_index (class_instances, fun_defs, predef_symbols) + # ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index] + | glob_module == cIclModIndex && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols + # fun_defs = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_defs + = (class_instances, fun_defs, predef_symbols) + = (class_instances, fun_defs, predef_symbols) + + make_instance_strict instances offset_table ins_offset instance_defs + # {ds_index} = instances.[ins_offset] + (inst_def, instance_defs) = instance_defs![ds_index] + (Yes symbol_type) = inst_def.fun_type + = { instance_defs & [ds_index] = { inst_def & fun_type = Yes (makeElemTypeOfArrayFunctionStrict symbol_type ins_offset offset_table) } } + +// MW.. +get_upper_limits icl_common=:{com_type_defs, com_cons_defs, com_selector_defs, com_class_defs + ,com_member_defs, com_instance_defs} + # (size_type_defs, com_type_defs) = usize com_type_defs + (size_cons_defs, com_cons_defs) = usize com_cons_defs + (size_selector_defs, com_selector_defs) = usize com_selector_defs + (size_class_defs, com_class_defs) = usize com_class_defs + (size_member_defs, com_member_defs) = usize com_member_defs + (size_instance_defs, com_instance_defs) = usize com_instance_defs + upper_limits = { createArray cConversionTableSize 0 + & [cTypeDefs]=size_type_defs + , [cConstructorDefs]=size_cons_defs + , [cSelectorDefs]=size_selector_defs + , [cClassDefs]=size_class_defs + , [cMemberDefs]=size_member_defs + , [cInstanceDefs]=size_instance_defs + } + = (upper_limits, { com_type_defs =com_type_defs + , com_cons_defs =com_cons_defs + , com_selector_defs =com_selector_defs + , com_class_defs =com_class_defs + , com_member_defs =com_member_defs + , com_instance_defs =com_instance_defs + }) +// ..MW + +// MW.. +add_defs_only_in_main_dcl defs_only_in_main_dcl {dcl_common} icl_common + = { icl_common + & com_type_defs = append_array_and_list icl_common.com_type_defs + [ dcl_common.com_type_defs.[dcl_index] + \\ {dcl_index} <- defs_only_in_main_dcl.[cTypeDefs]] + , com_cons_defs = append_array_and_list icl_common.com_cons_defs + [ dcl_common.com_cons_defs.[dcl_index] + \\ {dcl_index} <- defs_only_in_main_dcl.[cConstructorDefs]] + , com_selector_defs = append_array_and_list icl_common.com_selector_defs + [ dcl_common.com_selector_defs.[dcl_index] + \\ {dcl_index} <- defs_only_in_main_dcl.[cSelectorDefs]] + , com_class_defs = append_array_and_list icl_common.com_class_defs + [ dcl_common.com_class_defs.[dcl_index] + \\ {dcl_index} <- defs_only_in_main_dcl.[cClassDefs]] + , com_member_defs = append_array_and_list icl_common.com_member_defs + [ dcl_common.com_member_defs.[dcl_index] + \\ {dcl_index} <- defs_only_in_main_dcl.[cMemberDefs]] + } + where + append_array_and_list a [] + = a + append_array_and_list a l + = { el \\ el <- [el \\ el<-:a]++l} +// ..MW + +arrayFunOffsetToPD_IndexTable member_defs predef_symbols + # nr_of_array_functions = size member_defs + = iFoldSt offset_to_PD_index PD_CreateArrayFun (PD_CreateArrayFun + nr_of_array_functions) + (createArray nr_of_array_functions NoIndex, member_defs, predef_symbols) +where + offset_to_PD_index pd_index (table, member_defs, predef_symbols) + # ({pds_def}, predef_symbols) = predef_symbols![pd_index] + #! {me_offset} = member_defs.[pds_def] + = ({ table & [me_offset] = pd_index }, member_defs, predef_symbols) + +elemTypeIsStrict [TA {type_index={glob_object,glob_module}} _ : _] predef_symbols + = glob_module == predef_symbols.[PD_PredefinedModule].pds_def && + (glob_object == predef_symbols.[PD_StrictArrayType].pds_def || glob_object == predef_symbols.[PD_UnboxedArrayType].pds_def) + +makeElemTypeOfArrayFunctionStrict st=:{st_args,st_result} me_offset offset_table + # array_fun_kind = offset_table.[me_offset] + | array_fun_kind == PD_UnqArraySelectFun + # (TA tuple [elem : res_array]) = st_result.at_type + = { st & st_result = { st_result & at_type = TA tuple [{ elem & at_annotation = AN_Strict } : res_array]}} + | array_fun_kind == PD_ArrayUpdateFun + # [array, index, elem: _] = st_args + = { st & st_args = [array, index, { elem & at_annotation = AN_Strict }] } + | array_fun_kind == PD_CreateArrayFun + # [array, elem: _] = st_args + = { st & st_args = [array, { elem & at_annotation = AN_Strict }] } + | array_fun_kind == PD_ArrayReplaceFun + # [arg_array, index, elem: _] = st_args + (TA tuple [elem : res_array]) = st_result.at_type + = { st & st_args = [arg_array, index, { elem & at_annotation = AN_Strict }], + st_result = { st_result & at_type = TA tuple [{ elem & at_annotation = AN_Strict } : res_array]}} + = st + + +:: ImportInfo = + { ii_modules :: !.{# DclModule} + , ii_funs_and_macros :: !.{# FunDef} + , ii_next_num :: !Int + , ii_deps :: ![SymbolPtr] + } + +checkImports :: ![ParsedImport] !*ImportInfo !*Heaps !*CheckState -> (!Int, !*ImportInfo, !*Heaps, !*CheckState) +checkImports [] iinfo=:{ii_modules,ii_deps} heaps cs + #! mod_num = size ii_modules + = (mod_num, iinfo, heaps, cs) +checkImports [ {import_module = {id_info}}: mods ] iinfo heaps cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # (min_mod_num1, iinfo, heaps, cs) = checkImport id_info entry iinfo heaps cs + (min_mod_num2, iinfo, heaps, cs) = checkImports mods iinfo heaps cs + = (min min_mod_num1 min_mod_num2, iinfo, heaps, cs) + + +checkImport :: SymbolPtr SymbolTableEntry *ImportInfo *Heaps *CheckState -> *(Int,*ImportInfo,*Heaps,*CheckState); // MW++ +checkImport module_id_info entry=:{ste_kind = STE_OpenModule mod_num _} iinfo heaps cs + = (mod_num, iinfo, heaps, cs) +checkImport module_id_info entry=:{ste_kind = STE_ClosedModule} iinfo=:{ii_modules} heaps cs + #! mod_num = size ii_modules + = (mod_num, iinfo, heaps, cs) +checkImport module_id_info entry=:{ste_kind = STE_Module mod, ste_index} iinfo=:{ii_next_num,ii_deps} heaps cs=:{cs_symbol_table} + # entry = { entry & ste_kind = STE_OpenModule ii_next_num mod} + cs = { cs & cs_symbol_table = cs_symbol_table <:= (module_id_info,entry) } + iinfo = { iinfo & ii_next_num = inc ii_next_num, ii_deps = [module_id_info : ii_deps] } + (min_mod_num, iinfo, heaps, cs) = checkImports mod.mod_imports iinfo heaps cs + + | ii_next_num <= min_mod_num + # {ii_deps,ii_modules,ii_funs_and_macros} = iinfo + (ii_deps, ii_modules, ii_funs_and_macros, heaps, cs) + = check_component module_id_info ii_deps ii_modules ii_funs_and_macros heaps cs + #! max_mod_num = size ii_modules + = (max_mod_num, { iinfo & ii_deps = ii_deps, ii_modules = ii_modules, ii_funs_and_macros = ii_funs_and_macros }, heaps, cs) + = (min_mod_num, iinfo, heaps, cs) + where + check_component lowest_mod_info [mod_info : ds] modules macro_and_fun_defs heaps cs=:{cs_symbol_table} + #! entry = sreadPtr mod_info cs_symbol_table + # {ste_kind=STE_OpenModule _ mod,ste_index} = entry + (modules, macro_and_fun_defs, heaps, cs) = checkDclModule mod ste_index modules macro_and_fun_defs heaps cs + cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (mod_info, { entry & ste_kind = STE_ClosedModule })} + | lowest_mod_info == mod_info + = (ds, modules, macro_and_fun_defs, heaps, cs) +// MW was = check_component mod_info ds modules macro_and_fun_defs heaps cs + = check_component lowest_mod_info ds modules macro_and_fun_defs heaps cs + +initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_type},all_defs) var_heap + # (dcl_common, var_heap) = createCommonDefinitions mod_defs var_heap + = ({ dcl_name = mod_name + , dcl_functions = { function \\ function <- mod_defs.def_funtypes } + , dcl_macros = def_macros + , dcl_instances = { ir_from = 0, ir_to = 0 } + , dcl_class_specials = { ir_from = 0, ir_to = 0 } + , dcl_specials = { ir_from = 0, ir_to = 0 } + , dcl_common = dcl_common + , dcl_declared = + { dcls_import = [] + , dcls_local = all_defs + , dcls_explicit = [] // MW++ + } + , dcl_conversions = No + , dcl_is_system = case mod_type of + MK_System -> True + _ -> False + }, var_heap) + +// MW moved retrieveAndRemoveImportsFromSymbolTable + +checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions heaps=:{hp_var_heap, hp_type_heaps} cs + #! dcl_mod = modules.[mod_index] + # dcl_defined = dcl_mod.dcl_declared.dcls_local + + // createCommonDefinitions only converts lists into arrays + + (dcl_common, hp_var_heap) = createCommonDefinitions mod_defs hp_var_heap + dcl_macros = mod_defs.def_macros + (imports, modules, cs) = collect_imported_symbols mod_imports [] modules cs + + // imports :: [(Index,Declarations)] + + # cs = add_imported_symbols_to_symbol_table imports cs +// cs = addImportedSymbolsToSymbolTable imports cs + cs = addGlobalDefinitionsToSymbolTable dcl_defined cs + + nr_of_dcl_functions = size dcl_mod.dcl_functions + (upper_limits, dcl_common) = get_upper_limits dcl_common // MW++ + (dcl_common, modules, hp_type_heaps, hp_var_heap, cs) +// MW was = checkCommonDefinitions cIsADclModule mod_index dcl_common modules hp_type_heaps hp_var_heap cs + = checkCommonDefinitions cIsADclModule mod_index upper_limits dcl_common modules hp_type_heaps hp_var_heap cs + (memb_inst_defs, nr_of_dcl_functions_and_instances, rev_spec_class_inst, dcl_common, modules, hp_type_heaps, hp_var_heap, cs) + = determineTypesOfInstances nr_of_dcl_functions mod_index dcl_common modules hp_type_heaps hp_var_heap cs + (nr_of_dcl_funs_insts_and_specs, rev_function_list, rev_special_defs, com_type_defs, com_class_defs, modules, heaps, cs) + = checkDclFunctions mod_index nr_of_dcl_functions_and_instances mod_defs.def_funtypes + dcl_common.com_type_defs dcl_common.com_class_defs modules { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } cs + + (nr_of_dcl_funs_insts_and_specs, new_class_instances, rev_special_defs, all_spec_types, heaps, cs_error) + = checkSpecialsOfInstances mod_index nr_of_dcl_functions rev_spec_class_inst nr_of_dcl_funs_insts_and_specs [] + rev_special_defs { mem \\ mem <- memb_inst_defs } { [] \\ mem <- memb_inst_defs } heaps cs.cs_error + + dcl_functions = { function \\ function <- revAppend rev_function_list + ( [ { mem_inst & ft_specials = if (isEmpty spec_types) SP_None (SP_ContextTypes spec_types) } \\ + mem_inst <- memb_inst_defs & spec_types <-: all_spec_types ] ++ + reverse rev_special_defs) } + + e_info = { ef_type_defs = com_type_defs, ef_selector_defs = dcl_common.com_selector_defs, ef_class_defs = com_class_defs, + ef_cons_defs = dcl_common.com_cons_defs, ef_member_defs = dcl_common.com_member_defs, ef_modules = modules } + + (icl_functions, e_info, heaps, cs) + = checkMacros mod_index dcl_macros icl_functions e_info heaps { cs & cs_error = cs_error } + + com_instance_defs = dcl_common.com_instance_defs + com_instance_defs = { inst_def \\ inst_def <- [ inst_def \\ inst_def <-: com_instance_defs ] ++ new_class_instances } + + (ef_member_defs, com_instance_defs, dcl_functions, cs) + = adjust_predefined_symbols mod_index e_info.ef_member_defs com_instance_defs dcl_functions cs + + first_special_class_index = size com_instance_defs + last_special_class_index = first_special_class_index + length new_class_instances + + dcl_common = { dcl_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_instance_defs = com_instance_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = ef_member_defs } + + (dcl_imported, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable imports [] cs.cs_symbol_table + cs_symbol_table = removeDeclarationsFromSymbolTable dcl_defined cModuleScope cs_symbol_table + + dcls_explicit = flatten [dcls_explicit \\ (_,{dcls_explicit})<-imports] //MW++ + +/* MW was + dcl_mod = { dcl_mod & dcl_declared = { dcl_mod.dcl_declared & dcls_import = dcl_imported }, dcl_common = dcl_common, dcl_functions = dcl_functions, + dcl_instances = { ir_from = nr_of_dcl_functions, ir_to = nr_of_dcl_functions_and_instances }, + dcl_specials = { ir_from = nr_of_dcl_functions_and_instances, ir_to = nr_of_dcl_funs_insts_and_specs }, + dcl_class_specials = { ir_from = first_special_class_index, ir_to = last_special_class_index }} +*/ + dcl_mod = { dcl_mod & dcl_declared = { dcl_mod.dcl_declared & dcls_import = dcl_imported, dcls_explicit = dcls_explicit }, + dcl_common = dcl_common, dcl_functions = dcl_functions, + dcl_instances = { ir_from = nr_of_dcl_functions, ir_to = nr_of_dcl_functions_and_instances }, + dcl_specials = { ir_from = nr_of_dcl_functions_and_instances, ir_to = nr_of_dcl_funs_insts_and_specs }, + dcl_class_specials = { ir_from = first_special_class_index, ir_to = last_special_class_index }} + = ({ e_info.ef_modules & [ mod_index ] = dcl_mod }, icl_functions, heaps, { cs & cs_symbol_table = cs_symbol_table }) +where +/* MW was + collect_imported_symbols [{import_module={id_info}} : mods ] all_decls modules cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # (all_decls, modules, cs) = collect_declarations_of_module id_info entry all_decls modules cs + = collect_imported_symbols mods all_decls modules cs +*/ + collect_imported_symbols [{import_module={id_info},import_symbols,import_file_position} : mods ] all_decls modules cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # (decls_of_imported_module, modules, cs) = collect_declarations_of_module id_info entry [] modules cs + (imported_decls, modules, cs) = possibly_filter_decls + import_symbols decls_of_imported_module import_file_position modules cs + = collect_imported_symbols mods (imported_decls++all_decls) modules cs + collect_imported_symbols [] all_decls modules cs + = (all_decls, modules, cs) + + collect_declarations_of_module module_id_info entry=:{ste_index, ste_kind= old_kind=:STE_OpenModule mod_num {mod_imports} } + all_decls modules cs=:{cs_symbol_table} + # cs = { cs & cs_symbol_table = cs_symbol_table <:= (module_id_info, { entry & ste_kind = STE_LockedModule })} + (imported_decls, modules, cs) = collect_imported_symbols mod_imports [] modules cs + #! dcl_mod = modules.[ste_index] + # (declared, cs) = determine_declared_symbols ste_index dcl_mod.dcl_declared.dcls_local imported_decls cs +// MW was = ([(ste_index, declared) : all_decls], modules, { cs & cs_symbol_table = cs.cs_symbol_table <:= (module_id_info, { entry & ste_kind = old_kind })}) + = ( [(ste_index, declared) : all_decls] + , modules + , { cs & cs_symbol_table = cs.cs_symbol_table <:= (module_id_info, { entry & ste_kind = old_kind })} + ) + collect_declarations_of_module module_id_info entry=:{ste_index, ste_kind= STE_ClosedModule} all_decls modules cs + #! {dcl_declared} = modules.[ste_index] + = ([(ste_index, dcl_declared) : all_decls], modules, cs) + collect_declarations_of_module module_id_info entry=:{ste_kind= STE_LockedModule} all_decls modules cs + = (all_decls, modules, cs) + + determine_declared_symbols mod_index definitions imported_decls cs + # cs = addGlobalDefinitionsToSymbolTable definitions (add_imported_symbols_to_symbol_table imported_decls cs) + (dcls_import, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable imported_decls [] cs.cs_symbol_table + cs_symbol_table = removeDeclarationsFromSymbolTable definitions cModuleScope cs_symbol_table + = ( {dcls_import = dcls_import, dcls_local = definitions, dcls_explicit = []}, { cs & cs_symbol_table = cs_symbol_table }) + + add_imported_symbols_to_symbol_table [(mod_index, {dcls_import,dcls_local}) : imports] cs + = add_imported_symbols_to_symbol_table imports (addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs) + add_imported_symbols_to_symbol_table [] cs + = cs + + adjust_predefined_symbols mod_index class_members class_instances fun_types cs=:{cs_predef_symbols} + #! pre_mod = cs_predef_symbols.[PD_StdArray] + | pre_mod.pds_def == mod_index + # cs = cs + <=< adjust_predef_symbols PD_CreateArrayFun PD_UnqArraySizeFun mod_index STE_Member + <=< adjust_predef_symbol PD_ArrayClass mod_index STE_Class + (class_members, class_instances, fun_types, cs_predef_symbols) + = adjust_instance_types_of_array_functions_in_std_array_dcl mod_index class_members class_instances fun_types cs.cs_predef_symbols + = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols }) + #! pre_mod = cs_predef_symbols.[PD_PredefinedModule] + | pre_mod.pds_def == mod_index + = (class_members, class_instances, fun_types, cs + <=< adjust_predef_symbols PD_ListType PD_UnboxedArrayType mod_index STE_Type + <=< adjust_predef_symbols PD_ConsSymbol PD_Arity32TupleSymbol mod_index STE_Constructor + <=< adjust_predef_symbol PD_TypeCodeClass mod_index STE_Class + <=< adjust_predef_symbol PD_TypeCodeMember mod_index STE_Member) + #! pre_mod = cs_predef_symbols.[PD_StdBool] + | pre_mod.pds_def == mod_index + = (class_members, class_instances, fun_types, cs + <=< adjust_predef_symbol PD_AndOp mod_index STE_DclFunction + <=< adjust_predef_symbol PD_OrOp mod_index STE_DclFunction) + #! pre_mod = cs_predef_symbols.[PD_StdDynamics] + | pre_mod.pds_def == mod_index + = (class_members, class_instances, fun_types, cs + <=< adjust_predef_symbol PD_TypeObjectType mod_index STE_Type + <=< adjust_predef_symbol PD_TypeConsSymbol mod_index STE_Constructor + <=< adjust_predef_symbol PD_variablePlaceholder mod_index STE_Constructor + <=< adjust_predef_symbol PD_unify mod_index STE_DclFunction + <=< adjust_predef_symbol PD_undo_indirections mod_index STE_DclFunction) + = (class_members, class_instances, fun_types, cs) + where + + adjust_predef_symbols next_symb last_symb mod_index symb_kind cs=:{cs_predef_symbols, cs_symbol_table, cs_error} + | next_symb > last_symb + = cs + = cs + <=< adjust_predef_symbol next_symb mod_index symb_kind + <=< adjust_predef_symbols (inc next_symb) last_symb mod_index symb_kind + + adjust_predef_symbol predef_index mod_index symb_kind cs=:{cs_predef_symbols,cs_symbol_table,cs_error} + #! pre_symb = cs_predef_symbols.[predef_index] + # pre_id = pre_symb.pds_ident + #! pre_index = determine_index_of_symbol (sreadPtr pre_id.id_info cs_symbol_table) symb_kind + | pre_index <> NoIndex + = { cs & cs_predef_symbols = {cs_predef_symbols & [predef_index] = { pre_symb & pds_def = pre_index, pds_module = mod_index }}} + = { cs & cs_error = checkError pre_id " function not defined" cs_error } + where + determine_index_of_symbol {ste_kind, ste_index} symb_kind + | ste_kind == symb_kind + = ste_index + = NoIndex + + adjust_instance_types_of_array_functions_in_std_array_dcl array_mod_index class_members class_instances fun_types predef_symbols + #! nr_of_instances = size class_instances + # ({pds_def}, predef_symbols) = predef_symbols![PD_ArrayClass] + (offset_table, class_members, predef_symbols) = arrayFunOffsetToPD_IndexTable class_members predef_symbols + (class_instances, fun_types, predef_symbols) + = iFoldSt (adjust_instance_types_of_array_functions array_mod_index pds_def offset_table) 0 nr_of_instances + (class_instances, fun_types, predef_symbols) + = (class_members, class_instances, fun_types, predef_symbols) + where + adjust_instance_types_of_array_functions array_mod_index array_class_index offset_table inst_index (class_instances, fun_types, predef_symbols) + # ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index] + | glob_module == array_mod_index && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols + # fun_types = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_types + = (class_instances, fun_types, predef_symbols) + = (class_instances, fun_types, predef_symbols) + + make_instance_strict instances offset_table ins_offset instance_defs + # {ds_index} = instances.[ins_offset] + (inst_def, instance_defs) = instance_defs![ds_index] + (Yes symbol_type) = inst_def.ft_type + = { instance_defs & [ds_index] = { inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table } } + +// MW moved functions + +NewEntry symbol_table symb_ptr def_kind def_index level previous :== + symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous }) + +// MW moved function + +addImportsToSymbolTable :: ![ParsedImport] ![(!Declaration, !LineNr)] !*{# DclModule} !*CheckState + -> (![(!Declaration, !LineNr)], !*{# DclModule}, !*CheckState) +addImportsToSymbolTable [{import_module={id_info},import_symbols, import_file_position} : mods ] + explicit_akku modules cs=:{cs_symbol_table} + #! {ste_index} = sreadPtr id_info cs_symbol_table + #! {dcl_declared=decls_of_imported_module} = modules.[ste_index] + (imported_decls, modules, cs) = possibly_filter_decls import_symbols + [(ste_index, decls_of_imported_module)] import_file_position modules cs + | isEmpty imported_decls + = addImportsToSymbolTable mods explicit_akku modules cs + #! (_,{dcls_import,dcls_local,dcls_explicit}) = hd imported_decls + = addImportsToSymbolTable mods (dcls_explicit++explicit_akku) + modules (addDeclaredSymbolsToSymbolTable cIsNotADclModule ste_index dcls_local dcls_import cs) +addImportsToSymbolTable [] explicit_akku modules cs + = (explicit_akku, modules, cs) + +// MW moved functions + +file_and_status {ea_file,ea_ok} + = (ea_file, ea_ok) + +instance <<< FunCall +where + (<<<) file {fc_index} = file <<< fc_index + +instance <<< Priority +where + (<<<) file (Prio ass prio) = file <<< "##" <<< prio <<< ass <<< "##" + (<<<) file NoPrio = file <<< "#" + +instance <<< Assoc +where + (<<<) file LeftAssoc = file <<< 'L' + (<<<) file RightAssoc = file <<< 'R' + (<<<) file _ = file + +instance <<< DefinedSymbol +where + (<<<) file { ds_index, ds_ident } = file <<< ds_ident <<< '.' <<< ds_index + +instance <<< FreeVar +where + (<<<) file { fv_name } = file <<< fv_name + +instance <<< FieldSymbol +where + (<<<) file { fs_var } = file <<< fs_var + + +instance <<< Declarations +where + (<<<) file { dcls_import, dcls_local } = file <<< "I:" <<< dcls_import <<< "L:" <<< dcls_local + +instance <<< Specials +where + (<<<) file (SP_ParsedSubstitutions _) = file <<< "SP_ParsedSubstitutions" + (<<<) file (SP_Substitutions substs) = file <<< "SP_Substitutions " <<< substs + (<<<) file (SP_ContextTypes specials) = file <<< "SP_ContextTypes " <<< specials + (<<<) file (SP_FunIndex _) = file <<< "SP_ParsedSubstitutions" + (<<<) file SP_None = file <<< "SP_None" + +instance <<< Special +where + (<<<) file {spec_types} = file <<< spec_types + + +instance <<< SpecialSubstitution +where + (<<<) file {ss_environ} = file <<< ss_environ + +instance <<< Declaration +where + (<<<) file { dcl_ident } = file <<< dcl_ident + +instance <<< Ptr a +where + (<<<) file ptr = file <<< "[[" <<< ptrToInt ptr <<< "]]" + +instance <<< LocalDefs +where + (<<<) file (CollectedLocalDefs { loc_functions={ir_from,ir_to} }) = file <<< ir_from <<< '-' <<< ir_to + +retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index) +retrieveGlobalDefinition {ste_kind = STE_Imported kind dcl_index, ste_def_level, ste_index} requ_kind mod_index + | kind == requ_kind + = (ste_index, dcl_index) + = (NotFound, mod_index) +retrieveGlobalDefinition {ste_kind,ste_def_level,ste_index} requ_kind mod_index + | ste_kind == requ_kind && ste_def_level == cGlobalScope + = (ste_index, mod_index) + = (NotFound, mod_index) + + diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl new file mode 100644 index 0000000..32db0be --- /dev/null +++ b/frontend/checksupport.dcl @@ -0,0 +1,136 @@ +definition module checksupport + +import StdEnv +import syntax, predef + +cIclModIndex :== 0 // MW++ + +CS_NotChecked :== -1 +NotFound :== -1 + +cModuleScope :== 0 +cGlobalScope :== 1 + +cIsNotADclModule :== False // MW++ +cIsADclModule :== True // MW++ + +:: VarHeap :== Heap VarInfo + +:: Heaps = + { hp_var_heap ::!.VarHeap + , hp_expression_heap ::!.ExpressionHeap + , hp_type_heaps ::!.TypeHeaps + } + +:: ErrorAdmin = { ea_file :: !.File, ea_loc :: ![IdentPos], ea_ok :: !Bool } + +:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin } + +// SymbolTable :== {# SymbolTableEntry} + +instance == STE_Kind + +:: ConversionTable :== {# .{# Int }} + +cTypeDefs :== 0 +cConstructorDefs :== 1 +cSelectorDefs :== 2 +cClassDefs :== 3 +cMemberDefs :== 4 +cInstanceDefs :== 5 +cFunctionDefs :== 6 +cMacroDefs :== 7 + +cConversionTableSize :== 8 + +:: CommonDefs = + { com_type_defs :: !.{# CheckedTypeDef} + , com_cons_defs :: !.{# ConsDef} + , com_selector_defs :: !.{# SelectorDef} + , com_class_defs :: !.{# ClassDef} + , com_member_defs :: !.{# MemberDef} + , com_instance_defs :: !.{# ClassInstance} +// , com_instance_types :: !.{ SymbolType} + } + +:: Declaration = + { dcl_ident :: !Ident + , dcl_kind :: !STE_Kind + , dcl_index :: !Index + } + +:: Declarations = + { dcls_import ::![Declaration] + , dcls_local ::![Declaration] + , dcls_explicit ::![(!Declaration, !LineNr)] // MW++ + } + +:: IclModule = + { icl_name :: !Ident + , icl_functions :: !.{# FunDef } + , icl_instances :: !IndexRange + , icl_specials :: !IndexRange + , icl_common :: !.CommonDefs + , icl_declared :: !Declarations +// RWS ... + , icl_imported_objects :: ![ImportedObject] +// ... RWS + } + +:: DclModule = + { dcl_name :: !Ident + , dcl_functions :: !{# FunType } + , dcl_instances :: !IndexRange + , dcl_macros :: !IndexRange + , dcl_class_specials :: !IndexRange + , dcl_specials :: !IndexRange + , dcl_common :: !CommonDefs + , dcl_declared :: !Declarations + , dcl_conversions :: !Optional ConversionTable + , dcl_is_system :: !Bool + } + +class Erroradmin state +where + pushErrorAdmin :: !IdentPos *state -> *state + setErrorAdmin :: !IdentPos *state -> *state + popErrorAdmin :: *state -> *state + +instance Erroradmin ErrorAdmin, CheckState + +newPosition :: !Ident !Position -> IdentPos + +checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b +checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b + +class envLookUp a :: !a !(Env Ident .b) -> (!Bool,.b) + +instance envLookUp TypeVar, AttributeVar, ATypeVar + +class toIdent a :: !a -> Ident + +instance toIdent ConsDef, TypeDef a, ClassDef, MemberDef, FunDef, SelectorDef // , ClassInstance +instance toIdent SymbIdent, TypeSymbIdent, BoundVar, TypeVar, ATypeVar, Ident + +instance toInt STE_Kind +instance <<< STE_Kind +instance <<< IdentPos + +// MW.. +retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +addLocalFunctionDefsToSymbolTable :: Level Index .Index u:(a FunDef) *SymbolTable *ErrorAdmin -> (v:(a FunDef),.SymbolTable,.ErrorAdmin) | Array .a, [u <= v]; +addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin) +addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; +addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState; +addImportedFunctionOrMacro :: !Ident .Int !*CheckState -> .CheckState; +addFieldToSelectorDefinition :: !Ident (Global .Int) !*CheckState -> .CheckState; +addImportedSymbol :: !Ident STE_Kind .Int .Int !*CheckState -> .CheckState; +addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState; +retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry); +removeFieldFromSelectorDefinition :: !Ident .Int .Int !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +removeDeclarationsFromSymbolTable :: ![Declaration] !Int !*(Heap SymbolTableEntry) -> *Heap SymbolTableEntry; +removeLocalIdentsFromSymbolTable :: .Int !.[Ident] !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +removeLocalsFromSymbolTable :: .Level .[Ident] LocalDefs u:(a b) *(Heap SymbolTableEntry) -> (v:(a b),.Heap SymbolTableEntry) | Array .a & select_u , toIdent b, [u <= v]; +removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +// ..MW
\ No newline at end of file diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl new file mode 100644 index 0000000..1bd4655 --- /dev/null +++ b/frontend/checksupport.icl @@ -0,0 +1,521 @@ +implementation module checksupport + +import StdEnv, compare_constructor +import syntax, predef +import utilities // MW++ + +:: VarHeap :== Heap VarInfo + +cIclModIndex :== 0 // MW++ + +CS_NotChecked :== -1 +NotFound :== -1 + +cModuleScope :== 0 +cGlobalScope :== 1 + +cIsNotADclModule :== False // MW++ +cIsADclModule :== True // MW++ + +:: Heaps = + { hp_var_heap ::!.VarHeap + , hp_expression_heap ::!.ExpressionHeap + , hp_type_heaps ::!.TypeHeaps + } + +:: ErrorAdmin = { ea_file :: !.File, ea_loc :: ![IdentPos], ea_ok :: !Bool } + +:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin } + +:: ConversionTable :== {# .{# Int }} + +cTypeDefs :== 0 +cConstructorDefs :== 1 +cSelectorDefs :== 2 +cClassDefs :== 3 +cMemberDefs :== 4 +cInstanceDefs :== 5 +cFunctionDefs :== 6 +cMacroDefs :== 7 + +cConversionTableSize :== 8 + +instance toInt STE_Kind +where + toInt STE_Type = cTypeDefs + toInt STE_Constructor = cConstructorDefs + toInt (STE_Field _) = cSelectorDefs + toInt STE_Class = cClassDefs + toInt STE_Member = cMemberDefs + toInt STE_Instance = cInstanceDefs + toInt STE_DclFunction = cFunctionDefs + toInt (STE_FunctionOrMacro _) = cMacroDefs + toInt _ = NoIndex + +:: CommonDefs = + { com_type_defs :: !.{# CheckedTypeDef} + , com_cons_defs :: !.{# ConsDef} + , com_selector_defs :: !.{# SelectorDef} + , com_class_defs :: !.{# ClassDef} + , com_member_defs :: !.{# MemberDef} + , com_instance_defs :: !.{# ClassInstance} +// , com_instance_types :: !.{ SymbolType} + } + +:: Declaration = + { dcl_ident :: !Ident + , dcl_kind :: !STE_Kind + , dcl_index :: !Index + } + +:: Declarations = + { dcls_import ::![Declaration] + , dcls_local ::![Declaration] + , dcls_explicit ::![(!Declaration, !LineNr)] // MW++ + } + +:: IclModule = + { icl_name :: !Ident + , icl_functions :: !.{# FunDef } + , icl_instances :: !IndexRange + , icl_specials :: !IndexRange + , icl_common :: !.CommonDefs + , icl_declared :: !Declarations +// RWS ... + , icl_imported_objects :: ![ImportedObject] +// ... RWS + } + +:: DclModule = + { dcl_name :: !Ident + , dcl_functions :: !{# FunType } + , dcl_instances :: !IndexRange + , dcl_macros :: !IndexRange + , dcl_class_specials :: !IndexRange + , dcl_specials :: !IndexRange + , dcl_common :: !CommonDefs + , dcl_declared :: !Declarations + , dcl_conversions :: !Optional ConversionTable + , dcl_is_system :: !Bool + } + +class Erroradmin state // PK... +where + pushErrorAdmin :: !IdentPos *state -> *state + setErrorAdmin :: !IdentPos *state -> *state + popErrorAdmin :: *state -> *state + +instance Erroradmin ErrorAdmin +where + pushErrorAdmin pos error=:{ea_loc} + = { error & ea_loc = [pos : ea_loc] } + + setErrorAdmin pos error + = { error & ea_loc = [pos] } + + popErrorAdmin error=:{ea_loc = [_:ea_locs]} + = { error & ea_loc = ea_locs } + +instance Erroradmin CheckState +where + pushErrorAdmin pos cs=:{cs_error} + = {cs & cs_error = pushErrorAdmin pos cs_error } + + setErrorAdmin pos cs=:{cs_error} + = {cs & cs_error = setErrorAdmin pos cs_error } + + popErrorAdmin cs=:{cs_error} + = {cs & cs_error = popErrorAdmin cs_error } //...PK + +newPosition :: !Ident !Position -> IdentPos +newPosition id (FunPos file_name line_nr _) + = { ip_ident = id, ip_line = line_nr, ip_file = file_name } +newPosition id (LinePos file_name line_nr) + = { ip_ident = id, ip_line = line_nr, ip_file = file_name } +newPosition id (PreDefPos file_name) + = { ip_ident = id, ip_line = cNotALineNumber, ip_file = file_name.id_name } +newPosition id NoPos + = { ip_ident = id, ip_line = cNotALineNumber, ip_file = "???" } + +checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK +checkError id mess error=:{ea_file,ea_loc=[]} + = { error & ea_file = ea_file <<< "Check Error " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } +checkError id mess error=:{ea_file,ea_loc} + = { error & ea_file = ea_file <<< "Check Error " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } + +checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK +checkWarning id mess error=:{ea_file,ea_loc=[]} + = { error & ea_file = ea_file <<< "Check Warning " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n' } +checkWarning id mess error=:{ea_file,ea_loc} + = { error & ea_file = ea_file <<< "Check Warning " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n' } + +class envLookUp a :: !a !(Env Ident .b) -> (!Bool,.b) + +instance envLookUp TypeVar +where + envLookUp var [bind:binds] + | var.tv_name == bind.bind_src + = (True, bind.bind_dst) + = envLookUp var binds + envLookUp var [] + = (False, abort "illegal value") + +instance envLookUp AttributeVar +where + envLookUp var [bind:binds] + | var.av_name == bind.bind_src + = (True, bind.bind_dst) + = envLookUp var binds + envLookUp var [] + = (False, abort "illegal value") + + +instance envLookUp ATypeVar +where + envLookUp var=:{atv_variable} [bind:binds] + | atv_variable.tv_name == bind.bind_src + = (True, bind.bind_dst) + = envLookUp var binds + envLookUp var [] + = (False, abort "illegal value") + + +// MW.. +retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +retrieveAndRemoveImportsFromSymbolTable [(_, {dcls_import,dcls_local}) : imports] all_decls symbol_table + # (all_decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local all_decls symbol_table + = retrieveAndRemoveImportsFromSymbolTable imports all_decls symbol_table +retrieveAndRemoveImportsFromSymbolTable [] all_decls symbol_table + = (all_decls, symbol_table) + +retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +retrieveAndRemoveImportsOfModuleFromSymbolTable imports locals all_decls symbol_table + # (all_decls, symbol_table) = retrieve_declared_symbols imports all_decls symbol_table + = retrieve_declared_symbols locals all_decls symbol_table +where + retrieve_declared_symbols :: ![Declaration] ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable) + retrieve_declared_symbols decls collected_decls symbol_table + = foldSt retrieve_declared_symbol decls (collected_decls, symbol_table) + + retrieve_declared_symbol symbol=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index} (decls, symbol_table) + #! entry = sreadPtr id_info symbol_table + # {ste_kind,ste_def_level,ste_previous} = entry + | ste_kind == STE_Empty || ste_def_level > cModuleScope + = (decls, symbol_table) + = case ste_kind of + STE_Field selector_id + -> ([{ symbol & dcl_kind = ste_kind } : decls ], + removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, ste_previous))) + STE_Imported (STE_Field selector_id) def_mod + -> ([{ symbol & dcl_kind = ste_kind } : decls ], + removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, ste_previous))) + _ + -> ([{ symbol & dcl_kind = ste_kind } : decls ], symbol_table <:= (id_info, ste_previous)) + +addLocalFunctionDefsToSymbolTable :: Level Index .Index u:(a FunDef) *SymbolTable *ErrorAdmin -> (v:(a FunDef),.SymbolTable,.ErrorAdmin) | Array .a, [u <= v]; +addLocalFunctionDefsToSymbolTable level from_index to_index fun_defs symbol_table error + | from_index == to_index + = (fun_defs, symbol_table, error) + #! fun_def = fun_defs.[from_index] + (symbol_table, error) = addDefToSymbolTable level from_index fun_def.fun_symb (STE_FunctionOrMacro []) symbol_table error + = addLocalFunctionDefsToSymbolTable level (inc from_index) to_index fun_defs symbol_table error + +NewEntry symbol_table symb_ptr def_kind def_index level previous :== + symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous }) + + +addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin) +addDefToSymbolTable level def_index def_ident=:{id_info} def_kind symbol_table error + #! entry = sreadPtr id_info symbol_table + | entry.ste_kind == STE_Empty || entry.ste_def_level <> level + # entry = {ste_index = def_index, ste_kind = def_kind, ste_def_level = level, ste_previous = entry } + = (symbol_table <:= (id_info,entry), error) + = (symbol_table, checkError def_ident " already defined" error) + +addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; +addDeclaredSymbolsToSymbolTable is_dcl_mod ste_index locals imported cs + = addLocalSymbolsToSymbolTable locals ste_index (add_imports_to_symbol_table is_dcl_mod imported cs) +where + add_imports_to_symbol_table is_dcl_mod [{dcl_ident,dcl_kind,dcl_index} : symbols] cs + = case dcl_kind of + STE_Imported def_kind def_mod + | is_dcl_mod || def_mod <> cIclModIndex + -> add_imports_to_symbol_table is_dcl_mod symbols (addImportedSymbol dcl_ident def_kind dcl_index def_mod cs) + -> add_imports_to_symbol_table is_dcl_mod symbols cs + STE_FunctionOrMacro _ + -> add_imports_to_symbol_table is_dcl_mod symbols (addImportedFunctionOrMacro dcl_ident dcl_index cs) + add_imports_to_symbol_table is_dcl_mod [] cs + = cs + +addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState; +addLocalSymbolsToSymbolTable [{dcl_ident,dcl_kind,dcl_index} : symbols] mod_index cs + = case dcl_kind of + STE_FunctionOrMacro _ + -> addLocalSymbolsToSymbolTable symbols mod_index (addImportedFunctionOrMacro dcl_ident dcl_index cs) + _ + -> addLocalSymbolsToSymbolTable symbols mod_index (addImportedSymbol dcl_ident dcl_kind dcl_index mod_index cs) +addLocalSymbolsToSymbolTable [] mod_index cs + = cs + +addImportedFunctionOrMacro :: !Ident .Int !*CheckState -> .CheckState; +addImportedFunctionOrMacro ident=:{id_info} def_index cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + = case entry.ste_kind of + STE_Empty + -> { cs & cs_symbol_table = NewEntry cs.cs_symbol_table id_info (STE_FunctionOrMacro []) def_index cModuleScope entry} + STE_FunctionOrMacro _ + | entry.ste_index == def_index + -> cs + _ + -> { cs & cs_error = checkError ident " multiply imported" cs.cs_error} + +addFieldToSelectorDefinition :: !Ident (Global .Int) !*CheckState -> .CheckState; +addFieldToSelectorDefinition {id_info} glob_field_index cs=:{cs_symbol_table} + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } + = case entry.ste_kind of + STE_Selector selector_list + -> { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { entry & ste_kind = STE_Selector [ glob_field_index : selector_list ] })} + _ + -> { cs & cs_symbol_table = NewEntry cs.cs_symbol_table id_info (STE_Selector [glob_field_index]) NoIndex cModuleScope entry } + +addImportedSymbol :: !Ident STE_Kind .Int .Int !*CheckState -> .CheckState; +addImportedSymbol ident def_kind def_index def_mod cs=:{cs_symbol_table} + # (entry, cs_symbol_table) = readPtr ident.id_info cs_symbol_table + = add_imported_symbol entry ident def_kind def_index def_mod { cs & cs_symbol_table = cs_symbol_table } +where + add_imported_symbol entry=:{ste_kind = STE_Empty} {id_info} def_kind def_index def_mod cs=:{cs_symbol_table} + # cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info (STE_Imported def_kind def_mod) def_index cModuleScope entry} + = case def_kind of + STE_Field selector_id + -> addFieldToSelectorDefinition selector_id { glob_module = def_mod, glob_object = def_index } cs + _ + -> cs + add_imported_symbol entry=:{ste_kind = STE_Imported kind mod_index, ste_index} ident=:{id_info} def_kind def_index def_mod cs + | kind == def_kind && mod_index == def_mod && ste_index == def_index + = cs + add_imported_symbol entry ident def_kind def_index def_mod cs=:{cs_error} + = { cs & cs_error = checkError ident " multiply imported" cs_error} + +addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState; +addGlobalDefinitionsToSymbolTable decls cs + = foldSt add_global_definition decls cs +where + add_global_definition {dcl_ident=ident=:{id_info},dcl_kind,dcl_index} cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + | entry.ste_def_level < cGlobalScope + # cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info dcl_kind dcl_index cGlobalScope entry } + = case dcl_kind of + STE_Field selector_id + -> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = dcl_index } cs + _ + -> cs + = { cs & cs_error = checkError ident "(global definition) already defined" cs.cs_error} + +retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry); +retrieveImportsFromSymbolTable [{import_module=import_module=:{id_info},import_symbols} : mods ] decls modules symbol_table + #! entry = sreadPtr id_info symbol_table + # {ste_index} = entry + #! {dcl_declared={dcls_import,dcls_local}} = modules.[ste_index] + (decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local decls symbol_table + = retrieveImportsFromSymbolTable mods decls modules symbol_table +retrieveImportsFromSymbolTable [] decls modules symbol_table + = (decls, modules, symbol_table) + +removeFieldFromSelectorDefinition :: !Ident .Int .Int !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +removeFieldFromSelectorDefinition {id_info} field_mod field_index symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table + (STE_Selector selector_list) = entry.ste_kind + = symbol_table <:= (id_info, { entry & ste_kind = STE_Selector (remove_field field_mod field_index selector_list) }) +where + remove_field field_mod field_index [field=:{glob_module, glob_object} : fields] + | field_mod == glob_module && field_index == glob_object + = fields + = [field : remove_field field_mod field_index fields] + remove_field field_mod field_index [] + = [] + + +removeDeclarationsFromSymbolTable :: ![Declaration] !Int !*(Heap SymbolTableEntry) -> *Heap SymbolTableEntry; +removeDeclarationsFromSymbolTable decls scope symbol_table + = foldSt (remove_declaration scope) decls symbol_table +where + remove_declaration scope {dcl_ident={id_info}, dcl_index} symbol_table + #! entry = sreadPtr id_info symbol_table + # {ste_kind,ste_previous} = entry + = case ste_kind of + STE_Field field_id + # symbol_table = removeFieldFromSelectorDefinition field_id NoIndex dcl_index symbol_table + | ste_previous.ste_def_level == scope + -> symbol_table <:= (id_info, ste_previous.ste_previous) + -> symbol_table <:= (id_info, ste_previous) + _ + | ste_previous.ste_def_level == scope + -> symbol_table <:= (id_info, ste_previous.ste_previous) + -> symbol_table <:= (id_info, ste_previous) + + +removeLocalIdentsFromSymbolTable :: .Int !.[Ident] !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +removeLocalIdentsFromSymbolTable level idents symbol_table + = foldSt (removeIdentFromSymbolTable level) idents symbol_table + + +removeLocalsFromSymbolTable :: .Level .[Ident] LocalDefs u:(a b) *(Heap SymbolTableEntry) -> (v:(a b),.Heap SymbolTableEntry) | Array .a & select_u , toIdent b, [u <= v]; +removeLocalsFromSymbolTable level loc_vars (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) defs symbol_table + = remove_defs_from_symbol_table level ir_from ir_to defs (removeLocalIdentsFromSymbolTable level loc_vars symbol_table) +where + remove_defs_from_symbol_table level from_index to_index defs symbol_table + | from_index == to_index + = (defs, symbol_table) + #! def = defs.[from_index] + id_info = (toIdent def).id_info + entry = sreadPtr id_info symbol_table + | level == entry.ste_def_level + = remove_defs_from_symbol_table level (inc from_index) to_index defs (symbol_table <:= (id_info, entry.ste_previous)) + = remove_defs_from_symbol_table level (inc from_index) to_index defs symbol_table + + +removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +removeIdentFromSymbolTable level {id_name,id_info} symbol_table + #! {ste_previous,ste_def_level} = sreadPtr id_info symbol_table + | level <= ste_def_level + = symbol_table <:= (id_info,ste_previous) // ---> ("removeIdentFromSymbolTable", id_name) + = symbol_table // ---> ("NO removeIdentFromSymbolTable", id_name) +// ..MW + +class toIdent a :: !a -> Ident + +instance toIdent SymbIdent +where + toIdent symb = symb.symb_name + +instance toIdent TypeSymbIdent +where + toIdent type_symb = type_symb.type_name + +instance toIdent BoundVar +where + toIdent var = var.var_name + +instance toIdent TypeVar +where + toIdent tvar = tvar.tv_name + +instance toIdent ATypeVar +where + toIdent {atv_variable} = atv_variable.tv_name + + +instance toIdent Ident +where + toIdent id = id + +instance toIdent ConsDef +where + toIdent cons = cons.cons_symb + +instance toIdent TypeDef a +where + toIdent td = td.td_name + +instance toIdent ClassDef +where + toIdent cl = cl.class_name + +instance toIdent MemberDef +where + toIdent me = me.me_symb + +instance toIdent FunDef +where + toIdent fun = fun.fun_symb + +instance toIdent SelectorDef +where + toIdent sd = sd.sd_symb + +/* +instance toIdent DeltaRule +where + toIdent delta = delta.delta_name +*/ + +instance toIdent (a,b) | toIdent a +where + toIdent (x,y) = toIdent x + +instance == STE_Kind +where + (==) (STE_FunctionOrMacro _) STE_DclFunction = True + (==) STE_DclFunction (STE_FunctionOrMacro _) = True + (==) sk1 sk2 = equal_constructor sk1 sk2 + +instance <<< IdentPos +where + (<<<) file {ip_file,ip_line,ip_ident} + | ip_line == cNotALineNumber + = file <<< '[' <<< ip_file <<< ',' <<< ip_ident <<< ']' + = file <<< '[' <<< ip_file <<< ',' <<< ip_line <<< ',' <<< ip_ident <<< ']' + + +instance <<< STE_Kind +where + (<<<) file + (STE_FunctionOrMacro _) + = file <<< "STE_FunctionOrMacro" + (<<<) file + STE_Type + = file <<< "STE_Type" + (<<<) file + STE_Constructor + = file <<< "STE_Constructor" + (<<<) file + (STE_Selector _) + = file <<< "STE_Selector" + (<<<) file + STE_Class + = file <<< "STE_Class" + (<<<) file + STE_Member + = file <<< "STE_Member" + (<<<) file + STE_Instance + = file <<< "STE_Instance" + (<<<) file + (STE_Variable _) + = file <<< "STE_Variable" + (<<<) file + (STE_TypeVariable _) + = file <<< "STE_TypeVariable" + (<<<) file + (STE_TypeAttribute _) + = file <<< "STE_TypeAttribute" + (<<<) file + (STE_BoundTypeVariable _) + = file <<< "STE_BoundTypeVariable" + (<<<) file + (STE_BoundType _) + = file <<< "STE_BoundType" + (<<<) file + (STE_Imported _ _) + = file <<< "STE_Imported" + (<<<) file + STE_DclFunction + = file <<< "STE_DclFunction" + (<<<) file + (STE_Module _) + = file <<< "STE_Module" + (<<<) file + (STE_OpenModule _ _) + = file <<< "STE_OpenModule" + (<<<) file + STE_ClosedModule + = file <<< "STE_ClosedModule" + (<<<) file + STE_LockedModule + = file <<< "STE_LockedModule" + (<<<) file + STE_Empty + = file <<< "STE_Empty" + + diff --git a/frontend/checktypes.dcl b/frontend/checktypes.dcl new file mode 100644 index 0000000..efb8526 --- /dev/null +++ b/frontend/checktypes.dcl @@ -0,0 +1,25 @@ +definition module checktypes + +import checksupport, typesupport + +checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !Int !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*TypeHeaps !*CheckState + -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*TypeHeaps, !*CheckState) + +checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) + +checkTypeContexts :: ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) + +checkInstanceType :: !Index !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) + +checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState + -> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState) + +createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !Int !*TypeVarHeap !*VarHeap !*CheckState + -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) + +isATopConsVar cv :== cv < 0 +encodeTopConsVar cv :== dec (~cv) +decodeTopConsVar cv :== ~(inc cv) diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl new file mode 100644 index 0000000..b649de0 --- /dev/null +++ b/frontend/checktypes.icl @@ -0,0 +1,1225 @@ +implementation module checktypes + +import StdEnv +import syntax, checksupport, check, typesupport, utilities, RWSDebug + + +:: TypeSymbols = + { ts_type_defs :: !.{# CheckedTypeDef} + , ts_cons_defs :: !.{# ConsDef} + , ts_selector_defs :: !.{# SelectorDef} + , ts_modules :: !.{# DclModule} + } + +:: TypeInfo = + { ti_heaps :: !.TypeHeaps + } + +:: CurrentTypeInfo = + { cti_module_index :: !Index + , cti_type_index :: !Index + , cti_lhs_attribute :: !TypeAttribute + } + +class bindTypes type :: !CurrentTypeInfo !type !(!*TypeSymbols, !*TypeInfo, !*CheckState) + -> (!type, !TypeAttribute, !(!*TypeSymbols, !*TypeInfo, !*CheckState)) + +instance bindTypes AType +where + bindTypes cti atype=:{at_attribute,at_type} ts_ti_cs + # (at_type, type_attr, (ts, ti, cs)) = bindTypes cti at_type ts_ti_cs + (combined_attribute, cs_error) = check_type_attribute at_attribute type_attr cti.cti_lhs_attribute cs.cs_error + = ({ atype & at_attribute = combined_attribute, at_type = at_type }, combined_attribute, (ts, ti, { cs & cs_error = cs_error })) + where + check_type_attribute :: !TypeAttribute !TypeAttribute !TypeAttribute !*ErrorAdmin -> (!TypeAttribute,!*ErrorAdmin) + check_type_attribute TA_Anonymous type_attr root_attr error + | try_to_combine_attributes type_attr root_attr + = (root_attr, error) + = (TA_Multi, checkError "" "conflicting attribution of type definition" error) + check_type_attribute TA_Unique type_attr root_attr error + | try_to_combine_attributes TA_Unique type_attr || try_to_combine_attributes TA_Unique root_attr + = (TA_Unique, error) + = (TA_Multi, checkError "" "conflicting attribution of type definition" error) + check_type_attribute (TA_Var var) _ _ error + = (TA_Multi, checkError var "attribute variable not allowed" error) + check_type_attribute (TA_RootVar var) _ _ error + = (TA_Multi, checkError var "attribute variable not allowed" error) + check_type_attribute _ type_attr root_attr error + = (type_attr, error) + + try_to_combine_attributes :: !TypeAttribute !TypeAttribute -> Bool + try_to_combine_attributes TA_Multi _ + = True + try_to_combine_attributes (TA_Var attr_var1) (TA_Var attr_var2) + = attr_var1.av_name == attr_var2.av_name + try_to_combine_attributes TA_Unique TA_Unique + = True + try_to_combine_attributes TA_Unique TA_Multi + = True + try_to_combine_attributes _ _ + = False + +instance bindTypes TypeVar +where + bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table}) + #! var_def = sreadPtr id_info cs_symbol_table + = case var_def.ste_kind of + STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count} + # cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { var_def & ste_kind = STE_BoundTypeVariable { bv & stv_count = inc stv_count }})} + -> ({ tv & tv_info_ptr = stv_info_ptr }, stv_attribute, (ts, ti, cs)) + _ + -> (tv, TA_Multi, (ts, ti, { cs & cs_error = checkError var_id "undefined" cs.cs_error })) + + +instance bindTypes [a] | bindTypes a +where + bindTypes cti [] ts_ti_cs + = ([], TA_Multi, ts_ti_cs) + bindTypes cti [x : xs] ts_ti_cs + # (x, _, ts_ti_cs) = bindTypes cti x ts_ti_cs + (xs, attr, ts_ti_cs) = bindTypes cti xs ts_ti_cs + = ([x : xs], attr, ts_ti_cs) + + +instance bindTypes Type +where + bindTypes cti (TV tv) ts_ti_cs + # (tv, attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs + = (TV tv, attr, ts_ti_cs) + bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TA type_cons=:{type_name=type_name=:{id_info}} types) + (ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table}) + #! entry = sreadPtr id_info cs_symbol_table + # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type cti_module_index + | type_index <> NotFound + # ({td_arity,td_attribute},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules + ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules } + | td_arity >= type_cons.type_arity + # (types, _, ts_ti_cs) = bindTypes cti types (ts, ti, cs) + | type_module == cti_module_index && cti_type_index == type_index + = (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, cti_lhs_attribute, ts_ti_cs) + = (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, + determine_type_attribute td_attribute, ts_ti_cs) + = (type, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name " used with wrong arity" cs.cs_error })) + = (type, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name " undefined" cs.cs_error})) + where + determine_type_attribute TA_Unique = TA_Unique + determine_type_attribute _ = TA_Multi + + bindTypes cti (arg_type --> res_type) ts_ti_cs + # (arg_type, _, ts_ti_cs) = bindTypes cti arg_type ts_ti_cs + (res_type, _, ts_ti_cs) = bindTypes cti res_type ts_ti_cs + = (arg_type --> res_type, TA_Multi, ts_ti_cs) + bindTypes cti (CV tv :@: types) ts_ti_cs + # (tv, type_attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs + (types, _, ts_ti_cs) = bindTypes cti types ts_ti_cs + = (CV tv :@: types, type_attr, ts_ti_cs) + bindTypes cti type ts_ti_cs + = (type, TA_Multi, ts_ti_cs) + + +addToAttributeEnviron :: !TypeAttribute !TypeAttribute ![AttrInequality] !*ErrorAdmin -> (![AttrInequality],!*ErrorAdmin) +addToAttributeEnviron TA_Multi _ attr_env error + = (attr_env, error) +addToAttributeEnviron _ TA_Unique attr_env error + = (attr_env, error) +addToAttributeEnviron (TA_Var attr_var) (TA_Var root_var) attr_env error + | attr_var.av_info_ptr == root_var.av_info_ptr + = (attr_env, error) + = ([ { ai_demanded = attr_var, ai_offered = root_var } : attr_env], error) +addToAttributeEnviron (TA_RootVar attr_var) root_attr attr_env error + = (attr_env, error) +addToAttributeEnviron _ _ attr_env error + = (attr_env, checkError "" "inconsistent attribution of type definition" error) + +/* +bindTypesOfCons :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !Bool !Index !Level !TypeAttribute !Conditions !*TypeSymbols !*TypeInfo !*CheckState + -> *(!TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) +*/ + +bindTypesOfConstructors _ _ _ _ _ [] ts_ti_cs + = ts_ti_cs +bindTypesOfConstructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_heaps}, cs) + #! cons_def = ts_cons_defs.[ds_index] + # (exi_vars, (ti_heaps, cs)) + = addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_heaps cs + (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs)) + = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] (ts, { ti & ti_heaps = ti_heaps }, cs) + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel exi_vars cs.cs_symbol_table + (ts, ti, cs) = bindTypesOfConstructors cti (inc cons_index) free_vars free_attrs type_lhs conses + (ts, ti, { cs & cs_symbol_table = cs_symbol_table }) + cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env } + = ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] = + { cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, + cons_arg_vars = cons_arg_vars }}}, ti, cs) +where +/* + check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState + -> *(![AType], ![[ATypeVar]], ![AttrInequality], !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) +*/ + + bind_types_of_cons [] cti free_vars attr_env ts_ti_cs + = ([], [], attr_env, ts_ti_cs) + bind_types_of_cons [type : types] cti free_vars attr_env ts_ti_cs + # (types, local_vars_list, attr_env, ts_ti_cs) + = bind_types_of_cons types cti free_vars attr_env ts_ti_cs + (type, type_attr, (ts, ti, cs)) = bindTypes cti type ts_ti_cs + (local_vars, cs_symbol_table) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table) + (attr_env, cs_error) = addToAttributeEnviron type_attr cti.cti_lhs_attribute attr_env cs.cs_error + = ([type : types], [local_vars : local_vars_list], attr_env, (ts, ti , { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) + where + retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table) + # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count}}, symbol_table) = readPtr id_info symbol_table + | stv_count == 0 + = (local_vars, symbol_table) + = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr }, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], + symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})) + + +/* +checkRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !Bool !Index !Level !TypeAttribute !Index !Conditions !*TypeSymbols !*TypeInfo !*CheckState + -> (!TypeRhs, !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) +*/ +checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs + # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) + [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + ts_ti_cs = bindTypesOfConstructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs + = (td_rhs, ts_ti_cs) + +checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}} + attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs + # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) + [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + (ts, ti, cs) = bindTypesOfConstructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] + attr_vars type_lhs [rec_cons] ts_ti_cs + #! rec_cons_def = ts.ts_cons_defs.[ds_index] + # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def + (ts_selector_defs, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars ts.ts_selector_defs cs.cs_error + = (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, ti, { cs & cs_error = cs_error})) +where + check_selectors :: !Index !{# FieldSymbol} !Index ![AType] !AType ![TypeVar] ![AttributeVar] ![ATypeVar] !*{#SelectorDef} !*ErrorAdmin + -> (!*{#SelectorDef},!*ErrorAdmin) + check_selectors field_nr fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs error + | field_nr < size fields + # {fs_index} = fields.[field_nr] + #! sel_def = selector_defs.[fs_index] + # [sel_type:sel_types] = sel_types + # (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error + sd_type = { sel_def.sd_type & st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars, + st_attr_vars = st_attr_vars, st_attr_env = st_attr_env } + selector_defs = { selector_defs & [fs_index] = { sel_def & sd_type = sd_type, sd_field_nr = field_nr, sd_type_index = rec_type_index, + sd_exi_vars = exi_vars } } + = check_selectors (inc field_nr) fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs error + = (selector_defs, error) +checkRhsOfTypeDef {td_rhs = SynType type} _ cti ts_ti_cs + # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs + = (SynType type, ts_ti_cs) +checkRhsOfTypeDef {td_rhs} _ _ ts_ti_cs + = (td_rhs, ts_ti_cs) + +emptyIdent name :== { id_name = name, id_info = nilPtr } + +isATopConsVar cv :== cv < 0 +encodeTopConsVar cv :== dec (~cv) +decodeTopConsVar cv :== ~(inc cv) + +// checkTypeDef :: !Bool !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!Int, !Conditions, !*TypeSymbols, !*TypeInfo, !*CheckState); +checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_heaps} cs=:{cs_error} + #! type_def = ts_type_defs.[type_index] + # {td_name,td_pos,td_args,td_attribute,td_properties} = type_def + position = newPosition td_name td_pos + cs_error = pushErrorAdmin position cs_error + (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_heaps.th_attrs + (type_vars, (attr_vars, ti_heaps, cs)) + = addTypeVariablesToSymbolTable td_args attr_vars { ti_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } + type_def = { type_def & td_args = type_vars, td_index = type_index, td_attrs = attr_vars, td_attribute = td_attribute } + (td_rhs, (ts, ti, cs)) = checkRhsOfTypeDef type_def attr_vars + { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } (ts,{ ti & ti_heaps = ti_heaps}, cs) + = ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs }}}, ti, + { cs & cs_error = popErrorAdmin cs.cs_error, + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table }) +where + determine_root_attribute TA_None name attr_var_heap + # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} + = (TA_Var new_var, [new_var], attr_var_heap) + determine_root_attribute TA_Unique name attr_var_heap + = (TA_Unique, [], attr_var_heap) + +CS_Checked :== 1 +CS_Checking :== 0 + +:: SynTypeInfo = + { sti_type_defs ::!.{# CheckedTypeDef} + , sti_modules ::!.{# DclModule} + , sti_marks ::!.{# Int} + } + + +class expand a :: !Index !a !*SynTypeInfo !*CheckState -> (!a, !TypeAttribute, !*SynTypeInfo, !*CheckState) + +expandTypeVariable :: TypeVar !*SynTypeInfo !*CheckState -> (!Type, !TypeAttribute, !*SynTypeInfo, !*CheckState) +expandTypeVariable {tv_name={id_info}} sti cs=:{cs_symbol_table} + #! {ste_kind = STE_BoundType {at_attribute,at_type}} = sreadPtr id_info cs_symbol_table + = (at_type, at_attribute, sti, cs) + + +instance expand Type +where + expand module_index (TV tv) sti cs + = expandTypeVariable tv sti cs + expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) sti=:{sti_marks} cs=:{cs_error,cs_symbol_table} + | module_index == glob_module + #! mark = sti_marks.[glob_object] + | mark == CS_NotChecked + # (sti, cs) = expandSynType module_index glob_object sti cs + (types, attr, sti, cs) = expand module_index types sti cs + = (TA type_cons types, attr, sti, cs) + | mark == CS_Checked + # (types, attr, sti, cs) = expand module_index types sti cs + = (TA type_cons types, attr, sti, cs) +// | mark == CS_Checking + = (type, TA_None, sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error }) + # (types, attr, sti, cs) = expand module_index types sti cs + = (TA type_cons types, attr, sti, cs) + expand module_index (arg_type --> res_type) sti cs + # (arg_type, _, sti, cs) = expand module_index arg_type sti cs + (res_type, _, sti, cs) = expand module_index res_type sti cs + = (arg_type --> res_type, TA_None, sti, cs) + expand module_index (CV tv :@: types) sti cs + # (type, type_attr, sti, cs) = expandTypeVariable tv sti cs + (types, _, sti, cs) = expand module_index types sti cs + = (simplify_type_appl type types, type_attr, sti, cs) + where + simplify_type_appl :: !Type ![AType] -> Type + simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args + = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) + simplify_type_appl (TV tv) type_args + = CV tv :@: type_args + expand module_index type sti cs + = (type, TA_None, sti, cs) + +instance expand [a] | expand a +where + expand module_index [x:xs] sti cs + # (x, _, sti, cs) = expand module_index x sti cs + (xs, _, sti, cs) = expand module_index xs sti cs + = ([x:xs], TA_None, sti, cs) + expand module_index [] sti cs + = ([], TA_None, sti, cs) + +instance expand AType +where + expand module_index atype=:{at_type} sti cs + # (at_type, attr, sti, cs) = expand module_index at_type sti cs + = ({ atype & at_type = at_type, at_attribute = attr }, attr, sti, cs) + +class look_for_cycles a :: !Index !a !(!*SynTypeInfo, !*CheckState) -> (!*SynTypeInfo, !*CheckState) + +instance look_for_cycles Type +where + look_for_cycles module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) (sti=:{sti_marks}, cs=:{cs_error}) + | module_index == glob_module + #! mark = sti_marks.[glob_object] + | mark == CS_NotChecked + # (sti, cs) = expandSynType module_index glob_object sti cs + = look_for_cycles module_index types (sti, cs) + | mark == CS_Checked + = look_for_cycles module_index types (sti, cs) + = (sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error }) + = look_for_cycles module_index types (sti, cs) + look_for_cycles module_index (arg_type --> res_type) state + = look_for_cycles module_index res_type (look_for_cycles module_index arg_type state) + look_for_cycles module_index (type :@: types) state + = look_for_cycles module_index types state + look_for_cycles module_index type state + = state + +instance look_for_cycles [a] | look_for_cycles a +where + look_for_cycles mod_index l state + = foldr (look_for_cycles mod_index) state l + +instance look_for_cycles AType +where + look_for_cycles mod_index {at_type} state + = look_for_cycles mod_index at_type state + +expandSynType :: !Index !Index !*SynTypeInfo !*CheckState -> (!*SynTypeInfo, !*CheckState) +expandSynType mod_index type_index sti=:{sti_type_defs,sti_marks,sti_modules} cs + #! type_def = sti_type_defs.[type_index] + = case type_def.td_rhs of + SynType type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} + # (type_def2,_,sti_type_defs,sti_modules) = getTypeDef glob_object glob_module mod_index sti_type_defs sti_modules + -> case type_def2.td_rhs of + SynType rhs_type + # cs_symbol_table = bind_args type_def2.td_args types cs.cs_symbol_table + position = newPosition type_def.td_name type_def.td_pos + cs_error = pushErrorAdmin position cs.cs_error + sti_marks = { sti_marks & [type_index] = CS_Checking } + (exp_type, _, sti, cs) = expand mod_index rhs_type.at_type + { sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = sti_marks } + { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table } + -> ({sti & sti_type_defs = { sti.sti_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}}, + sti_marks = { sti.sti_marks & [type_index] = CS_Checked }}, + { cs & cs_symbol_table = free_args type_def2.td_args cs.cs_symbol_table, cs_error = popErrorAdmin cs.cs_error }) + _ + # sti_marks = { sti_marks & [type_index] = CS_Checking } + position = newPosition type_def.td_name type_def.td_pos + (sti, cs) = look_for_cycles mod_index types + ({ sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = sti_marks }, + { cs & cs_error = pushErrorAdmin position cs.cs_error }) + -> ({ sti & sti_marks = { sti.sti_marks & [type_index] = CS_Checked }}, { cs & cs_error = popErrorAdmin cs.cs_error }) + + _ + -> ({ sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = { sti_marks & [type_index] = CS_Checked }}, cs) +where + bind_args [{atv_variable = {tv_name = {id_info}}} : type_vars] [type : types] symbol_table + #! entry = sreadPtr id_info symbol_table + = bind_args type_vars types symbol_table <:= (id_info, + { ste_index = NoIndex, ste_kind = STE_BoundType type, ste_def_level = cGlobalScope, ste_previous = entry }) + bind_args [] [] symbol_table + = symbol_table + + free_args [{atv_variable = {tv_name = {id_info}}} : type_vars] symbol_table + #! {ste_previous} = sreadPtr id_info symbol_table + = free_args type_vars (symbol_table <:= (id_info, ste_previous)) + free_args [] symbol_table + = symbol_table + +instance toString KindInfo +where + toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr) + toString (KI_Const) = "*" + toString (KI_Arrow kinds) = kind_list_to_string kinds + where + kind_list_to_string [k] = "* -> *" + kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks +/* +instance toString TypeKind +where + toString (KindVar var_num) = "*" +++ toString var_num + toString (KindConst) = "*" + toString (KindArrow [k:ks]) = toString k +++ kind_list_to_string ks +++ " -> *" + where + kind_list_to_string [] = "" + kind_list_to_string [k:ks] = " -> " +++ toString k +++ kind_list_to_string ks +*/ +checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !Int !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*TypeHeaps !*CheckState + -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*TypeHeaps, !*CheckState) +checkTypeDefs is_main_dcl type_defs module_index nr_of_types cons_defs selector_defs modules heaps cs + # ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules } + ti = { ti_heaps = heaps } + = check_type_defs is_main_dcl 0 nr_of_types module_index ts ti cs +where + check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_heaps} cs + | type_index == nr_of_types + | cs.cs_error.ea_ok && not is_main_dcl + # marks = createArray nr_of_types CS_NotChecked + (type_defs, modules, cs) = expand_syn_types module_index 0 nr_of_types + { sti_type_defs = ts.ts_type_defs, sti_modules = ts.ts_modules, sti_marks = marks } cs + = (type_defs, ts.ts_cons_defs, ts.ts_selector_defs, modules, ti_heaps, cs) + = (ts.ts_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, ts.ts_modules, ti_heaps, cs) + # (ts, ti, cs) = checkTypeDef type_index module_index ts ti cs + = check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs + + expand_syn_types module_index type_index nr_of_types sti cs + | type_index == nr_of_types + = (sti.sti_type_defs, sti.sti_modules, cs) + | sti.sti_marks.[type_index] == CS_NotChecked + # (sti, cs) = expandSynType module_index type_index sti cs + = expand_syn_types module_index (inc type_index) nr_of_types sti cs + = expand_syn_types module_index (inc type_index) nr_of_types sti cs + +:: OpenTypeInfo = + { oti_heaps :: !.TypeHeaps + , oti_all_vars :: ![TypeVar] + , oti_all_attrs :: ![AttributeVar] + , oti_global_vars :: ![TypeVar] + } + +:: OpenTypeSymbols = + { ots_type_defs :: .{# CheckedTypeDef} + , ots_modules :: .{# DclModule} + } + +determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_heaps,oti_all_attrs} symbol_table + #! entry = sreadPtr id_info symbol_table + # {ste_kind,ste_def_level} = entry + | ste_kind == STE_Empty || ste_def_level == cModuleScope + #! (new_attr_ptr, th_attrs) = newPtr AVI_Empty oti_heaps.th_attrs + # symbol_table = symbol_table <:= (id_info,{ ste_index = NoIndex, ste_kind = STE_TypeAttribute new_attr_ptr, + ste_def_level = cGlobalScope, ste_previous = entry }) + new_attr = { attr_var & av_info_ptr = new_attr_ptr} + = (new_attr, { oti & oti_heaps = { oti_heaps & th_attrs = th_attrs }, oti_all_attrs = [new_attr : oti_all_attrs] }, symbol_table) + # (STE_TypeAttribute attr_ptr) = ste_kind + = ({ attr_var & av_info_ptr = attr_ptr}, oti, symbol_table) + +:: DemandedAttributeKind = DAK_Ignore | DAK_Unique | DAK_None + +newAttribute DAK_Ignore var_name _ oti cs + = (TA_Multi, oti, cs) +newAttribute DAK_Unique var_name new_attr oti cs + = case new_attr of + TA_Unique + -> (TA_Unique, oti, cs) + TA_Multi + -> (TA_Unique, oti, cs) + TA_None + -> (TA_Unique, oti, cs) + _ + -> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed (1)" cs.cs_error }) +newAttribute DAK_None var_name (TA_Var attr_var) oti cs=:{cs_symbol_table} + # (attr_var, oti, cs_symbol_table) = determineAttributeVariable attr_var oti cs_symbol_table + = (TA_Var attr_var, oti, { cs & cs_symbol_table = cs_symbol_table }) +newAttribute DAK_None var_name TA_Anonymous oti=:{oti_heaps, oti_all_attrs} cs + # (new_attr_ptr, th_attrs) = newPtr AVI_Empty oti_heaps.th_attrs + new_attr = { av_info_ptr = new_attr_ptr, av_name = emptyIdent var_name } + = (TA_Var new_attr, { oti & oti_heaps = { oti_heaps & th_attrs = th_attrs }, oti_all_attrs = [new_attr : oti_all_attrs] }, cs) +newAttribute DAK_None var_name TA_Unique oti cs + = (TA_Unique, oti, cs) +newAttribute DAK_None var_name attr oti cs + = (TA_Multi, oti, cs) + + +getTypeDef :: !Index !Index !Index !u:{# CheckedTypeDef} !v:{# DclModule} -> (!CheckedTypeDef, !Index , !u:{# CheckedTypeDef}, !v:{# DclModule}) +getTypeDef type_index type_module module_index type_defs modules + | type_module == module_index + #! type_def = type_defs.[type_index] + = (type_def, type_index, type_defs, modules) + #! {dcl_common={com_type_defs},dcl_conversions} = modules.[type_module] + #! type_def = com_type_defs.[type_index] + # type_index = convertIndex type_index (toInt STE_Type) dcl_conversions + = (type_def, type_index, type_defs, modules) + +getClassDef :: !Index !Index !Index !u:{# ClassDef} !v:{# DclModule} -> (!ClassDef, !Index , !u:{# ClassDef}, !v:{# DclModule}) +getClassDef class_index type_module module_index class_defs modules + | type_module == module_index + #! si = size class_defs + #! class_def = class_defs.[class_index] + = (class_def, class_index, class_defs, modules) + #! {dcl_common={com_class_defs},dcl_conversions} = modules.[type_module] + #! class_def = com_class_defs.[class_index] + # class_index = convertIndex class_index (toInt STE_Class) dcl_conversions + = (class_def, class_index, class_defs, modules) + + +checkTypeVar mod_index scope dem_attr tv=:{tv_name=var_name=:{id_name,id_info}} tv_attr (ots, oti, cs=:{cs_symbol_table}) + #! entry = sreadPtr id_info cs_symbol_table + # {ste_kind,ste_def_level} = entry + | ste_kind == STE_Empty || ste_def_level == cModuleScope + # (new_attr, oti=:{oti_heaps,oti_all_vars}, cs) = newAttribute dem_attr id_name tv_attr oti cs + (new_var_ptr, th_vars) = newPtr (TVI_Attribute new_attr) oti_heaps.th_vars + new_var = { tv & tv_info_ptr = new_var_ptr } + = (new_var, new_attr, (ots, { oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_all_vars = [new_var : oti_all_vars]}, + { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr, + ste_def_level = scope, ste_previous = entry })})) + # (STE_TypeVariable tv_info_ptr) = ste_kind + {oti_heaps} = oti + (var_info, th_vars) = readPtr tv_info_ptr oti_heaps.th_vars + (var_attr, oti, cs) = check_attribute id_name dem_attr var_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }} cs + = ({ tv & tv_info_ptr = tv_info_ptr }, var_attr, (ots, oti, cs)) +where + check_attribute var_name DAK_Ignore (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error} + = (TA_Multi, oti, cs) + check_attribute var_name dem_attr (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error} + # (new_attr, cs_error) = determine_attribute var_name dem_attr this_attr cs_error + = check_var_attribute prev_attr new_attr oti { cs & cs_error = cs_error } + where + check_var_attribute (TA_Var old_var) (TA_Var new_var) oti cs=:{cs_symbol_table,cs_error} + # (new_var, oti, cs_symbol_table) = determineAttributeVariable new_var oti cs_symbol_table + | old_var.av_info_ptr == new_var.av_info_ptr + = (TA_Var old_var, oti, { cs & cs_symbol_table = cs_symbol_table }) + = (TA_Var old_var, oti, { cs & cs_symbol_table = cs_symbol_table, + cs_error = checkError new_var.av_name "inconsistently attributed (4)" cs_error }) + check_var_attribute var_attr=:(TA_Var old_var) TA_Anonymous oti cs + = (var_attr, oti, cs) + check_var_attribute TA_Unique new_attr oti cs + = case new_attr of + TA_Unique + -> (TA_Unique, oti, cs) + _ + -> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed (5)" cs.cs_error }) + check_var_attribute TA_Multi new_attr oti cs + = case new_attr of + TA_Multi + -> (TA_Multi, oti, cs) + TA_None + -> (TA_Multi, oti, cs) + _ + -> (TA_Multi, oti, { cs & cs_error = checkError var_name "inconsistently attributed (6)" cs.cs_error }) + check_var_attribute var_attr new_attr oti cs + = (var_attr, oti, { cs & cs_error = checkError var_name "inconsistently attributed (7)" cs.cs_error })// ---> (var_attr, new_attr) + + + determine_attribute var_name DAK_Unique new_attr error + = case new_attr of + TA_Multi + -> (TA_Unique, error) + TA_None + -> (TA_Unique, error) + TA_Unique + -> (TA_Unique, error) + _ + -> (TA_Unique, checkError var_name "inconsistently attributed (3)" error) + determine_attribute var_name dem_attr TA_None error + = (TA_Multi, error) + determine_attribute var_name dem_attr new_attr error + = (new_attr, error) + + check_attribute var_name dem_attr _ this_attr oti cs + = (TA_Multi, oti, cs) + + +checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} ots_oti_cs + # (tv, at_attribute, ots_oti_cs) = checkTypeVar mod_index scope dem_attr tv at_attribute ots_oti_cs + = ({ type & at_type = TV tv, at_attribute = at_attribute }, ots_oti_cs) +checkOpenAType mod_index scope dem_attr type=:{at_type = GTV var_id=:{tv_name={id_info}}} (ots, oti=:{oti_heaps,oti_global_vars}, cs=:{cs_symbol_table}) + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + (type_var, oti_global_vars, th_vars, entry) + = retrieve_global_variable var_id entry oti_global_vars oti_heaps.th_vars + = ({type & at_type = TV type_var, at_attribute = TA_Multi }, (ots, { oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_global_vars = oti_global_vars }, + { cs & cs_symbol_table = cs_symbol_table <:= (id_info, entry) })) +where + retrieve_global_variable var entry=:{ste_kind = STE_Empty} global_vars var_heap + # (new_var_ptr, var_heap) = newPtr TVI_Used var_heap + var = { var & tv_info_ptr = new_var_ptr } + = (var, [var : global_vars], var_heap, + { entry & ste_kind = STE_TypeVariable new_var_ptr, ste_def_level = cModuleScope, ste_previous = entry }) + retrieve_global_variable var entry=:{ste_kind,ste_def_level, ste_previous} global_vars var_heap + | ste_def_level == cModuleScope + = case ste_kind of + STE_TypeVariable glob_info_ptr + # var = { var & tv_info_ptr = glob_info_ptr } + (var_info, var_heap) = readPtr glob_info_ptr var_heap + -> case var_info of + TVI_Empty + -> (var, [var : global_vars], var_heap <:= (glob_info_ptr, TVI_Used), entry) + TVI_Used + -> (var, global_vars, var_heap, entry) + # (var, global_vars, var_heap, ste_previous) = retrieve_global_variable var ste_previous global_vars var_heap + = (var, global_vars, var_heap, { entry & ste_previous = ste_previous }) + +checkOpenAType mod_index scope dem_attr type=:{ at_type=TA type_cons=:{type_name=type_name=:{id_name,id_info}} types, at_attribute} + (ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table,cs_error}) + #! entry = sreadPtr id_info cs_symbol_table + # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index + | type_index <> NotFound + # ({td_arity,td_args,td_attribute},type_index,ots_type_defs,ots_modules) = getTypeDef type_index type_module mod_index ots_type_defs ots_modules + ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules } + | type_cons.type_arity <= td_arity + # type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }} + (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr types td_args (ots, oti, cs) + (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr td_attribute) id_name at_attribute oti cs + = ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs)) + = (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs_error})) + = (type, (ots, oti, {cs & cs_error = checkError type_name "undefined" cs_error})) +where + check_args_of_type_cons mod_index scope dem_attr [] _ cot_state + = ([], cot_state) + check_args_of_type_cons mod_index scope dem_attr [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state + # (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute dem_attr atv_attribute) arg_type cot_state + (arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr arg_types td_args cot_state + = ([arg_type : arg_types], cot_state) + + new_demanded_attribute DAK_Ignore _ + = DAK_Ignore + new_demanded_attribute _ TA_Unique + = DAK_Unique + new_demanded_attribute dem_attr _ + = dem_attr + +checkOpenAType mod_index scope dem_attr type=:{at_type = arg_type --> result_type, at_attribute} cot_state + # (arg_type, cot_state) = checkOpenAType mod_index scope DAK_None arg_type cot_state + (result_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None result_type cot_state + (new_attr, oti, cs) = newAttribute dem_attr "-->" at_attribute oti cs + = ({ type & at_type = arg_type --> result_type, at_attribute = new_attr }, (ots, oti, cs)) +checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} cot_state + # (cons_var, _, cot_state) = checkTypeVar mod_index scope DAK_None tv TA_Multi cot_state + (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types cot_state + (new_attr, oti, cs) = newAttribute dem_attr ":@:" at_attribute oti cs + = ({ type & at_type = CV cons_var :@: types, at_attribute = new_attr }, (ots, oti, cs)) +checkOpenAType mod_index scope dem_attr type=:{at_attribute} (ots, oti, cs) + # (new_attr, oti, cs) = newAttribute dem_attr "." at_attribute oti cs + = ({ type & at_attribute = new_attr}, (ots, oti, cs)) + +checkOpenTypes mod_index scope dem_attr types cot_state + = mapSt (checkOpenType mod_index scope dem_attr) types cot_state + +checkOpenType mod_index scope dem_attr type cot_state + # ({at_type}, cot_state) = checkOpenAType mod_index scope dem_attr { at_type = type, at_attribute = TA_Multi, at_annotation = AN_None } cot_state + = (at_type, cot_state) + +checkOpenATypes mod_index scope types cot_state + = mapSt (checkOpenAType mod_index scope DAK_None) types cot_state + +checkInstanceType :: !Index !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkInstanceType mod_index it=:{it_types,it_context} specials type_defs class_defs modules heaps cs + # ots = { ots_type_defs = type_defs, ots_modules = modules } + oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] } + (it_types, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, cs) + (it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index ots.ots_type_defs class_defs ots.ots_modules oti_heaps cs + (specials, cs) = checkSpecialTypeVars specials cs + cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table + cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table + (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table } + = ({it & it_vars = oti_all_vars, it_types = it_types, it_attr_vars = oti_all_attrs, it_context = it_context }, + specials, type_defs, class_defs, modules, heaps, cs) + +checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkSymbolType mod_index st=:{st_args,st_result,st_context,st_attr_env} specials type_defs class_defs modules heaps cs + # ots = { ots_type_defs = type_defs, ots_modules = modules } + oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] } + (st_args, cot_state) = checkOpenATypes mod_index cGlobalScope st_args (ots, oti, cs) + (st_result, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state + (st_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts st_context mod_index ots.ots_type_defs class_defs ots.ots_modules oti_heaps cs + (st_attr_env, cs) = check_attr_inequalities st_attr_env cs + (specials, cs) = checkSpecialTypeVars specials cs + cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table + cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table + (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table } + = ({st & st_vars = oti_all_vars, st_args = st_args, st_result = st_result, st_context = st_context, + st_attr_vars = oti_all_attrs, st_attr_env = st_attr_env }, specials, type_defs, class_defs, modules, heaps, cs)// ---> (st, "--->", st_args, st_result) +where + check_attr_inequalities [ineq : ineqs] cs + # (ineq, cs) = check_attr_inequality ineq cs + (ineqs, cs) = check_attr_inequalities ineqs cs + = ([ineq : ineqs], cs) + check_attr_inequalities [] cs + = ([], cs) + + check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_name=dem_name},ai_offered=ai_offered=:{av_name=off_name}} cs=:{cs_symbol_table,cs_error} + #! dem_entry = sreadPtr dem_name.id_info cs_symbol_table + # (found_dem_attr, dem_attr_ptr) = retrieve_attribute dem_entry + | found_dem_attr + #! off_entry = sreadPtr off_name.id_info cs_symbol_table + # (found_off_attr, off_attr_ptr) = retrieve_attribute off_entry + | found_off_attr + = ({ai_demanded = { ai_demanded & av_info_ptr = dem_attr_ptr }, ai_offered = { ai_offered & av_info_ptr = off_attr_ptr }}, cs) + = (ineq, { cs & cs_error = checkError off_name "attribute variable undefined" cs_error }) + = (ineq, { cs & cs_error = checkError dem_name "attribute variable undefined" cs_error }) + + retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index} + | ste_def_level == cGlobalScope + = (True, attr_ptr) + retrieve_attribute entry + = (False, abort "no attribute") + +checkTypeContexts :: ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkTypeContexts [tc : tcs] mod_index type_defs class_defs modules heaps cs + # (tc, type_defs, class_defs, modules, heaps, cs) = check_type_context tc mod_index type_defs class_defs modules heaps cs + (tcs, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts tcs mod_index type_defs class_defs modules heaps cs + = ([tc : tcs], type_defs, class_defs, modules, heaps, cs) +where + + check_type_context :: !TypeContext !Index v:{#CheckedTypeDef} !x:{#ClassDef} !u:{#.DclModule} !*TypeHeaps !*CheckState + -> (!TypeContext,!z:{#CheckedTypeDef},!x:{#ClassDef},!w:{#DclModule},!*TypeHeaps,!*CheckState), [u v <= w, v u <= z] + check_type_context tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident={id_name,id_info},ds_arity}},tc_types} + mod_index type_defs class_defs modules heaps cs=:{cs_symbol_table} + #! entry = sreadPtr id_info cs_symbol_table + # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index + | class_index <> NotFound + # (class_def, class_index, class_defs, modules) = getClassDef class_index class_module mod_index class_defs modules + ots = { ots_modules = modules, ots_type_defs = type_defs } + oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] } + (tc_types, (ots, {oti_all_vars,oti_all_attrs,oti_heaps}, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) + cs = foldr (\ {tv_name} cs=:{cs_symbol_table,cs_error} -> + { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table, + cs_error = checkError tv_name " undefined" cs_error}) cs oti_all_vars + cs = foldr (\ {av_name} cs=:{cs_symbol_table,cs_error} -> + { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table, + cs_error = checkError av_name " undefined" cs_error}) cs oti_all_attrs + tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types} + | class_def.class_arity == ds_arity + = (tc, ots.ots_type_defs, class_defs, ots.ots_modules, oti_heaps, cs) + = (tc, ots.ots_type_defs, class_defs, ots.ots_modules, oti_heaps, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error }) + = (tc, type_defs, class_defs, modules, heaps, { cs & cs_error = checkError id_name "undefined" cs.cs_error }) +checkTypeContexts [] _ type_defs class_defs modules heaps cs + = ([], type_defs, class_defs, modules, heaps, cs) + +checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState + -> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState) +checkDynamicTypes mod_index dyn_type_ptrs No type_defs modules type_heaps expr_heap cs + # (type_defs, modules, heaps, expr_heap, cs) = checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs modules type_heaps expr_heap cs + (expr_heap, cs_symbol_table) = remove_global_type_variables_in_dynamics dyn_type_ptrs (expr_heap, cs.cs_symbol_table) + = (type_defs, modules, heaps, expr_heap, { cs & cs_symbol_table = cs_symbol_table }) +where + remove_global_type_variables_in_dynamics dyn_info_ptrs expr_heap_and_symbol_table + = foldSt remove_global_type_variables_in_dynamic dyn_info_ptrs expr_heap_and_symbol_table + where + remove_global_type_variables_in_dynamic dyn_info_ptr (expr_heap, symbol_table) + # (dyn_info, expr_heap) = readPtr dyn_info_ptr expr_heap + = case dyn_info of + EI_Dynamic (Yes {dt_global_vars}) + -> (expr_heap, remove_global_type_variables dt_global_vars symbol_table) + EI_Dynamic No + -> (expr_heap, symbol_table) + EI_DynamicTypeWithVars loc_type_vars {dt_global_vars} loc_dynamics + -> remove_global_type_variables_in_dynamics loc_dynamics (expr_heap, remove_global_type_variables dt_global_vars symbol_table) + + + remove_global_type_variables global_vars symbol_table + = foldSt remove_global_type_variable global_vars symbol_table + where + remove_global_type_variable {tv_name=tv_name=:{id_info}} symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table + | entry.ste_kind == STE_Empty + = symbol_table + = symbol_table <:= (id_info, entry.ste_previous) + +checkDynamicTypes mod_index dyn_type_ptrs (Yes {st_vars}) type_defs modules type_heaps expr_heap cs=:{cs_symbol_table} + # (th_vars, cs_symbol_table) = foldSt add_type_variable_to_symbol_table st_vars (type_heaps.th_vars, cs_symbol_table) + (type_defs, modules, heaps, expr_heap, cs) = checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs modules + { type_heaps & th_vars = th_vars } expr_heap { cs & cs_symbol_table = cs_symbol_table } + cs_symbol_table = removeVariablesFromSymbolTable cModuleScope st_vars cs.cs_symbol_table + (expr_heap, cs) = check_global_type_variables_in_dynamics dyn_type_ptrs (expr_heap, { cs & cs_symbol_table = cs_symbol_table }) + = (type_defs, modules, heaps, expr_heap, cs) +where + add_type_variable_to_symbol_table {tv_name={id_info},tv_info_ptr} (var_heap,symbol_table) + # (entry, symbol_table) = readPtr id_info symbol_table + = ( var_heap <:= (tv_info_ptr, TVI_Empty), + symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable tv_info_ptr, + ste_def_level = cModuleScope, ste_previous = entry })) + + check_global_type_variables_in_dynamics dyn_info_ptrs expr_heap_and_cs + = foldSt check_global_type_variables_in_dynamic dyn_info_ptrs expr_heap_and_cs + where + check_global_type_variables_in_dynamic dyn_info_ptr (expr_heap, cs) + # (dyn_info, expr_heap) = readPtr dyn_info_ptr expr_heap + = case dyn_info of + EI_Dynamic (Yes {dt_global_vars}) + -> (expr_heap, check_global_type_variables dt_global_vars cs) + EI_Dynamic No + -> (expr_heap, cs) + EI_DynamicTypeWithVars loc_type_vars {dt_global_vars} loc_dynamics + -> check_global_type_variables_in_dynamics loc_dynamics (expr_heap, check_global_type_variables dt_global_vars cs) + + + check_global_type_variables global_vars cs + = foldSt check_global_type_variable global_vars cs + where + check_global_type_variable {tv_name=tv_name=:{id_info}} cs=:{cs_symbol_table, cs_error} + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + | entry.ste_kind == STE_Empty + = { cs & cs_symbol_table = cs_symbol_table } + = { cs & cs_symbol_table = cs_symbol_table <:= (id_info, entry.ste_previous), + cs_error = checkError tv_name.id_name " global type variable not used in type of the function" cs_error } + +checkDynamics mod_index scope dyn_type_ptrs type_defs modules type_heaps expr_heap cs + = foldSt (check_dynamic mod_index scope) dyn_type_ptrs (type_defs, modules, type_heaps, expr_heap, cs) +where + check_dynamic mod_index scope dyn_info_ptr (type_defs, modules, type_heaps, expr_heap, cs) + # (dyn_info, expr_heap) = readPtr dyn_info_ptr expr_heap + = case dyn_info of + EI_Dynamic opt_type + -> case opt_type of + Yes dyn_type + # (dyn_type, loc_type_vars, type_defs, modules, type_heaps, cs) = check_dynamic_type mod_index scope dyn_type type_defs modules type_heaps cs + | isEmpty loc_type_vars + -> (type_defs, modules, type_heaps, expr_heap <:= (dyn_info_ptr, EI_Dynamic (Yes dyn_type)), cs) + # cs_symbol_table = removeVariablesFromSymbolTable scope loc_type_vars cs.cs_symbol_table + cs_error = checkError loc_type_vars " type variable(s) not defined" cs.cs_error + -> (type_defs, modules, type_heaps, expr_heap <:= (dyn_info_ptr, EI_Dynamic (Yes dyn_type)), + { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) + No + -> (type_defs, modules, type_heaps, expr_heap, cs) + EI_DynamicType dyn_type loc_dynamics + # (dyn_type, loc_type_vars, type_defs, modules, type_heaps, cs) = check_dynamic_type mod_index scope dyn_type type_defs modules type_heaps cs + (type_defs, modules, type_heaps, expr_heap, cs) = check_local_dynamics mod_index scope loc_dynamics type_defs modules type_heaps expr_heap cs + cs_symbol_table = removeVariablesFromSymbolTable scope loc_type_vars cs.cs_symbol_table + -> (type_defs, modules, type_heaps, expr_heap <:= (dyn_info_ptr, EI_DynamicTypeWithVars loc_type_vars dyn_type loc_dynamics), + { cs & cs_symbol_table = cs_symbol_table }) + // ---> ("check_dynamic ", scope, dyn_type, loc_type_vars) + + check_local_dynamics mod_index scope local_dynamics type_defs modules type_heaps expr_heap cs + = foldSt (check_dynamic mod_index (inc scope)) local_dynamics (type_defs, modules, type_heaps, expr_heap, cs) + + check_dynamic_type mod_index scope dt=:{dt_uni_vars,dt_type} type_defs modules type_heaps=:{th_vars} cs + # (dt_uni_vars, (th_vars, cs)) = mapSt (add_type_variable_to_symbol_table scope) dt_uni_vars (th_vars, cs) + ots = { ots_type_defs = type_defs, ots_modules = modules } + oti = { oti_heaps = { type_heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] } + (dt_type, ( {ots_type_defs, ots_modules}, {oti_heaps,oti_all_vars,oti_all_attrs, oti_global_vars}, cs)) + = checkOpenAType mod_index scope DAK_Ignore dt_type (ots, oti, cs) + th_vars = foldSt (\{tv_info_ptr} -> writePtr tv_info_ptr TVI_Empty) oti_global_vars oti_heaps.th_vars + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable scope dt_uni_vars cs.cs_symbol_table + | isEmpty oti_all_attrs + = ({ dt & dt_uni_vars = dt_uni_vars, dt_global_vars = oti_global_vars, dt_type = dt_type }, + oti_all_vars, ots_type_defs, ots_modules, { oti_heaps & th_vars = th_vars }, { cs & cs_symbol_table = cs_symbol_table }) + # cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table + = ({ dt & dt_uni_vars = dt_uni_vars, dt_global_vars = oti_global_vars, dt_type = dt_type }, + oti_all_vars, ots_type_defs, ots_modules, { oti_heaps & th_vars = th_vars }, + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError (hd oti_all_attrs).av_name " type attribute variable not allowed" cs.cs_error}) + + add_type_variable_to_symbol_table :: !Level !ATypeVar !*(!*TypeVarHeap,!*CheckState) -> (!ATypeVar,!(!*TypeVarHeap, !*CheckState)) + add_type_variable_to_symbol_table scope atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} (type_var_heap, cs=:{cs_symbol_table,cs_error}) + #! var_info = tv_name.id_info + var_entry = sreadPtr var_info cs_symbol_table + | var_entry.ste_kind == STE_Empty || scope < var_entry.ste_def_level + #! (new_var_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap + # cs_symbol_table = cs_symbol_table <:= + (var_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr, ste_def_level = scope, ste_previous = var_entry }) + = ({atv & atv_attribute = TA_Multi, atv_variable = { atv_variable & tv_info_ptr = new_var_ptr }}, (type_var_heap, + { cs & cs_symbol_table = cs_symbol_table, cs_error = check_attribute atv_attribute cs_error})) + = (atv, (type_var_heap, { cs & cs_error = checkError tv_name.id_name " type variable already defined" cs_error })) + + check_attribute TA_Unique error + = error + check_attribute TA_Multi error + = error + check_attribute TA_None error + = error + check_attribute attr error + = checkError attr " attribute not allowed in type of dynamic" error + + +checkSpecialTypeVars :: !Specials !*CheckState -> (!Specials, !*CheckState) +checkSpecialTypeVars (SP_ParsedSubstitutions env) cs + # (env, cs) = mapSt (mapSt check_type_var) env cs + = (SP_ParsedSubstitutions env, cs) +where + check_type_var bind=:{bind_dst=type_var=:{tv_name={id_name,id_info}}} cs=:{cs_symbol_table,cs_error} + #! entry = sreadPtr id_info cs_symbol_table + # {ste_kind,ste_def_level} = entry + | ste_kind <> STE_Empty && ste_def_level == cGlobalScope + # (STE_TypeVariable tv_info_ptr) = ste_kind + = ({ bind & bind_dst = { type_var & tv_info_ptr = tv_info_ptr}}, cs) + = (bind, { cs & cs_error = checkError id_name " type variable not defined" cs_error }) +checkSpecialTypeVars SP_None cs + = (SP_None, cs) +/* +checkSpecialTypes :: !Index !Specials !u:{#.CheckedTypeDef} !u:{#.DclModule} !*TypeHeaps !*CheckState + -> (!Specials, !u:{#CheckedTypeDef},!u:{#DclModule},!*TypeHeaps,!*CheckState) +*/ +checkSpecialTypes mod_index (SP_ParsedSubstitutions envs) type_defs modules heaps cs + # ots = { ots_type_defs = type_defs, ots_modules = modules } + (specials, (heaps, ots, cs)) = mapSt (check_environment mod_index) envs (heaps, ots, cs) + = (SP_Substitutions specials, ots.ots_type_defs, ots.ots_modules, heaps, cs) +where + check_environment mod_index env (heaps, ots, cs) + # oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] } + (env, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = mapSt (check_substituted_type mod_index) env (ots, oti, cs) + cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table + cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table + = ({ ss_environ = env, ss_context = [], ss_vars = oti_all_vars, ss_attrs = oti_all_attrs}, (oti_heaps, ots, { cs & cs_symbol_table = cs_symbol_table })) + + check_substituted_type mod_index bind=:{bind_src} cot_state + # (bind_src, cot_state) = checkOpenType mod_index cGlobalScope DAK_Ignore bind_src cot_state + = ({ bind & bind_src = bind_src }, cot_state) +checkSpecialTypes mod_index SP_None type_defs modules heaps cs + = (SP_None, type_defs, modules, heaps, cs) + + +instance <<< SelectorDef +where + (<<<) file {sd_symb} = file <<< sd_symb + +instance <<< AttrInequality +where + (<<<) file {ai_demanded,ai_offered} + = file <<< ai_offered <<< " <= " <<< ai_demanded +/* +instance <<< VarBind +where + (<<<) file vb = file <<< (vb.vb_var,vb.vb_vars) +*/ + +cOuterMostLevel :== 0 + +addTypeVariablesToSymbolTable :: ![ATypeVar] ![AttributeVar] !*TypeHeaps !*CheckState + -> (![ATypeVar], !(![AttributeVar], !*TypeHeaps, !*CheckState)) +addTypeVariablesToSymbolTable type_vars attr_vars heaps cs + = mapSt (add_type_variable_to_symbol_table) type_vars (attr_vars, heaps, cs) +where + add_type_variable_to_symbol_table :: !ATypeVar !(![AttributeVar], !*TypeHeaps, !*CheckState) + -> (!ATypeVar, !(![AttributeVar], !*TypeHeaps, !*CheckState)) + add_type_variable_to_symbol_table atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} + (attr_vars, heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) + #! tv_info = tv_name.id_info + entry = sreadPtr tv_info cs_symbol_table + | entry.ste_def_level < cOuterMostLevel + # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars + atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } + (atv_attribute, attr_vars, th_attrs, cs_error) = check_attribute atv_attribute tv_name.id_name attr_vars th_attrs cs_error + cs_symbol_table = cs_symbol_table <:= (tv_info, {ste_index = NoIndex, ste_kind = STE_BoundTypeVariable {stv_attribute = atv_attribute, + stv_info_ptr = tv_info_ptr, stv_count = 0 }, ste_def_level = cOuterMostLevel, ste_previous = entry }) + heaps = { heaps & th_vars = th_vars, th_attrs = th_attrs } + = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, + (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) + = (atv, (attr_vars, { heaps & th_vars = th_vars }, + { cs & cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) + + check_attribute :: !TypeAttribute !String ![AttributeVar] !*AttrVarHeap !*ErrorAdmin + -> (!TypeAttribute, ![AttributeVar], !*AttrVarHeap, !*ErrorAdmin) + check_attribute TA_Multi name attr_vars attr_var_heap cs + # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} + = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) + check_attribute TA_None name attr_vars attr_var_heap cs + # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} + = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) + check_attribute TA_Unique name attr_vars attr_var_heap cs + = (TA_Unique, attr_vars, attr_var_heap, cs) + check_attribute _ name attr_vars attr_var_heap cs + = (TA_Multi, attr_vars, attr_var_heap, checkError name "specified attribute variable not allowed" cs) + + +addExistentionalTypeVariablesToSymbolTable :: !TypeAttribute ![ATypeVar] !*TypeHeaps !*CheckState + -> (![ATypeVar], !(!*TypeHeaps, !*CheckState)) +addExistentionalTypeVariablesToSymbolTable root_attr type_vars heaps cs + = mapSt (add_type_variable_to_symbol_table root_attr) type_vars (heaps, cs) +where + add_type_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState) + -> (!ATypeVar, !(!*TypeHeaps, !*CheckState)) + add_type_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} + (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) + #! tv_info = tv_name.id_info + entry = sreadPtr tv_info cs_symbol_table + | entry.ste_def_level < cOuterMostLevel + # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars + atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } + (atv_attribute, cs_error) = check_attribute atv_attribute root_attr tv_name.id_name cs_error + cs_symbol_table = cs_symbol_table <:= (tv_info, {ste_index = NoIndex, ste_kind = STE_BoundTypeVariable {stv_attribute = atv_attribute, + stv_info_ptr = tv_info_ptr, stv_count = 0 }, ste_def_level = cOuterMostLevel, ste_previous = entry }) + heaps = { heaps & th_vars = th_vars } + = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, + (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) + = (atv, ({ heaps & th_vars = th_vars }, + { cs & cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) + + check_attribute :: !TypeAttribute !TypeAttribute !String !*ErrorAdmin + -> (!TypeAttribute, !*ErrorAdmin) + check_attribute TA_Multi root_attr name error + = (TA_Multi, error) + check_attribute TA_None root_attr name error + = (TA_Multi, error) + check_attribute TA_Unique root_attr name error + = (TA_Unique, error) + check_attribute TA_Anonymous root_attr name error + = case root_attr of + TA_Var var + -> (TA_RootVar var, error) + _ + -> (root_attr, error) + check_attribute attr root_attr name error + = (TA_Multi, checkError name "specified attribute not allowed" error) + +retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap) +retrieveKinds type_vars var_heap = mapSt retrieve_kind type_vars var_heap +where + retrieve_kind {atv_variable = {tv_info_ptr}} var_heap + # (TVI_TypeKind kind_info_ptr, var_heap) = readPtr tv_info_ptr var_heap + = (KindVar kind_info_ptr, var_heap) + +removeAttributedTypeVarsFromSymbolTable :: !Level ![ATypeVar] !*SymbolTable -> *SymbolTable +removeAttributedTypeVarsFromSymbolTable level vars symbol_table + = foldr (\{atv_variable={tv_name}} -> removeDefinitionFromSymbolTable level tv_name) symbol_table vars + + +cExistentialVariable :== True +cUniversalVariable :== False + +removeDefinitionFromSymbolTable level {id_info} symbol_table + | isNilPtr id_info + = symbol_table + #! entry = sreadPtr id_info symbol_table + | entry.ste_def_level == level + = symbol_table <:= (id_info, entry.ste_previous) + = symbol_table + +removeAttributesFromSymbolTable :: ![AttributeVar] !*SymbolTable -> *SymbolTable +removeAttributesFromSymbolTable attrs symbol_table + = foldr (\{av_name} -> removeDefinitionFromSymbolTable cGlobalScope av_name) symbol_table attrs + +removeVariablesFromSymbolTable :: !Int ![TypeVar] !*SymbolTable -> *SymbolTable +removeVariablesFromSymbolTable scope vars symbol_table + = foldr (\{tv_name} -> removeDefinitionFromSymbolTable scope tv_name) symbol_table vars + +:: Indexes = + { index_type :: !Index + , index_cons :: !Index + , index_selector :: !Index + } + +makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = annot, at_type = type } + +createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !Int !*TypeVarHeap !*VarHeap !*CheckState + -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) +createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index upper_limit type_var_heap var_heap cs + # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = create_class_dictionaries mod_index 0 class_defs modules [] + { index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap cs + (type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table) + = (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, {cs & cs_symbol_table = cs_symbol_table }) +where + collect_type_def type_ptr (type_defs, sel_defs, cons_defs, symbol_table) + # ({ ste_kind = STE_DictType type_def }, symbol_table) = readPtr type_ptr symbol_table + (RecordType {rt_constructor, rt_fields}) = type_def.td_rhs + ({ ste_kind = STE_DictCons cons_def }, symbol_table) = readPtr rt_constructor.ds_ident.id_info symbol_table + (sel_defs, symbol_table) = collect_fields 0 rt_fields (sel_defs, symbol_table) + = ( [type_def : type_defs ] , sel_defs, [cons_def : cons_defs], symbol_table) + where + collect_fields field_nr fields (sel_defs, symbol_table) + | field_nr < size fields + # (sel_defs, symbol_table) = collect_fields (inc field_nr) fields (sel_defs, symbol_table) + ({ ste_kind = STE_DictField sel_def }, symbol_table) = readPtr fields.[field_nr].fs_name.id_info symbol_table + = ( [ sel_def : sel_defs ], symbol_table) + = ( sel_defs, symbol_table) + + create_class_dictionaries mod_index class_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs +// MW was | class_index < size class_defs + | class_index < upper_limit + # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = + create_class_dictionary mod_index class_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs + = create_class_dictionaries mod_index (inc class_index) class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs + = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) + + create_class_dictionary mod_index class_index class_defs =:{[class_index] = class_def } modules rev_dictionary_list + indexes type_var_heap var_heap cs=:{cs_symbol_table,cs_error} + # {class_name,class_args,class_arity,class_members,class_context,class_dictionary=ds=:{ds_ident={id_info}}} = class_def + | isNilPtr id_info + # (type_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table + nr_of_members = size class_members + nr_of_fields = nr_of_members + length class_context + rec_type_id = { class_name & id_info = type_id_info} + class_dictionary = { ds & ds_ident = rec_type_id } + class_defs = { class_defs & [class_index] = { class_def & class_dictionary = class_dictionary}} + (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) + = create_class_dictionaries_of_contexts mod_index class_context class_defs modules + rev_dictionary_list indexes type_var_heap var_heap { cs & cs_symbol_table = cs_symbol_table } + + { index_type, index_cons, index_selector } = indexes + + type_symb = MakeTypeSymbIdent { glob_object = index_type, glob_module = mod_index } rec_type_id class_arity + + rec_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]]) + field_type = makeAttributedType TA_Multi AN_None TE + + (rev_fields, var_heap, cs_symbol_table) + = build_fields 0 nr_of_members class_members rec_type field_type index_type index_selector [] var_heap cs.cs_symbol_table + (index_selector, rev_fields, rev_field_types, class_defs, modules, var_heap, cs_symbol_table) + = build_context_fields mod_index nr_of_members class_context rec_type index_type (index_selector + nr_of_members) rev_fields + [ { field_type & at_annotation = AN_Strict } \\ i <- [1..nr_of_members] ] class_defs modules var_heap cs_symbol_table + + (cons_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table + rec_cons_id = { class_name & id_info = cons_id_info} + cons_symbol = { ds_ident = rec_cons_id, ds_arity = nr_of_fields, ds_index = index_cons } + (cons_type_ptr, var_heap) = newPtr VI_Empty var_heap + + (td_args, type_var_heap) = mapSt new_attributed_type_variable class_args type_var_heap + + + type_def = + { td_name = rec_type_id + , td_index = index_type + , td_arity = 0 + , td_args = td_args + , td_attrs = [] + , td_context = [] + , td_rhs = RecordType {rt_constructor = cons_symbol, rt_fields = { field \\ field <- reverse rev_fields }} + , td_attribute = TA_None + , td_pos = NoPos +// , td_kinds = [] +// , td_properties = cAllBitsClear +// , td_info = EmptyTypeDefInfo + } + + cons_def = + { cons_symb = rec_cons_id + , cons_type = { st_vars = [], st_args = reverse rev_field_types, st_result = rec_type, + st_arity = nr_of_fields, st_context = [], st_attr_vars = [], st_attr_env = [] } + , cons_priority = NoPrio + , cons_index = 0 + , cons_type_index = index_type + , cons_exi_vars = [] +// , cons_exi_attrs = [] + , cons_arg_vars = [] + , cons_type_ptr = cons_type_ptr + , cons_pos = NoPos + } + = ({ class_defs & [class_index] = { class_def & class_dictionary = { class_dictionary & ds_index = index_type }}}, modules, + [ type_id_info : rev_dictionary_list ], { index_type = inc index_type, index_cons = inc index_cons, index_selector = index_selector }, + type_var_heap, var_heap, { cs & cs_symbol_table = cs_symbol_table + <:= (type_id_info, { ste_kind = STE_DictType type_def, ste_index = index_type, + ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" }) + <:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons, + ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })}) + # ({ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table + | ste_kind == STE_Empty + = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError class_name "cyclic dependencies between type classes" cs_error}) + = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, { cs & cs_symbol_table = cs_symbol_table }) + + create_class_dictionaries_of_contexts mod_index [{tc_class = {glob_module, glob_object={ds_index}}}:tcs] class_defs modules + rev_dictionary_list indexes type_var_heap var_heap cs + | mod_index == glob_module + # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) + = create_class_dictionary mod_index ds_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs + = create_class_dictionaries_of_contexts mod_index tcs class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs + = create_class_dictionaries_of_contexts mod_index tcs class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs + create_class_dictionaries_of_contexts mod_index [] class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs + = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) + + new_attributed_type_variable tv type_var_heap + # (new_tv_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap + = ({atv_attribute = TA_Multi, atv_annotation = AN_None , atv_variable = { tv & tv_info_ptr = new_tv_ptr }}, type_var_heap) + + build_fields field_nr nr_of_fields class_members rec_type field_type rec_type_index next_selector_index rev_fields var_heap symbol_table + | field_nr < nr_of_fields + # (field, var_heap, symbol_table) = build_field field_nr class_members.[field_nr].ds_ident.id_name rec_type_index + rec_type field_type next_selector_index var_heap symbol_table + = build_fields (inc field_nr) nr_of_fields class_members rec_type field_type rec_type_index (inc next_selector_index) + [ field : rev_fields ] var_heap symbol_table + = (rev_fields, var_heap, symbol_table) + + build_context_fields mod_index field_nr [{tc_class = {glob_module, glob_object={ds_index}}}:tcs] rec_type rec_type_index + next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table + # ({class_name, class_arity, class_dictionary = {ds_ident, ds_index}}, _, class_defs, modules) = getClassDef ds_index glob_module mod_index class_defs modules + type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity + field_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]]) + (field, var_heap, symbol_table) = build_field field_nr class_name.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table + = build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ] + [field_type : rev_field_types] class_defs modules var_heap symbol_table + build_context_fields mod_index field_nr [] rec_type rec_type_index next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table + = (next_selector_index, rev_fields, rev_field_types , class_defs, modules, var_heap, symbol_table) + + build_field field_nr field_name rec_type_index rec_type field_type selector_index var_heap symbol_table + # (id_info, symbol_table) = newPtr EmptySymbolTableEntry symbol_table + (sd_type_ptr, var_heap) = newPtr VI_Empty var_heap + field_id = { id_name = field_name, id_info = id_info } + sel_def = + { sd_symb = field_id + , sd_field = field_id + , sd_type = { st_vars = [], st_args = [ rec_type ], st_result = field_type, st_arity = 1, + st_context = [], st_attr_vars = [], st_attr_env = [] } + , sd_exi_vars = [] +// , sd_exi_attrs = [] + , sd_field_nr = field_nr + , sd_type_index = rec_type_index + , sd_type_ptr = sd_type_ptr + , sd_pos = NoPos + } + field = { fs_name = field_id, fs_var = field_id, fs_index = selector_index } + = (field, var_heap, symbol_table <:= (id_info, { ste_kind = STE_DictField sel_def, ste_index = selector_index, + ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })) + +class toVariable var :: !STE_Kind !Ident -> var + +instance toVariable TypeVar +where + toVariable (STE_TypeVariable info_ptr) ident = { tv_name = ident, tv_info_ptr = info_ptr } + +instance toVariable AttributeVar +where + toVariable (STE_TypeAttribute info_ptr) ident = { av_name = ident, av_info_ptr = info_ptr } + +instance == AttributeVar +where + (==) av1 av2 = av1.av_info_ptr == av2.av_info_ptr + +instance <<< DynamicType +where + (<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type diff --git a/frontend/compare_constructor.dcl b/frontend/compare_constructor.dcl new file mode 100644 index 0000000..3261007 --- /dev/null +++ b/frontend/compare_constructor.dcl @@ -0,0 +1,5 @@ +system module compare_constructor; + +equal_constructor :: !a !a ->Bool; +less_constructor :: !a !a ->Bool; +greater_constructor :: !a !a ->Bool; diff --git a/frontend/compare_constructor.icl b/frontend/compare_constructor.icl new file mode 100644 index 0000000..d92f9a9 --- /dev/null +++ b/frontend/compare_constructor.icl @@ -0,0 +1,36 @@ +implementation module compare_constructor; + +equal_constructor :: !a !a ->Bool; +equal_constructor _ _ = code { + .inline equal_constructor + pushD_a 1 + pushD_a 0 + pop_a 2 + eqI + .end +}; + +less_constructor :: !a !a ->Bool; +less_constructor _ _ = code { + .inline less_constructor + pushD_a 1 + pushD_a 0 + pop_a 2 + ltI + .end +}; + +greater_constructor :: !a !a ->Bool; +greater_constructor _ _ = code { + .inline greater_constructor + pushD_a 1 + pushD_a 0 + pop_a 2 + gtI + .end +}; + + + + + diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl new file mode 100644 index 0000000..45c8d35 --- /dev/null +++ b/frontend/convertDynamics.dcl @@ -0,0 +1,7 @@ +definition module convertDynamics + +import syntax, transform, convertcases + +convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols + !*{#{# CheckedTypeDef}} !ImportedFunctions !*VarHeap !*TypeHeaps !*ExpressionHeap + -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl new file mode 100644 index 0000000..d046d72 --- /dev/null +++ b/frontend/convertDynamics.icl @@ -0,0 +1,528 @@ +implementation module convertDynamics + +import syntax, transform, utilities, convertcases + +:: *ConversionInfo = + { ci_predef_symb :: !*PredefinedSymbols + , ci_var_heap :: !*VarHeap + , ci_expr_heap :: !*ExpressionHeap + , ci_new_functions :: ![FunctionInfoPtr] + , ci_fun_heap :: !*FunctionHeap + , ci_next_fun_nr :: !Index + } + +:: ConversionInput = + { cinp_glob_type_inst :: !{! GlobalTCType} + , cinp_group_index :: !Int + } + +:: OpenedDynamic = + { opened_dynamic_expr :: Expression + , opened_dynamic_type :: Expression + } + +:: DefaultExpression :== Optional (BoundVar, [IndirectionVar]) //DefaultRecord +:: DefaultRecord = + { c_i :: BoundVar + , indirections :: [IndirectionVar] + } +:: BoundVariables :== [(FreeVar, AType)] +:: IndirectionVar :== BoundVar + +convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols + !*{#{# CheckedTypeDef}} !ImportedFunctions !*VarHeap !*TypeHeaps !*ExpressionHeap + -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) +convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs groups fun_defs predefined_symbols + imported_types imported_conses var_heap type_heaps expr_heap + #! nr_of_funs = size fun_defs + # (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions})) + = convert_groups 0 groups global_type_instances (fun_defs, { + ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap, + ci_new_functions = [], ci_fun_heap = newHeap, ci_next_fun_nr = nr_of_funs }) + (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap) + = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions groups imported_types imported_conses type_heaps ci_var_heap + = (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap) +where + convert_groups group_nr groups global_type_instances fun_defs_and_ci + | group_nr == size groups + = (groups, fun_defs_and_ci) + #! group = groups.[group_nr] + = convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci) + + convert_function group_nr global_type_instances fun (fun_defs, ci) + #! fun_def = fun_defs.[fun] + # {fun_body,fun_type} = fun_def + (fun_body, ci) = convert_dynamics_in_body {cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci + = ({fun_defs & [fun] = { fun_def & fun_body = fun_body }}, ci) + + convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_args}) ci + # vars_with_types = zip2 tb_args st_args + (tb_rhs, ci) = convertDynamics global_type_instances vars_with_types No tb_rhs ci + = (TransformedBody {tb_args = tb_args,tb_rhs = tb_rhs}, ci) + convert_dynamics_in_body global_type_instances other fun_type ci + = abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'" + + + +class convertDynamics a :: !ConversionInput !BoundVariables !DefaultExpression !a !*ConversionInfo -> (!a, !*ConversionInfo) + +instance convertDynamics [a] | convertDynamics a +where + convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression ![a] !*ConversionInfo -> (![a], !*ConversionInfo) | convertDynamics a + convertDynamics cinp bound_vars default_expr xs ci = mapSt (convertDynamics cinp bound_vars default_expr) xs ci + +instance convertDynamics (Optional a) | convertDynamics a +where + convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Optional a) !*ConversionInfo -> (!Optional a, !*ConversionInfo) | convertDynamics a + convertDynamics cinp bound_vars default_expr (Yes x) ci + # (x, ci) = convertDynamics cinp bound_vars default_expr x ci + = (Yes x, ci) + convertDynamics _ _ _ No ci + = (No, ci) + +instance convertDynamics (Bind a b) | convertDynamics a +where + convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Bind a b) !*ConversionInfo -> (!Bind a b, !*ConversionInfo) | convertDynamics a + convertDynamics cinp bound_vars default_expr binding=:{bind_src} ci + # (bind_src, ci) = convertDynamics cinp bound_vars default_expr bind_src ci + = ({binding & bind_src = bind_src}, ci) + +convertDynamicsOfAlgebraicPattern :: !ConversionInput !BoundVariables !DefaultExpression !(!AlgebraicPattern,[AType]) !*ConversionInfo -> (!AlgebraicPattern,!*ConversionInfo) +convertDynamicsOfAlgebraicPattern cinp bound_vars default_expr (algebraic_pattern=:{ap_vars, ap_expr}, arg_types_of_conses) ci + # (ap_expr, ci) = convertDynamics cinp (zipAppend2 ap_vars arg_types_of_conses bound_vars) default_expr ap_expr ci + = ({algebraic_pattern & ap_expr = ap_expr}, ci) + +instance convertDynamics BasicPattern +where + convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !BasicPattern !*ConversionInfo -> (!BasicPattern, !*ConversionInfo) + convertDynamics cinp bound_vars default_expr basic_pattern=:{bp_expr} ci + # (bp_expr, ci) = convertDynamics cinp bound_vars default_expr bp_expr ci + = ({basic_pattern & bp_expr = bp_expr}, ci) + + +instance convertDynamics Expression +where + convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !Expression !*ConversionInfo -> (!Expression, !*ConversionInfo) + convertDynamics cinp bound_vars default_expr (Var var) ci + = (Var var, ci) + convertDynamics cinp bound_vars default_expr (App appje=:{app_args}) ci + # (app_args,ci) = convertDynamics cinp bound_vars default_expr app_args ci + = (App {appje & app_args = app_args}, ci) + convertDynamics cinp bound_vars default_expr (expr @ exprs) ci + # (expr, ci) = convertDynamics cinp bound_vars default_expr expr ci + (exprs, ci) = convertDynamics cinp bound_vars default_expr exprs ci + = (expr @ exprs, ci) + convertDynamics cinp bound_vars default_expr (Let letje=:{let_binds, let_expr,let_info_ptr}) ci + # (let_types, ci) = determine_let_types let_info_ptr ci + bound_vars = zipAppend2 [ bind.bind_dst \\ bind <- let_binds ] let_types bound_vars + (let_binds, ci) = convertDynamics cinp bound_vars default_expr let_binds ci + (let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci + = (Let { letje & let_binds = let_binds, let_expr = let_expr}, ci) + where + determine_let_types let_info_ptr ci=:{ci_expr_heap} + # (EI_LetType let_types, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap + = (let_types, { ci & ci_expr_heap = ci_expr_heap }) + + convertDynamics cinp bound_vars default_expr (Case keesje=:{case_expr, case_guards, case_default, case_info_ptr}) ci + # (case_expr, ci) = convertDynamics cinp bound_vars default_expr case_expr ci + (case_default, ci) = convertDynamics cinp bound_vars default_expr case_default ci + (this_case_default, nested_case_default, ci) = determine_defaults case_default default_expr ci + (EI_CaseType {ct_cons_types, ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap + ci = { ci & ci_expr_heap = ci_expr_heap } + = case case_guards of + (AlgebraicPatterns type algebraic_patterns) + # (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default) + (zip2 algebraic_patterns ct_cons_types) ci + -> (Case {keesje & case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = this_case_default}, ci) + (BasicPatterns type basic_patterns) + # (basic_patterns, ci) = convertDynamics cinp bound_vars nested_case_default basic_patterns ci + -> (Case {keesje & case_expr = case_expr, case_guards = BasicPatterns type basic_patterns, case_default = this_case_default}, ci) + (DynamicPatterns dynamic_patterns) + # keesje = {keesje & case_expr = case_expr, case_default = this_case_default} + -> convertDynamicPatterns cinp bound_vars keesje ci + NoPattern + -> (Case {keesje & case_expr = case_expr, case_guards = NoPattern, case_default = this_case_default}, ci) + _ + -> abort "unexpected value in convertDynamics: 'convertDynamics.CasePatterns'" + convertDynamics cinp bound_vars default_expr (Selection opt_symb expression selections) ci + # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci + = (Selection opt_symb expression selections, ci) + convertDynamics cinp bound_vars default_expr (Update expression1 selections expression2) ci + # (expression1,ci) = convertDynamics cinp bound_vars default_expr expression1 ci + # (expression2,ci) = convertDynamics cinp bound_vars default_expr expression2 ci + = (Update expression1 selections expression2, ci) + convertDynamics cinp bound_vars default_expr (RecordUpdate cons_symbol expression expressions) ci + # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci + # (expressions,ci) = convertDynamics cinp bound_vars default_expr expressions ci + = (RecordUpdate cons_symbol expression expressions, ci) + convertDynamics cinp bound_vars default_expr (TupleSelect definedSymbol int expression) ci + # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci + = (TupleSelect definedSymbol int expression, ci) + convertDynamics _ _ _ (BasicExpr basicValue basicType) ci + = (BasicExpr basicValue basicType, ci) + convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci + = (AnyCodeExpr codeBinding1 codeBinding2 strings, ci) + convertDynamics _ _ _ (ABCCodeExpr strings bool) ci + = (ABCCodeExpr strings bool, ci) + convertDynamics cinp bound_vars default_expr (MatchExpr opt_symb symb expression) ci + # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci + = (MatchExpr opt_symb symb expression, ci) + convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_uni_vars, dyn_type_code}) ci + # (twoTuple_symb, ci) = getSymbol (GetTupleConsIndex 2) SK_Constructor 2 ci + (let_binds, ci) = createVariables dyn_uni_vars [] ci + (dyn_expr, ci) = convertDynamics cinp bound_vars default_expr dyn_expr ci + (dyn_type_code, ci) = convertTypecode cinp dyn_type_code ci + = case let_binds of + [] -> (App { app_symb = twoTuple_symb, + app_args = [dyn_expr, dyn_type_code], + app_info_ptr = nilPtr }, ci) + _ # (let_info_ptr, ci) = let_ptr ci + -> ( Let { let_strict = False, + let_binds = let_binds, + let_expr = App { app_symb = twoTuple_symb, + app_args = [dyn_expr, dyn_type_code], + app_info_ptr = nilPtr }, + let_info_ptr = let_info_ptr}, ci) + convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci + = convertTypecode cinp type_code ci + convertDynamics cinp bound_vars default_expr EE ci + = (EE, ci) + convertDynamics cinp bound_vars default_expr expression ci + = abort "unexpected value in convertDynamics: 'convertDynamics.Expression'" + +convertTypecode :: !ConversionInput TypeCodeExpression !*ConversionInfo -> (Expression,!*ConversionInfo) +convertTypecode cinp TCE_Empty ci + = (EE, ci) +convertTypecode cinp (TCE_Var var_info_ptr) ci + = (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, ci) +convertTypecode cinp (TCE_Constructor index typecode_exprs) ci + # (typecons_symb, ci) = getSymbol PD_TypeConsSymbol SK_Constructor 2 ci + constructor = get_constructor cinp.cinp_glob_type_inst index + (typecode_exprs, ci) = convertTypecodes cinp typecode_exprs ci + = (App {app_symb = typecons_symb, + app_args = [constructor , typecode_exprs], + app_info_ptr = nilPtr}, ci) +convertTypecode cinp (TCE_Selector selections var_info_ptr) ci + = (Selection No (Var { var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selections, ci) + +convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo -> (Expression,!*ConversionInfo) +convertTypecodes _ [] ci + # (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci + = (App { app_symb = nil_symb, + app_args = [], + app_info_ptr = nilPtr}, ci) +convertTypecodes cinp [typecode_expr : typecode_exprs] ci + # (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci + (expr, ci) = convertTypecode cinp typecode_expr ci + (exprs, ci) = convertTypecodes cinp typecode_exprs ci + = (App { app_symb = cons_symb, + app_args = [expr , exprs], + app_info_ptr = nilPtr}, ci) + + +determine_defaults :: (Optional Expression) DefaultExpression !*ConversionInfo -> (Optional Expression, DefaultExpression, !*ConversionInfo) +/*** +determine_defaults :: case_default default_expr varheap -> (this_case_default, nested_case_default, var_heap) + this_case_default = IF this case has no default, but there is a surrounding default + THEN that is now the default and its reference count must be increased. + ELSE it keeps this default + nested_case_default = IF this case has no default + THEN the deault_expr remains default in the nested cases. + ELSE nested cases get this default. This is semantically already the case, so nothing has to be changed. +***/ +determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap} + #! var_info = sreadPtr var_info_ptr ci_var_heap + # (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap} + = case var_info of + VI_Default ref_count + -> (expression, default_expr, {ci & ci_var_heap = ci.ci_var_heap <:= (var_info_ptr, VI_Default (inc ref_count))} ) + _ + -> (expression, default_expr, ci ) +determine_defaults case_default _ ci + = (case_default, No, ci) + + +add_dynamic_bound_vars :: ![DynamicPattern] BoundVariables -> BoundVariables +add_dynamic_bound_vars [] bound_vars = bound_vars +add_dynamic_bound_vars [{dp_var, dp_type_patterns_vars} : patterns] bound_vars + = add_dynamic_bound_vars patterns [(dp_var, empty_attributed_type) : mapAppend bind_info_ptr dp_type_patterns_vars bound_vars] +where + bind_info_ptr var_info_ptr + = ({fv_def_level = NotALevel, fv_name = a_ij_var_name, fv_info_ptr = var_info_ptr, fv_count = 0}, empty_attributed_type) + + +open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, Bind Expression FreeVar, !*ConversionInfo) +open_dynamic dynamic_expr ci + # (twotuple, ci) = getTupleSymbol 2 ci + (dynamicType_var, ci) = newVariable "dt" VI_Empty ci + = ( { opened_dynamic_expr = TupleSelect twotuple 0 dynamic_expr, opened_dynamic_type = Var dynamicType_var }, + { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = varToFreeVar dynamicType_var 0 }, + ci) + +/**************************************************************************************************/ + +convertDynamicPatterns :: !ConversionInput !BoundVariables !Case *ConversionInfo -> (Expression, *ConversionInfo) +convertDynamicPatterns cinp bound_vars {case_guards = DynamicPatterns [], case_default} ci + = case case_default of + (Yes expr) -> (expr, ci) + No -> abort "unexpected value in convertDynamics: 'convertDynamicPatterns'" +convertDynamicPatterns cinp bound_vars {case_expr, case_guards = DynamicPatterns patterns, case_default, case_info_ptr} ci + # (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci + (ind_0, ci) = newVariable "ind_0" VI_Empty ci + (c_1, ci) = newVariable "c_1" (VI_Default 0) ci + new_default = newDefault c_1 ind_0 + (result_type, ci) = getResultType case_info_ptr ci + bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type + (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars))) + (binds, expr, ci) = convertDynamicPattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci + (let_info_ptr, ci) = let_ptr ci + = (Let {let_strict = False, let_binds = [ dt_bind : binds ], let_expr = expr, let_info_ptr = let_info_ptr}, ci) + +convertDynamicPattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo -> (Env Expression FreeVar, Expression, *ConversionInfo) +convertDynamicPattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default + [{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci + # /*** The last case may noy have a default ***/ + ind_var = getIndirectionVar this_default + this_default = if (isEmpty patterns && (isNo last_default)) No this_default + + /*** convert the elements of this pattern ***/ + x_i_bind = { bind_src = opened_dynamic.opened_dynamic_expr, bind_dst = dp_var } + (a_ij_binds, ci) = createVariables dp_type_patterns_vars [] ci + (type_code, ci) = convertTypecode cinp dp_type_code ci + (dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci + + /*** recursively convert the other patterns ***/ + (binds, ci) = convertOtherPatterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci + + /*** generate the expression ***/ + (unify_symb, ci) = getSymbol PD_unify SK_Function 2 ci + (twotuple, ci) = getTupleSymbol 2 ci + (let_info_ptr, ci) = let_ptr ci + (case_info_ptr, ci) = case_ptr ci + (default_expr, ci) = toExpression this_default ci + (unify_result, ci) = newVariable "result" VI_Empty ci + (unify_bool, ci) = newVariable "unify_bool" VI_Empty ci + let_expr = Let { let_strict = False, + let_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, + bind_dst = varToFreeVar unify_result 0 }, + { bind_src = TupleSelect twotuple 0 (Var unify_result), + bind_dst = varToFreeVar unify_bool 0 }, + { bind_src = TupleSelect twotuple 1 (Var unify_result), + bind_dst = varToFreeVar ind_var 0 } + ], + let_expr = Case { case_expr = Var unify_bool, + case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}], + case_default = default_expr, + case_ident = No, + case_info_ptr = case_info_ptr }, + let_info_ptr = let_info_ptr } + = ([x_i_bind : a_ij_binds ++ binds], let_expr, ci) + +convertOtherPatterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo -> (Env Expression FreeVar, *ConversionInfo) +convertOtherPatterns _ _ _ _ _ _ No [] ci + = ([], ci) +convertOtherPatterns cinp bound_vars this_default _ _ result_type (Yes last_default_expr) [] ci + # c_i = getVariable this_default + (c_bind, ci) = generateBinding cinp bound_vars c_i last_default_expr result_type ci + = ([c_bind], ci) +convertOtherPatterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci + # (ind_i, ci) = newVariable ("ind_"+++toString (pattern_number)) VI_Empty ci + (c_inc_i, ci) = newVariable ("c_"+++toString (inc pattern_number)) (VI_Default 0) ci + new_default = newDefault c_inc_i ind_i + bound_vars = addToBoundVars ind_i empty_attributed_type (addToBoundVars c_inc_i result_type bound_vars) + (binds, expr, ci) = convertDynamicPattern cinp bound_vars new_default (inc pattern_number) opened_dynamic result_type last_default patterns ci + c_i = getVariable this_default + (c_bind, ci) = generateBinding cinp bound_vars c_i expr result_type ci + = ([c_bind : binds], ci) + +generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo) +generateBinding cinp bound_vars var bind_expr result_type ci + # (ref_count, ci) = get_reference_count var ci + | ref_count == 0 + = ({ bind_src = bind_expr, bind_dst = varToFreeVar var 1}, ci) + # (saved_defaults, ci_var_heap) = foldSt save_default bound_vars ([], ci.ci_var_heap) + (act_args, free_typed_vars, tb_rhs, ci_var_heap) = copyExpression bound_vars bind_expr ci_var_heap + ci_var_heap = foldSt restore_default saved_defaults ci_var_heap + tb_args = [ arg \\ (arg, _) <- free_typed_vars ] + arg_types = [ type \\ (_, type) <- free_typed_vars ] + (fun_symb, (ci_next_fun_nr, ci_new_functions, ci_fun_heap)) + = newFunction No (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}) arg_types result_type cinp.cinp_group_index + (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) + = ({ bind_src = App { app_symb = fun_symb, + app_args = act_args, + app_info_ptr = nilPtr }, + bind_dst = varToFreeVar var (inc ref_count) }, + { ci & ci_var_heap = ci_var_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions, ci_fun_heap = ci_fun_heap }) + where + get_reference_count {var_name,var_info_ptr} ci=:{ci_var_heap} + # (info, ci_var_heap) = readPtr var_info_ptr ci_var_heap + ci = { ci & ci_var_heap = ci_var_heap } + = case info of + VI_Default ref_count -> (ref_count, ci) +// _ -> (0, ci) ---> ("get_reference_count", var_name) /* A predicted variable always has a ref_count */ + + save_default ({fv_info_ptr},_) (saved_defaults, ci_var_heap) + # (info, ci_var_heap) = readPtr fv_info_ptr ci_var_heap + = case info of + VI_Default ref_count -> ([(fv_info_ptr, ref_count) : saved_defaults] , ci_var_heap) + _ -> (saved_defaults, ci_var_heap) + + restore_default (var_info_ptr,ref_count) ci_var_heap + = ci_var_heap <:= (var_info_ptr, VI_Default ref_count) + + +/**************************************************************************************************/ + +createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo) +createVariables var_info_ptrs binds ci + = mapAppendSt create_variable var_info_ptrs binds ci +where + create_variable :: VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) + create_variable var_info_ptr ci + # (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci + cyclic_var = {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} + = ({ bind_src = App { app_symb = placeholder_symb, + app_args = [Var cyclic_var, Var cyclic_var], + app_info_ptr = nilPtr }, + bind_dst = varToFreeVar cyclic_var 1 + }, + ci) + +/**************************************************************************************************/ + +newVariable :: String !VarInfo !*ConversionInfo -> *(!BoundVar,!*ConversionInfo) +newVariable var_name var_info ci=:{ci_var_heap} + # (var_info_ptr, ci_var_heap) = newPtr var_info ci_var_heap + = ( { var_name = {id_name = var_name, id_info = nilPtr}, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, + { ci & ci_var_heap = ci_var_heap }) + + +newDefault :: BoundVar IndirectionVar -> DefaultExpression +newDefault variable indirection_var = Yes (variable, [indirection_var]) + +getVariable :: DefaultExpression -> BoundVar +getVariable (Yes (variable, _)) = variable +getVariable No = abort "unexpected value in convertDynamics: 'getVariable'" + +getIndirectionVar (Yes (_, [ind_var:_])) = ind_var +getIndirectionVar No = abort "unexpected value in convertDynamics: 'getIndirectionVar'" + +toExpression :: DefaultExpression !*ConversionInfo -> (Optional Expression, !*ConversionInfo) +toExpression No ci = (No, ci) +toExpression (Yes (variable, indirection_var_list)) ci + # (expression, ci) = toExpression2 variable indirection_var_list ci + = (Yes expression, ci) +where + toExpression2 variable [] ci = (Var variable, ci) + toExpression2 variable [indirection_var : indirection_vars] ci + # (expression, ci) = toExpression2 variable indirection_vars ci + (undo_symb, ci) = getSymbol PD_undo_indirections SK_Function 2 ci + = (App { app_symb = undo_symb, + app_args = [expression, Var indirection_var], + app_info_ptr = nilPtr }, ci) + +varToFreeVar :: BoundVar Int -> FreeVar +varToFreeVar {var_name, var_info_ptr} count + = {fv_def_level = NotALevel, fv_name = var_name, fv_info_ptr = var_info_ptr, fv_count = count} + +freeVarToVar :: FreeVar -> BoundVar +freeVarToVar {fv_name, fv_info_ptr} + = { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} + + +addToBoundVars :: BoundVar AType BoundVariables -> BoundVariables +addToBoundVars var type bound_vars + = [ (varToFreeVar var 0, type) : bound_vars ] + + +get_constructor :: !{!GlobalTCType} Index -> Expression +get_constructor glob_type_inst index + = BasicExpr (BVS ("\"" +++ toString glob_type_inst.[index] +++ "\"")) (BT_String TE) + + +instance toString GlobalTCType +where + toString (GTT_Basic basic_type) = toString basic_type + toString GTT_Function = " -> " + toString (GTT_Constructor type_symb_indent) = type_symb_indent.type_name.id_name + +instance toString BasicType +where + toString BT_Int = "Int" + toString BT_Char = "Char" + toString BT_Real = "Real" + toString BT_Bool = "Bool" + toString BT_Dynamic = "Dynamic" + toString BT_File = "File" + toString BT_World = "World" + toString (BT_String _) = "String" + + +getResultType :: ExprInfoPtr !*ConversionInfo -> (!AType, !*ConversionInfo) +getResultType case_info_ptr ci=:{ci_expr_heap} + # (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap + = (ct_result_type, {ci & ci_expr_heap = ci_expr_heap}) + +getSymbol :: Index ((Global Index) -> SymbKind) Int !*ConversionInfo -> (SymbIdent, !*ConversionInfo) +getSymbol index symb_kind arity ci=:{ci_predef_symb} + # ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![index] + ci = {ci & ci_predef_symb = ci_predef_symb} + symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity } + = (symbol, ci) + +getTupleSymbol arity ci=:{ci_predef_symb} + # ({pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![GetTupleConsIndex arity] + = ( {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}, {ci & ci_predef_symb = ci_predef_symb }) + +getGlobalIndex :: Index !*ConversionInfo -> (Global Index, !*ConversionInfo) +getGlobalIndex index ci=:{ci_predef_symb} + # ({pds_module, pds_def}, ci_predef_symb) = ci_predef_symb![index] + = ( { glob_module = pds_module, glob_object = pds_def} , {ci & ci_predef_symb = ci_predef_symb} ) + +getConstructor :: Index Int !*ConversionInfo -> (Global DefinedSymbol, !*ConversionInfo) +getConstructor index arity ci=:{ci_predef_symb} + # ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![index] + defined_symbol = { ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def} + = ( {glob_object = defined_symbol, glob_module = pds_module} , {ci & ci_predef_symb = ci_predef_symb} ) + + +a_ij_var_name :== { id_name = "a_ij", id_info = nilPtr } + +case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo) +case_ptr ci=:{ci_expr_heap} + # (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType { ct_pattern_type = empty_attributed_type, + ct_result_type = empty_attributed_type, + ct_cons_types = repeat (repeat empty_attributed_type)}) ci_expr_heap + = (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap}) + +let_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo) +let_ptr ci=:{ci_expr_heap} + # (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeat empty_attributed_type)) ci_expr_heap + = (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap}) + + +empty_attributed_type :: AType +empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE } + + + +isNo :: (Optional a) -> Bool +isNo (Yes _) = False +isNo No = True + +zipAppend2 :: [.a] [.b] u:[w:(.a,.b)] -> v:[x:(.a,.b)], [w <= x, u <= v] +zipAppend2 [] ys zs = zs +zipAppend2 xs [] zs = zs +zipAppend2 [x : xs] [y : ys] zs = [ (x,y) : zipAppend2 xs ys zs ] + + +instance <<< FreeVar +where + (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '[' <<< fv_info_ptr <<< ']' + +instance <<< Ptr a +where + (<<<) file ptr = file <<< ptrToInt ptr + + + diff --git a/frontend/convertcases.dcl b/frontend/convertcases.dcl new file mode 100644 index 0000000..d7b2cf2 --- /dev/null +++ b/frontend/convertcases.dcl @@ -0,0 +1,28 @@ +definition module convertcases + +import syntax, transform, trans + +:: ImportedFunctions :== [Global Index] + +convertCasesOfFunctionsIntoPatterns :: !*{! Group} !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} + !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap + -> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) + +convertImportedTypeSpecifications :: !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions + !*{# {#CheckedTypeDef}} !*TypeHeaps !*VarHeap -> (!*{#{#CheckedTypeDef}}, !*TypeHeaps, !*VarHeap) + +convertDclModule :: !{# DclModule} !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps + -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) + +convertIclModule :: !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps + -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) + + +newFunction :: !(Optional Ident) !FunctionBody ![AType] !AType !Int !(!Int, ![FunctionInfoPtr],!*FunctionHeap) + -> (! SymbIdent, !(!Int, ![FunctionInfoPtr],!*FunctionHeap)) + +copyExpression :: ![(FreeVar,AType)] !Expression !*VarHeap -> (![Expression], ![.(FreeVar,AType)], !Expression, !*VarHeap) + +addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap + -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl new file mode 100644 index 0000000..b4be642 --- /dev/null +++ b/frontend/convertcases.icl @@ -0,0 +1,1456 @@ +implementation module convertcases + +import syntax, transform, checksupport, StdCompare, check, utilities, trans, general, RWSDebug + + +:: *ConversionInfo = + { ci_new_functions :: ![FunctionInfoPtr] + , ci_fun_heap :: !*FunctionHeap + , ci_var_heap :: !*VarHeap + , ci_expr_heap :: !*ExpressionHeap + , ci_next_fun_nr :: !Index + } + +getIdent (Yes ident) fun_nr + = ident +getIdent No fun_nr + = { id_name = "_f" +++ toString fun_nr, id_info = nilPtr } + + +class convertCases a :: ![(FreeVar, AType)] !Index !{# CommonDefs } !a !*ConversionInfo -> (!a, !*ConversionInfo) + +instance convertCases [a] | convertCases a +where + convertCases bound_vars group_index common_defs l ci = mapSt (convertCases bound_vars group_index common_defs) l ci + +instance convertCases (a,b) | convertCases a & convertCases b +where + convertCases bound_vars group_index common_defs t ci + = app2St (convertCases bound_vars group_index common_defs, convertCases bound_vars group_index common_defs) t ci + +instance convertCases Bind a b | convertCases a +where + convertCases bound_vars group_index common_defs bind=:{bind_src} ci + # (bind_src, ci) = convertCases bound_vars group_index common_defs bind_src ci + = ({ bind & bind_src = bind_src }, ci) + +instance convertCases DynamicExpr +where + convertCases bound_vars group_index common_defs dynamik=:{dyn_expr} ci + # (dyn_expr, ci) = convertCases bound_vars group_index common_defs dyn_expr ci + = ({ dynamik & dyn_expr = dyn_expr }, ci) + +instance convertCases Let +where + convertCases bound_vars group_index common_defs lad=:{let_binds,let_expr,let_info_ptr} ci=:{ci_expr_heap} + # (let_info, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap + ci = { ci & ci_expr_heap = ci_expr_heap } + = case let_info of + EI_LetType let_type + # ((let_binds,let_expr), ci) = convertCases (addLetVars let_binds let_type bound_vars) group_index common_defs (let_binds,let_expr) ci + -> ({ lad & let_binds = let_binds, let_expr = let_expr }, ci) + _ + -> abort "convertCases [Let] (convertcases 53)" <<- let_info + +addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars + = addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ] +addLetVars [] _ bound_vars + = bound_vars + +instance convertCases Expression +where + convertCases bound_vars group_index common_defs (App app=:{app_args}) ci + # (app_args, ci) = convertCases bound_vars group_index common_defs app_args ci + = (App {app & app_args = app_args}, ci) + convertCases bound_vars group_index common_defs (fun_expr @ exprs) ci + # ((fun_expr, exprs), ci) = convertCases bound_vars group_index common_defs (fun_expr, exprs) ci + = (fun_expr @ exprs, ci) + convertCases bound_vars group_index common_defs (Let lad) ci + # (lad, ci) = convertCases bound_vars group_index common_defs lad ci + = (Let lad, ci) + convertCases bound_vars group_index common_defs (MatchExpr opt_tuple constructor expr) ci + # (expr, ci) = convertCases bound_vars group_index common_defs expr ci + = (MatchExpr opt_tuple constructor expr, ci) + convertCases bound_vars group_index common_defs (Selection is_unique expr selectors) ci + # (expr, ci) = convertCases bound_vars group_index common_defs expr ci + (selectors, ci) = convertCases bound_vars group_index common_defs selectors ci + = (Selection is_unique expr selectors, ci) + convertCases bound_vars group_index common_defs (Update expr1 selectors expr2) ci + # (expr1, ci) = convertCases bound_vars group_index common_defs expr1 ci + (selectors, ci) = convertCases bound_vars group_index common_defs selectors ci + (expr2, ci) = convertCases bound_vars group_index common_defs expr2 ci + = (Update expr1 selectors expr2, ci) + convertCases bound_vars group_index common_defs (RecordUpdate cons_symbol expression expressions) ci + # (expression, ci) = convertCases bound_vars group_index common_defs expression ci + (expressions, ci) = convertCases bound_vars group_index common_defs expressions ci + = (RecordUpdate cons_symbol expression expressions, ci) + convertCases bound_vars group_index common_defs (TupleSelect tuple_symbol arg_nr expr) ci + # (expr, ci) = convertCases bound_vars group_index common_defs expr ci + = (TupleSelect tuple_symbol arg_nr expr, ci) + convertCases bound_vars group_index common_defs (Case case_expr) ci + = convertCasesInCaseExpression bound_vars group_index common_defs cHasNoDefault case_expr ci + convertCases bound_vars group_index common_defs (DynamicExpr dynamik) ci + # (dynamik, ci) = convertCases bound_vars group_index common_defs dynamik ci + = (DynamicExpr dynamik, ci) + convertCases bound_vars group_index common_defs expr ci + = (expr, ci) + +instance convertCases Selection +where + convertCases bound_vars group_index common_defs (DictionarySelection record selectors expr_ptr index_expr) ci + # (index_expr, ci) = convertCases bound_vars group_index common_defs index_expr ci + (selectors, ci) = convertCases bound_vars group_index common_defs selectors ci + = (DictionarySelection record selectors expr_ptr index_expr, ci) + convertCases bound_vars group_index common_defs (ArraySelection selector expr_ptr index_expr) ci + # (index_expr, ci) = convertCases bound_vars group_index common_defs index_expr ci + = (ArraySelection selector expr_ptr index_expr, ci) + convertCases bound_vars group_index common_defs selector ci + = (selector, ci) + +cHasNoDefault :== nilPtr + +convertDefaultToExpression default_ptr (EI_Default expr type prev_default) bound_vars group_index common_defs ci=:{ci_var_heap} + # (act_args, free_typed_vars, expression, ci_var_heap) = copyExpression bound_vars expr ci_var_heap + (fun_symb, ci) = newDefaultFunction free_typed_vars expression type prev_default group_index common_defs { ci & ci_var_heap = ci_var_heap } + = (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, + { ci & ci_expr_heap = ci.ci_expr_heap <:= (default_ptr, EI_DefaultFunction fun_symb act_args)}) +convertDefaultToExpression default_ptr (EI_DefaultFunction fun_symb act_args) bound_vars group_index common_defs ci + = (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, ci) + +combineDefaults default_ptr No bound_vars guards group_index common_defs ci=:{ci_expr_heap} + | isNilPtr default_ptr + = (No, ci) + | case_is_partial guards common_defs + # (default_info, ci_expr_heap) = readPtr default_ptr ci_expr_heap + (default_expr, ci) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs { ci & ci_expr_heap = ci_expr_heap } + = (Yes default_expr, ci) + = (No, ci) +where + case_is_partial (AlgebraicPatterns {glob_module, glob_object} patterns) common_defs + # {td_rhs} = common_defs.[glob_module].com_type_defs.[glob_object] + = length patterns < nr_of_alternatives td_rhs + where + nr_of_alternatives (AlgType conses) + = length conses + nr_of_alternatives _ + = 1 + + case_is_partial (BasicPatterns BT_Bool bool_patterns) common_defs + = length bool_patterns < 2 + case_is_partial patterns common_defs + = True + +combineDefaults default_ptr this_default bound_vars guards group_index common_defs ci + = (this_default, ci) + + +retrieveVariable (var_info_ptr, type) (bound_vars, free_typed_vars, var_heap) + # (VI_FreeVar name new_ptr count type, var_heap) = readPtr var_info_ptr var_heap + = ( [Var { var_name = name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : bound_vars], + [({ fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count }, type) : free_typed_vars], var_heap) + +copyCaseExpression bound_vars opt_variable guards_and_default var_heap + # var_heap = foldSt (\({fv_name,fv_info_ptr},type) -> writePtr fv_info_ptr (VI_BoundVar type)) bound_vars var_heap + (opt_copied_var, var_heap) = copy_variable opt_variable var_heap + (expression, {cp_free_vars, cp_var_heap}) = copy guards_and_default ({ cp_free_vars = [], cp_var_heap = var_heap } + ==> ("copyCaseExpression", bound_vars, guards_and_default)) + (bound_vars, free_typed_vars, var_heap) = foldSt retrieveVariable cp_free_vars ([], [], cp_var_heap) + (opt_free_var, var_heap) = toOptionalFreeVar opt_copied_var var_heap + = (bound_vars, free_typed_vars, opt_free_var, expression, var_heap) +where + copy_variable (Yes (var=:{var_name,var_info_ptr}, var_type)) var_heap + # (new_info, var_heap) = newPtr VI_Empty var_heap + = (Yes (var_info_ptr, var_type), var_heap <:= (var_info_ptr, VI_FreeVar var_name new_info 0 var_type)) + copy_variable No var_heap + = (No, var_heap) + +copyExpression :: ![(FreeVar,AType)] !Expression !*VarHeap -> (![Expression], ![.(FreeVar,AType)], !Expression, !*VarHeap) +copyExpression bound_vars expression var_heap + # var_heap = foldSt (\({fv_name,fv_info_ptr},type) -> writePtr fv_info_ptr (VI_BoundVar type)) bound_vars var_heap + (expression, {cp_free_vars, cp_var_heap}) = copy expression { cp_free_vars = [], cp_var_heap = var_heap } + (bound_vars, free_typed_vars, var_heap) = foldSt retrieveVariable cp_free_vars ([], [], cp_var_heap) + = (bound_vars, free_typed_vars, expression, var_heap) + +convertCasesInCaseExpression bound_vars group_index common_defs default_ptr { case_expr, case_guards, case_default, case_ident, case_info_ptr} ci + # (case_default, ci) = combineDefaults default_ptr case_default bound_vars case_guards group_index common_defs ci + (case_expr, ci) = convertCases bound_vars group_index common_defs case_expr ci + (EI_CaseTypeAndRefCounts case_type ref_counts, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap + (act_vars, form_vars, opt_free_var, (case_guards, case_default), ci_var_heap) + = copyCaseExpression bound_vars (get_variable case_expr case_type.ct_pattern_type) (case_guards,case_default) ci.ci_var_heap + (fun_symb, ci) = newCaseFunction case_ident case_guards case_default case_type opt_free_var form_vars + group_index common_defs default_ptr { ci & ci_var_heap = ci_var_heap, ci_expr_heap = ci_expr_heap } + = (App { app_symb = fun_symb, app_args = [ case_expr : act_vars ], app_info_ptr = nilPtr }, ci) +where + get_variable (Var var) pattern_type + = Yes (var, pattern_type) + get_variable _ _ + = No + + +makePtrToDefault (Yes default_expr) type prev_default_ptr expr_heap + = newPtr (EI_Default default_expr type prev_default_ptr) expr_heap +makePtrToDefault No type prev_default_ptr expr_heap + = (cHasNoDefault, expr_heap) + + +convertDefault default_ptr opt_var left_vars right_vars group_index common_defs (fun_bodies, ci) + | isNilPtr default_ptr + = (fun_bodies, ci) + # (default_info, ci_expr_heap) = readPtr default_ptr ci.ci_expr_heap + = convert_default default_info opt_var left_vars right_vars group_index common_defs (fun_bodies, { ci & ci_expr_heap = ci_expr_heap}) +where + convert_default (EI_Default default_expr type prev_default) opt_var left_vars right_vars group_index common_defs (fun_bodies, ci) + # (bb_rhs, ci) = convertRootExpression (left_vars ++ consOptional opt_var right_vars) group_index common_defs prev_default default_expr ci + bb_args = build_args opt_var left_vars right_vars + = (fun_bodies ++ [{ bb_args = bb_args, bb_rhs = bb_rhs }], ci) + convert_default (EI_DefaultFunction fun_symb act_args) opt_var left_vars right_vars group_index common_defs (fun_bodies, ci) + # bb_args = build_args opt_var left_vars right_vars + bb_rhs = App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr } + = (fun_bodies ++ [{ bb_args = bb_args, bb_rhs = bb_rhs }], ci) + + build_args (Yes (var,type)) left_vars right_vars + = mapAppend typed_free_var_to_pattern left_vars [FP_Variable var : map typed_free_var_to_pattern right_vars] + build_args No left_vars right_vars + = mapAppend typed_free_var_to_pattern left_vars [FP_Empty : map typed_free_var_to_pattern right_vars] + + typed_free_var_to_pattern (free_var, type) = FP_Variable free_var + +newDefaultFunction free_vars rhs_expr result_type prev_default group_index common_defs ci + # (guarded_exprs, ci) = convertPatternExpression [] [free_vars] group_index common_defs prev_default rhs_expr ci + fun_bodies = map build_pattern guarded_exprs + arg_types = map (\(_,type) -> type) free_vars + (fun_symb, (ci_next_fun_nr, ci_new_functions, ci_fun_heap)) + = newFunction No (BackendBody fun_bodies) arg_types result_type group_index + (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) + = (fun_symb, { ci & ci_fun_heap = ci_fun_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions }) +where + build_pattern ([ right_patterns : _ ], bb_rhs) + = { bb_args = right_patterns, bb_rhs = bb_rhs } + +newCaseFunction opt_id patterns case_default {ct_result_type,ct_pattern_type,ct_cons_types} opt_var free_vars + group_index common_defs prev_default ci=:{ci_expr_heap} + # (default_ptr, ci_expr_heap) = makePtrToDefault case_default ct_result_type prev_default ci_expr_heap + (fun_bodies, ci) = convertPatterns patterns ct_cons_types opt_var [] free_vars default_ptr group_index common_defs { ci & ci_expr_heap = ci_expr_heap } + (fun_bodies, ci) = convertDefault default_ptr opt_var [] free_vars group_index common_defs (fun_bodies, ci) + (fun_symb, (ci_next_fun_nr, ci_new_functions, ci_fun_heap)) + = newFunction opt_id (BackendBody fun_bodies) [ct_pattern_type : map (\(_,type) -> type) free_vars] ct_result_type group_index + (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) + = (fun_symb, { ci & ci_fun_heap = ci_fun_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions }) + +newFunction :: !(Optional Ident) !FunctionBody ![AType] !AType !Int !(!Int, ![FunctionInfoPtr],!*FunctionHeap) + -> (! SymbIdent, !(!Int, ![FunctionInfoPtr],!*FunctionHeap)) +newFunction opt_id fun_bodies arg_types result_type group_index (ci_next_fun_nr, ci_new_functions, ci_fun_heap) + # (fun_def_ptr, ci_fun_heap) = newPtr FI_Empty ci_fun_heap + fun_id = getIdent opt_id ci_next_fun_nr + arity = length arg_types + fun_type = + { st_vars = [] + , st_args = arg_types + , st_arity = arity + , st_result = result_type + , st_context = [] + , st_attr_vars = [] + , st_attr_env = [] + } + + fun_def = + { fun_symb = fun_id + , fun_arity = arity + , fun_priority = NoPrio + , fun_body = fun_bodies + , fun_type = Yes fun_type + , fun_pos = NoPos + , fun_index = NoIndex + , fun_kind = FK_Function + , fun_lifted = 0 + , fun_info = { EmptyFunInfo & fi_group_index = group_index } + } + = ({ symb_name = fun_id, symb_kind = SK_GeneratedFunction fun_def_ptr ci_next_fun_nr, symb_arity = arity }, + (inc ci_next_fun_nr, [fun_def_ptr : ci_new_functions], + ci_fun_heap <:= (fun_def_ptr, FI_Function { gf_fun_def = fun_def, gf_instance_info = II_Empty, + gf_fun_index = ci_next_fun_nr, gf_cons_args = {cc_args = [], cc_size=0} }))) + + +consOptional (Yes x) xs = [x : xs] +consOptional No xs = xs + +getOptionalFreeVar (Yes (free_var,_)) = Yes free_var +getOptionalFreeVar No = No + +optionalToListofLists (Yes x) + = [[x]] +optionalToListofLists No + = [] + +hasOption (Yes _) = True +hasOption No = False + +convertPatterns (AlgebraicPatterns algtype patterns) cons_types opt_var left_vars right_vars default_ptr group_index common_defs ci + # (guarded_exprs_list, ci) = mapSt (convert_algebraic_guard_into_function_pattern opt_var left_vars right_vars + group_index common_defs default_ptr) (zip2 patterns cons_types) ci + = (flatten guarded_exprs_list, ci) +where + convert_algebraic_guard_into_function_pattern opt_var left_vars right_vars group_index common_defs default_ptr ({ap_symbol, ap_vars, ap_expr}, cons_arg_types) ci + # pattern_vars = zip2 ap_vars cons_arg_types + (guarded_exprs, ci) + = convertPatternExpression (consOptional opt_var left_vars) [pattern_vars, right_vars] group_index common_defs default_ptr ap_expr ci + = (map (complete_pattern left_vars ap_symbol (getOptionalFreeVar opt_var)) guarded_exprs, ci) + where + complete_pattern left_vars cons_symbol optional_var ([ pattern_args, right_patterns : _ ], bb_rhs) + # bb_args = mapAppend selectFreeVar left_vars [FP_Algebraic cons_symbol pattern_args optional_var : right_patterns ] + = { bb_args = bb_args, bb_rhs = bb_rhs } +convertPatterns (BasicPatterns bastype patterns) cons_types opt_var left_vars right_vars default_ptr group_index common_defs ci + # (guarded_exprs_list, ci) = mapSt (convert_basic_guard_into_function_pattern opt_var left_vars right_vars + group_index common_defs default_ptr) patterns ci + = (flatten guarded_exprs_list, ci) +where + convert_basic_guard_into_function_pattern opt_var left_vars right_vars group_index common_defs default_ptr {bp_value, bp_expr} ci + # (guarded_exprs, ci) + = convertPatternExpression (consOptional opt_var left_vars) [right_vars] group_index common_defs default_ptr bp_expr ci + = (map (complete_pattern left_vars bp_value (getOptionalFreeVar opt_var)) guarded_exprs, ci) + where + complete_pattern left_vars value optional_var ([ right_patterns : _ ], bb_rhs) + # bb_args = mapAppend selectFreeVar left_vars [FP_Basic value optional_var : right_patterns ] + = { bb_args = bb_args, bb_rhs = bb_rhs } + +convertPatternExpression :: ![(FreeVar,AType)] ![[(FreeVar,AType)]] !Index !{#CommonDefs} !ExprInfoPtr !Expression !*ConversionInfo + -> *(![([[FunctionPattern]], !Expression)], !*ConversionInfo) +convertPatternExpression left_vars right_vars group_index common_defs default_ptr + case_expr=:(Case {case_expr = Var var=:{var_info_ptr}, case_guards, case_default, case_info_ptr}) ci + | list_contains_variable var_info_ptr right_vars + = case case_guards of + BasicPatterns type basic_patterns + # split_result = split_list_of_vars var_info_ptr [] right_vars + (default_patterns, ci) = convert_default left_vars split_result group_index common_defs case_default ci + (guarded_exprs, ci) = mapSt (convert_basic_guard_into_function_pattern left_vars split_result group_index common_defs) basic_patterns ci + -> (flatten guarded_exprs ++ default_patterns, ci) + AlgebraicPatterns type algebraic_patterns + # (EI_CaseTypeAndRefCounts {ct_cons_types} _, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap + split_result = split_list_of_vars var_info_ptr [] right_vars + (default_patterns, ci) = convert_default left_vars split_result group_index common_defs case_default { ci & ci_expr_heap = ci_expr_heap } + (guarded_exprs, ci) = mapSt (convert_algebraic_guard_into_function_pattern left_vars split_result group_index common_defs case_info_ptr) + (zip2 algebraic_patterns ct_cons_types) ci + -> (flatten guarded_exprs ++ default_patterns, ci) + _ + -> convertToRhsExpression left_vars right_vars group_index common_defs default_ptr case_expr ci + = convertToRhsExpression left_vars right_vars group_index common_defs default_ptr case_expr ci +where + list_contains_variable var_info_ptr [] + = False + list_contains_variable var_info_ptr [ right_vars : list_of_right_vars ] + = contains_variable var_info_ptr right_vars || list_contains_variable var_info_ptr list_of_right_vars + where + contains_variable var_info_ptr [] + = False + contains_variable var_info_ptr [ ({fv_info_ptr},_) : right_vars ] + = var_info_ptr == fv_info_ptr || contains_variable var_info_ptr right_vars + + convert_default left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs (Yes default_expr) ci + # (guarded_exprs, ci) + = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) list_of_right group_index common_defs default_ptr default_expr ci + = (map (complete_pattern list_of_left fv) guarded_exprs, ci) + where + complete_pattern list_of_left this_var (list_of_patterns, expr) + = (complete_patterns list_of_left (FP_Variable this_var) list_of_patterns, expr) + convert_default left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs No ci + = ([], ci) + + convert_basic_guard_into_function_pattern left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs {bp_value, bp_expr} ci + # (guarded_exprs, ci) + = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) list_of_right group_index common_defs default_ptr bp_expr ci + = (map (complete_pattern list_of_left bp_value (Yes fv)) guarded_exprs, ci) + where + complete_pattern list_of_left value opt_var (list_of_patterns, expr) + = (complete_patterns list_of_left (FP_Basic value opt_var) list_of_patterns, expr) + + convert_algebraic_guard_into_function_pattern left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs case_info_ptr + ({ap_symbol, ap_vars, ap_expr}, arg_types) ci=:{ci_expr_heap} + # (guarded_exprs, ci) + = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) [ zip2 ap_vars arg_types : list_of_right ] + group_index common_defs default_ptr ap_expr { ci & ci_expr_heap = ci_expr_heap } + = (map (complete_pattern list_of_left ap_symbol (Yes fv)) guarded_exprs, ci) + where + complete_pattern :: ![[(FreeVar,a)]] !(Global DefinedSymbol) !(Optional !FreeVar) !([[FunctionPattern]], !b) -> (![[FunctionPattern]], !b) + complete_pattern list_of_left cons_symbol opt_var ([ patterns : list_of_patterns], expr) + = (complete_patterns list_of_left (FP_Algebraic cons_symbol patterns opt_var) list_of_patterns, expr) + + split_list_of_vars var_info_ptr list_of_left [ vars : list_of_vars ] + # (fv, left, list_of_left, list_of_right) = split_vars var_info_ptr [] list_of_left vars list_of_vars + = (fv, [left : list_of_left], list_of_right) + where + split_vars var_info_ptr left list_of_left [] list_of_vars + # (fv, list_of_left, list_of_right) = split_list_of_vars var_info_ptr list_of_left list_of_vars + = (fv, left, list_of_left, list_of_right) + + split_vars var_info_ptr left list_of_left [ this_var=:(fv,_) : vars ] list_of_vars + | var_info_ptr == fv.fv_info_ptr + = (this_var, left, list_of_left, [ vars : list_of_vars ]) + = split_vars var_info_ptr [this_var : left] list_of_left vars list_of_vars + + complete_patterns [ left_args ] current_pattern [ right_args : list_of_right_args ] + = [ add_free_vars left_args [current_pattern : right_args] : list_of_right_args ] + complete_patterns [ left_args : list_of_left_args ] current_pattern list_of_right_args + = [ add_free_vars left_args [] : complete_patterns list_of_left_args current_pattern list_of_right_args ] + + add_free_vars [(fv, _) : left_vars] right_vars + = add_free_vars left_vars [ FP_Variable fv : right_vars ] + add_free_vars [] right_vars + = right_vars + +convertPatternExpression left_vars right_vars group_index common_defs default_ptr expr ci + = convertToRhsExpression left_vars right_vars group_index common_defs default_ptr expr ci + +convertToRhsExpression left_vars right_vars group_index common_defs default_ptr expr ci + # (bb_rhs, ci) = convertRootExpression (left_vars ++ flatten right_vars) group_index common_defs default_ptr expr ci + = ([(map (map selectFreeVar) right_vars, bb_rhs)], ci) + +selectFreeVar (fv,_) = FP_Variable fv + +toFreeVar (var_info_ptr, _) var_heap + #! var_info = sreadPtr var_info_ptr var_heap + # (VI_FreeVar name new_ptr count type) = var_info + = (FP_Variable { fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count}, var_heap) + +toOptionalFreeVar (Yes (var_info_ptr, type)) var_heap + #! var_info = sreadPtr var_info_ptr var_heap + = case var_info of + VI_FreeVar name new_ptr count type + -> (Yes ({ fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count}, type), var_heap) + _ + -> (No, var_heap) +toOptionalFreeVar No var_heap + = (No, var_heap) + +:: ImportedFunctions :== [Global Index] + +addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap + -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) +addNewFunctionsToGroups common_defs fun_heap new_functions groups imported_types imported_conses type_heaps var_heap + = foldSt (add_new_function_to_group fun_heap common_defs) new_functions (groups, [], imported_types, imported_conses, type_heaps, var_heap) +where + + add_new_function_to_group :: !FunctionHeap !{# CommonDefs} !FunctionInfoPtr + !(!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + add_new_function_to_group fun_heap common_defs fun_ptr (groups, fun_defs, imported_types, imported_conses, type_heaps, var_heap) + # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap + group_index = gf_fun_def.fun_info.fi_group_index + (Yes ft) = gf_fun_def.fun_type + (ft, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft imported_types imported_conses type_heaps var_heap + #! group = groups.[group_index] + = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, + [ { gf_fun_def & fun_type = Yes ft }: fun_defs], imported_types, imported_conses, type_heaps, var_heap) + +convertCasesOfFunctionsIntoPatterns :: !*{! Group} !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} + !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap + -> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) +convertCasesOfFunctionsIntoPatterns groups dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap + #! nr_of_funs = size fun_defs + # (groups, (fun_defs, collected_imports, {ci_new_functions, ci_var_heap, ci_expr_heap, ci_fun_heap})) + = convert_groups 0 groups dcl_functions common_defs + (fun_defs, [], { ci_new_functions = [], ci_fun_heap = newHeap, ci_var_heap = var_heap, ci_expr_heap = expr_heap, ci_next_fun_nr = nr_of_funs }) + (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap) + = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions groups imported_types imported_conses type_heaps ci_var_heap +// = foldSt (add_new_function_to_group ci_fun_heap common_defs) ci_new_functions (groups, [], imported_types, imported_conses, type_heaps, ci_var_heap) + (imported_functions, imported_conses) = foldSt split collected_imports ([], imported_conses) + = (imported_functions, groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, + imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap) +where + convert_groups group_nr groups dcl_functions common_defs fun_defs_and_ci + | group_nr == size groups + = (groups, fun_defs_and_ci) + #! group = groups.[group_nr] + = convert_groups (inc group_nr) groups dcl_functions common_defs + (foldSt (convert_function group_nr dcl_functions common_defs) group.group_members fun_defs_and_ci) + + + convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, ci) + #! fun_def = fun_defs.[fun] + # {fun_body,fun_type} = fun_def + (fun_body, (collected_imports, ci)) = eliminate_code_sharing_in_function dcl_functions common_defs (fun_body ==> ("convert_function", fun_def.fun_symb)) (collected_imports, ci) + (fun_body, ci) = convert_cases_into_function_patterns fun_body fun_type group_index common_defs ci + = ({fun_defs & [fun] = { fun_def & fun_body = fun_body }}, collected_imports, ci) + + convert_cases_into_function_patterns (TransformedBody {tb_args,tb_rhs=Case {case_expr = Var var=:{var_info_ptr}, case_guards, case_default, case_info_ptr}}) + (Yes {st_result,st_args}) group_index common_defs ci=:{ci_expr_heap} + # (EI_CaseTypeAndRefCounts case_type _, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap + (default_ptr, ci_expr_heap) = makePtrToDefault case_default st_result cHasNoDefault ci_expr_heap + vars_with_types = zip2 tb_args st_args + (form_var_with_type, left_vars, right_vars) = split_vars var_info_ptr vars_with_types + (fun_bodies, ci) = convertPatterns case_guards case_type.ct_cons_types (Yes form_var_with_type) left_vars right_vars default_ptr group_index common_defs + { ci & ci_expr_heap = ci_expr_heap } + (fun_bodies, ci) = convertDefault default_ptr (Yes form_var_with_type) left_vars right_vars group_index common_defs (fun_bodies, ci) + = (BackendBody fun_bodies, ci) + where + split_vars var_info_ptr [ form_var_with_type=:({fv_info_ptr},_) : free_vars] + | var_info_ptr == fv_info_ptr + = (form_var_with_type, [], free_vars) + # (form_var, left, right) = split_vars var_info_ptr free_vars + = (form_var, [form_var_with_type : left], right) + convert_cases_into_function_patterns (TransformedBody {tb_args,tb_rhs}) (Yes {st_result,st_args}) group_index common_defs ci + # (tb_rhs, ci) = convertRootExpression (zip2 tb_args st_args) group_index common_defs cHasNoDefault tb_rhs ci + = (BackendBody [ { bb_args = map FP_Variable tb_args, bb_rhs = tb_rhs }], ci) + + eliminate_code_sharing_in_function dcl_functions common_defs (TransformedBody body=:{tb_rhs}) (collected_imports, ci=:{ci_expr_heap,ci_var_heap}) + # {rc_var_heap, rc_expr_heap, rc_imports} = weightedRefCount dcl_functions common_defs 1 tb_rhs + { rc_var_heap = ci_var_heap, rc_expr_heap = ci_expr_heap, rc_free_vars = [], rc_imports = collected_imports} + ==> ("eliminate_code_sharing_in_function (weightedRefCount)", tb_rhs) + (tb_rhs, {di_lets,di_var_heap,di_expr_heap}) = distributeLets 1 tb_rhs { di_lets = [], di_var_heap = rc_var_heap, di_expr_heap = rc_expr_heap} + (tb_rhs, (var_heap, expr_heap)) = buildLetExpr di_lets tb_rhs (di_var_heap,di_expr_heap) + = (TransformedBody { body & tb_rhs = tb_rhs }, (rc_imports, { ci & ci_var_heap = var_heap, ci_expr_heap = expr_heap })) + ==> ("eliminate_code_sharing_in_function (distributeLets)", tb_rhs) + + split (SK_Function fun_symb) (collected_functions, collected_conses) + = ([fun_symb : collected_functions], collected_conses) + split (SK_Constructor cons_symb) (collected_functions, collected_conses) + = (collected_functions, [ cons_symb : collected_conses]) + +convertDclModule :: !{# DclModule} !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps + -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) +convertDclModule dcl_mods common_defs imported_types imported_conses var_heap type_heaps + # {dcl_functions,dcl_common={com_type_defs,com_cons_defs,com_selector_defs},dcl_conversions} = dcl_mods.[cIclModIndex] + = case dcl_conversions of + Yes conversion_table + # (icl_type_defs, imported_types) = imported_types![cIclModIndex] + types_and_heaps = convert_dcl_functions dcl_functions common_defs ( { imported_types & [cIclModIndex] = com_type_defs }, imported_conses, var_heap, type_heaps) + types_and_heaps = convertConstructorTypes com_cons_defs common_defs types_and_heaps + (imported_types, imported_conses, var_heap, type_heaps) = convertSelectorTypes com_selector_defs common_defs types_and_heaps + -> ({ imported_types & [cIclModIndex] = icl_type_defs}, imported_conses, var_heap, type_heaps) + No + -> (imported_types, imported_conses, var_heap, type_heaps) +where + convert_dcl_functions dcl_functions common_defs types_and_heaps + = iFoldSt (convert_dcl_function dcl_functions common_defs) 0 (size dcl_functions) types_and_heaps + + convert_dcl_function dcl_functions common_defs dcl_index (imported_types, imported_conses, var_heap, type_heaps) + # {ft_type, ft_type_ptr} = dcl_functions.[dcl_index] + (ft_type, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft_type imported_types imported_conses type_heaps var_heap + = (imported_types, imported_conses, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type), type_heaps) + +convertConstructorTypes cons_defs common_defs types_and_heaps + = iFoldSt (convert_constructor_type common_defs cons_defs) 0 (size cons_defs) types_and_heaps +where + convert_constructor_type common_defs cons_defs cons_index (imported_types, imported_conses, var_heap, type_heaps) + # {cons_type_ptr, cons_type} = cons_defs.[cons_index] + (cons_type, imported_types, imported_conses, type_heaps, var_heap) + = convertSymbolType common_defs cons_type imported_types imported_conses type_heaps var_heap + = (imported_types, imported_conses, var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type), type_heaps) + + +convertSelectorTypes selector_defs common_defs types_and_heaps + = iFoldSt (convert_selector_type common_defs selector_defs) 0 (size selector_defs) types_and_heaps +where + convert_selector_type common_defs selector_defs sel_index (imported_types, imported_conses, var_heap, type_heaps) + # {sd_type_ptr, sd_type} = selector_defs.[sel_index] + (sd_type, imported_types, imported_conses, type_heaps, var_heap) + = convertSymbolType common_defs sd_type imported_types imported_conses type_heaps var_heap + = (imported_types, imported_conses, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type), type_heaps) + +convertIclModule :: !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps + -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) +convertIclModule common_defs imported_types imported_conses var_heap type_heaps + # types_and_heaps = convertConstructorTypes common_defs.[cIclModIndex].com_cons_defs common_defs (imported_types, imported_conses, var_heap, type_heaps) + = convertSelectorTypes common_defs.[cIclModIndex].com_selector_defs common_defs types_and_heaps + +convertImportedTypeSpecifications :: !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions + !*{# {#CheckedTypeDef}} !*TypeHeaps !*VarHeap -> (!*{#{#CheckedTypeDef}}, !*TypeHeaps, !*VarHeap) +convertImportedTypeSpecifications dcl_mods dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap + # {dcl_common={com_type_defs},dcl_conversions} = dcl_mods.[cIclModIndex] + = case dcl_conversions of + Yes conversion_table + # abstract_type_indexes = iFoldSt (determine_abstract_type com_type_defs) 0 (size com_type_defs) [] + | isEmpty abstract_type_indexes + -> convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap + # (icl_type_defs, imported_types) = imported_types![cIclModIndex] + type_defs = foldSt (insert_abstract_type conversion_table.[cTypeDefs]) abstract_type_indexes { icl_type_def \\ icl_type_def <-: icl_type_defs } + (imported_types, type_heaps, var_heap) + = convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions + { imported_types & [cIclModIndex] = type_defs } type_heaps var_heap + -> ({ imported_types & [cIclModIndex] = icl_type_defs }, type_heaps, var_heap) + No + -> convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap + + +where + determine_abstract_type dcl_type_defs type_index abstract_type_indexes + # {td_rhs} = dcl_type_defs.[type_index] + = case td_rhs of + AbstractType _ + -> [type_index : abstract_type_indexes] + _ + -> abstract_type_indexes + + insert_abstract_type conversion_table type_index type_defs + # icl_index = conversion_table.[type_index] + (type_def, type_defs) = type_defs![icl_index] + = { type_defs & [icl_index] = { type_def & td_rhs = AbstractType cAllBitsClear }} + + convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap + # (imported_types, imported_conses, type_heaps, var_heap) + = foldSt (convert_imported_function dcl_functions common_defs) imported_functions (imported_types, imported_conses, type_heaps, var_heap) + = convert_imported_constructors common_defs imported_conses imported_types type_heaps var_heap + + convert_imported_function dcl_functions common_defs {glob_object,glob_module} (imported_types, imported_conses, type_heaps, var_heap) + # {ft_type_ptr,ft_type} = dcl_functions.[glob_module].[glob_object] + (ft_type, imported_types, imported_conses, type_heaps, var_heap) + = convertSymbolType common_defs ft_type imported_types imported_conses type_heaps var_heap + = (imported_types, imported_conses, type_heaps, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type)) + + convert_imported_constructors common_defs [] imported_types type_heaps var_heap + = (imported_types, type_heaps, var_heap) + convert_imported_constructors common_defs [ {glob_module, glob_object} : conses ] imported_types type_heaps var_heap + # {com_cons_defs,com_selector_defs} = common_defs.[glob_module] + {cons_type_ptr,cons_type,cons_type_index} = common_defs.[glob_module].com_cons_defs.[glob_object] + (cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs cons_type imported_types conses type_heaps var_heap + var_heap = var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type) + ({td_rhs}, imported_types) = imported_types![glob_module].[cons_type_index] + = case td_rhs of + RecordType {rt_fields} + # (imported_types, conses, type_heaps, var_heap) + = iFoldSt (convert_type_of_imported_field glob_module com_selector_defs rt_fields) 0 (size rt_fields) + (imported_types, conses, type_heaps, var_heap) + -> convert_imported_constructors common_defs conses imported_types type_heaps var_heap + _ + -> convert_imported_constructors common_defs conses imported_types type_heaps var_heap + where + convert_type_of_imported_field module_index selector_defs fields field_index (imported_types, conses, type_heaps, var_heap) + # field_index = fields.[field_index].fs_index + {sd_type_ptr,sd_type} = selector_defs.[field_index] + (sd_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs sd_type imported_types conses type_heaps var_heap + = (imported_types, conses, type_heaps, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type)) + +convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_binds,let_expr,let_info_ptr}) ci=:{ci_expr_heap} + # (EI_LetType let_type, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap + bound_vars = addLetVars let_binds let_type bound_vars + (let_binds, ci) = convertCases bound_vars group_index common_defs let_binds { ci & ci_expr_heap = ci_expr_heap } + (let_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr let_expr ci + = (Let { lad & let_binds = let_binds, let_expr = let_expr }, ci) +convertRootExpression bound_vars group_index common_defs default_ptr (Case kees=:{case_expr, case_guards, case_default, case_info_ptr}) ci + = case case_guards of + BasicPatterns BT_Bool patterns + -> convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr case_expr patterns case_default case_info_ptr ci + _ + -> convertCasesInCaseExpression bound_vars group_index common_defs default_ptr kees ci + +where +/* + convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr guard [ alt : alts ] case_default case_info_ptr ci + # (guard, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault guard ci + (then_bool, then_expr, opt_else_expr) = check_reachability alt alts + = case opt_else_expr of + Yes else_expr + # (then_expr, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault then_expr ci + (else_expr, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault else_expr ci + -> (build_conditional then_bool guard then_expr else_expr, ci) + No + -> case case_default of + Yes default_expr + # (EI_CaseTypeAndRefCounts case_type ref_counts, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap + (default_ptr, ci_expr_heap) = makePtrToDefault case_default case_type.ct_result_type default_ptr ci_expr_heap + (then_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr then_expr { ci & ci_expr_heap = ci_expr_heap } + (default_info, ci_expr_heap) = readPtr default_ptr ci.ci_expr_heap + (else_expr, ci) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs + { ci & ci_expr_heap = ci_expr_heap } + -> (build_conditional then_bool guard then_expr else_expr, ci) + No + # (then_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr then_expr ci + | isNilPtr default_ptr + -> (Conditional { if_cond = convert_guard then_bool guard, if_then = then_expr, if_else = No }, ci) + # (default_info, ci_expr_heap) = readPtr default_ptr ci.ci_expr_heap + (else_expr, ci) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs + { ci & ci_expr_heap = ci_expr_heap } + -> (build_conditional then_bool guard then_expr else_expr, ci) + + convert_guard guard_bool guard + | guard_bool + = guard + = Conditional { if_cond = guard, if_then = BasicExpr (BVB False) BT_Bool, if_else = Yes (BasicExpr (BVB True) BT_Bool) } + + build_conditional then_bool guard then_expr else_expr + | then_bool + = Conditional { if_cond = guard, if_then = then_expr, if_else = Yes else_expr } + = Conditional { if_cond = guard, if_then = else_expr, if_else = Yes then_expr } + + + check_reachability {bp_value=BVB bool,bp_expr} alts + = (bool, bp_expr, check_other_alternatives bool alts) + where + check_other_alternatives then_bool [] + = No + check_other_alternatives then_bool [{bp_value=BVB else_bool,bp_expr} : alts ] + | then_bool == else_bool + = check_other_alternatives then_bool alts + = Yes bp_expr +*/ + +// convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr guard [ alt : alts ] case_default case_info_ptr ci + convert_boolean_case_into_guard bound_vars group_index common_defs has_default guard [ alt : alts ] case_default case_info_ptr ci + # (guard, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault guard ci + # (sign_of_then_part, then_part, ci) = convert_boolean_guard bound_vars group_index common_defs alt ci + (opt_else_part, ci) = convert_to_else_part bound_vars group_index common_defs has_default sign_of_then_part alts case_default ci +// = (Conditional { if_cond = { con_positive = sign_of_then_part, con_expression = guard }, if_then = then_part, if_else = opt_else_part }, ci) + = (build_conditional sign_of_then_part guard then_part opt_else_part, ci) + where + build_conditional True guard then_expr opt_else_expr + = Conditional { if_cond = guard, if_then = then_expr, if_else = opt_else_expr } + build_conditional false guard then_expr (Yes else_expr) + = Conditional { if_cond = guard, if_then = else_expr, if_else = Yes then_expr } + build_conditional false guard then_expr No + = Conditional { if_cond = Conditional { if_cond = guard, if_then = BasicExpr (BVB False) BT_Bool, if_else = Yes (BasicExpr (BVB True) BT_Bool) }, + if_then = then_expr, if_else = No } + + convert_to_else_part bound_vars group_index common_defs has_default sign_of_then_part [ alt : alts ] case_default ci + # (sign_of_else_part, else_part, ci) = convert_boolean_guard bound_vars group_index common_defs alt ci + | sign_of_then_part == sign_of_else_part + = convert_to_else_part bound_vars group_index common_defs has_default sign_of_then_part alts case_default ci + = (Yes else_part, ci) + convert_to_else_part bound_vars group_index common_defs has_default sign_of_then_part [ ] (Yes else_part) ci + # (else_part, ci) = convertRootExpression bound_vars group_index common_defs has_default else_part ci + = (Yes else_part, ci) + convert_to_else_part bound_vars group_index common_defs has_default sign_of_then_part [ ] No ci + = (No, ci) + + convert_boolean_guard bound_vars group_index common_defs {bp_value=BVB bool,bp_expr} ci + # (bp_expr, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault bp_expr ci + = (bool, bp_expr, ci) + + +convertRootExpression bound_vars group_index common_defs _ expr ci + = convertCases bound_vars group_index common_defs expr ci + + +:: CopyInfo = + { cp_free_vars :: ![(VarInfoPtr,AType)] + , cp_var_heap :: !.VarHeap + } + + +class copy e :: !e !*CopyInfo -> (!e, !*CopyInfo) + +instance copy BoundVar +where + copy var=:{var_name,var_info_ptr} cp_info=:{cp_free_vars, cp_var_heap} + #! var_info = sreadPtr var_info_ptr cp_var_heap + = case var_info of + VI_FreeVar name new_info_ptr count type + -> ({ var & var_info_ptr = new_info_ptr }, { cp_free_vars = cp_free_vars, + cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar name new_info_ptr (inc count) type)}) + VI_LocalVar + -> (var, {cp_free_vars = cp_free_vars, cp_var_heap = cp_var_heap}) + VI_BoundVar type + # (new_info_ptr, cp_var_heap) = newPtr VI_Empty cp_var_heap + -> ({ var & var_info_ptr = new_info_ptr }, { cp_free_vars = [ (var_info_ptr, type) : cp_free_vars ], + cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar var_name new_info_ptr 1 type) }) + _ + -> abort "copy [BoundVar] (convertcases, 612)" <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) + +instance copy Expression +where + copy (Var var) cp_info + # (var, cp_info) = copy var cp_info + = (Var var, cp_info) + copy (App app=:{app_args}) cp_info + # (app_args, cp_info) = copy app_args cp_info + = (App {app & app_args = app_args}, cp_info) + copy (fun_expr @ exprs) cp_info + # ((fun_expr, exprs), cp_info) = copy (fun_expr, exprs) cp_info + = (fun_expr @ exprs, cp_info) + copy (Let lad=:{let_binds,let_expr}) cp_info=:{cp_var_heap} + # ((let_binds,let_expr), cp_info) = copy (let_binds,let_expr) + { cp_info & cp_var_heap = foldSt (\{bind_dst={fv_info_ptr}} -> writePtr fv_info_ptr VI_LocalVar) let_binds cp_var_heap } + = (Let {lad & let_expr = let_expr, let_binds = let_binds }, cp_info) + copy (Case case_expr) cp_info + # (case_expr, cp_info) = copy case_expr cp_info + = (Case case_expr, cp_info) + copy expr=:(BasicExpr _ _) cp_info + = (expr, cp_info) + copy (MatchExpr opt_tuple constructor expr) cp_info + # (expr, cp_info) = copy expr cp_info + = (MatchExpr opt_tuple constructor expr, cp_info) + copy (Selection is_unique expr selectors) cp_info + # (expr, cp_info) = copy expr cp_info + (selectors, cp_info) = copy selectors cp_info + = (Selection is_unique expr selectors, cp_info) + copy (Update expr1 selectors expr2) cp_info + # (expr1, cp_info) = copy expr1 cp_info + (selectors, cp_info) = copy selectors cp_info + (expr2, cp_info) = copy expr2 cp_info + = (Update expr1 selectors expr2, cp_info) + copy (RecordUpdate cons_symbol expression expressions) cp_info + # (expression, cp_info) = copy expression cp_info + (expressions, cp_info) = copy expressions cp_info + = (RecordUpdate cons_symbol expression expressions, cp_info) + copy (TupleSelect tuple_symbol arg_nr expr) cp_info + # (expr, cp_info) = copy expr cp_info + = (TupleSelect tuple_symbol arg_nr expr, cp_info) + copy (DynamicExpr dynamik) cp_info + # (dynamik, cp_info) = copy dynamik cp_info + = (DynamicExpr dynamik, cp_info) + copy EE cp_info + = (EE, cp_info) + copy expr cp_info + = abort ("copy (Expression) does not match" ---> expr) + +instance copy Optional a | copy a +where + copy (Yes expr) cp_info + # (expr, cp_info) = copy expr cp_info + = (Yes expr, cp_info) + copy No cp_info + = (No, cp_info) + +instance copy Selection +where + copy (DictionarySelection record selectors expr_ptr index_expr) cp_info + # (index_expr, cp_info) = copy index_expr cp_info + (selectors, cp_info) = copy selectors cp_info + = (DictionarySelection record selectors expr_ptr index_expr, cp_info) + copy (ArraySelection selector expr_ptr index_expr) cp_info + # (index_expr, cp_info) = copy index_expr cp_info + = (ArraySelection selector expr_ptr index_expr, cp_info) + copy selector cp_info + = (selector, cp_info) + + +instance copy DynamicExpr +where + copy dynamik=:{dyn_expr,dyn_uni_vars,dyn_type_code} cp_info=:{cp_var_heap} + # ((dyn_expr, dyn_type_code), cp_info) = copy (dyn_expr,dyn_type_code) + { cp_info & cp_var_heap = foldSt (\info_ptr -> writePtr info_ptr VI_LocalVar) dyn_uni_vars cp_var_heap } + = ({ dynamik & dyn_expr = dyn_expr, dyn_type_code = dyn_type_code }, cp_info) + +instance copy TypeCodeExpression +where + copy (TCE_Var var_info_ptr) cp_info=:{cp_free_vars, cp_var_heap} + # (new_info_ptr, cp_info) = copyVarInfo var_info_ptr cp_info + = (TCE_Var new_info_ptr, cp_info) + copy (TCE_Constructor index type_codes) cp_info + # (type_codes, cp_info) = copy type_codes cp_info + = (TCE_Constructor index type_codes, cp_info) + copy (TCE_Selector selections var_info_ptr) cp_info + # (new_info_ptr, cp_info) = copyVarInfo var_info_ptr cp_info + = (TCE_Selector selections new_info_ptr, cp_info) + +copyVarInfo var_info_ptr cp_info=:{cp_free_vars, cp_var_heap} + #! var_info = sreadPtr var_info_ptr cp_var_heap + = case var_info of + VI_FreeVar name new_info_ptr count type + -> (new_info_ptr, { cp_free_vars = cp_free_vars, cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar name new_info_ptr (inc count) type)}) + VI_LocalVar + -> (var_info_ptr, {cp_free_vars = cp_free_vars, cp_var_heap = cp_var_heap}) + VI_BoundVar type + # (new_info_ptr, cp_var_heap) = newPtr VI_Empty cp_var_heap + -> (new_info_ptr, { cp_free_vars = [ (var_info_ptr, type) : cp_free_vars ], + cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar { id_name = "_t", id_info = nilPtr } new_info_ptr 1 type) }) +instance copy Case +where + copy this_case=:{case_expr, case_guards, case_default} cp_info + # ((case_expr,(case_guards,case_default)), cp_info) = copy (case_expr,(case_guards,case_default)) cp_info + = ({ this_case & case_expr = case_expr, case_guards = case_guards, case_default = case_default}, cp_info) + +instance copy CasePatterns +where + copy (AlgebraicPatterns type patterns) cp_info + # (patterns, cp_info) = copy patterns cp_info + = (AlgebraicPatterns type patterns, cp_info) + copy (BasicPatterns type patterns) cp_info + # (patterns, cp_info) = copy patterns cp_info + = (BasicPatterns type patterns, cp_info) + copy (DynamicPatterns patterns) cp_info + # (patterns, cp_info) = copy patterns cp_info + = (DynamicPatterns patterns, cp_info) + +instance copy AlgebraicPattern +where + copy pattern=:{ap_vars,ap_expr} cp_info=:{cp_var_heap} + # (ap_expr, cp_info) = copy ap_expr { cp_info & cp_var_heap = foldSt (\{fv_info_ptr} -> writePtr fv_info_ptr VI_LocalVar) ap_vars cp_var_heap} + = ({ pattern & ap_expr = ap_expr }, cp_info) + +instance copy BasicPattern +where + copy pattern=:{bp_expr} cp_info + # (bp_expr, cp_info) = copy bp_expr cp_info + = ({ pattern & bp_expr = bp_expr }, cp_info) + +instance copy DynamicPattern +where + copy pattern=:{dp_var={fv_info_ptr},dp_rhs,dp_type_patterns_vars, dp_type_code} cp_info=:{cp_var_heap} + # (dp_rhs, cp_info) = copy dp_rhs + { cp_info & cp_var_heap = foldSt (\info_ptr -> writePtr info_ptr VI_LocalVar) dp_type_patterns_vars cp_var_heap + <:= (fv_info_ptr, VI_LocalVar) } + (dp_type_code, cp_info) = copy dp_type_code cp_info + = ({ pattern & dp_rhs = dp_rhs, dp_type_code = dp_type_code }, cp_info) + +instance copy [a] | copy a +where + copy l cp_info = mapSt copy l cp_info + +instance copy (a,b) | copy a & copy b +where + copy t cp_info = app2St (copy, copy) t cp_info + +instance copy (Bind a b) | copy a +where + copy bind=:{bind_src} cp_info + # (bind_src, cp_info) = copy bind_src cp_info + = ({ bind & bind_src = bind_src }, cp_info) + +/* + + weightedRefCount determines the references counts of variables in an expression. Runtime behaviour of constructs into account: + multiple occurrences of variables in different alternatives of the same case clause are counted only once. The outcome + is used to distribute shared expressions (via let declarations) over cases. In this way code sharing is eliminated. + As a side effect, weightedRefCount returns a list of all imported function that have been used iinside the expression. + +*/ + +:: RCInfo = + { rc_free_vars :: ![VarInfoPtr] + , rc_imports :: ![SymbKind] + , rc_var_heap :: !.VarHeap + , rc_expr_heap :: !.ExpressionHeap + } + + +weightedRefCountOfVariable depth var_info_ptr lvi=:{lvi_count,lvi_var,lvi_depth,lvi_previous,lvi_new} ref_count new_vars + | lvi_depth < depth + = (True, {lvi & lvi_count = ref_count, lvi_depth = depth, lvi_new = True, lvi_previous = + [{plvi_count = lvi_count, plvi_depth = lvi_depth, plvi_new = lvi_new } : lvi_previous]}, [var_info_ptr : new_vars]) +// ==> (lvi_var, " PUSHED ",lvi_depth) + | lvi_count == 0 + = (True, { lvi & lvi_count = ref_count }, [var_info_ptr : new_vars]) + = (lvi_new, { lvi & lvi_count = lvi_count + ref_count }, new_vars) + +class weightedRefCount e :: !{# {# FunType} } !{# CommonDefs} !Int !e !*RCInfo -> *RCInfo + +instance weightedRefCount BoundVar +where + weightedRefCount dcl_functions common_defs depth {var_name,var_info_ptr} rc_info=:{rc_var_heap,rc_free_vars} + #! var_info = sreadPtr var_info_ptr rc_var_heap + = case var_info of + VI_LetVar lvi + # (is_new, lvi=:{lvi_expression}, rc_free_vars) = weightedRefCountOfVariable depth var_info_ptr lvi 1 rc_free_vars + | is_new + # rc_info = weightedRefCount dcl_functions common_defs depth lvi_expression + { rc_info & rc_free_vars = rc_free_vars, + rc_var_heap = rc_info.rc_var_heap <:= (var_info_ptr, VI_LetVar {lvi & lvi_expression = EE, lvi_new = False})} + (VI_LetVar lvi, rc_var_heap) = readPtr var_info_ptr rc_info.rc_var_heap + -> { rc_info & rc_var_heap = rc_var_heap <:= (var_info_ptr, VI_LetVar { lvi & lvi_expression = lvi_expression }) } +// ==> (var_name, var_info_ptr, depth, lvi.lvi_count) + -> { rc_info & rc_var_heap = rc_info.rc_var_heap <:= (var_info_ptr, VI_LetVar lvi) } + _ + -> rc_info + +instance weightedRefCount Expression +where + weightedRefCount dcl_functions common_defs depth (Var var) rc_info + = weightedRefCount dcl_functions common_defs depth var rc_info + weightedRefCount dcl_functions common_defs depth (App app) rc_info + = weightedRefCount dcl_functions common_defs depth app rc_info + weightedRefCount dcl_functions common_defs depth (fun_expr @ exprs) rc_info + = weightedRefCount dcl_functions common_defs depth (fun_expr, exprs) rc_info + weightedRefCount dcl_functions common_defs depth (Let {let_binds,let_expr, let_info_ptr}) rc_info=:{rc_var_heap} + # rc_info = weightedRefCount dcl_functions common_defs depth let_expr { rc_info & rc_var_heap = foldSt store_binding let_binds rc_var_heap } + (let_info, rc_expr_heap) = readPtr let_info_ptr rc_info.rc_expr_heap + rc_info = { rc_info & rc_expr_heap = rc_expr_heap } + = case let_info of + EI_LetType let_type + # (ref_counts, rc_var_heap) = mapSt get_ref_count let_binds rc_info.rc_var_heap + (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_var_heap) let_binds + -> { rc_info & rc_free_vars = rc_free_vars, rc_var_heap = rc_var_heap, + rc_expr_heap = rc_info.rc_expr_heap <:= (let_info_ptr, EI_LetTypeAndRefCounts let_type ref_counts)} + ==> ("weightedRefCount (EI_LetType)", ref_counts, rc_info.rc_free_vars, rc_free_vars, depth) + _ + # (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_info.rc_var_heap) let_binds + -> { rc_info & rc_free_vars = rc_free_vars, rc_var_heap = rc_var_heap } +// ==> ("weightedRefCount (Let)" <<- let_info) + where + remove_variable ([], var_heap) let_bind + = ([], var_heap) + remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{bind_dst={fv_name,fv_info_ptr}} + | fv_info_ptr == var_ptr + # (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap + = (var_ptrs, var_heap) +// ==> ("remove_variable (lvi_count,lvi_dpeth) ", fv_name, lvi_count, lvi_depth) + # (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind + = ([var_ptr : var_ptrs], var_heap) + + store_binding {bind_dst={fv_name,fv_info_ptr},bind_src} var_heap + = var_heap <:= (fv_info_ptr, VI_LetVar {lvi_count = 0, lvi_depth = depth, lvi_previous = [], + lvi_new = True, lvi_expression = bind_src, lvi_var = fv_name}) + + get_ref_count {bind_dst={fv_name,fv_info_ptr}} var_heap + # (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap + = (lvi_count, var_heap) +// ==> (fv_name,fv_info_ptr,lvi_count) + weightedRefCount dcl_functions common_defs depth (Case case_expr) rc_info=:{rc_expr_heap} + # (case_info, rc_expr_heap) = readPtr case_expr.case_info_ptr rc_expr_heap + = weightedRefCountOfCase dcl_functions common_defs depth case_expr case_info { rc_info & rc_expr_heap = rc_expr_heap } + weightedRefCount dcl_functions common_defs depth expr=:(BasicExpr _ _) rc_info + = rc_info + weightedRefCount dcl_functions common_defs depth (MatchExpr _ constructor expr) rc_info + = weightedRefCount dcl_functions common_defs depth expr rc_info + weightedRefCount dcl_functions common_defs depth (Selection opt_tuple expr selections) rc_info + = weightedRefCount dcl_functions common_defs depth (expr, selections) rc_info + weightedRefCount dcl_functions common_defs depth (Update expr1 selections expr2) rc_info + = weightedRefCount dcl_functions common_defs depth (expr1, (selections, expr2)) rc_info + weightedRefCount dcl_functions common_defs depth (RecordUpdate cons_symbol expression expressions) rc_info + = weightedRefCount dcl_functions common_defs depth (expression, expressions) rc_info + weightedRefCount dcl_functions common_defs depth (TupleSelect tuple_symbol arg_nr expr) rc_info + = weightedRefCount dcl_functions common_defs depth expr rc_info + weightedRefCount dcl_functions common_defs depth (DynamicExpr {dyn_expr}) rc_info + = weightedRefCount dcl_functions common_defs depth dyn_expr rc_info + weightedRefCount dcl_functions common_defs depth (AnyCodeExpr _ _ _) rc_info + = rc_info + weightedRefCount dcl_functions common_defs depth (ABCCodeExpr _ _) rc_info + = rc_info + weightedRefCount dcl_functions common_defs depth (TypeCodeExpression type_code_expr) rc_info + = weightedRefCount dcl_functions common_defs depth type_code_expr rc_info + weightedRefCount dcl_functions common_defs depth EE rc_info + = rc_info + weightedRefCount dcl_functions common_defs depth expr rc_info + = abort ("weightedRefCount [Expression] (convertcases, 864))" ---> expr) + +addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap) + #! var_info = sreadPtr var_info_ptr var_heap + = case var_info of + VI_LetVar lvi + # (_, lvi, free_vars) = weightedRefCountOfVariable depth var_info_ptr lvi ref_count free_vars + -> (free_vars, var_heap <:= (var_info_ptr, VI_LetVar lvi)) + _ + -> (free_vars, var_heap) + +weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseType case_type) + rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports } + # (local_vars, vars_and_heaps) = weighted_ref_count_in_case_patterns dcl_functions common_defs (inc depth) case_guards rc_imports rc_var_heap rc_expr_heap + (default_vars, (all_vars, rc_imports, var_heap, expr_heap)) = weighted_ref_count_in_default dcl_functions common_defs (inc depth) case_default vars_and_heaps + rc_info = weightedRefCount dcl_functions common_defs depth case_expr { rc_info & rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_imports = rc_imports } + (rc_free_vars, rc_var_heap) = foldSt (addPatternVariable depth) all_vars (rc_info.rc_free_vars, rc_info.rc_var_heap) +// (EI_CaseType case_type, rc_expr_heap) = readPtr case_info_ptr rc_info.rc_expr_heap + rc_expr_heap = rc_info.rc_expr_heap <:= (case_info_ptr, EI_CaseTypeAndRefCounts case_type + { rcc_all_variables = all_vars, rcc_default_variables = default_vars, rcc_pattern_variables = local_vars }) + = { rc_info & rc_var_heap = rc_var_heap, rc_expr_heap = rc_expr_heap, rc_free_vars = rc_free_vars } +// ==> (rc_free_vars, all_vars, default_vars, local_vars) + where + weighted_ref_count_in_default dcl_functions common_defs depth (Yes expr) info + = weightedRefCountInPatternExpr dcl_functions common_defs depth expr info + weighted_ref_count_in_default dcl_functions common_defs depth No info + = ([], info) + + weighted_ref_count_in_case_patterns dcl_functions common_defs depth (AlgebraicPatterns type patterns) collected_imports var_heap expr_heap + = mapSt (weighted_ref_count_in_algebraic_pattern dcl_functions common_defs depth) patterns ([], collected_imports, var_heap, expr_heap) + where + weighted_ref_count_in_algebraic_pattern dcl_functions common_defs depth {ap_expr,ap_symbol={glob_module, glob_object={ds_index}}} wrc_state + # (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap)) + = weightedRefCountInPatternExpr dcl_functions common_defs depth ap_expr wrc_state + | glob_module <> cIclModIndex + # {cons_type_ptr} = common_defs.[glob_module].com_cons_defs.[ds_index] + (collected_imports, var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index}) + cons_type_ptr (collected_imports, var_heap) + = (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap)) + = (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap)) + + weighted_ref_count_in_case_patterns dcl_functions common_defs depth (BasicPatterns type patterns) collected_imports var_heap expr_heap + = mapSt (\{bp_expr} -> weightedRefCountInPatternExpr dcl_functions common_defs depth bp_expr) patterns ([], collected_imports, var_heap, expr_heap) + weighted_ref_count_in_case_patterns dcl_functions common_defs depth (DynamicPatterns patterns) collected_imports var_heap expr_heap + = mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr dcl_functions common_defs depth dp_rhs) patterns ([], collected_imports, var_heap, expr_heap) + +weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseTypeAndRefCounts case_type {rcc_all_variables}) + rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports } + # rc_info = weightedRefCount dcl_functions common_defs depth case_expr rc_info + (rc_free_vars, rc_var_heap) = foldSt (addPatternVariable depth) rcc_all_variables (rc_info.rc_free_vars, rc_info.rc_var_heap) + = { rc_info & rc_var_heap = rc_var_heap, rc_free_vars = rc_free_vars } + +checkRecordSelector common_defs {glob_module, glob_object={ds_index}} rc_info=:{rc_imports,rc_var_heap} + | glob_module <> cIclModIndex + # {com_selector_defs,com_cons_defs,com_type_defs} = common_defs.[glob_module] + {sd_type_index} = com_selector_defs.[ds_index] + {td_rhs = RecordType {rt_constructor={ds_index=cons_index}, rt_fields}} = com_type_defs.[sd_type_index] + {cons_type_ptr} = com_cons_defs.[cons_index] + (rc_imports, rc_var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = cons_index}) + cons_type_ptr (rc_imports, rc_var_heap) + = { rc_info & rc_imports = rc_imports, rc_var_heap = rc_var_heap } + = rc_info + +instance weightedRefCount Selection +where + weightedRefCount dcl_functions common_defs depth (ArraySelection {glob_module,glob_object={ds_index}} _ index_expr) rc_info + # rc_info = weightedRefCount dcl_functions common_defs depth index_expr rc_info + = checkImportOfDclFunction dcl_functions common_defs glob_module ds_index rc_info + weightedRefCount dcl_functions common_defs depth (DictionarySelection _ selectors _ index_expr) rc_info + # rc_info = weightedRefCount dcl_functions common_defs depth index_expr rc_info + = weightedRefCount dcl_functions common_defs depth selectors rc_info + weightedRefCount dcl_functions common_defs depth (RecordSelection selector _) rc_info + = checkRecordSelector common_defs selector rc_info + +weightedRefCountInPatternExpr dcl_functions common_defs depth pattern_expr (previous_free_vars, collected_imports, var_heap, expr_heap) + # {rc_free_vars,rc_var_heap,rc_imports,rc_expr_heap} = weightedRefCount dcl_functions common_defs depth pattern_expr + { rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_free_vars = [], rc_imports = collected_imports} + (free_vars_with_rc, rc_var_heap) = mapSt get_ref_count rc_free_vars rc_var_heap + (previous_free_vars, rc_var_heap) = foldSt (select_unused_free_variable depth) previous_free_vars ([], rc_var_heap) + (all_free_vars, rc_var_heap) = foldSt (collect_free_variable depth) rc_free_vars (previous_free_vars, rc_var_heap) +// ==> ("remove_vars ", depth, free_vars_with_rc) + = (free_vars_with_rc, (all_free_vars, rc_imports, rc_var_heap, rc_expr_heap)) +where + select_unused_free_variable depth var=:{cv_variable = var_ptr, cv_count = var_count} (collected_vars, var_heap) + # (VI_LetVar info=:{lvi_count,lvi_depth}, var_heap) = readPtr var_ptr var_heap + | lvi_depth == depth && lvi_count > 0 + = (collected_vars, var_heap <:= (var_ptr, VI_LetVar {info & lvi_count = max lvi_count var_count})) + = ([ var : collected_vars], var_heap) + + get_ref_count var_ptr var_heap + # (VI_LetVar {lvi_count}, var_heap) = readPtr var_ptr var_heap + = ({cv_variable = var_ptr, cv_count = lvi_count}, var_heap) + + collect_free_variable depth var_ptr (collected_vars, var_heap) + # (VI_LetVar lvi=:{lvi_count,lvi_depth,lvi_previous}, var_heap) = readPtr var_ptr var_heap + | depth == lvi_depth + = case lvi_previous of + [{plvi_depth, plvi_count, plvi_new} : lvi_previous ] + -> ([ {cv_variable = var_ptr, cv_count = lvi_count} : collected_vars ], + (var_heap <:= (var_ptr, VI_LetVar {lvi & lvi_count = plvi_count, lvi_depth = plvi_depth, + lvi_new = plvi_new, lvi_previous = lvi_previous}))) + [] + -> (collected_vars, var_heap) + = ([ {cv_variable = var_ptr, cv_count = lvi_count} : collected_vars ], var_heap) + + +/* + Here we examine the appplication to see whether an imported function has been used. If so, the 'ft_type_ptr' is examined. Initially + this pointer contains VI_Empty. After the first occurrence the pointer will be set to 'VI_Used'. + +*/ + +checkImportOfDclFunction dcl_functions common_defs mod_index fun_index rc_info=:{rc_imports, rc_var_heap} + | mod_index <> cIclModIndex + # {ft_type_ptr} = dcl_functions.[mod_index].[fun_index] + (rc_imports, rc_var_heap) = checkImportedSymbol (SK_Function {glob_module=mod_index,glob_object=fun_index}) ft_type_ptr (rc_imports, rc_var_heap) + = { rc_info & rc_imports = rc_imports, rc_var_heap = rc_var_heap } + = rc_info + +instance weightedRefCount App +where + weightedRefCount dcl_functions common_defs depth {app_symb,app_args} rc_info + # rc_info = weightedRefCount dcl_functions common_defs depth app_args rc_info + = check_import dcl_functions common_defs app_symb.symb_kind rc_info + where + check_import dcl_functions common_defs symb_kind=:(SK_Function {glob_module,glob_object}) rc_info=:{rc_imports, rc_var_heap} + = checkImportOfDclFunction dcl_functions common_defs glob_module glob_object rc_info + check_import dcl_functions common_defs symb_kind=:(SK_Constructor {glob_module,glob_object}) rc_info=:{rc_imports, rc_var_heap} + | glob_module <> cIclModIndex + # {cons_type_ptr} = common_defs.[glob_module].com_cons_defs.[glob_object] + (rc_imports, rc_var_heap) = checkImportedSymbol symb_kind cons_type_ptr (rc_imports, rc_var_heap) + = { rc_info & rc_imports = rc_imports, rc_var_heap = rc_var_heap } + = rc_info + check_import dcl_functions common_defs symb_kind rc_info + = rc_info + + +instance weightedRefCount TypeCodeExpression +where + weightedRefCount dcl_functions common_defs depth type_code_expr rc_info + = rc_info + +instance weightedRefCount [a] | weightedRefCount a +where + weightedRefCount dcl_functions common_defs depth l rc_info = foldr (weightedRefCount dcl_functions common_defs depth) rc_info l + +instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b +where + weightedRefCount dcl_functions common_defs depth (x,y) rc_info = weightedRefCount dcl_functions common_defs depth y (weightedRefCount dcl_functions common_defs depth x rc_info) + +instance weightedRefCount (Bind a b) | weightedRefCount a +where + weightedRefCount dcl_functions common_defs depth bind=:{bind_src} rc_info + = weightedRefCount dcl_functions common_defs depth bind_src rc_info + +checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap) + #! type_info = sreadPtr symb_type_ptr var_heap + = case type_info of + VI_Used + -> (collected_imports, var_heap) + _ + -> ([symb_kind : collected_imports ], var_heap <:= (symb_type_ptr, VI_Used)) + +:: DistributeInfo = + { di_lets :: ![VarInfoPtr] + , di_var_heap :: !.VarHeap + , di_expr_heap :: !.ExpressionHeap + } +/* + distributeLets tries to move shared expressions as close as possible to the location at ewhich they are used. + Case-expression may require unsharing if the shared expression is used in different alternatives. Of course + only if the expreesion is not used in the pattern nor in a surrounding expression. +*/ + +class distributeLets e :: !Int !e !*DistributeInfo -> (!e, !*DistributeInfo) + + +instance distributeLets Expression +where + distributeLets depth (Var var=:{var_name,var_info_ptr}) dl_info=:{di_var_heap} + #! var_info = sreadPtr var_info_ptr di_var_heap + = case var_info of + VI_LetExpression lei + | lei.lei_count == 1 +// ==> (var_name, var_info_ptr, lei.lei_count, (lei.lei_expression, lei.lei_depth, depth)) + # (lei_updated_expr, dl_info) = distributeLets depth lei.lei_expression dl_info + | lei.lei_strict + -> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, { dl_info & di_lets = [ var_info_ptr : dl_info.di_lets ], + di_var_heap = dl_info.di_var_heap <:= (var_info_ptr, VI_LetExpression + { lei & lei_status = LES_Updated lei_updated_expr }) }) + -> (lei_updated_expr, { dl_info & di_var_heap = dl_info.di_var_heap <:= + (var_info_ptr, VI_LetExpression { lei & lei_status = LES_Updated lei_updated_expr }) }) + | lei.lei_depth == depth + # dl_info = distributeLetsInLetExpression depth var_info_ptr lei dl_info + -> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, dl_info) + -> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, dl_info) + VI_CaseVar var_info_ptr + -> (Var { var & var_info_ptr = var_info_ptr }, dl_info) + _ + -> (Var var, dl_info) + distributeLets depth (Case kees) dl_info + # (kees, dl_info) = distributeLets depth kees dl_info + = (Case kees, dl_info) + distributeLets depth (App app=:{app_args}) dl_info + # (app_args, dl_info) = distributeLets depth app_args dl_info + = (App {app & app_args = app_args}, dl_info) + distributeLets depth (fun_expr @ exprs) dl_info + # (fun_expr, dl_info) = distributeLets depth fun_expr dl_info + (exprs, dl_info) = distributeLets depth exprs dl_info + = (fun_expr @ exprs, dl_info) + distributeLets depth expr=:(BasicExpr _ _) dl_info + = (expr, dl_info) + distributeLets depth (MatchExpr opt_tuple constructor expr) dl_info + # (expr, dl_info) = distributeLets depth expr dl_info + = (MatchExpr opt_tuple constructor expr, dl_info) + distributeLets depth (Selection opt_tuple expr selectors) dl_info + # (expr, dl_info) = distributeLets depth expr dl_info + # (selectors, dl_info) = distributeLets depth selectors dl_info + = (Selection opt_tuple expr selectors, dl_info) + distributeLets depth (Update expr1 selectors expr2) dl_info + # (expr1, dl_info) = distributeLets depth expr1 dl_info + # (selectors, dl_info) = distributeLets depth selectors dl_info + # (expr2, dl_info) = distributeLets depth expr2 dl_info + = (Update expr1 selectors expr2, dl_info) + distributeLets depth (RecordUpdate cons_symbol expression expressions) dl_info + # (expression, dl_info) = distributeLets depth expression dl_info + # (expressions, dl_info) = distributeLets depth expressions dl_info + = (RecordUpdate cons_symbol expression expressions, dl_info) + distributeLets depth (TupleSelect tuple_symbol arg_nr expr) dl_info + # (expr, dl_info) = distributeLets depth expr dl_info + = (TupleSelect tuple_symbol arg_nr expr, dl_info) + distributeLets depth (Let lad=:{let_binds,let_expr,let_strict,let_info_ptr}) dl_info=:{di_expr_heap,di_var_heap} + # (EI_LetTypeAndRefCounts let_type ref_counts, di_expr_heap) = readPtr let_info_ptr di_expr_heap + di_var_heap = set_let_expression_info depth let_strict let_binds ref_counts let_type di_var_heap + (let_expr, dl_info) = distributeLets depth let_expr { dl_info & di_var_heap = di_var_heap, di_expr_heap = di_expr_heap } + = (let_expr, foldSt (distribute_lets_in_non_distributed_let depth) let_binds dl_info) + where + set_let_expression_info depth let_strict [{bind_src,bind_dst}:binds][ref_count:ref_counts][type:types] var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + lei = { lei_count = ref_count, lei_depth = depth, lei_strict = let_strict, /* lei_moved = False, */ + lei_var = { bind_dst & fv_info_ptr = new_info_ptr }, lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched } + = set_let_expression_info depth let_strict binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei)) + set_let_expression_info depth let_strict [] _ _ var_heap + = var_heap + + distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap} + # (VI_LetExpression lei=:{lei_depth,lei_count,lei_status}, di_var_heap) = readPtr fv_info_ptr di_var_heap + | lei_count > 0 +// | not lei_moved && lei_count > 0 + = distributeLetsInLetExpression depth fv_info_ptr lei { dl_info & di_var_heap = di_var_heap } + = { dl_info & di_var_heap = di_var_heap } + ==> ("distribute_lets_in_non_distributed_let (moved or not used)", lei_count, fv_name) + + is_moved LES_Moved = True + is_moved _ = False + + distributeLets depth (DynamicExpr dynamik=:{dyn_expr}) dl_info + # (dyn_expr, dl_info) = distributeLets depth dyn_expr dl_info + = (DynamicExpr { dynamik & dyn_expr = dyn_expr }, dl_info) + distributeLets depth expr=:(TypeCodeExpression _) dl_info + = (expr, dl_info) + distributeLets depth (AnyCodeExpr in_params out_params code_expr) dl_info=:{di_var_heap} + # (in_params, di_var_heap) = mapSt determineInputParameter in_params di_var_heap + = (AnyCodeExpr in_params out_params code_expr, { dl_info & di_var_heap = di_var_heap }) + where + determineInputParameter bind=:{bind_dst} var_heap + # (var_info, var_heap) = readPtr bind_dst.var_info_ptr var_heap + = case var_info of + VI_CaseVar new_info_ptr + -> ({ bind & bind_dst = { bind_dst & var_info_ptr = new_info_ptr }}, var_heap) + _ + -> (bind, var_heap) + + distributeLets depth expr=:(ABCCodeExpr _ _) dl_info + = (expr, dl_info) + distributeLets depth EE dl_info + = (EE, dl_info) + +instance distributeLets Case +where + distributeLets depth kees=:{case_info_ptr,case_guards,case_default,case_expr} dl_info=:{di_var_heap, di_expr_heap} + # (EI_CaseTypeAndRefCounts case_type { rcc_all_variables = tot_ref_counts , rcc_default_variables = ref_counts_in_default, rcc_pattern_variables = ref_counts_in_patterns }, di_expr_heap) = readPtr case_info_ptr di_expr_heap +// di_expr_heap = di_expr_heap <:= (case_info_ptr, EI_CaseType case_type) + new_depth = inc depth + (local_lets, di_var_heap) = foldSt (mark_local_let_var new_depth) tot_ref_counts ([], di_var_heap) + (case_guards, heaps) = distribute_lets_in_patterns new_depth ref_counts_in_patterns case_guards (di_var_heap, di_expr_heap) + (case_default, (di_var_heap, di_expr_heap)) = distribute_lets_in_default new_depth ref_counts_in_default case_default heaps + di_var_heap = foldSt reset_local_let_var local_lets di_var_heap + (case_expr, dl_info) = distributeLets depth case_expr { dl_info & di_var_heap = di_var_heap, di_expr_heap = di_expr_heap } + = ({ kees & case_guards = case_guards, case_expr = case_expr, case_default = case_default }, dl_info) + where + distribute_lets_in_patterns depth ref_counts (AlgebraicPatterns conses patterns) heaps + # (patterns, heaps) = mapSt (distribute_lets_in_alg_pattern depth) (zip2 ref_counts patterns) heaps + = (AlgebraicPatterns conses patterns, heaps) + where + distribute_lets_in_alg_pattern depth (ref_counts,pattern) (di_var_heap, di_expr_heap) + # (ap_vars, di_var_heap) = mapSt refresh_variable pattern.ap_vars di_var_heap + (ap_expr, heaps) = distribute_lets_in_pattern_expr depth ref_counts pattern.ap_expr (di_var_heap, di_expr_heap) + = ({ pattern & ap_vars = ap_vars, ap_expr = ap_expr }, heaps) + distribute_lets_in_patterns depth ref_counts (BasicPatterns type patterns) heaps + # (patterns, heaps) = mapSt (distribute_lets_in_basic_pattern depth) (zip2 ref_counts patterns) heaps + = (BasicPatterns type patterns, heaps) + where + distribute_lets_in_basic_pattern depth (ref_counts,pattern) heaps + # (bp_expr, heaps) = distribute_lets_in_pattern_expr depth ref_counts pattern.bp_expr heaps + = ({ pattern & bp_expr = bp_expr }, heaps) + distribute_lets_in_patterns depth ref_counts (DynamicPatterns patterns) heaps + # (patterns, heaps) = mapSt (distribute_lets_in_dynamic_pattern depth) (zip2 ref_counts patterns) heaps + = (DynamicPatterns patterns, heaps) + where + distribute_lets_in_dynamic_pattern depth (ref_counts,pattern) (di_var_heap, di_expr_heap) + # (dp_var, di_var_heap) = refresh_variable pattern.dp_var di_var_heap + (dp_rhs, heaps) = distribute_lets_in_pattern_expr depth ref_counts pattern.dp_rhs (di_var_heap, di_expr_heap) + = ({ pattern & dp_rhs = dp_rhs, dp_var = dp_var }, heaps) + + distribute_lets_in_default depth ref_counts_in_default (Yes expr) heaps + # (expr, heaps) = distribute_lets_in_pattern_expr depth ref_counts_in_default expr heaps + = (Yes expr, heaps) + distribute_lets_in_default depth ref_counts_in_default No heaps + = (No, heaps) + + refresh_variable fv=:{fv_info_ptr} var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ({ fv & fv_info_ptr = new_info_ptr }, var_heap <:= (fv_info_ptr, VI_CaseVar new_info_ptr)) + + mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap) + # (VI_LetExpression lei=:{lei_count,lei_depth}, var_heap) = readPtr cv_variable var_heap + | lei_count == cv_count + = ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth})) + ==> ("mark_local_let_var ", lei.lei_var.fv_name, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth)) + = (local_vars, var_heap) + + reset_local_let_var (var_info_ptr, lei_count, lei_depth) var_heap + # (VI_LetExpression lei, var_heap) = readPtr var_info_ptr var_heap + = var_heap <:= (var_info_ptr, VI_LetExpression { lei & lei_depth = lei_depth, lei_count = lei_count, lei_status = LES_Moved }) + + distribute_lets_in_pattern_expr depth local_vars pattern_expr (var_heap, expr_heap) + # var_heap = foldSt (mark_local_let_var_of_pattern_expr depth) local_vars var_heap + (pattern_expr, dl_info) = distributeLets depth pattern_expr { di_lets = [], di_var_heap = var_heap, di_expr_heap = expr_heap} + dl_info = foldSt (reexamine_local_let_expressions depth) local_vars dl_info + = buildLetExpr dl_info.di_lets pattern_expr (dl_info.di_var_heap, dl_info.di_expr_heap) + ==> ("distribute_lets_in_pattern_expr", dl_info.di_lets) + + mark_local_let_var_of_pattern_expr depth {cv_variable, cv_count} var_heap + # (VI_LetExpression lei, var_heap) = readPtr cv_variable var_heap + | depth == lei.lei_depth + = var_heap <:= (cv_variable, VI_LetExpression { lei & lei_count = cv_count, lei_status = LES_Untouched }) + ==> ("mark_local_let_var_of_pattern_expr ", lei.lei_var.fv_name, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth)) + = var_heap + + reexamine_local_let_expressions depth {cv_variable, cv_count} dl_info=:{di_var_heap} + | cv_count > 1 + # (VI_LetExpression lei, di_var_heap) = readPtr cv_variable di_var_heap + | depth == lei.lei_depth + = distributeLetsInLetExpression depth cv_variable lei { dl_info & di_var_heap = di_var_heap } + = { dl_info & di_var_heap = di_var_heap } + = dl_info + + +distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_status = LES_Moved} dl_info + = dl_info +distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_status = LES_Updated _} dl_info + = dl_info +distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_status = LES_Untouched} dl_info=:{di_var_heap} + # di_var_heap = di_var_heap <:= (let_var_info_ptr, VI_LetExpression { lei & lei_status = LES_Updated EE}) /* to prevent doing this expression twice */ + (lei_expression, dl_info) = distributeLets depth lei_expression { dl_info & di_var_heap = di_var_heap } + = { dl_info & di_lets = [ let_var_info_ptr : dl_info.di_lets ], + di_var_heap = dl_info.di_var_heap <:= (let_var_info_ptr, VI_LetExpression { lei & lei_status = LES_Updated lei_expression })} + + +buildLetExpr :: ![VarInfoPtr] !Expression !*(!*VarHeap, !*ExpressionHeap) -> (!Expression, !(!*VarHeap, !*ExpressionHeap)) +buildLetExpr let_vars let_expr (var_heap, expr_heap) + # (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap) = foldr build_bind ([], [], [], [], var_heap) let_vars + | isEmpty strict_binds + | isEmpty lazy_binds + = (let_expr, (var_heap, expr_heap)) + # (let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap + = (Let { let_binds = lazy_binds, let_strict = cIsNotStrict, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap)) + | isEmpty lazy_binds + # (let_info_ptr, expr_heap) = newPtr (EI_LetType strict_bind_types) expr_heap + = (Let { let_binds = strict_binds, let_strict = cIsStrict, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap)) + # (strict_let_info_ptr, expr_heap) = newPtr (EI_LetType strict_bind_types) expr_heap + (lazy_let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap + = (Let { let_binds = strict_binds, let_strict = cIsStrict, let_info_ptr = strict_let_info_ptr, let_expr = + Let { let_binds = lazy_binds, let_strict = cIsNotStrict, let_info_ptr = lazy_let_info_ptr, let_expr = let_expr }}, (var_heap, expr_heap)) + +where + build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap) + -> (!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap) + build_bind info_ptr (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap) + # (let_info, var_heap) = readPtr info_ptr var_heap + # (VI_LetExpression lei=:{lei_strict,lei_var,lei_expression,lei_status,lei_type}) = let_info + (LES_Updated updated_expr) = lei_status + (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + var_heap = var_heap <:= (info_ptr, VI_LetExpression { lei & lei_status = LES_Untouched, lei_var = { lei_var & fv_info_ptr = new_info_ptr }}) +// ==> (lei_var.fv_name, info_ptr, new_info_ptr) + | lei_strict + = ([{ bind_src = updated_expr, bind_dst = lei_var } : strict_binds], [lei_type : strict_bind_types ], lazy_binds, lazy_binds_types, var_heap) + = (strict_binds, strict_bind_types, [{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) + +instance distributeLets Selection +where + distributeLets depth (ArraySelection selector expr_ptr expr) cp_info + # (expr, cp_info) = distributeLets depth expr cp_info + = (ArraySelection selector expr_ptr expr, cp_info) + distributeLets depth selection cp_info + = (selection, cp_info) + +instance distributeLets [a] | distributeLets a +where + distributeLets depth l cp_info = mapSt (distributeLets depth) l cp_info + +instance distributeLets (Bind a b) | distributeLets a +where + distributeLets depth bind=:{bind_src} cp_info + # (bind_src, cp_info) = distributeLets depth bind_src cp_info + = ({ bind & bind_src = bind_src }, cp_info) + +instance <<< ExprInfo +where + (<<<) file EI_Empty = file <<< "*Empty*" + (<<<) file (EI_CaseType _) = file <<< "CaseType" + +instance <<< Ptr a +where + (<<<) file ptr = file <<< ptrToInt ptr + +instance <<< FreeVar +where + (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '[' <<< fv_info_ptr <<< ']' + +instance <<< BoundVar +where + (<<<) file {var_name,var_info_ptr} = file <<< var_name <<< '[' <<< var_info_ptr <<< ']' + +instance <<< FunctionBody +where + (<<<) file (TransformedBody {tb_rhs}) = file <<< tb_rhs + +instance <<< CountedVariable +where + (<<<) file {cv_variable,cv_count} = file <<< '<' <<< cv_variable <<< ',' <<< cv_count <<< '>' + +(==>) a b :== a +//(==>) a b :== a ---> b diff --git a/frontend/explicitimports.dcl b/frontend/explicitimports.dcl new file mode 100644 index 0000000..45562f6 --- /dev/null +++ b/frontend/explicitimports.dcl @@ -0,0 +1,17 @@ +definition module explicitimports + +import syntax, checksupport + +temporary_import_solution_XXX yes no :== yes +// to switch between importing modes. +// iff this is yes, then explicit imports happen in the old Clean 1.3 fashion. +// This feature will be removed, when all programs are ported to Clean 2.0. The last Constructors of AtomType +// and StructureType should then be removed also + +// MW2 everything changed in this dcl +:: FunctionConsequence + +possibly_filter_decls :: .[ImportDeclaration] u:[w:(.Index,y:Declarations)] (.FileName,.LineNr) *{#.DclModule} *CheckState -> (v:[x:(Index,z:Declarations)],.{#DclModule},.CheckState), [y <= z, w <= x, u <= v]; +check_completeness_of_module :: .Index [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState); +check_completeness_of_all_dcl_modules :: !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState + -> (!Int, !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap, !*CheckState)) diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl new file mode 100644 index 0000000..e683a83 --- /dev/null +++ b/frontend/explicitimports.icl @@ -0,0 +1,865 @@ +implementation module explicitimports + +import StdEnv + +import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug + + +temporary_import_solution_XXX yes no :== yes +// to switch between importing modes. +// iff this is yes, then explicit imports happen in the old Clean 1.3 fashion. +// This feature will be removed, when all programs are ported to Clean 2.0. The last Constructors of AtomType +// and StructureType should then be removed also +do_temporary_import_solution_XXX :== temporary_import_solution_XXX True False + +// MW was cIclModIndex :== 0 + +// MW DclModule +:: ExplicitImports :== (![AtomicImport], ![StructureImport]) +:: AtomicImport :== (!Ident, !AtomType) +:: StructureImport :== (!Ident, !StructureInfo, !StructureType, !OptimizeInfo) + +:: AtomType = AT_Function | AT_Class | AT_Instance | AT_RecordType | AT_AlgType | AT_Type + | AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen Bool // XXX +:: StructureInfo = SI_DotDot + // The .. notation was used for the structure + // (currently nothing is known about the elements) + | SI_Elements ![Ident] !Bool + // list of elements, that were not imported yet. + // Bool: the elements were listed explicitly in the structure +:: StructureType = ST_AlgType | ST_RecordType | ST_Class + | ST_stomm_stomm_stomm String +:: IdentWithKind :== (!Ident, !STE_Kind) +:: IdentWithCKind :== (!Ident, !ConsequenceKind) + +:: OptimizeInfo :== (Optional !Index) + +:: ConsequenceKind = CK_Function !(Global Index) + | CK_DynamicPatternType ExprInfoPtr + | CK_Macro + | CK_Constructor + | CK_Selector !(Global DefinedSymbol) + | CK_Type + | CK_Class + +:: FunctionConsequence :== Optional !(!Int, !Optional ![IdentWithCKind]) + // Int i: The consequences of this function/macro have already been considered for all dcl modules with indices <= i + +check_completeness_of_all_dcl_modules :: !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState + -> (!Int, !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap, !*CheckState)) +check_completeness_of_all_dcl_modules modules icl_functions expr_heap cs + # (nr_modules, modules) = usize modules + (nr_functions, icl_functions) = usize icl_functions + f_consequences = f_consequences nr_functions + result + = iFoldSt check_completeness_of_dcl_module 0 (nr_modules) (f_consequences, modules, icl_functions, expr_heap, cs) + = (nr_modules, result) + where + f_consequences :: !Int -> *{!FunctionConsequence} + f_consequences i = createArray i No + +check_completeness_of_dcl_module mod_index (f_consequences, modules, icl_functions, expr_heap, cs=:{cs_predef_symbols}) + # pre_mod = cs_predef_symbols.[PD_PredefinedModule] + | pre_mod.pds_def == mod_index + = (f_consequences, modules, icl_functions, expr_heap, cs) // predefined module should not be checked for completeness of explicit imports + # (modul=:{ dcl_name, dcl_declared=dcl_declared=:{dcls_import,dcls_local, dcls_explicit}}, modules) + = modules![mod_index] + cs = addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs + (f_consequences, modules, icl_functions, expr_heap, cs) + = check_completeness_of_module mod_index dcls_explicit (dcl_name.id_name+++".dcl") (f_consequences, modules, icl_functions, expr_heap, cs) + (_, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable [(mod_index, dcl_declared)] [] cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = (f_consequences, modules, icl_functions, expr_heap, cs) + +possibly_filter_decls :: .[ImportDeclaration] u:[w:(.Index,y:Declarations)] (.FileName,.LineNr) *{#.DclModule} *CheckState -> (v:[x:(Index,z:Declarations)],.{#DclModule},.CheckState), [y <= z, w <= x, u <= v]; +possibly_filter_decls [] decls_of_imported_module _ modules cs // implicit import can't go wrong + = (decls_of_imported_module, modules, cs) +possibly_filter_decls listed_symbols decls_of_imported_module (file_name, line_nr) modules cs + // explicit import + #! + ident_pos = { ip_ident= { id_name="", id_info=nilPtr } + , ip_line = line_nr + , ip_file = file_name + } + cs = { cs & cs_error = pushErrorAdmin ident_pos cs.cs_error } + (result, modules, cs) = filter_explicitly_imported_decl listed_symbols decls_of_imported_module [] line_nr modules cs + cs = { cs & cs_error = popErrorAdmin cs.cs_error } + = (result, modules, cs) + +filter_explicitly_imported_decl _ [] akku _ modules cs + = (akku, modules, cs) +filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,dcls_explicit}):new_decls] akku + line_nr modules cs + # undefined = -1 + atoms = flatten (map toAtom import_symbols) + structures = flatten (map toStructure import_symbols) + (checked_atoms, cs) = checkAtoms atoms cs + unimported = (checked_atoms, structures) + ((dcls_import,unimported), modules, cs) + = filter_decl dcls_import [] unimported undefined modules cs + ((dcls_local,unimported), modules, cs) + = filter_decl dcls_local [] unimported index modules cs + cs_error = foldSt checkAtomError (fst unimported) cs.cs_error + cs_error = foldSt checkStructureError (snd unimported) cs_error + cs = { cs & cs_error=cs_error } + | (isEmpty dcls_import && isEmpty dcls_local && isEmpty dcls_explicit) + = filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs + # local_imports = [ { declaration & dcl_kind = STE_Imported declaration.dcl_kind index } + \\ declaration <- dcls_local] + new_dcls_explicit = [ (dcls, line_nr) \\ dcls<-dcls_import++local_imports ] + newAkku = [(index, { dcls_import=dcls_import, dcls_local=dcls_local , dcls_explicit=new_dcls_explicit}) : akku] + = filter_explicitly_imported_decl import_symbols new_decls newAkku line_nr modules cs + where + toAtom (ID_Function {ii_ident}) + = [(ii_ident, temporary_import_solution_XXX + (AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen False) + AT_Function)] + toAtom (ID_Class {ii_ident} _) + = [(ii_ident, AT_Class)] + toAtom (ID_Type {ii_ident} (Yes _)) + = [(ii_ident, AT_AlgType)] + toAtom (ID_Type {ii_ident} No) + = [(ii_ident, AT_Type)] + toAtom (ID_Record {ii_ident} yesOrNo) + = [(ii_ident, AT_RecordType)] + toAtom (ID_Instance _ ident _) + = [(ident, AT_Instance)] + toAtom _ + = [] + + atomTypeString AT_Function = "function" + atomTypeString AT_Class = "class" + atomTypeString AT_Instance = "instance" + atomTypeString _ = "type" + + toStructure (ID_Class {ii_ident} yesOrNo) + = to_structure ii_ident yesOrNo ST_Class + toStructure (ID_Type {ii_ident} yesOrNo) + = to_structure ii_ident yesOrNo ST_AlgType + toStructure (ID_Record {ii_ident} yesOrNo) + = to_structure ii_ident yesOrNo ST_RecordType +// MW added + toStructure (ID_Function {ii_ident}) + | do_temporary_import_solution_XXX + = [(ii_ident, SI_DotDot, ST_stomm_stomm_stomm ii_ident.id_name, No)] +// ..MW + toStructure _ + = [] + + to_structure _ No _ + = [] + to_structure ident (Yes []) structureType + = [(ident, SI_DotDot, structureType, No)] + to_structure ident (Yes elements) structureType + # element_idents = removeDup [ ii_ident \\ {ii_ident}<-elements] + = [(ident, (SI_Elements element_idents True),structureType, No)] + + checkAtoms l cs + # groups = grouped l + # wrong = filter isErrornous groups + unique = map hd groups + | isEmpty wrong + = (unique, cs) + = (unique, foldSt error wrong cs) + where + isErrornous l=:[(_,AT_Type),_:_] = True + isErrornous l=:[(_,AT_AlgType),_:_] = True + isErrornous l=:[(_,AT_RecordType),_:_] = True + isErrornous _ = False + + error [(ident, atomType):_] cs + = { cs & cs_error = checkError ("type "+++ident.id_name) "imported more than once in one from statement" + cs.cs_error } + + checkAtomError (id, AT_Instance) cs_error + = checkError ("specified instance of class "+++id.id_name) "not exported by the specified module" cs_error + checkAtomError (id, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen was_imported_at_least_once) cs_error + | do_temporary_import_solution_XXX + = case was_imported_at_least_once of + True -> cs_error + _ -> checkError id ("not exported by the specified module") cs_error + checkAtomError (id, atomType) cs_error + = checkError id ("not exported as a "+++atomTypeString atomType+++" by the specified module") cs_error + +// MW remove this later.. + checkStructureError (_,_, ST_stomm_stomm_stomm _, _) cs_error + | do_temporary_import_solution_XXX + = cs_error + // further with next alternative +// ..MW + checkStructureError (struct_id, (SI_Elements wrong_elements _), st, _) cs_error + = foldSt err wrong_elements cs_error + where + err element_id cs_error + # (element_type, structure_type) = case st of + ST_AlgType -> ("constructor", "algebraic type") + ST_RecordType -> ("field", "record type") + ST_Class -> ("member", "class") + = checkError element_id ( "not a "+++element_type+++" of "+++structure_type + +++" "+++struct_id.id_name) cs_error + checkStructureError _ cs_error + = cs_error + + // collect groups, e.g. grouped [3,5,1,3,1] = [[1,1],[3,3],[5]] + grouped [] + = [] + grouped l + # sorted = qsort l + = grouped_ [hd sorted] (tl sorted) [] + where + grouped_ group [] akku + = [group:akku] + grouped_ group=:[x:_] [h:t] akku + | x==h = grouped_ [h:group] t akku + = grouped_ [h] t [group:akku] + + qsort [] = [] + qsort [h:t] = qsort left++[h: qsort right] + where + left = [x \\ x<-t | greater x h] + right = [x \\ x<-t | not (greater x h) || x==h] + greater ({id_name=id_name_l}, atomType_l) ({id_name=id_name_r}, atomType_r) + | id_name_l >id_name_r = True + | id_name_l==id_name_r = toInt atomType_l > toInt atomType_r + = False + +instance == AtomType + where + (==) l r = toInt l==toInt r + +instance toInt AtomType + where + toInt AT_Function = 0 + toInt AT_Class = 1 + toInt AT_Instance = 2 + toInt AT_RecordType = 3 + toInt AT_AlgType = 3 + toInt AT_Type = 3 // AT_RecordType, AT_AlgType & AT_Type are in one class !!! + toInt (AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen _) + = 0 + +instance == ConsequenceKind + where + (==) CK_Type c = case c of CK_Type -> True + _ -> False + (==) CK_Constructor c = case c of CK_Constructor -> True + _ -> False + (==) (CK_Selector globDefinedSymb1) + c = case c of CK_Selector globDefinedSymb2 -> globDefinedSymb1==globDefinedSymb2 + _ -> False + (==) CK_Class c = case c of CK_Class-> True + _ -> False + (==) (CK_Function globIndex1) + c = case c of (CK_Function globIndex2) -> globIndex1==globIndex2 + _ -> False + (==) CK_Macro c = case c of CK_Macro-> True + _ -> False + +filter_decl [] akku unimported _ modules cs + = ((akku, unimported), modules, cs) +filter_decl [decl:decls] akku unimported index modules cs + # ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs + = filter_decl decls (if appears [decl:akku] akku) unimported index modules cs + +decl_appears :: !Declaration !ExplicitImports !Index !*{#DclModule} !*CheckState + -> (!(!Bool, !ExplicitImports), !*{#DclModule}, !*CheckState) +decl_appears dec=:{dcl_kind=STE_Imported ste_Kind def_index} unimported _ modules cs + = decl_appears {dec & dcl_kind=ste_Kind} unimported def_index modules cs +/* MW2 was: +decl_appears {dcl_ident,dcl_kind=STE_Constructor,dcl_index} unimported index modules cs + = elementAppears ST_AlgType dcl_ident dcl_index unimported index modules cs +*/ +decl_appears {dcl_ident,dcl_kind=STE_Constructor,dcl_index} unimported index modules cs + # (result=:((appears, unimported), modules, cs)) + = elementAppears ST_AlgType dcl_ident dcl_index unimported index modules cs + | appears || not do_temporary_import_solution_XXX + = result + = atomAppears dcl_ident dcl_index unimported index modules cs +/* MW2 was +decl_appears { dcl_ident,dcl_kind=(STE_Field _),dcl_index} unimported index modules cs + = elementAppears ST_RecordType dcl_ident dcl_index unimported index modules cs +*/ +decl_appears { dcl_ident,dcl_kind=(STE_Field _),dcl_index} unimported index modules cs + # (result=:((appears, unimported), modules, cs)) + = elementAppears ST_RecordType dcl_ident dcl_index unimported index modules cs + | appears || not do_temporary_import_solution_XXX + = result + = atomAppears dcl_ident dcl_index unimported index modules cs +/* MW2 was +decl_appears { dcl_ident,dcl_kind=STE_Member,dcl_index} unimported index modules cs + = elementAppears ST_Class dcl_ident dcl_index unimported index modules cs +*/ +decl_appears { dcl_ident,dcl_kind=STE_Member,dcl_index} unimported index modules cs + # (result=:((appears, unimported), modules, cs)) + = elementAppears ST_Class dcl_ident dcl_index unimported index modules cs + | appears || not do_temporary_import_solution_XXX + = result + = atomAppears dcl_ident dcl_index unimported index modules cs +decl_appears {dcl_ident, dcl_kind, dcl_index} unimported index modules cs + | isAtom dcl_kind + = atomAppears dcl_ident dcl_index unimported index modules cs + where + isAtom STE_DclFunction = True + isAtom (STE_FunctionOrMacro _) = True + isAtom STE_Class = True + isAtom STE_Type = True + isAtom STE_Instance = True + + +// CommonDefs CollectedDefinitions + +elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs + # ((result, structureImports), modules, cs) + = element_appears imported_st dcl_ident dcl_index structureImports [] index modules cs + = ((result, (atomicImports, structureImports)), modules, cs) + +atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules cs + # ((result, atomicImports), modules, cs) + = atom_appears dcl_ident dcl_index atomicImports [] index modules cs + = ((result, (atomicImports, structureImports)), modules, cs) + + +atom_appears _ _ [] akku _ modules cs + = ((False, akku), modules, cs) +atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules cs +// MW2.. + | do_temporary_import_solution_XXX + && ident.id_name==import_ident.id_name + && atomType==(AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) // True or False doesn't matter in this line + # new_h = (import_ident, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) + = ((True, [new_h:t]++akku), modules, cs) +// ..MW2 + | ident==import_ident + # (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs + = ((True, t++akku), modules, cs) + // goes further with next alternative + where + checkRecordError atomType import_ident dcl_index index modules cs + # (td_rhs, modules, cs) = lookup_type dcl_index index modules cs + cs_error = cs.cs_error + cs_error = case atomType of + AT_RecordType + -> case td_rhs of + RecordType _ -> cs_error + _ -> checkError import_ident "imported as a record type" cs_error + AT_AlgType + -> case td_rhs of + AlgType _ -> cs_error + _ -> checkError import_ident "imported as an algebraic type" cs_error + _ -> cs_error + = (modules, { cs & cs_error=cs_error }) +atom_appears ident dcl_index [h:t] akku index modules cs + = atom_appears ident dcl_index t [h:akku] index modules cs + +instance == StructureType + where + (==) ST_AlgType ST_AlgType = True + (==) ST_RecordType ST_RecordType = True + (==) ST_Class ST_Class = True + (==) _ _ = False + +element_appears _ _ _ [] akku _ modules cs + = ((False, akku), modules, cs) +// MW remove this later .. +element_appears imported_st element_ident dcl_index + [h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] akku + index modules cs + | do_temporary_import_solution_XXX + # (appears, modules, cs) + = element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs + | appears + = ((appears,[h:t]++akku), modules, cs) + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + // otherwise go further with next alternative +// ..MW +element_appears imported_st element_ident dcl_index + [h=:(_, _, st, _):t] akku + index modules cs + | imported_st<>st + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + // goes further with next alternative +element_appears imported_st element_ident dcl_index + [h=:(_, _, _, (Yes notDefinedHere)):t] akku + index modules cs + | notDefinedHere==dcl_index + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + // goes further with next alternative +element_appears imported_st element_ident dcl_index + [h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] akku + index modules cs + # (l,r) = span ((<>) element_ident) elements + | isEmpty r + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + # oneLess = l++(tl r) + newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo) + | not explicit + = ((True, [newStructure: t]++akku), modules, cs) + // the found element was explicitly specified by the programmer: check it + # (appears, _, _, modules, cs) + = element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs + | appears + = ((True, [newStructure: t]++akku), modules, cs) + # message = "does not belong to specified "+++(case st of + ST_Class -> "class." + _ -> "type.") + cs = { cs & cs_error= checkError element_ident message cs.cs_error} + = ((False, t++akku), modules, cs) +element_appears imported_st element_ident dcl_index + [h=:(struct_id, SI_DotDot, st, optInfo):t] akku + index modules cs + # (appears, defined, opt_element_idents, modules, cs) + = element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs + | not appears + # structureInfo = case opt_element_idents of + No -> SI_DotDot + Yes element_idents -> (SI_Elements element_idents False) + newStructure = (struct_id, SI_DotDot, st, (if defined No (Yes dcl_index))) + = element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs + # (Yes element_idents) = opt_element_idents + oneLess = filter ((<>) element_ident) element_idents + newStructure = (struct_id, (SI_Elements oneLess False), st, No) + = ((True,[newStructure:t]++akku), modules, cs) +element_appears imported_st element_ident dcl_index [h:t] akku index modules cs + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + +lookup_type dcl_index index modules cs + # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] + (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = continuation module_entry.ste_kind dcl_module modules cs + where + continuation (STE_OpenModule _ modul) _ modules cs + # allTypes = modul.mod_defs.def_types + = ((allTypes !! dcl_index).td_rhs, modules, cs) + continuation STE_ClosedModule dcl_module modules cs + # com_type_def = dcl_module.dcl_common.com_type_defs.[dcl_index] + = (com_type_def.td_rhs, modules, cs) + +// MW remove this later CCC +element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs + | not do_temporary_import_solution_XXX + = abort "element_appears_in_stomm_struct will be never called, when the above guard holds. This statement is only to remind people to remove this function." + # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] + (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = continuation imported_st module_entry.ste_kind dcl_module modules cs + where + continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs + // lookup the constructors/fields for the algebraic type/record + # allTypes = modul.mod_defs.def_types + search = dropWhile (\{td_name} -> td_name.id_name<>type_name_string) allTypes + | isEmpty search + = (False, modules, cs) + # {td_rhs} = hd search + | not (isRecordType td_rhs) + = (False, modules, cs) + # element_idents = getElements td_rhs + = (isMember element_ident element_idents, modules, cs) + continuation ST_RecordType STE_ClosedModule dcl_module modules cs + // lookup the type of the constructor and compare + # type_index = dcl_module.dcl_common.com_selector_defs.[dcl_index].sd_type_index + com_type_def = dcl_module.dcl_common.com_type_defs.[type_index] + appears = com_type_def.td_name.id_name==type_name_string + = (appears, modules, cs) + continuation ST_Class (STE_OpenModule _ modul) _ modules cs + // lookup the members for the class + # allClasses = modul.mod_defs.def_classes + search = dropWhile (\{class_name} -> class_name.id_name<>type_name_string) allClasses + | isEmpty search + = (False, modules, cs) + # {class_members} = hd search + element_idents = [ ds_ident \\ {ds_ident} <-:class_members ] + = (isMember element_ident element_idents, modules, cs) + continuation ST_Class STE_ClosedModule dcl_module modules cs + // lookup the class and compare + # com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index] + {glob_object} = com_member_def.me_class + com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object] + allMembers = com_class_def.class_members + member_idents = [ ds_ident \\ {ds_ident} <-: allMembers] + appears = com_class_def.class_name.id_name==type_name_string + = (appears, modules, cs) + continuation _ _ _ modules cs + = (False, modules, cs) + getElements (RecordType {rt_fields}) + = [ fs_name \\ {fs_name}<-:rt_fields ] + getElements _ + = [] + isRecordType (RecordType _) = True + isRecordType _ = False +// ..MW + +/* 1st result: whether the element appears in the structure + 2nd result: whether the structure is defined at all in the module + 3rd result: Yes: a list of all idents of the elements of the structure +the first bool implies the second +*/ +element_appears_in_struct imported_st element_ident dcl_index struct_ident index modules cs + # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] + (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = continuation imported_st module_entry.ste_kind dcl_module modules cs + where + continuation ST_Class (STE_OpenModule _ modul) _ modules cs + // lookup the members for the class + # allClasses = modul.mod_defs.def_classes + search = dropWhile (\{class_name} -> class_name<>struct_ident) allClasses + | isEmpty search + = (False, False, No, modules, cs) + # {class_members} = hd search + element_idents = [ ds_ident \\ {ds_ident} <-:class_members ] + = (isMember element_ident element_idents, True, Yes element_idents, modules, cs) + continuation imported_st (STE_OpenModule _ modul) _ modules cs + // lookup the constructors/fields for the algebraic type/record + # allTypes = modul.mod_defs.def_types + search = dropWhile (\{td_name} -> td_name<>struct_ident) allTypes + | isEmpty search + = (False, False, No, modules, cs) + # {td_rhs} = hd search + | not (isAlgOrRecordType td_rhs) + = (False, True, No, modules, cs) + # element_idents = getElements td_rhs + = (isMember element_ident element_idents, True, Yes element_idents, modules, cs) + continuation ST_Class STE_ClosedModule dcl_module modules cs + // lookup the class and compare + # com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index] + {glob_object} = com_member_def.me_class + com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object] + allMembers = com_class_def.class_members + member_idents = [ ds_ident \\ {ds_ident} <-: allMembers] + appears = com_class_def.class_name==struct_ident + = (appears, True, if appears (Yes member_idents) No, modules, cs) + continuation imported_st STE_ClosedModule dcl_module modules cs + // lookup the type of the constructor and compare + # type_index = if (imported_st==ST_AlgType) + dcl_module.dcl_common.com_cons_defs.[dcl_index].cons_type_index + dcl_module.dcl_common.com_selector_defs.[dcl_index].sd_type_index + com_type_def = dcl_module.dcl_common.com_type_defs.[type_index] + element_idents = getElements com_type_def.td_rhs + appears = com_type_def.td_name==struct_ident + = (appears, True, if appears (Yes element_idents) No, modules, cs) + isAlgOrRecordType (AlgType _) = True + isAlgOrRecordType (RecordType _) = True + isAlgOrRecordType _ = False + getElements (AlgType constructor_symbols) + = [ds_ident \\ {ds_ident} <- constructor_symbols] + getElements (RecordType {rt_fields}) + = [ fs_name \\ {fs_name}<-:rt_fields ] + getElements _ + = [] + +check_completeness_of_module :: .Index [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState); +check_completeness_of_module mod_index dcls_explicit file_name (f_consequences, modules, icl_functions, expr_heap, cs) + # dcls_imp = [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr)) + \\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit] + (conseqs, (f_consequences, modules, icl_functions, expr_heap)) + = seqList (map (consequences_of mod_index) dcls_imp) (f_consequences, modules, icl_functions, expr_heap) + conseqs = flatten conseqs + #! (modules, cs) = seq (map checkConsequenceError conseqs) (modules, cs) + = (f_consequences, modules, icl_functions, expr_heap, cs) + +consequences_of :: !Index + (!IdentWithKind, !(!Index,!Index), !(!String, !Int)) !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap) + -> (![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)) +consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_index), errMsgInfo) + (f_consequences, modules, icl_functions, expr_heap) + # (modul, modules) = modules![mod_index] + (consequences, (f_consequences, icl_functions, expr_heap)) + = case expl_imp_kind of + STE_FunctionOrMacro _ + -> consequences_of_macro count dcl_index f_consequences icl_functions expr_heap + _ + -> (consequences_of_simple_symbol expl_imp_kind modul dcl_index, (f_consequences, icl_functions,expr_heap)) + conseqs = removeDup consequences + = ([(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-conseqs], (f_consequences, modules, icl_functions, expr_heap)) + +consequences_of_macro count dcl_index f_consequences icl_functions expr_heap + # (icl_function, icl_functions) = icl_functions![dcl_index] + {fun_symb, fun_type, fun_body} = icl_function + result = consequences fun_body + = expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap) + where + expand_functions_and_dynamics [] akku unique_stuff + = (akku, unique_stuff) + expand_functions_and_dynamics [(_,CK_DynamicPatternType exprInfoPtr):t] akku (f_consequences, icl_functions, expr_heap) + # (conseqs, expr_heap) = expand_dynamic exprInfoPtr expr_heap + = expand_functions_and_dynamics t (conseqs++akku) (f_consequences, icl_functions, expr_heap) + expand_functions_and_dynamics [(ident,(CK_Function globIndex)):t] akku unique_stuff + # (conseqs, unique_stuff) = expand_function ident globIndex unique_stuff + = expand_functions_and_dynamics t (conseqs++akku) unique_stuff + expand_functions_and_dynamics [h:t] akku unique_stuff + = expand_functions_and_dynamics t [h:akku] unique_stuff + + expand_dynamic :: ExprInfoPtr *ExpressionHeap -> ([IdentWithCKind], *ExpressionHeap) + expand_dynamic exprInfoPtr expr_heap + // it is assumed, that the pointer structure from the fi_dynamics field (of record FunInfo) + // is a tree + # (exprInfo, expr_heap) = readPtr exprInfoPtr expr_heap + (conseqs, expr_heap) + = case exprInfo of + (EI_Dynamic No) + -> ([], expr_heap) + (EI_Dynamic (Yes dynamicType)) + -> (consequences dynamicType, expr_heap) + (EI_Dynamic (Yes dynamicType)) + -> (consequences dynamicType, expr_heap) + (EI_DynamicType dynamicType further_dynamic_ptrs) + # (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap + -> (further_conseqs++consequences dynamicType, expr_heap) + (EI_DynamicTypeWithVars _ dynamicType further_dynamic_ptrs) + # (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap + -> (further_conseqs++consequences dynamicType, expr_heap) + = (conseqs, expr_heap) + + expand_dynamics [] akku expr_heap + = (akku, expr_heap) + expand_dynamics [h:t] akku expr_heap + # (dyn, expr_heap) = expand_dynamic h expr_heap + = expand_dynamics t (dyn++akku) expr_heap + + + expand_function ident globIndex=:{glob_object,glob_module} (f_consequences, icl_functions, expr_heap) + | glob_module<>cIclModIndex // the function that is referred from within a macro is a DclFunction + // -> must be global -> is a consequence + = ([(ident, CK_Function globIndex)], (f_consequences, icl_functions, expr_heap)) + # (fun_def, icl_functions) = icl_functions![glob_object] + | fun_def.fun_info.fi_def_level==cGlobalScope // the function is defined in the icl module in the global scope + // -> it's not a consequence + = ([], (f_consequences, icl_functions, expr_heap)) + // otherwise the function was defined locally in a macro and stored in the IclModule object. + // it is not a consequence, but it's type and body are consequences ! + # (opt_f_consequences, f_consequences) = f_consequences![glob_object] + = case opt_f_consequences of + No # type_consequences = consequences fun_def.fun_type + body_consequences = consequences fun_def.fun_body + dynamic_pointers = fun_def.fun_info.fi_dynamics + # (dynamic_consequences, expr_heap) + = expand_dynamics dynamic_pointers [] expr_heap + f_consequences = { f_consequences & [glob_object]=Yes (count, No) } + (cons, (f_consequences, icl_functions, expr_heap)) + = expand_functions_and_dynamics body_consequences [] (f_consequences, icl_functions,expr_heap) + cons_of_function = type_consequences++cons++dynamic_consequences + f_consequences = { f_consequences & [glob_object]=Yes (count, Yes cons_of_function) } + -> (cons_of_function, (f_consequences, icl_functions, expr_heap)) + Yes (j, opt_consequences) + | j==count // the consequences of the function are already considered + -> ([], (f_consequences, icl_functions, expr_heap)) + Yes (j, Yes cons) + | j<count // always True + -> (cons, (f_consequences, icl_functions, expr_heap)) + +consequences_of_simple_symbol STE_Type {dcl_common} dcl_index + = consequences dcl_common.com_type_defs.[dcl_index] +consequences_of_simple_symbol STE_Constructor {dcl_common} dcl_index + = consequences dcl_common.com_cons_defs.[dcl_index] +consequences_of_simple_symbol STE_DclFunction {dcl_functions} dcl_index + = consequences dcl_functions.[dcl_index] +consequences_of_simple_symbol (STE_Field _) {dcl_common} dcl_index + = consequences dcl_common.com_selector_defs.[dcl_index] +consequences_of_simple_symbol STE_Class {dcl_common} dcl_index + = consequences dcl_common.com_class_defs.[dcl_index] +consequences_of_simple_symbol STE_Member {dcl_common} dcl_index + = consequences dcl_common.com_member_defs.[dcl_index] +consequences_of_simple_symbol STE_Instance {dcl_common} dcl_index + = consequences dcl_common.com_instance_defs.[dcl_index] + +checkConsequenceError (expl_imp_ident_kind, conseq_ident_kind=:(conseq_ident, conseq_kind), (file_name, line_nr)) + (modules, cs=:{cs_symbol_table, cs_error}) + # (c_ident, modules) + = case conseq_kind of + CK_Selector {glob_object,glob_module} // if a selector is a consequence of an imported macro the + # (modul, modules) = modules![glob_module] // it's FIELD has to be looked up + com_selector_def = modul.dcl_common.com_selector_defs.[glob_object.ds_index] + -> (com_selector_def.sd_field, modules) + _ -> (conseq_ident, modules) + ({ste_kind}, cs_symbol_table) = readPtr c_ident.id_info cs_symbol_table + cs_error + = case ste_kind of + STE_Empty + -> cError expl_imp_ident_kind + ( "explicitly imported without importing " + +++cIdent_kind_to_string conseq_ident_kind) + cs_error + _ -> cs_error + = (modules, { cs & cs_symbol_table=cs_symbol_table, cs_error=cs_error }) + where + ident_kind_to_string ({id_name}, kind) + = kind_to_string kind+++" "+++id_name + cIdent_kind_to_string ({id_name}, cKind) + = cKind_to_string cKind+++" "+++id_name + cError expl_imp_ident_kind=:(expl_ident,_) s2 cs_error + # identPos = { ip_ident = expl_ident, ip_line = line_nr, ip_file = file_name } + cs_error = pushErrorAdmin identPos cs_error + cs_error = checkError (ident_kind_to_string expl_imp_ident_kind) s2 cs_error + cs_error = popErrorAdmin cs_error + = cs_error + +kind_to_string (STE_FunctionOrMacro _) = "function" +kind_to_string STE_Type = "type" +kind_to_string STE_Constructor = "constructor" +kind_to_string (STE_Field _) = "field" +kind_to_string STE_Class = "class" +kind_to_string STE_Member = "member" +kind_to_string STE_Instance = "instance" +kind_to_string STE_DclFunction = "function" + +cKind_to_string (CK_Function _) = "function" +cKind_to_string CK_Macro = "macro" +cKind_to_string CK_Type = "type" +cKind_to_string CK_Constructor = "constructor" +cKind_to_string (CK_Selector _) = "appropriate record field" +cKind_to_string CK_Class = "class" + +class consequences x :: x -> [IdentWithCKind] + +instance consequences App + where consequences {app_symb, app_args} = consequences app_symb++consequences app_args + +instance consequences AlgebraicPattern + where consequences {ap_symbol, ap_expr} = [ (ap_symbol.glob_object.ds_ident, CK_Constructor) : consequences ap_expr] + +instance consequences AType + where + consequences {at_type} = consequences at_type + +instance consequences BasicPattern + where consequences {bp_expr} = consequences bp_expr + +instance consequences Case + where consequences { case_expr, case_guards, case_default, case_ident } + = consequences case_expr++consequences case_guards++consequences case_default + +instance consequences CasePatterns + where + consequences (AlgebraicPatterns _ algebraicPatterns) = consequences algebraicPatterns + consequences (BasicPatterns _ basicPatterns) = consequences basicPatterns + consequences (DynamicPatterns dynamicPatterns) = consequences dynamicPatterns + consequences NoPattern = [] + +instance consequences CheckedBody + where consequences {cb_rhs} = consequences cb_rhs + +instance consequences ClassDef + where + consequences {class_context} = consequences class_context + +instance consequences ClassInstance + where + consequences {ins_type} = consequences ins_type + +instance consequences ConsDef + where + consequences {cons_type} = consequences cons_type + +instance consequences DynamicPattern // the types, that are found via dp_type are checked later + where consequences { dp_rhs, dp_type } = [({ id_name="", id_info=nilPtr}, CK_DynamicPatternType dp_type): consequences dp_rhs] + +instance consequences DynamicExpr + where consequences { dyn_expr, dyn_opt_type } = consequences dyn_expr++consequences dyn_opt_type + +instance consequences DynamicType + where consequences { dt_type } = consequences dt_type + +instance consequences Expression + where + consequences (Var _) = [] + consequences (App app) = consequences app + consequences (expression @ expressions) = consequences expression++consequences expressions + consequences (Let let_) = consequences let_ + consequences (Case case_) = consequences case_ + consequences (Selection _ expression selections) = consequences expression++consequences selections + consequences (TupleSelect _ _ expression) = consequences expression + consequences (BasicExpr _ _) = [] + consequences (AnyCodeExpr _ _ _) = [] + consequences (ABCCodeExpr _ _) = [] + consequences (MatchExpr _ constructor expression) + = [(constructor.glob_object.ds_ident,CK_Constructor):consequences expression] + consequences (FreeVar _) = [] + consequences (DynamicExpr dynamicExpr) = consequences dynamicExpr + consequences EE = [] + +instance consequences FunctionBody + where consequences (CheckedBody body) = consequences body + consequences (TransformedBody body) = consequences body + // other alternatives should not occur + +instance consequences FunType + where + consequences {ft_type} = consequences ft_type + +instance consequences (Global x) | consequences x + where consequences { glob_object } = consequences glob_object + +instance consequences InstanceType + where + consequences {it_types, it_context} = consequences it_types++consequences it_context + +instance consequences Let + where consequences { let_binds, let_expr } + = consequences let_expr++(flatten [consequences bind_src \\ {bind_src}<-let_binds] ) + +instance consequences MemberDef + where + consequences {me_type} = consequences me_type + +instance consequences (Optional x) | consequences x + where consequences (Yes x) = consequences x + consequences No = [] + +instance consequences Selection + where consequences (RecordSelection globDefinedSymbol=:{glob_object={ds_ident}} _) + = [(ds_ident, CK_Selector globDefinedSymbol)] + consequences (ArraySelection {glob_object={ds_ident={id_name}}} _ _) + = [] + +instance consequences SelectorDef + where consequences {sd_type} = consequences sd_type + +instance consequences SymbIdent + where consequences {symb_name, symb_kind} + = case symb_kind of + SK_Constructor _ -> [(symb_name, CK_Constructor)] + SK_Function globalIndex -> [(symb_name, CK_Function globalIndex)] + SK_OverloadedFunction globalIndex + -> [(symb_name, CK_Function globalIndex)] + SK_Macro globalIndex -> [(symb_name, CK_Macro)] + _ -> [] + +instance consequences SymbolType + where + consequences {st_args, st_result, st_context} + = consequences st_args++consequences st_result++consequences st_context + +instance consequences TransformedBody + where consequences {tb_rhs} = consequences tb_rhs + +instance consequences Type + where + consequences (TA {type_name} arguments) + = [(type_name, CK_Type):consequences arguments] + consequences (l --> r) + = consequences l++consequences r + consequences (_ :@: arguments) + = consequences arguments + consequences _ + = [] + + +instance consequences TypeContext + where + consequences {tc_class= {glob_object={ds_ident}}, tc_types} + = [(ds_ident,CK_Class):consequences tc_types] + +instance consequences (TypeDef TypeRhs) // ==CheckedTypeDef + where + consequences {td_rhs, td_context} = consequences td_rhs++consequences td_context + +instance consequences TypeRhs + where + consequences (SynType aType) = consequences aType + consequences _ = [] + +instance consequences [a] | consequences a + where + consequences l = flatten (map consequences l) + diff --git a/frontend/general.dcl b/frontend/general.dcl new file mode 100644 index 0000000..e2215df --- /dev/null +++ b/frontend/general.dcl @@ -0,0 +1,31 @@ +definition module general + +from StdEnv import <<<, +, ~ + +instance ~ Bool + +instance <<< Bool +instance <<< (a,b) | <<< a & <<< b +instance <<< (a,b,c) | <<< a & <<< b & <<< c +instance <<< (a,b,c,d) | <<< a & <<< b & <<< c & <<< d +instance <<< (a,b,c,d,e) | <<< a & <<< b & <<< c & <<< d & <<< e +instance <<< [a] | <<< a + +:: Bind a b = + { bind_src :: !a + , bind_dst :: !b + } + +:: Env a b :== [Bind a b] + +:: Optional x = Yes !x | No + +(--->) infix :: .a !b -> .a | <<< b +(-?->) infix :: .a !(!Bool, !b) -> .a | <<< b + +instance + {#Char} + +cMAXINT :== 2147483647 + +:: BITVECT :== Int + diff --git a/frontend/general.icl b/frontend/general.icl new file mode 100644 index 0000000..83f854e --- /dev/null +++ b/frontend/general.icl @@ -0,0 +1,72 @@ +implementation module general + +import StdEnv + +:: Bind a b = + { bind_src :: !a + , bind_dst :: !b + } + +:: Env a b :== [Bind a b] + +:: Optional x = Yes !x | No + +cMAXINT :== 2147483647 + +:: BITVECT :== Int + +instance ~ Bool +where ~ b = not b + +instance <<< Bool +where + (<<<) file bool = file <<< (toString bool) + +instance <<< (a,b) | <<< a & <<< b +where + (<<<) file (x,y) = file <<< '(' <<< x <<< ", " <<< y <<< ") " + +instance <<< (a,b,c) | <<< a & <<< b & <<< c +where + (<<<) file (x,y,z) = file <<< '(' <<< x <<< ", " <<< y <<< ", " <<< z <<< ") " + +instance <<< (a,b,c,d) | <<< a & <<< b & <<< c & <<< d +where + (<<<) file (w,x,y,z) = file <<< '(' <<< w <<< ", " <<< x <<< ", " <<< y <<< ", " <<< z <<< ") " + +instance <<< (a,b,c,d,e) | <<< a & <<< b & <<< c & <<< d & <<< e +where + (<<<) file (v,w,x,y,z) = file <<< '(' <<< v <<< ", " <<< w <<< ", " <<< x <<< ", " <<< y <<< ", " <<< z <<< ") " + +instance <<< [a] | <<< a +where + (<<<) file [] = file <<< "[]" + (<<<) file l = showTail (file <<< "[") l + where + showTail f [x] = f <<< x <<< "] " + showTail f [a:x] = showTail (f <<< a <<< ", ") x + showTail f [] = f <<< "] " + +(--->) infix :: .a !b -> .a | <<< b +(--->) val message + | file_to_true (stderr <<< message <<< '\n') + = val + = abort "Internal error in --->" + +(-?->) infix :: .a !(!Bool, !b) -> .a | <<< b +(-?->) val (cond, message) + | cond && file_to_true (stderr <<< message <<< '\n') + = val + = abort "Internal error in --->" + +file_to_true :: !File -> Bool +file_to_true file = code { + .inline file_to_true + pop_b 2 + pushB TRUE + .end + } + +instance + {#Char} +where + (+) s t = s +++ t diff --git a/frontend/hashtable.dcl b/frontend/hashtable.dcl new file mode 100644 index 0000000..2d1621f --- /dev/null +++ b/frontend/hashtable.dcl @@ -0,0 +1,26 @@ +definition module hashtable + +import syntax + +:: HashTableEntry + +:: HashTable = + { hte_symbol_heap :: !.SymbolTable + , hte_entries :: !.{! .HashTableEntry} + } + +newHashTable :: *HashTable + +:: IdentClass = IC_Expression + | IC_Type + | IC_TypeAttr + | IC_Class + | IC_Module + | IC_Field !Ident + | IC_Selector + | IC_Instance ![Type] + | IC_Unknown + + +putIdentInHashTable :: !String !IdentClass !*HashTable -> (!Ident, !*HashTable) + diff --git a/frontend/hashtable.icl b/frontend/hashtable.icl new file mode 100644 index 0000000..ed90380 --- /dev/null +++ b/frontend/hashtable.icl @@ -0,0 +1,99 @@ +implementation module hashtable + +import predef, syntax, StdCompare, compare_constructor + + +:: HashTableEntry = HTE_Ident !String !SymbolPtr !IdentClass !HashTableEntry !HashTableEntry + | HTE_Empty + +:: HashTable = + { hte_symbol_heap :: !.SymbolTable + , hte_entries :: !.{! .HashTableEntry} + } + +:: IdentClass = IC_Expression + | IC_Type + | IC_TypeAttr + | IC_Class + | IC_Module + | IC_Field !Ident + | IC_Selector + | IC_Instance ![Type] + | IC_Unknown + +newHashTable :: *HashTable +newHashTable = { hte_symbol_heap = newHeap, hte_entries = { HTE_Empty \\ i <- [0 .. dec cHashTableSize] }} + +instance =< IdentClass +where + (=<) (IC_Instance types1) (IC_Instance types2) + = compare_types types1 types2 + where + compare_types [t1 : t1s] [t2 : t2s] + # cmp = t1 =< t2 + | cmp == Equal + = t1s =< t2s + = cmp + compare_types [] [] + = Equal + compare_types [] _ + = Smaller + compare_types _ [] + = Greater + (=<) (IC_Field typ_id1) (IC_Field typ_id2) + = typ_id1 =< typ_id2 + (=<) ic1 ic2 + | equal_constructor ic1 ic2 + = Equal + | less_constructor ic1 ic2 + = Smaller + = Greater + +instance =< (!a,!b) | =< a & =< b +where + (=<) (x1,y1) (x2,y2) + # cmp = x1 =< x2 + | cmp == Equal + = y1 =< y2 + = cmp + +cHashTableSize :== 1023 + +hashValue :: !String -> Int +hashValue name + # hash_val = hash_value name (size name) 0 mod cHashTableSize + | hash_val < 0 + = hash_val + cHashTableSize + = hash_val +where + hash_value :: !String !Int !Int -> Int + hash_value name index val + | index == 0 + = val + # index = dec index + char = name.[index] + = hash_value name index (val << 2 + toInt char) + +putIdentInHashTable :: !String !IdentClass !*HashTable -> (!Ident, !*HashTable) +putIdentInHashTable name indent_class {hte_symbol_heap,hte_entries} + # hash_val = hashValue name + (entries,hte_entries) = replace hte_entries hash_val HTE_Empty + (ident, hte_symbol_heap, entries) = insert name indent_class hte_symbol_heap entries + (_,hte_entries) = replace hte_entries hash_val entries + = (ident, { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries }) + +where + insert :: !String !IdentClass !*SymbolTable *HashTableEntry -> (!Ident, !*SymbolTable, !*HashTableEntry) + insert name indent_class hte_symbol_heap HTE_Empty + # (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap + = ({ id_name = name, id_info = hte_symbol_ptr}, hte_symbol_heap, HTE_Ident name hte_symbol_ptr indent_class HTE_Empty HTE_Empty) + insert name indent_class hte_symbol_heap (HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) + # cmp = (name,indent_class) =< (hte_name,hte_class) + | cmp == Equal + = ({ id_name = hte_name, id_info = hte_symbol_ptr}, hte_symbol_heap, HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) + | cmp == Smaller + #! (ident, hte_symbol_heap, hte_left) = insert name indent_class hte_symbol_heap hte_left + = (ident, hte_symbol_heap, HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) + #! (ident, hte_symbol_heap, hte_right) = insert name indent_class hte_symbol_heap hte_right + = (ident, hte_symbol_heap, HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) + diff --git a/frontend/main.icl b/frontend/main.icl new file mode 100644 index 0000000..c4532a3 --- /dev/null +++ b/frontend/main.icl @@ -0,0 +1,323 @@ +module main + +import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics + +import StdEnv + +Start world + # (std_io, world) = stdio world + (_, ms_out, world) = fopen "out" FWriteText world + (ms_out,world) = accFiles ( + \files -> + (let + (ms_paths, ms_files, ms_error) = converFileToListOfStrings "mainPrefs" files stderr + ms = CommandLoop No { ms_io = std_io, ms_out = ms_out, ms_error = ms_error, ms_files = ms_files, ms_paths = ms_paths } + in + (ms.ms_out, ms.ms_files))) world + = fclose ms_out world + +CommandLoop proj ms=:{ms_io} + # (answer, ms_io) = freadline (ms_io <<< "> ") + (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer)) + | command == [] + = CommandLoop proj { ms & ms_io = ms_io} + # (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io} + | ready + = ms + = CommandLoop proj ms + +:: MainStateDefs funs funtypes types conses classes instances members selectors = + { msd_funs :: !funs + , msd_funtypes :: !funtypes + , msd_types :: !types + , msd_conses :: !conses + , msd_classes :: !classes + , msd_instances :: !instances + , msd_members :: !members + , msd_selectors :: !selectors + , msd_genfuns :: ![FunDef] + } + + +:: *MainState funs funtypes types conses classes instances members selectors = + { ms_io :: !*File + , ms_error :: !*File + , ms_out :: !*File + , ms_paths :: !SearchPaths + , ms_files :: !*Files + } + +:: ModuleTree = ModuleNode !InterMod !ModuleTree !ModuleTree | NoModules + +containsModule name (ModuleNode {inter_name = {id_name}} left right) + # cmp = id_name =< name + | cmp == Equal + = True + | cmp == Smaller + = containsModule name right + = containsModule name left +containsModule name NoModules + = False + +addModule name mod tree=:(ModuleNode this_mod=:{inter_name = {id_name}} left right) + # cmp = id_name =< name + | cmp == Equal + = tree + | cmp == Smaller + = ModuleNode this_mod left (addModule name mod right) + = ModuleNode this_mod (addModule name mod left) right +addModule _ mod NoModules + = ModuleNode mod NoModules NoModules + +:: Project = + { proj_main_module :: !Ident + , proj_hash_table :: !.HashTable + , proj_predef_symbols :: !.PredefinedSymbols + , proj_modules :: !ModuleTree + } + +:: InterMod = + { inter_name :: Ident + , inter_modules :: !{# Ident} + , inter_fun_defs :: !{# FunDef} + , inter_icl_dcl_conversions :: !Optional {# Index} + , inter_dcl_icl_conversions :: !Optional {# Index} + } + + +DoCommand ['c':_] argument proj ms + # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) + (opt_mod, ms) = compileModule (toString file_name) ms + = (False, proj, ms) +DoCommand ['s':_] argument proj ms=:{ms_io, ms_files} + # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) + file_name = toString (file_name++['.icl']) + (ok,file,files) = fopen file_name FReadText ms_files + (lines,file) = freadlines file + (ok,files) = fclose file files + = (False, proj, {ms & ms_io = ms_io <<< ("file "+++file_name+++" "+++toString (length lines)+++" lines\n") <<< lines <<< "\n", ms_files = files}) +DoCommand ['t':_] argument proj ms=:{ms_files, ms_io} + # (file_names, ms_files, ms_io) = converFileToListOfStrings "testfiles" ms_files ms_io + = (False, proj, foldSt check_module file_names { ms & ms_files = ms_files, ms_io = ms_io }) +where + check_module file_name ms + # (opt_mod, ms) = compileModule file_name (ms ---> file_name) + = case opt_mod of + No + -> { ms & ms_io = ms.ms_io <<< file_name <<< " is not OK\n" } + _ + -> ms +DoCommand ['p':_] argument proj ms=:{ms_io, ms_files} + # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) + (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable + (mod_ident, hash_table) = putIdentInHashTable (toString file_name) IC_Module hash_table + = (False, Yes { proj_main_module = mod_ident, proj_hash_table = hash_table, proj_predef_symbols = predef_symbols, proj_modules = NoModules }, ms) +DoCommand ['q':_] argument proj ms + = (True, proj, ms) +DoCommand ['h':_] argument proj ms=:{ms_io} + = (False, proj, {ms & ms_io = ms_io <<< "No help available. Sorry.\n"}) +DoCommand command argument proj ms=:{ms_io} + = (False, proj, {ms & ms_io = ms_io <<< toString command <<< "?\n"}) + +freadlines file + | sfend file + = ([],file) + # (line, file) = freadline file + # (lines,file) = freadlines file + = ([line:lines],file) + +SplitAtLayoutChar [] = ([], []) +SplitAtLayoutChar [x:xs] + | x == ' ' || x == '\t' || x == '\n' + = ([], xs) + | otherwise + = ([x:word], rest_input) +where + (word, rest_input) = SplitAtLayoutChar xs + +compileModule mod_name ms + # (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable + (mod_ident, hash_table) = putIdentInHashTable mod_name IC_Module hash_table + (opt_module, predef_symbols, hash_table, ms) = loadModule mod_ident predef_symbols hash_table ms + = (opt_module, ms) + +loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths} + # (ok, mod, hash_table, ms_error, predef_symbols, ms_files) + = wantModule cWantIclFile mod_ident (hash_table ---> "Parsing") ms_error ms_paths predef_symbols ms_files + | not ok + = (No, predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error }) + # (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, ms_error, predef_symbols, ms_files) + = scanModule (mod ---> "Scanning") hash_table ms_error ms_paths predef_symbols ms_files + | not ok + = (No, predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error }) + # symbol_table = hash_table.hte_symbol_heap + (ok, icl_mod, dcl_mods, components, dcl_icl_conversions, heaps, predef_symbols, symbol_table, ms_error) + = checkModule mod nr_of_global_funs mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table ---> "Checking") ms_error + | not ok + = (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io }) + # {icl_functions,icl_instances,icl_specials,icl_common,icl_declared={dcls_import}} = icl_mod +// (components, icl_functions, ms_error) = showComponents components 0 True icl_functions ms_error + (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, ms_error) + = typeProgram (components ---> "Typing") icl_functions icl_specials icl_common dcls_import dcl_mods heaps predef_symbols ms_error + | not ok + = (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out }) + + # (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials] + (components, fun_defs, ms_io) = showTypes components 0 fun_defs ms_io +// (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out + (acc_args, components, fun_defs, var_heap) = analyseGroups (components ---> "Transform") fun_defs heaps.hp_var_heap + (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) + = transformGroups components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps heaps.hp_expression_heap +// (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error + (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps + (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps + (components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap) + = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols + dcl_types used_conses var_heap type_heaps expression_heap + (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out + (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) + = convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap + (dcl_types, var_heap, type_heaps) + = convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap +// (components, fun_defs, ms_out) = showComponents components 0 False fun_defs ms_out + = (Yes (buildInterMod mod_ident dcl_mods fun_defs dcl_icl_conversions), predef_symbols, + { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out }) + + +makeProject (Yes proj=:{proj_main_module,proj_hash_table,proj_predef_symbols}) ms + # (main_mod, proj_predef_symbols, proj_hash_table, ms) = loadModule proj_main_module proj_predef_symbols proj_hash_table ms + proj = { proj & proj_hash_table = proj_hash_table, proj_predef_symbols = proj_predef_symbols } + = case main_mod of + Yes main_mod=:{inter_modules} + # (proj_modules, ms) = collect_modules [ mod \\ mod <-: inter_modules ] (ModuleNode main_mod NoModules NoModules) ms + -> (Yes { proj & proj_modules = proj_modules }, ms) + _ + -> (Yes proj, ms) +where + collect_modules [{id_name} : modules] collected_modules ms + | containsModule id_name collected_modules + = collect_modules modules collected_modules ms + # (this_mod, ms) = compileModule id_name ms + = case this_mod of + Yes new_mod + -> collect_modules (modules ++ [ mod \\ mod <-: new_mod.inter_modules ]) (addModule id_name new_mod collected_modules) ms + _ + -> (NoModules, ms) + collect_modules [{id_name} : modules] collected_modules ms + = (collected_modules, ms) + +buildInterMod name dcl_modules fun_defs dcl_icl_conversions + = { inter_name = name + , inter_modules = { dcl_name \\ {dcl_name} <-: dcl_modules } + , inter_fun_defs = fun_defs + , inter_icl_dcl_conversions = build_icl_dcl_conversions (size fun_defs) dcl_icl_conversions + , inter_dcl_icl_conversions = dcl_icl_conversions + } +where + build_icl_dcl_conversions table_size (Yes conversion_table) + # dcl_table_size = size conversion_table + icl_dcl_conversions = update_conversion_array 0 dcl_table_size conversion_table (createArray table_size NoIndex) + = Yes (fill_empty_positions 0 table_size dcl_table_size icl_dcl_conversions) + build_icl_dcl_conversions table_size No + = No + + update_conversion_array dcl_index dcl_table_size conversion_table icl_conversions + | dcl_index < dcl_table_size + # icl_index = conversion_table.[dcl_index] + = update_conversion_array (inc dcl_index) dcl_table_size conversion_table + { icl_conversions & [icl_index] = dcl_index } + = icl_conversions + + fill_empty_positions next_index table_size next_new_index icl_conversions + | next_index < table_size + | icl_conversions.[next_index] == NoIndex + = fill_empty_positions (inc next_index) table_size (inc next_new_index) { icl_conversions & [next_index] = next_new_index } + = fill_empty_positions (inc next_index) table_size next_new_index icl_conversions + = icl_conversions + +showComponents :: !*{! Group} !Int !Bool !*{# FunDef} !*File -> (!*{! Group}, !*{# FunDef},!*File) +showComponents comps comp_index show_types fun_defs file + | comp_index >= size comps + = (comps, fun_defs, file) + # (comp, comps) = comps![comp_index] + # (fun_defs, file) = show_component comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n') + = showComponents comps (inc comp_index) show_types fun_defs file +where + show_component [] show_types fun_defs file + = (fun_defs, file <<< '\n') + show_component [fun:funs] show_types fun_defs file + #! fun_def = fun_defs.[fun] + | show_types + = show_component funs show_types fun_defs (file <<< '\n' <<< fun_def) + = show_component funs show_types fun_defs (file <<< fun_def) +// = show_component funs show_types fun_defs (file <<< fun_def.fun_symb) + +instance <<< Optional a | <<< a +where + (<<<) file (Yes x) = file <<< x + (<<<) file No = file + +showComponents2 :: !{! Group} !Int !*{# FunDef} !{! ConsClasses} !*File -> (!*{# FunDef},!*File) +showComponents2 comps comp_index fun_defs acc_args file + | comp_index >= (size comps) + = (fun_defs, file) + # (fun_defs, file) = show_component comps.[comp_index].group_members fun_defs acc_args file + = showComponents2 comps (inc comp_index) fun_defs acc_args file +where + show_component [] fun_defs _ file + = (fun_defs, file <<< '\n') + show_component [fun:funs] fun_defs acc_args file + #! fd = fun_defs.[fun] + # file = show_accumulating_arguments acc_args.[fun].cc_args (file <<< fd.fun_symb <<< '.' <<< fun <<< " (") + = show_component funs fun_defs acc_args (file <<< ") ") + + show_accumulating_arguments [ cc : ccs] file + | cc == cPassive + = show_accumulating_arguments ccs (file <<< 'p') + | cc == cActive + = show_accumulating_arguments ccs (file <<< 'c') + | cc == cAccumulating + = show_accumulating_arguments ccs (file <<< 'a') + = show_accumulating_arguments ccs (file <<< '?') + show_accumulating_arguments [] file + = file + + +show_components comps fun_defs = map (show_component fun_defs) comps + +show_component fun_defs [] = [] +show_component fun_defs [fun:funs] = [fun_defs.[fun ---> fun] : show_component fun_defs funs] + +showTypes :: !*{! Group} !Int !*{# FunDef} !*File -> (!*{! Group}, !*{# FunDef},!*File) +showTypes comps comp_index fun_defs file + | comp_index >= size comps + = (comps, fun_defs, file) + # (comp, comps) = comps![comp_index] + # (fun_defs, file) = show_types comp.group_members fun_defs (file <<< "component " <<< comp_index <<< '\n') + = showTypes comps (inc comp_index) fun_defs file +where + show_types [] fun_defs file + = (fun_defs, file <<< '\n') + show_types [fun:funs] fun_defs file + #! fun_def = fun_defs.[fun] + = show_types funs fun_defs (file <<< '\n' <<< fun_def.fun_type) + +converFileToListOfStrings file_name files error + # (ok, file, files) = fopen file_name FReadText files + | ok + # (lines, file) = read_lines file + = (lines, snd (fclose file files), error) + = ([], files, error <<< "Could not open \"" <<< file_name <<< "\"\n") +where + read_lines file + # (line, file) = freadline file + last_char_index = size line - 1 + | last_char_index < 0 + = ([], file) + | line.[last_char_index] == '\n' + | last_char_index == 0 || line.[0] == '|' + = read_lines file + # (lines, file) = read_lines file + = ([line % (0, last_char_index - 1) : lines ], file) + // otherwise + = ([line], file) diff --git a/frontend/overloading.dcl b/frontend/overloading.dcl new file mode 100644 index 0000000..2b1accb --- /dev/null +++ b/frontend/overloading.dcl @@ -0,0 +1,52 @@ +definition module overloading + +import StdEnv +import syntax, check + +:: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty + +:: ClassInstanceInfo :== {# {! .InstanceTree}} + +:: ArrayInstance = + { ai_record :: !TypeSymbIdent + , ai_members :: !{# DefinedSymbol} + } + +:: GlobalTCInstance = + { gtci_type :: !GlobalTCType + , gtci_index :: !Index + } + +:: SpecialInstances = + { si_next_array_member_index :: !Index + , si_array_instances :: ![ArrayInstance] + , si_next_TC_member_index :: !Index + , si_TC_instances :: ![GlobalTCInstance] + } + +:: OverloadingState = + { os_type_heaps :: !.TypeHeaps + , os_var_heap :: !.VarHeap + , os_symbol_heap :: !.ExpressionHeap + , os_predef_symbols :: !.PredefinedSymbols + , os_special_instances :: !.SpecialInstances + , os_error :: !.ErrorAdmin + } + +:: LocalTypePatternVariable + +tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState + -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState) + +:: TypeCodeInfo = + { tci_next_index :: !Index + , tci_instances :: ![GlobalTCInstance] + , tci_type_var_heap :: !.TypeVarHeap + } + +removeOverloadedFunctions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap + !*TypeCodeInfo !*VarHeap !*ErrorAdmin + -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) + +updateDynamics :: ![Int] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin + -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) diff --git a/frontend/overloading.icl b/frontend/overloading.icl new file mode 100644 index 0000000..ec2973a --- /dev/null +++ b/frontend/overloading.icl @@ -0,0 +1,1201 @@ +implementation module overloading + +import StdEnv + +import syntax, check, type, typesupport, utilities, unitype, predef, RWSDebug + + +:: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty + +:: ClassInstanceInfo :== {# {! .InstanceTree}} + +:: ReducedContext = + { rc_class :: !Global DefinedSymbol + , rc_types :: ![Type] + , rc_inst_module :: !Index + , rc_inst_members :: !{# DefinedSymbol} + , rc_red_contexts :: ![ClassApplication] + } + +:: ReducedContexts = + { rcs_class_context :: !ReducedContext + , rcs_constraints_contexts :: ![ReducedContexts] + } + +:: TypeCodeInstance = + { tci_index :: !Index + , tci_contexts :: ![ClassApplication] + } + + +:: ClassApplication = CA_Instance !ReducedContexts + | CA_Context !TypeContext + | CA_LocalTypeCode !VarInfoPtr /* for (local) type pattern variables */ + | CA_GlobalTypeCode !TypeCodeInstance /* for (global) type constructors */ + + +:: ArrayInstance = + { ai_record :: !TypeSymbIdent + , ai_members :: !{# DefinedSymbol} + } + +:: GlobalTCInstance = + { gtci_type :: !GlobalTCType + , gtci_index :: !Index + } + +:: SpecialInstances = + { si_next_array_member_index :: !Index + , si_array_instances :: ![ArrayInstance] + , si_next_TC_member_index :: !Index + , si_TC_instances :: ![GlobalTCInstance] + } + +:: LocalTypePatternVariable = + { ltpv_var :: !Int + , ltpv_new_var :: !VarInfoPtr + } + +:: LocalTypePatternVariables = + { ltp_var_heap :: !.VarHeap + , ltp_variables :: ![LocalTypePatternVariable] + } + +:: OverloadingState = + { os_type_heaps :: !.TypeHeaps + , os_var_heap :: !.VarHeap + , os_symbol_heap :: !.ExpressionHeap + , os_predef_symbols :: !.PredefinedSymbols + , os_special_instances :: !.SpecialInstances + , os_error :: !.ErrorAdmin + } + +instance =< TypeSymbIdent +where + (=<) {type_index={glob_module=mod1,glob_object=index1}} {type_index={glob_module=mod2,glob_object=index2}} + # cmp = mod1 =< mod2 + | cmp == Equal + = index1 =< index2 + = cmp + +instance =< GlobalTCType +where + (=<) globtype1 globtype2 + | equal_constructor globtype1 globtype2 + = compare_types globtype1 globtype2 + | less_constructor globtype1 globtype2 + = Smaller + = Greater + where + compare_types (GTT_Basic bt1) (GTT_Basic bt2) + = bt1 =< bt2 + compare_types (GTT_Constructor cons1) (GTT_Constructor cons2) + = cons1 =< cons2 + compare_types _ _ + = Equal + + +instanceError symbol types err=:{ea_file,ea_loc} + # ea_file = ea_file <<< "Overloading error " <<< hd ea_loc <<< ": \"" <<< symbol <<< "\" no instance available of type " <<< types <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + +contextError err=:{ea_file,ea_loc} + # ea_file = ea_file <<< "Overloading Error " <<< hd ea_loc <<< ": specified context is too general\n" + = { err & ea_file = ea_file, ea_ok = False} + +uniqueError symbol types err=:{ea_file, ea_loc} + # ea_file = ea_file <<< "Overloading/Uniqueness Error " <<< hd ea_loc <<< ": \"" <<< symbol <<< "\" uniqueness specification of instance conflicts with current application " <<< types <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + +unboxError type err=:{ea_file,ea_loc} + # ea_file = ea_file <<< "Overloading error " <<< hd ea_loc <<< ": instance cannot be unboxed" <<< type <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + +get :: !a !(Env a b) -> b | == a +get elem_id [] + = abort "illegal access" +get elem_id [b : bs] + | elem_id == b.bind_src + = b.bind_dst + = get elem_id bs + +/* + As soon as all overloaded variables in an type context are instantiated, context reduction is carried out. + This reduction yields a type class instance (here represented by a an index) and a list of + ClassApplications. +*/ + +simpleSubstitution type type_heaps + = substitute type type_heaps + +FoundObject object :== object.glob_module <> NotFound +ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound } + + +reduceContexts :: ![TypeContext] !{# CommonDefs} !ClassInstanceInfo !*SpecialInstances !*LocalTypePatternVariables + !*TypeHeaps !*Coercions !*PredefinedSymbols !*ErrorAdmin + -> *(![ClassApplication], !*SpecialInstances, !*LocalTypePatternVariables, !*TypeHeaps, !*Coercions, !*PredefinedSymbols, !*ErrorAdmin) +reduceContexts [] defs instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + = ([], special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) +reduceContexts [tc : tcs] defs instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + # (appl, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = try_to_reduce_context tc defs instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + (appls, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = reduceContexts tcs defs instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + = ([appl : appls], special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + +where + try_to_reduce_context :: !TypeContext !{# CommonDefs} !ClassInstanceInfo !*SpecialInstances !*LocalTypePatternVariables + !*TypeHeaps !*Coercions !*PredefinedSymbols !*ErrorAdmin + -> *(!ClassApplication, !*SpecialInstances, !*LocalTypePatternVariables, !*TypeHeaps, !*Coercions, !*PredefinedSymbols, !*ErrorAdmin) + try_to_reduce_context tc=:{tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info + special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + | is_reducible tc_types + | is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols + # (red_context, (special_instances, type_pattern_vars)) = reduce_TC_context class_symb (hd tc_types) special_instances type_pattern_vars + = (red_context, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + # (class_appls, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = reduceContext tc defs instance_info special_instances type_pattern_vars + type_heaps coercion_env predef_symbols error + = (CA_Instance class_appls, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = (CA_Context tc, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + +/* reduceContext :: !ClassDef !InstanceTree ![Type] !{# CommonDefs} !ClassInstanceInfo !*SpecialInstances !*LocalTypePatternVariables + !*TypeHeaps !*Coercions !*PredefinedSymbols !*ErrorAdmin + -> *(![ReducedContext], !*SpecialInstances, !*LocalTypePatternVariables, !*TypeHeaps, !*Coercions, !*PredefinedSymbols, !*ErrorAdmin) +*/ + reduceContext {tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs + instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + # {class_members,class_context,class_args,class_name} = defs.[glob_module].com_class_defs.[ds_index] + | size class_members > 0 + # class_instances = instance_info.[glob_module].[ds_index] + # ({glob_module,glob_object}, contexts, uni_ok, type_heaps, coercion_env) = find_instance tc_types class_instances defs type_heaps coercion_env + | (glob_module <> NotFound) && uni_ok + # {ins_members, ins_class} = defs.[glob_module].com_instance_defs.[glob_object] + | is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_ArrayClass predef_symbols && + is_unboxed_array tc_types predef_symbols + # (rcs_class_context, special_instances, predef_symbols, error) + = check_unboxed_type glob_module ins_class ins_members tc_types class_members defs special_instances predef_symbols error + = ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, + special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + # (appls, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = reduceContexts contexts defs instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + (constraints, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = reduceContextsInConstraints tc_types class_args class_context defs instance_info special_instances type_pattern_vars + type_heaps coercion_env predef_symbols error + + = ({ rcs_class_context = { rc_class = ins_class, rc_inst_module = glob_module, rc_inst_members = ins_members, + rc_types = tc_types, rc_red_contexts = appls }, rcs_constraints_contexts = constraints }, + special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + # rcs_class_context = { rc_class = class_symb, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] } + | glob_module <> NotFound + = ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, + special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, uniqueError class_name tc_types error) + = ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, + special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, instanceError class_name tc_types error) + # (constraints, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = reduceContextsInConstraints tc_types class_args class_context defs instance_info special_instances type_pattern_vars + type_heaps coercion_env predef_symbols error + = ({ rcs_class_context = { rc_class = class_symb, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] }, + rcs_constraints_contexts = constraints }, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + + reduceContextsInConstraints types class_args [] defs instance_info special_instances type_pattern_vars type_heaps coercion_env predef_symbols error + = ([], special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + reduceContextsInConstraints types class_args class_context defs instance_info special_instances type_pattern_vars + type_heaps=:{th_vars} coercion_env predef_symbols error + # th_vars = fold2St (\ type {tv_info_ptr} -> writePtr tv_info_ptr (TVI_Type type)) types class_args th_vars + (instantiated_context, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } + # (cappls, (special_instances, type_pattern_vars, type_var_heap, coercion_env, predef_symbols, error)) + = mapSt (reduce_context_in_constraint defs instance_info) instantiated_context + (special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + = (cappls, special_instances, type_pattern_vars, type_var_heap, coercion_env, predef_symbols, error) + + where + reduce_context_in_constraint defs instance_info tc (special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) + # (cappls, special_instances, type_pattern_vars, type_var_heap, coercion_env, predef_symbols, error) + = reduceContext tc defs instance_info special_instances + type_pattern_vars type_heaps coercion_env predef_symbols error + = (cappls, (special_instances, type_pattern_vars, type_var_heap, coercion_env, predef_symbols, error)) + + find_instance co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs type_heaps coercion_env + # (left_index, types, uni_ok, type_heaps, coercion_env) = find_instance co_types left defs type_heaps coercion_env + | FoundObject left_index + = (left_index, types, uni_ok, type_heaps, coercion_env) + # {ins_type={it_types,it_context}, ins_specials} = defs.[glob_module].com_instance_defs.[glob_object] + (matched, type_heaps) = match defs it_types co_types type_heaps + | matched + # (subst_context, type_heaps) = simpleSubstitution it_context type_heaps + (uni_ok, coercion_env, type_heaps) = adjust_type_attributes defs co_types it_types coercion_env type_heaps + (spec_inst, type_heaps) = trySpecializedInstances subst_context (get_specials ins_specials) type_heaps + | FoundObject spec_inst + = (spec_inst, [], uni_ok, type_heaps, coercion_env) + = (this_inst_index, subst_context, uni_ok, type_heaps, coercion_env) + = find_instance co_types right defs type_heaps coercion_env + find_instance co_types IT_Empty defs type_heaps coercion_env + = (ObjectNotFound, [], True, type_heaps, coercion_env) + + get_specials (SP_ContextTypes specials) = specials + get_specials SP_None = [] + + adjust_type_attributes defs act_types form_types coercion_env type_heaps + = fold2St (adjust_type_attribute defs) act_types form_types (True, coercion_env, type_heaps) + + adjust_type_attribute defs (TA type_cons1 cons_args1) (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps) + | type_cons1 == type_cons2 + # (ok, coercion_env) = fold2St adjust_attribute cons_args1 cons_args2 (ok, coercion_env) + = (ok, coercion_env, type_heaps) + # (_, type1, type_heaps) = tryToExpandTypeSyn defs type_cons1 cons_args1 type_heaps + (_, type2, type_heaps) = tryToExpandTypeSyn defs type_cons2 cons_args2 type_heaps + = adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps) + adjust_type_attribute _ _ _ state + = state + + adjust_attribute {at_attribute} {at_attribute = TA_Var _} state + = state + adjust_attribute {at_attribute} {at_attribute = TA_Unique} (ok, coercion_env) + = case at_attribute of + TA_Unique + -> (ok, coercion_env) + TA_TempVar av_number + # (succ, coercion_env) = tryToMakeUnique av_number coercion_env + -> (ok && succ, coercion_env) + _ + -> (False, coercion_env) + adjust_attribute {at_attribute} attr (ok, coercion_env) + = case at_attribute of + TA_Multi + -> (ok, coercion_env) + TA_TempVar av_number + # (succ, coercion_env) = tryToMakeNonUnique av_number coercion_env + -> (ok && succ, coercion_env) + _ + -> (False, coercion_env) + + is_reducible [] + = True + is_reducible [TempV _ : types] + = False + is_reducible [ _ :@: _ : types] + = False + is_reducible [ _ : types] + = is_reducible types + + is_predefined_symbol mod_index symb_index predef_index predef_symbols + # {pds_def,pds_module,pds_ident} = predef_symbols.[predef_index] + = (mod_index == pds_module && symb_index == pds_def) + + is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols + = is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols + is_unboxed_array _ predef_symbols + = False + + + check_unboxed_type ins_module ins_class ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols error + # (unboxable, opt_record, predef_symbols) = try_to_unbox elem_type defs predef_symbols + | unboxable + = case opt_record of + Yes record + # (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances + -> ({ rc_class = ins_class, rc_inst_module = cIclModIndex, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, + special_instances, predef_symbols, error) + No + -> ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, + special_instances, predef_symbols, error) + = ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, + special_instances, predef_symbols, unboxError elem_type error) + where + try_to_unbox (TB _) _ predef_symbols + = (True, No, predef_symbols) + try_to_unbox (TA type_symb=:{type_index={glob_module,glob_object},type_arity} _) defs predef_symbols + # {td_arity,td_rhs} = defs.[glob_module].com_type_defs.[glob_object] + = case td_rhs of + RecordType _ + -> (True, (Yes type_symb), predef_symbols) + AbstractType _ + #! unboxable = + is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols || + is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols || + is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols + -> (unboxable, No, predef_symbols) + _ + -> (False, No, predef_symbols) + + try_to_unbox type _ predef_symbols + = (True, No, predef_symbols) + + add_record_to_array_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances) + add_record_to_array_instances record members special_instances=:{si_next_array_member_index,si_array_instances} + # (inst_members, si_array_instances, si_next_array_member_index) = add_array_instance record members si_next_array_member_index si_array_instances + = (inst_members, { special_instances & si_array_instances = si_array_instances, si_next_array_member_index = si_next_array_member_index }) + where + add_array_instance :: !TypeSymbIdent !{# DefinedSymbol} !Index !u:[ArrayInstance] + -> (!{#DefinedSymbol}, !u:[ArrayInstance], !Index) + add_array_instance record members next_member_index instances=:[inst : insts] + # cmp = record =< inst.ai_record + | cmp == Equal + = (inst.ai_members, instances, next_member_index) + | cmp == Smaller + # ai_members = { { class_member & ds_index = next_inst_index } \\ + class_member <-: members & next_inst_index <- [next_member_index .. ]} + = (ai_members, [{ ai_members = ai_members, ai_record = record } : instances ], next_member_index + size members) + # (found_inst, insts, next_member_index) = add_array_instance record members next_member_index insts + = (found_inst, [inst : insts], next_member_index) + add_array_instance record members next_member_index [] + # ai_members = { { class_member & ds_index = next_inst_index } \\ + class_member <-: members & next_inst_index <- [next_member_index .. ]} + = (ai_members, [{ ai_members = ai_members, ai_record = record }], next_member_index + size members) + + + reduce_TC_context type_code_class tc_type special_instances type_pattern_vars + = reduce_tc_context type_code_class tc_type (special_instances, type_pattern_vars) + where + reduce_tc_context type_code_class (TA cons_id cons_args) (special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars) + # (inst_index, (si_next_TC_member_index, si_TC_instances)) + = addGlobalTCInstance (GTT_Constructor cons_id) (si_next_TC_member_index, si_TC_instances) + (rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args + ({ special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars) + = (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances) + + reduce_tc_context type_code_class (TB basic_type) (special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars) + # (inst_index, (si_next_TC_member_index, si_TC_instances)) + = addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances) + = (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = [] }, + ({ special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars)) + + reduce_tc_context type_code_class (arg_type --> result_type) (special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars) + # (inst_index, (si_next_TC_member_index, si_TC_instances)) + = addGlobalTCInstance GTT_Function (si_next_TC_member_index, si_TC_instances) + (rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type] + ({ special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars) + = (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances) + + + reduce_tc_context type_code_class (TempQV var_number) (special_instances, type_pattern_vars) + # (inst_var, type_pattern_vars) = addLocalTCInstance var_number type_pattern_vars + = (CA_LocalTypeCode inst_var, (special_instances, type_pattern_vars)) + + reduce_tc_context type_code_class (TempV var_number) instances + = (CA_Context { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = nilPtr }, instances) + + + reduce_TC_contexts type_code_class cons_args instances + = mapSt (\{at_type} -> reduce_tc_context type_code_class at_type) cons_args instances + +addLocalTCInstance var_number ltp=:{ltp_variables=instances=:[inst : insts], ltp_var_heap} + # cmp = var_number =< inst.ltpv_var + | cmp == Equal + = (inst.ltpv_new_var, ltp) + | cmp == Smaller + # (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap + = (ltpv_new_var, { ltp_variables = [{ ltpv_new_var = ltpv_new_var, ltpv_var = var_number } : instances ], ltp_var_heap = ltp_var_heap }) + # (found_var, ltp) = addLocalTCInstance var_number { ltp & ltp_variables = insts } + = (found_var, { ltp & ltp_variables = [inst :ltp.ltp_variables ] }) +addLocalTCInstance var_number {ltp_variables = [], ltp_var_heap} + # (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap + = (ltpv_new_var, { ltp_variables = [{ ltpv_new_var = ltpv_new_var, ltpv_var = var_number }], ltp_var_heap = ltp_var_heap }) + +addGlobalTCInstance type_of_TC (next_member_index, instances=:[inst : insts]) + # cmp = type_of_TC =< inst.gtci_type + | cmp == Equal + = (inst.gtci_index, (next_member_index, instances)) + | cmp == Smaller + = (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC } : instances ])) + # (found_inst, (next_member_index, insts)) = addGlobalTCInstance type_of_TC (next_member_index, insts) + = (found_inst, (next_member_index, [inst : insts])) +addGlobalTCInstance type_of_TC (next_member_index, []) + = (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC }])) + +tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module}} type_args type_heaps + # {td_name,td_rhs,td_args} = defs.[glob_module].com_type_defs.[glob_object] + | is_synonym_type td_rhs + # (SynType {at_type}) = td_rhs + type_heaps = fold2St bind_var td_args type_args type_heaps + (expanded_type, type_heaps) = substitute at_type type_heaps + = (True, expanded_type, type_heaps) + = (False, TA cons_id type_args, type_heaps) +where + is_synonym_type (SynType _) + = True + is_synonym_type type_rhs + = False + + bind_var {atv_attribute = TA_Var {av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute, at_type} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } + bind_var {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } + +class match type :: !{# CommonDefs} !type !type !*TypeHeaps -> (!Bool, !*TypeHeaps) + +instance match AType +where + match defs atype1 atype2 type_heaps = match defs atype1.at_type atype2.at_type type_heaps + +instance match Type +where + match defs (TV {tv_info_ptr}) type type_heaps=:{th_vars} + = (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type type)}) + match defs (TA cons_id1 cons_args1) (TA cons_id2 cons_args2) type_heaps + | cons_id1 == cons_id2 + = match defs cons_args1 cons_args2 type_heaps +// # (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps + # (succ2, type2, type_heaps) = tryToExpandTypeSyn defs cons_id2 cons_args2 type_heaps + | succ2 + = case type2 of + TA cons_id2 cons_args2 + | cons_id1 == cons_id2 + -> match defs cons_args1 cons_args2 type_heaps + -> (False, type_heaps) + _ + -> (False, type_heaps) + = (False, type_heaps) + match defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) type_heaps + = match defs (arg_type1,res_type1) (arg_type2,res_type2) type_heaps + match defs (type1 :@: types1) (type2 :@: types2) type_heaps + = match defs (type1,types1) (type2,types2) type_heaps + match defs (CV tv :@: types) (TA type_cons cons_args) type_heaps + # diff = type_cons.type_arity - length types + | diff >= 0 + = match defs (TV tv, types) (TA { type_cons & type_arity = diff } (take diff cons_args), drop diff cons_args) type_heaps + = (False, type_heaps) + match defs (TB tb1) (TB tb2) type_heaps + = (tb1 == tb2, type_heaps) +/* match defs type (TB (BT_String array_type)) type_heaps + = match defs type array_type type_heaps +*/ match defs (TA cons_id cons_args) type2 type_heaps + # (succ, type1, type_heaps) = tryToExpandTypeSyn defs cons_id cons_args type_heaps + | succ + = match defs type1 type2 type_heaps + = (False, type_heaps) + match defs type1 (TA cons_id cons_args) type_heaps + # (succ, type2, type_heaps) = tryToExpandTypeSyn defs cons_id cons_args type_heaps + | succ + = match defs type1 type2 type_heaps + = (False, type_heaps) + match defs type1 type2 type_heaps + = (False, type_heaps) + +instance match (!a,!b) | match a & match b +where + match defs (x1,y1) (x2,y2) type_heaps + # (matched, type_heaps) = match defs x1 x2 type_heaps + | matched + = match defs y1 y2 type_heaps + = (False, type_heaps) + +instance match [a] | match a +where + match defs [t1 : ts1] [t2 : ts2] type_heaps + = match defs (t1,ts1) (t2,ts2) type_heaps + match defs [] [] type_heaps + = (True, type_heaps) + +instance match ConsVariable +where + match defs (CV {tv_info_ptr}) cons_var type_heaps=:{th_vars} + = (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type (consVariableToType cons_var))}) + +consVariableToType (TempCV temp_var_id) + = TempV temp_var_id +consVariableToType (TempQCV temp_var_id) + = TempQV temp_var_id + +trySpecializedInstances type_contexts [] type_heaps + = (ObjectNotFound, type_heaps) +trySpecializedInstances type_contexts specials type_heaps=:{th_vars} + # (spec_index, th_vars) = try_specialized_instances (map (\{tc_types} -> tc_types) type_contexts) specials th_vars + = (spec_index, { type_heaps & th_vars = th_vars }) +where + + try_specialized_instances type_contexts_types [{spec_index,spec_vars,spec_types} : specials] type_var_heap + # type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) spec_vars type_var_heap + (equ, type_var_heap) = equalTypes spec_types type_contexts_types type_var_heap + | equ + = (spec_index, type_var_heap) + = try_specialized_instances type_contexts_types specials type_var_heap + try_specialized_instances type_contexts_types [] type_var_heap + = (ObjectNotFound, type_var_heap) + +tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState + -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState) +tryToSolveOverloading ocs defs instance_info coercion_env os + = foldSt (try_to_solve_overloading defs instance_info) ocs ([], coercion_env, [], os) +where + + try_to_solve_overloading defs instance_info (fun_context, call_ptrs, location) (contexts, coercion_env, type_pattern_vars, os=:{os_error}) + | isEmpty call_ptrs + = (contexts, coercion_env, type_pattern_vars, os) + # os = { os & os_error = setErrorAdmin location os_error } + = case fun_context of + Yes specified_context + # (_, coercion_env, type_pattern_vars, os) + = reduce_and_simplify_contexts call_ptrs defs instance_info True specified_context coercion_env type_pattern_vars os + -> (contexts, coercion_env, type_pattern_vars, os) +// ---> ("try_to_solve_overloading (Yes ...)", specified_context) + No + -> reduce_and_simplify_contexts call_ptrs defs instance_info False contexts coercion_env type_pattern_vars os +// ---> ("try_to_solve_overloading (No)", contexts) + + reduce_and_simplify_contexts :: ![ExprInfoPtr] !{# CommonDefs } !ClassInstanceInfo !Bool ![TypeContext] !*Coercions ![LocalTypePatternVariable] + !*OverloadingState -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState) + reduce_and_simplify_contexts [over_info_ptr : ocs] defs instance_info has_context contexts coercion_env type_pattern_vars os=:{os_symbol_heap, os_type_heaps} + # (EI_Overloaded {oc_symbol, oc_context, oc_specials}, os_symbol_heap) = readPtr over_info_ptr os_symbol_heap + (glob_fun, os_type_heaps) = trySpecializedInstances oc_context oc_specials os_type_heaps + | FoundObject glob_fun + # os_symbol_heap = os_symbol_heap <:= (over_info_ptr, EI_Instance {glob_module = glob_fun.glob_module, glob_object = + { ds_ident = oc_symbol.symb_name, ds_arity = 0, ds_index = glob_fun.glob_object }} []) + = reduce_and_simplify_contexts ocs defs instance_info has_context contexts coercion_env type_pattern_vars + { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap } + # (appls, os_special_instances, {ltp_var_heap, ltp_variables}, os_type_heaps, coercion_env, os_predef_symbols, os_error) + = reduceContexts oc_context defs instance_info os.os_special_instances {ltp_var_heap = os.os_var_heap, ltp_variables = type_pattern_vars} + os_type_heaps coercion_env os.os_predef_symbols os.os_error + | os_error.ea_ok + # (contexts, os_type_heaps, os_var_heap, os_symbol_heap, os_error) + = simplifyOverloadedCall oc_symbol over_info_ptr appls defs has_context contexts os_type_heaps ltp_var_heap os_symbol_heap os_error + = reduce_and_simplify_contexts ocs defs instance_info has_context contexts coercion_env ltp_variables { os & + os_type_heaps = os_type_heaps, os_var_heap = os_var_heap, os_symbol_heap = os_symbol_heap, + os_predef_symbols = os_predef_symbols, os_special_instances = os_special_instances, os_error = os_error } + + = reduce_and_simplify_contexts ocs defs instance_info has_context contexts coercion_env ltp_variables + { os & os_type_heaps = os_type_heaps, os_predef_symbols = os_predef_symbols, os_symbol_heap = os_symbol_heap, + os_special_instances = os_special_instances, os_error = os_error, os_var_heap = ltp_var_heap} + reduce_and_simplify_contexts [] defs instance_info has_context contexts coercion_env type_pattern_vars os + = (contexts, coercion_env, type_pattern_vars, os) + +/* +RecordName = { id_name = "_Record", id_info = nilPtr } + +InternalSelectSymbol = { symb_name = {id_name = "_Select", id_info = nilPtr }, + symb_kind = SK_InternalFunction (-1), symb_arity = 2 } +*/ + +selectFromDictionary dict_mod dict_index member_index defs + # (RecordType {rt_fields}) = defs.[dict_mod].com_type_defs.[dict_index].td_rhs + { fs_name, fs_index } = rt_fields.[member_index] + = { glob_module = dict_mod, glob_object = { ds_ident = fs_name, ds_index = fs_index, ds_arity = 1 }} + +getDictionaryConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs + # {class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] + (RecordType {rt_constructor}) = defs.[glob_module].com_type_defs.[class_dictionary.ds_index].td_rhs + = rt_constructor + +simplifyOverloadedCall {symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} expr_info_ptr [class_appl:class_appls] + defs has_context contexts type_heaps var_heap symbol_heap error + # mem_def = defs.[glob_module].com_member_defs.[glob_object] + # (class_exprs, (contexts, heaps, error)) = convertClassApplsToExpressions defs has_context class_appls (contexts, (type_heaps, var_heap, symbol_heap), error) + (inst_expr, contexts, (type_heaps, var_heap, symbol_heap), error) + = adjust_member_application mem_def symb_arity class_appl class_exprs defs has_context contexts heaps error + = (contexts, type_heaps, var_heap, symbol_heap <:= (expr_info_ptr, inst_expr), error) + +where + adjust_member_application {me_symb,me_offset,me_class} symb_arity (CA_Instance red_contexts) class_exprs defs has_context contexts heaps error + # ({glob_module,glob_object}, red_contexts) = find_instance_of_member me_class me_offset red_contexts + (exprs, (contexts, heaps, error)) = convertClassApplsToExpressions defs has_context red_contexts (contexts, heaps, error) + class_exprs = exprs ++ class_exprs + = (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_symb, ds_arity = length class_exprs, ds_index = glob_object }} + class_exprs, contexts, heaps, error) + adjust_member_application {me_symb,me_offset,me_class={glob_module,glob_object}} symb_arity (CA_Context tc) + class_exprs defs has_context contexts (type_heaps, var_heap, symbol_heap) error + # (class_context, address, contexts, type_heaps, var_heap, error) + = determineContextAddress tc has_context contexts defs type_heaps var_heap error + {class_dictionary={ds_index}} = defs.[glob_module].com_class_defs.[glob_object] + selector = selectFromDictionary glob_module ds_index me_offset defs + = (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) (createBoundVar class_context) class_exprs, + contexts, (type_heaps, var_heap, symbol_heap), error) + + adjust_member_application _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ defs has_context contexts heaps error + # (exprs, (contexts, heaps, error)) = convertClassApplsToExpressions defs has_context tci_contexts (contexts, heaps, error) + = (EI_TypeCode (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), contexts, heaps, error) + adjust_member_application _ _ (CA_LocalTypeCode new_var_ptr) _ defs has_context contexts heaps error + = (EI_TypeCode (TCE_Var new_var_ptr), contexts, heaps, error) + + find_instance_of_member me_class me_offset { rcs_class_context = {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts}, rcs_constraints_contexts} + | rc_class.glob_module == me_class.glob_module && rc_class.glob_object.ds_index == me_class.glob_object + = ({ glob_module = rc_inst_module, glob_object = rc_inst_members.[me_offset].ds_index }, rc_red_contexts) + = find_instance_of_member_in_constraints me_class me_offset rcs_constraints_contexts + where + find_instance_of_member_in_constraints me_class me_offset [ rcs=:{rcs_constraints_contexts} : rcss ] + = find_instance_of_member me_class me_offset {rcs & rcs_constraints_contexts = rcs_constraints_contexts ++ rcss} + find_instance_of_member_in_constraints me_class me_offset [] + = abort "Error in module overloading: find_instance_of_member_in_constraints\n" + +simplifyOverloadedCall {symb_kind = SK_TypeCode} expr_info_ptr class_appls defs has_context contexts type_heaps var_heap symbol_heap error + # (class_expressions, (contexts, (type_heaps, var_heap, symbol_heap), error)) + = convertClassApplsToExpressions defs has_context class_appls (contexts, (type_heaps, var_heap, symbol_heap), error) + = (contexts, type_heaps, var_heap, symbol_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions)), error) +simplifyOverloadedCall _ expr_info_ptr appls defs has_context contexts type_heaps var_heap symbol_heap error + # (class_expressions, (contexts, (type_heaps, var_heap, symbol_heap), error)) + = convertClassApplsToExpressions defs has_context appls (contexts, (type_heaps, var_heap, symbol_heap), error) + = (contexts, type_heaps, var_heap, symbol_heap <:= (expr_info_ptr, EI_Context class_expressions), error) + + +expressionToTypeCodeExpression (TypeCodeExpression texpr) = texpr +expressionToTypeCodeExpression (Var {var_info_ptr}) = TCE_Var var_info_ptr + +generateClassSelection address last_selectors + = mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors + +convertClassApplsToExpressions defs has_context cl_appls contexts_heaps_error + = mapSt (convert_class_appl_to_expression defs has_context) cl_appls contexts_heaps_error +where + convert_class_appl_to_expression defs has_context (CA_Instance {rcs_class_context,rcs_constraints_contexts}) contexts_heaps_error + # (class_symb, class_members, instance_types, contexts_heaps_error) + = convert_reduced_context_to_expression defs has_context rcs_class_context contexts_heaps_error + (members_of_constraints, (contexts, (type_heaps, var_heap, expr_heap), error)) + = convert_list_of_reduced_contexts_to_expressions defs has_context rcs_constraints_contexts contexts_heaps_error + {ds_ident,ds_index,ds_arity} = getDictionaryConstructor class_symb defs + record_symbol = { symb_name = ds_ident, symb_kind = SK_Constructor {glob_module = class_symb.glob_module, glob_object = ds_index}, symb_arity = ds_arity } + (app_info_ptr, expr_heap) = newPtr (EI_ClassTypes instance_types) expr_heap + = (App { app_symb = record_symbol, app_args = class_members ++ members_of_constraints, app_info_ptr = app_info_ptr }, + (contexts, (type_heaps, var_heap, expr_heap), error)) + convert_class_appl_to_expression defs has_context (CA_Context tc) (contexts, (type_heaps, var_heap, expr_heap), error) + # (class_context, context_address, contexts, type_heaps, var_heap, error) + = determineContextAddress tc has_context contexts defs type_heaps var_heap error + | isEmpty context_address + = (Var (createBoundVar class_context), (contexts, (type_heaps, var_heap, expr_heap), error)) + = (Selection No (Var (createBoundVar class_context)) (generateClassSelection context_address []), (contexts, (type_heaps, var_heap, expr_heap), error)) + convert_class_appl_to_expression defs has_context (CA_LocalTypeCode new_var_ptr) contexts_heaps_error + = (TypeCodeExpression (TCE_Var new_var_ptr), contexts_heaps_error) + convert_class_appl_to_expression defs has_context (CA_GlobalTypeCode {tci_index,tci_contexts}) contexts_heaps_error + # (exprs, contexts_heaps_error) = convertClassApplsToExpressions defs has_context tci_contexts contexts_heaps_error + = (TypeCodeExpression (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), contexts_heaps_error) + + convert_reduced_context_to_expression defs has_context {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} contexts_heaps_error + # (expressions, contexts_heaps_error) = convertClassApplsToExpressions defs has_context rc_red_contexts contexts_heaps_error + members = build_class_members 0 rc_inst_members rc_inst_module expressions (length expressions) + = (rc_class, members, rc_types, contexts_heaps_error) + where + build_class_members mem_offset ins_members mod_index class_arguments arity + | mem_offset == size ins_members + = [] + # expressions = build_class_members (inc mem_offset) ins_members mod_index class_arguments arity + {ds_ident,ds_index} = ins_members.[mem_offset] + = [ App { app_symb = { symb_name = ds_ident, symb_kind = SK_Function { glob_object = ds_index, glob_module = mod_index }, + symb_arity = arity }, app_args = class_arguments, app_info_ptr = nilPtr } : expressions ] + + convert_list_of_reduced_contexts_to_expressions defs has_context list_of_rcs contexts_heaps_error + = mapSt (convert_reduced_contexts_to_expressions defs has_context) list_of_rcs contexts_heaps_error + + convert_reduced_contexts_to_expressions defs has_context {rcs_class_context,rcs_constraints_contexts} contexts_heaps_error + # (class_symb, rc_exprs, instance_types, contexts_heaps_error) + = convert_reduced_context_to_expression defs has_context rcs_class_context contexts_heaps_error + (rcs_exprs, (contexts, (type_heaps, var_heap, expr_heap), error)) + = convert_list_of_reduced_contexts_to_expressions defs has_context rcs_constraints_contexts contexts_heaps_error + {ds_ident,ds_index,ds_arity} = getDictionaryConstructor class_symb defs + record_symbol = { symb_name = ds_ident, symb_kind = SK_Constructor {glob_module = class_symb.glob_module, glob_object = ds_index}, symb_arity = ds_arity } + (app_info_ptr, expr_heap) = newPtr (EI_ClassTypes instance_types) expr_heap + rc_record = App { app_symb = record_symbol, app_args = rc_exprs ++ rcs_exprs, app_info_ptr = app_info_ptr } + = (rc_record, (contexts, (type_heaps, var_heap, expr_heap), error)) + +createBoundVar :: !TypeContext -> BoundVar +createBoundVar {tc_class={glob_object={ds_ident}}, tc_var} + | isNilPtr tc_var + = abort ("createBoundVar : NIL ptr" ---> ds_ident) + = { var_name = { id_name = "_v" +++ ds_ident.id_name, id_info = nilPtr }, var_info_ptr = tc_var, var_expr_ptr = nilPtr } + +createFreeVar :: !TypeContext -> FreeVar +createFreeVar {tc_class={glob_object={ds_ident}}, tc_var} + | isNilPtr tc_var + = abort ("createFreeVar : NIL ptr" ---> ds_ident) + = { fv_name = { id_name = "_v" +++ ds_ident.id_name, id_info = nilPtr }, fv_info_ptr = tc_var, fv_def_level = NotALevel, fv_count = -1 } + + +determineContextAddress :: !TypeContext !Bool ![TypeContext] !{#CommonDefs} !*TypeHeaps !*VarHeap !*ErrorAdmin + -> (!TypeContext, ![(Int, Global DefinedSymbol)], ![TypeContext], !*TypeHeaps, !*VarHeap, !*ErrorAdmin) +determineContextAddress tc has_context contexts defs type_heaps var_heap error + = determine_context_and_address tc contexts has_context contexts defs type_heaps var_heap error +where + determine_context_and_address :: !TypeContext ![TypeContext] !Bool ![TypeContext] !{#CommonDefs} !*TypeHeaps !*VarHeap !*ErrorAdmin + -> (!TypeContext, ![(Int, Global DefinedSymbol)], ![TypeContext], !*TypeHeaps, !*VarHeap, !*ErrorAdmin) + determine_context_and_address context [] has_context contexts defs type_heaps var_heap error + | has_context + = (context, [], contexts, type_heaps, var_heap, contextError error) + #! (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + # new_context = { context & tc_var = new_info_ptr} + = (new_context, [], [new_context : contexts], type_heaps, var_heap, error) + determine_context_and_address context [tc : tcs] has_context contexts defs type_heaps var_heap error + #! (may_be_addres, type_heaps) = determine_address context tc [] defs type_heaps + = case may_be_addres of + Yes address + | isNilPtr tc.tc_var + -> abort ("determine_context_and_address" ---> tc.tc_class.glob_object.ds_ident) + -> (tc, address, contexts, type_heaps, var_heap, error) + No + -> determine_context_and_address context tcs has_context contexts defs type_heaps var_heap error + + determine_address :: !TypeContext !TypeContext ![(Int, Global DefinedSymbol)] !{#CommonDefs} !*TypeHeaps + -> (!Optional [(Int, Global DefinedSymbol)],!*TypeHeaps) + determine_address tc1 tc2 address defs type_heaps=:{th_vars} + | tc1 == tc2 + = (Yes address, type_heaps) + # {tc_class={glob_object={ds_index},glob_module}} = tc2 + {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] + th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types + (super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } + = find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps + + find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps + -> (!Optional [(Int, Global DefinedSymbol)],!*TypeHeaps) + find_super_instance context [] tc_index address dict_mod dict_index defs type_heaps + = (No, type_heaps) + find_super_instance context [tc : tcs] tc_index address dict_mod dict_index defs type_heaps + #! (may_be_addres, type_heaps) = determine_address context tc address defs type_heaps + = case may_be_addres of + Yes address + # selector = selectFromDictionary dict_mod dict_index tc_index defs + -> (Yes [ (tc_index, selector) : address ], type_heaps) + No + -> find_super_instance context tcs (inc tc_index) address dict_mod dict_index defs type_heaps + +updateDynamics :: ![Int] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin + -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) +updateDynamics funs type_contexts type_pattern_vars fun_defs symbol_heap type_code_info var_heap error + | error.ea_ok + = update_dynamics funs type_contexts fun_defs symbol_heap type_code_info { ltp_var_heap = var_heap, ltp_variables = type_pattern_vars} error + = (fun_defs, symbol_heap, type_code_info, var_heap, error) +where + update_dynamics [] type_contexts fun_defs symbol_heap type_code_info ltp error + = (fun_defs, symbol_heap, type_code_info, ltp.ltp_var_heap, error) + update_dynamics [fun:funs] type_contexts fun_defs symbol_heap type_code_info ltp error + #! fun_def = fun_defs.[fun] + # {fun_body,fun_info={fi_group_index, fi_dynamics}} = fun_def + | isEmpty fi_dynamics + = update_dynamics funs type_contexts fun_defs symbol_heap type_code_info ltp error + # (type_code_info, symbol_heap, ltp) = convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, ltp) + (TransformedBody tb) = fun_body + (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_fun_defs}) + = updateExpression fi_group_index [] tb.tb_rhs { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs } + fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}} + = update_dynamics funs type_contexts { ui_fun_defs & [fun] = fun_def } ui_symbol_heap type_code_info ltp error + +removeOverloadedFunctions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap + !*TypeCodeInfo !*VarHeap !*ErrorAdmin + -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) +removeOverloadedFunctions funs opt_spec_contexts type_contexts type_pattern_vars fun_defs symbol_heap type_code_info var_heap error + | error.ea_ok + = remove_overloaded_functions funs opt_spec_contexts type_contexts fun_defs symbol_heap type_code_info + { ltp_var_heap = var_heap, ltp_variables = type_pattern_vars} error + = (fun_defs, symbol_heap, type_code_info, var_heap, error) +where + remove_overloaded_functions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo + !*LocalTypePatternVariables !*ErrorAdmin + -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) + remove_overloaded_functions [] opt_contexts type_contexts fun_defs symbol_heap type_code_info ltp error + = (fun_defs, symbol_heap, type_code_info, ltp.ltp_var_heap, error) + remove_overloaded_functions [fun:funs] [(opt_context, location):opt_contexts] type_contexts fun_defs symbol_heap type_code_info ltp error + #! fun_def = fun_defs.[fun] + # {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb} = fun_def + error = setErrorAdmin location error + (type_code_info, symbol_heap, ltp) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, ltp) + tb_args = determine_class_arguments opt_context type_contexts tb_args + (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_fun_defs}) = updateExpression fun_info.fi_group_index type_contexts tb_rhs + { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs } + fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, + fun_arity = length tb_args, fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls } } + = remove_overloaded_functions funs opt_contexts type_contexts { ui_fun_defs & [fun] = fun_def } ui_symbol_heap type_code_info ltp error + + determine_class_arguments (Yes spec_context) _ tb_args + = mapAppend (\tc -> createFreeVar tc) spec_context tb_args + determine_class_arguments No type_contexts tb_args + = mapAppend (\tc -> createFreeVar tc) type_contexts tb_args + +/* + type_contexts fun_symb fun_info_ptr tb_args symbol_heap error + #! fun_info = sreadPtr fun_info_ptr symbol_heap + = case fun_info of + EI_Empty + -> (mapAppend (\tc -> createFreeVar tc) type_contexts tb_args, symbol_heap, error) + EI_Context class_expressions + # (tb_args, error) = convert_class_expressions fun_symb class_expressions tb_args error + -> (tb_args, symbol_heap, error) + _ +// -> (tb_args, symbol_heap, contextError fun_symb error) + -> (tb_args, symbol_heap, contextError error) + + convert_class_expressions fun_symb [] tb_args error + = (tb_args, error) + convert_class_expressions fun_symb [Var {var_name,var_info_ptr} : class_exprs] tb_args error + # (tb_args, error) = convert_class_expressions fun_symb class_exprs tb_args error + = ([ { fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = -1 } : tb_args], error) + convert_class_expressions fun_symb [class_expr : class_exprs] tb_args error +// = (tb_args, contextError fun_symb error) + = (tb_args, contextError error) +*/ +convertDynamicTypes dyn_ptrs update_info + = foldSt update_dynamic dyn_ptrs update_info +where + update_dynamic dyn_ptr (type_code_info, expr_heap, local_type_pattern_vars) + # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap + = case dyn_info of + EI_TempDynamicType (Yes {dt_global_vars, dt_uni_vars, dt_type}) _ _ expr_ptr _ + # (expr_info, expr_heap) = readPtr expr_ptr expr_heap + -> case expr_info of + EI_TypeCodes type_codes + # type_var_heap = fold2St (\{tv_info_ptr} type_code -> writePtr tv_info_ptr (TVI_TypeCode type_code)) + dt_global_vars type_codes type_code_info.tci_type_var_heap + (uni_vars, (type_var_heap, ltp_var_heap)) = new_type_variables dt_uni_vars (type_var_heap, local_type_pattern_vars.ltp_var_heap) + (type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), {local_type_pattern_vars & ltp_var_heap = ltp_var_heap}) + EI_Empty + # (uni_vars, (type_var_heap, ltp_var_heap)) = new_type_variables dt_uni_vars (type_code_info.tci_type_var_heap, local_type_pattern_vars.ltp_var_heap) + (type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), {local_type_pattern_vars & ltp_var_heap = ltp_var_heap}) + EI_TempDynamicType No _ _ expr_ptr _ + # (expr_info, expr_heap) = readPtr expr_ptr expr_heap + -> case expr_info of + EI_TypeCode type_expr + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] type_expr), local_type_pattern_vars) + EI_Selection selectors record_var _ + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors record_var)), local_type_pattern_vars) + EI_TempDynamicPattern type_vars {dt_global_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr _ + # (expr_info, expr_heap) = readPtr expr_ptr expr_heap + -> case expr_info of + EI_TypeCodes type_codes + # type_var_heap = fold2St (\{tv_info_ptr} type_code -> writePtr tv_info_ptr (TVI_TypeCode type_code)) dt_global_vars type_codes type_code_info.tci_type_var_heap + (var_ptrs, local_type_pattern_vars) = mapSt addLocalTCInstance temp_local_vars local_type_pattern_vars + type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_var_heap + (type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } + -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), local_type_pattern_vars) + EI_Empty + # (var_ptrs, local_type_pattern_vars) = mapSt addLocalTCInstance temp_local_vars local_type_pattern_vars + type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_code_info.tci_type_var_heap + (type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } + -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), local_type_pattern_vars) + + where + convert_local_dynamics loc_dynamics state + = foldSt update_dynamic loc_dynamics state +/* + convert_local_dynamics (Yes loc_dynamics) state + = update_dynamic loc_dynamics state + convert_local_dynamics No state + = state +*/ + convert_selectors [type_code_selector] {var_info_ptr} + = TCE_Var var_info_ptr + convert_selectors selectors {var_info_ptr} + = TCE_Selector (init selectors) var_info_ptr + + new_type_variables uni_vars heaps + = mapSt new_type_variable uni_vars heaps + + new_type_variable {atv_variable = {tv_info_ptr}} (type_var_heap, var_heap) + # (new_var_ptr, var_heap) = newPtr VI_Empty var_heap + = (new_var_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var new_var_ptr)), var_heap)) + +:: TypeCodeInfo = + { tci_next_index :: !Index + , tci_instances :: ![GlobalTCInstance] + , tci_type_var_heap :: !.TypeVarHeap + } + +class toTypeCodeExpression type :: type !*TypeCodeInfo -> (!TypeCodeExpression, !*TypeCodeInfo) + +instance toTypeCodeExpression Type +where + toTypeCodeExpression (TA cons_id type_args) tci=:{tci_next_index,tci_instances} + # (inst_index, (tci_next_index, tci_instances)) + = addGlobalTCInstance (GTT_Constructor cons_id) (tci_next_index, tci_instances) + (type_code_args, tci) = mapSt toTypeCodeExpression type_args { tci & tci_next_index = tci_next_index, tci_instances = tci_instances } + = (TCE_Constructor inst_index type_code_args, tci) + toTypeCodeExpression (TB basic_type) tci=:{tci_next_index,tci_instances} + # (inst_index, (tci_next_index, tci_instances)) + = addGlobalTCInstance (GTT_Basic basic_type) (tci_next_index, tci_instances) + = (TCE_Constructor inst_index [], { tci & tci_next_index = tci_next_index, tci_instances = tci_instances }) + toTypeCodeExpression (arg_type --> result_type) tci=:{tci_next_index,tci_instances} + # (inst_index, (tci_next_index, tci_instances)) + = addGlobalTCInstance GTT_Function (tci_next_index, tci_instances) + (type_code_args, tci) = mapSt toTypeCodeExpression [arg_type, result_type] { tci & tci_next_index = tci_next_index, tci_instances = tci_instances } + = (TCE_Constructor inst_index type_code_args, tci) + toTypeCodeExpression (TV {tv_info_ptr}) tci=:{tci_type_var_heap} + # (TVI_TypeCode type_code, tci_type_var_heap) = readPtr tv_info_ptr tci_type_var_heap + = (type_code, { tci & tci_type_var_heap = tci_type_var_heap }) + +instance toTypeCodeExpression AType +where + toTypeCodeExpression {at_type} tci = toTypeCodeExpression at_type tci + + +:: UpdateInfo = + { ui_instance_calls :: ![FunCall] + , ui_symbol_heap :: !.ExpressionHeap + , ui_fun_defs :: !.{# FunDef} + } + +class updateExpression e :: !Index ![TypeContext] !e !*UpdateInfo -> (!e, !*UpdateInfo) + +instance updateExpression Expression +where + updateExpression group_index type_contexts (App app=:{app_symb=symb=:{symb_kind,symb_arity,symb_name},app_args,app_info_ptr}) ui + # (app_args, ui) = updateExpression group_index type_contexts app_args ui + | isNilPtr app_info_ptr + = (App { app & app_args = app_args }, ui) + #! symb_info = sreadPtr app_info_ptr ui.ui_symbol_heap + = case symb_info of + EI_Empty + | is_recursive_call group_index symb_kind ui.ui_fun_defs + # app_args = strictMapAppend (\tc -> Var (createBoundVar tc)) type_contexts app_args + -> (App { app & app_symb = { symb & symb_arity = length type_contexts + symb_arity }, app_args = app_args }, ui) + -> (App { app & app_args = app_args }, ui) + EI_Instance inst_symbol context_args + -> (build_application inst_symbol context_args app_args symb_arity app_info_ptr, + examine_calls context_args (new_call inst_symbol.glob_module inst_symbol.glob_object.ds_index ui)) + EI_Selection selectors record_var context_args + # all_args = context_args ++ app_args + select_expr = Selection No (Var record_var) selectors + | isEmpty all_args + -> (select_expr, ui) + -> (select_expr @ all_args, examine_calls context_args ui) + EI_Context context_args + # app = { app & app_symb = { symb & symb_arity = length context_args + symb_arity }, app_args = context_args ++ app_args} + -> (App app, examine_calls context_args ui) + + + where + is_recursive_call group_index (SK_Function {glob_module,glob_object}) fun_defs + | glob_module == cIclModIndex + #! fun_def = fun_defs.[glob_object] + = fun_def.fun_info.fi_group_index == group_index + = False + is_recursive_call group_index _ fun_defs + = False + + build_application def_symbol=:{glob_object} context_args orig_args nr_of_orig_args app_info_ptr + = App {app_symb = { symb_name = glob_object.ds_ident, + symb_kind = SK_Function { def_symbol & glob_object = glob_object.ds_index }, + symb_arity = glob_object.ds_arity + nr_of_orig_args }, + app_args = context_args ++ orig_args, app_info_ptr = app_info_ptr } + + examine_application (SK_Function {glob_module,glob_object}) ui + = new_call glob_module glob_object ui + examine_application symb_kind ui + = ui + + new_call mod_index symb_index ui=:{ui_instance_calls,ui_fun_defs} + | mod_index == cIclModIndex && symb_index < size ui_fun_defs + # ui_instance_calls = add_call symb_index ui_instance_calls + = { ui & ui_instance_calls = ui_instance_calls } + = ui + where + add_call fun_num [] + = [{ fc_level = 0, fc_index = fun_num }] + add_call fun_num funs=:[call=:{fc_index} : ui] + | fun_num == fc_index + = funs + | fun_num < fc_index + = [{ fc_level = 0, fc_index = fun_num } : funs] + = [call : add_call fun_num ui] + + examine_calls [expr : exprs] ui + = examine_calls exprs (examine_calls_in_expr expr ui) + where + examine_calls_in_expr (App {app_symb = {symb_name,symb_kind}, app_args}) ui + = examine_calls app_args (examine_application symb_kind ui) + examine_calls_in_expr _ ui + = ui + examine_calls [] ui + = ui + + + updateExpression group_index type_contexts (expr @ exprs) ui + # ((expr, exprs), ui) = updateExpression group_index type_contexts (expr, exprs) ui + = (expr @ exprs, ui) + updateExpression group_index type_contexts (Let lad=:{let_binds, let_expr}) ui + # ((let_binds, let_expr), ui) = updateExpression group_index type_contexts (let_binds, let_expr) ui + = (Let {lad & let_binds = let_binds, let_expr = let_expr}, ui) + updateExpression group_index type_contexts (Case kees=:{case_expr,case_guards,case_default}) ui + # ((case_expr,(case_guards,case_default)), ui) = updateExpression group_index type_contexts (case_expr,(case_guards,case_default)) ui + = (Case { kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, ui) + updateExpression group_index type_contexts (Selection is_unique expr selectors) ui + # (expr, ui) = updateExpression group_index type_contexts expr ui + (selectors, ui) = updateExpression group_index type_contexts selectors ui + = (Selection is_unique expr selectors, ui) +/* + where + update_selections group_index type_contexts is_unique selectors ui + = foldl (update_selection group_index type_contexts is_unique) state selectors + + update_selection group_index type_contexts is_unique (expr, ui) (ArraySelection selector expr_ptr index_expr) + # (index_expr, ui) = updateExpression group_index type_contexts index_expr ui + #! symb_info = sreadPtr expr_ptr ui.ui_symbol_heap + = case symb_info of + EI_Instance array_select [] + -> (App {app_symb = { symb_name = glob_object.ds_ident, + symb_kind = SK_Function { glob_module = glob_module, glob_object = glob_object.ds_index }, + symb_arity = glob_object.ds_arity + 2 }, + app_args = context_args ++ [expr,index_expr], app_info_ptr = expr_ptr }, ui) + EI_Selection selectors record context_args + -> (Selection is_unique record selectors @ [expr,index_expr], ui) + update_selection group_index type_contexts is_unique (expr, ui) (RecordSelection selector field_nr) + = (Selection is_unique expr [RecordSelection selector field_nr], ui) +*/ + updateExpression group_index type_contexts (Update expr1 selectors expr2) ui + # (expr1, ui) = updateExpression group_index type_contexts expr1 ui + (selectors, ui) = updateExpression group_index type_contexts selectors ui + (expr2, ui) = updateExpression group_index type_contexts expr2 ui + = (Update expr1 selectors expr2, ui) + updateExpression group_index type_contexts (RecordUpdate cons_symbol expression expressions) ui + # (expression, ui) = updateExpression group_index type_contexts expression ui + (expressions, ui) = updateExpression group_index type_contexts expressions ui + = (RecordUpdate cons_symbol expression expressions, ui) + updateExpression group_index type_contexts (DynamicExpr dyn=:{dyn_expr,dyn_info_ptr}) ui + # (dyn_expr, ui) = updateExpression group_index type_contexts dyn_expr ui + (EI_TypeOfDynamic uni_vars type_code, ui_symbol_heap) = readPtr dyn_info_ptr ui.ui_symbol_heap + = (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code, dyn_uni_vars = uni_vars }, { ui & ui_symbol_heap = ui_symbol_heap }) + updateExpression group_index type_contexts (MatchExpr opt_tuple cons_symbol expr) ui + # (expr, ui) = updateExpression group_index type_contexts expr ui + = (MatchExpr opt_tuple cons_symbol expr, ui) + updateExpression group_index type_contexts (TupleSelect symbol argn_nr expr) ui + # (expr, ui) = updateExpression group_index type_contexts expr ui + = (TupleSelect symbol argn_nr expr, ui) + updateExpression group_index type_contexts expr ui + = (expr, ui) + +instance updateExpression Bind a b | updateExpression a +where + updateExpression group_index type_contexts bind=:{bind_src} ui + # (bind_src, ui) = updateExpression group_index type_contexts bind_src ui + = ({bind & bind_src = bind_src }, ui) + +instance updateExpression Optional a | updateExpression a +where + updateExpression group_index type_contexts (Yes x) ui + # (x, ui) = updateExpression group_index type_contexts x ui + = (Yes x, ui) + updateExpression group_index type_contexts No ui + = (No, ui) + +instance updateExpression CasePatterns +where + updateExpression group_index type_contexts (AlgebraicPatterns type patterns) ui + # (patterns, ui) = updateExpression group_index type_contexts patterns ui + = (AlgebraicPatterns type patterns, ui) + updateExpression group_index type_contexts (BasicPatterns type patterns) ui + # (patterns, ui) = updateExpression group_index type_contexts patterns ui + = (BasicPatterns type patterns, ui) + updateExpression group_index type_contexts (DynamicPatterns patterns) ui + # (patterns, ui) = updateExpression group_index type_contexts patterns ui + = (DynamicPatterns patterns, ui) + +instance updateExpression AlgebraicPattern +where + updateExpression group_index type_contexts pattern=:{ap_vars,ap_expr} ui + # (ap_expr, ui) = updateExpression group_index type_contexts ap_expr ui + = ({ pattern & ap_expr = ap_expr }, ui) + +instance updateExpression BasicPattern +where + updateExpression group_index type_contexts pattern=:{bp_expr} ui + # (bp_expr, ui) = updateExpression group_index type_contexts bp_expr ui + = ({ pattern & bp_expr = bp_expr }, ui) + +instance updateExpression Selection +where + updateExpression group_index type_contexts (ArraySelection selector expr_ptr index_expr) ui + # (index_expr, ui) = updateExpression group_index type_contexts index_expr ui + #! symb_info = sreadPtr expr_ptr ui.ui_symbol_heap + = case symb_info of + EI_Instance array_select [] + -> (ArraySelection array_select expr_ptr index_expr, ui) + EI_Selection selectors record context_args + -> (DictionarySelection record selectors expr_ptr index_expr, ui) + updateExpression group_index type_contexts selection ui + = (selection, ui) + +instance updateExpression TypeCase +where + updateExpression group_index type_contexts type_case=:{type_case_dynamic,type_case_patterns,type_case_default} ui + # ((type_case_dynamic,(type_case_patterns,type_case_default)), ui) = updateExpression group_index type_contexts + (type_case_dynamic,(type_case_patterns,type_case_default)) ui + = ({ type_case & type_case_dynamic = type_case_dynamic, type_case_patterns = type_case_patterns, type_case_default = type_case_default }, ui) + +instance updateExpression DynamicPattern +where + updateExpression group_index type_contexts dp=:{dp_type,dp_rhs} ui + # (dp_rhs, ui) = updateExpression group_index type_contexts dp_rhs ui + (EI_TypeOfDynamicPattern type_pattern_vars type_code, ui_symbol_heap) = readPtr dp_type ui.ui_symbol_heap + = ({ dp & dp_rhs = dp_rhs, dp_type_patterns_vars = type_pattern_vars, dp_type_code = type_code }, { ui & ui_symbol_heap = ui_symbol_heap }) + +instance updateExpression (a,b) | updateExpression a & updateExpression b +where + updateExpression group_index type_contexts t ui + = app2St (updateExpression group_index type_contexts,updateExpression group_index type_contexts) t ui + +instance updateExpression [e] | updateExpression e +where + updateExpression group_index type_contexts l ui + = mapSt (updateExpression group_index type_contexts) l ui + + +class equalTypes a :: !a !a !*TypeVarHeap -> (!Bool, !*TypeVarHeap) + +instance equalTypes AType +where + equalTypes atype1 atype2 type_var_heap + = equalTypes atype1.at_type atype2.at_type type_var_heap + +equalTypeVars {tv_info_ptr} temp_var_id type_var_heap + #! tv_info = sreadPtr tv_info_ptr type_var_heap + = case tv_info of + TVI_Forward forw_var_number + -> (forw_var_number == temp_var_id, type_var_heap) + _ + -> (True, type_var_heap <:= (tv_info_ptr, TVI_Forward temp_var_id)) + +instance equalTypes Type +where + equalTypes (TV tv) (TempV var_number) type_var_heap + = equalTypeVars tv var_number type_var_heap + equalTypes (arg_type1 --> restype1) (arg_type2 --> restype2) type_var_heap + = equalTypes (arg_type1,restype1) (arg_type2,restype2) type_var_heap + equalTypes (TA tc1 types1) (TA tc2 types2) type_var_heap + | tc1 == tc2 + = equalTypes types1 types2 type_var_heap + = (False, type_var_heap) + equalTypes (TB basic1) (TB basic2) type_var_heap + = (basic1 == basic2, type_var_heap) + equalTypes (CV tv :@: types1) (TempCV var_number :@: types2) type_var_heap + # (eq, type_var_heap) = equalTypeVars tv var_number type_var_heap + | eq + = equalTypes types1 types2 type_var_heap + = (False, type_var_heap) + equalTypes type1 type2 type_var_heap + = (False, type_var_heap) + +instance equalTypes (a,b) | equalTypes a & equalTypes b +where + equalTypes (x1,y1) (x2,y2) type_var_heap + # (eq, type_var_heap) = equalTypes x1 x2 type_var_heap + | eq + = equalTypes y1 y2 type_var_heap + = (False, type_var_heap) + +instance equalTypes [a] | equalTypes a +where + equalTypes [x:xs] [y:ys] type_var_heap + = equalTypes (x,xs) (y,ys) type_var_heap + equalTypes [] [] type_var_heap + = (True, type_var_heap) + equalTypes _ _ type_var_heap + = (False, type_var_heap) + +instance <<< TypeContext +where + (<<<) file tc = file <<< tc.tc_class.glob_object.ds_ident <<< ' ' <<< tc.tc_types + +instance <<< FunCall +where + (<<<) file {fc_index} = file <<< fc_index + + +instance <<< Special +where + (<<<) file {spec_types} = file <<< spec_types + +instance <<< (Ptr x) +where + (<<<) file _ = file + +instance <<< TypeCodeExpression +where + (<<<) file _ = file + diff --git a/frontend/parse.dcl b/frontend/parse.dcl new file mode 100644 index 0000000..6790bab --- /dev/null +++ b/frontend/parse.dcl @@ -0,0 +1,14 @@ +definition module parse + +import syntax, hashtable, scanner, predef + +:: *ParseErrorAdmin = + { pea_file :: !*File + , pea_ok :: !Bool + } + +cWantIclFile :== True +cWantDclFile :== False + +wantModule :: !Bool !Ident !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) diff --git a/frontend/parse.icl b/frontend/parse.icl new file mode 100644 index 0000000..78c3780 --- /dev/null +++ b/frontend/parse.icl @@ -0,0 +1,2811 @@ +implementation module parse + +import StdEnv +import scanner, syntax, hashtable, utilities, predef + +// RWS ... +ParseOnly :== False +import RWSDebug + +// +++ move to utilities? + +groupBy :: (a a -> Bool) [a] -> [[a]] +groupBy eq [] + = [] +groupBy eq [h : t] + = [[h : this] : groupBy eq other] + where + (this, other) + = span (eq h) t +/* +ident = { id_name = "id name", id_info = nilPtr } +Start + = is_record_update [{nu_selectors=[PS_Record ident No],nu_update_expr=PE_Empty}] + +is_record_update :: [NestedUpdate] -> Bool +is_record_update [{nu_selectors=[(PS_Record _ _) : _]}] + = True ->> "is_record_update" +is_record_update updates + = False ->> ("not is_record_update", updates) +*/ + +// ... RWS + +/* + +Parser for Clean 2.0 + +Conventions: + +- Parsing funtions with a name of the form try.. can fail without generating an error. + The parser will try an other alternative. +- Parsing functions with a name of the form want.. should succeed. If these functions + fail an error message is generated. +- Functions with names containing the character '_' are local functions. +- All functions should consume the tokens taken form the state or given as argument, + or put these tokens back themselves. + +*/ + +:: *ParseErrorAdmin = + { pea_file :: !*File + , pea_ok :: !Bool + } + +:: *ParseState = + { ps_scanState :: !ScanState + , ps_error :: !*ParseErrorAdmin + , ps_skipping :: !Bool + , ps_hash_table :: !*HashTable + , ps_pre_def_symbols :: !*PredefinedSymbols + } + +appScanState :: (ScanState -> ScanState) !ParseState -> ParseState +appScanState f pState=:{ps_scanState} + # ps_scanState = f ps_scanState + = { pState & ps_scanState = ps_scanState } + +accScanState :: (ScanState -> (.t,ScanState)) !ParseState -> (.t,ParseState) +accScanState f pState=:{ps_scanState} + # ( x, ps_scanState) = f ps_scanState + = ( x, {pState & ps_scanState = ps_scanState }) + +makeStringTypeSymbol pState=:{ps_pre_def_symbols} + #! string_id = ps_pre_def_symbols.[PD_StringType] + = (MakeNewTypeSymbIdent string_id.pds_ident 0, pState) + +makeListTypeSymbol arity pState=:{ps_pre_def_symbols} + #! list_id = ps_pre_def_symbols.[PD_ListType] + = (MakeNewTypeSymbIdent list_id.pds_ident arity, pState) + +makeLazyArraySymbol arity pState=:{ps_pre_def_symbols} + #! lazy_array_id = ps_pre_def_symbols.[PD_LazyArrayType] + = (MakeNewTypeSymbIdent lazy_array_id.pds_ident arity, pState) + +makeStrictArraySymbol arity pState=:{ps_pre_def_symbols} + #! strict_array_id = ps_pre_def_symbols.[PD_StrictArrayType] + = (MakeNewTypeSymbIdent strict_array_id.pds_ident arity, pState) + +makeUnboxedArraySymbol arity pState=:{ps_pre_def_symbols} + #! unboxed_array_id = ps_pre_def_symbols.[PD_UnboxedArrayType] + = (MakeNewTypeSymbIdent unboxed_array_id.pds_ident arity, pState) + +makeTupleTypeSymbol form_arity act_arity pState=:{ps_pre_def_symbols} + #! tuple_id = ps_pre_def_symbols.[GetTupleTypeIndex form_arity] + = (MakeNewTypeSymbIdent tuple_id.pds_ident act_arity, pState) + +makeNilExpression pState=:{ps_pre_def_symbols} + #! nil_id = ps_pre_def_symbols.[PD_NilSymbol] + = (PE_List [PE_Ident nil_id.pds_ident], pState) + +makeConsExpression a1 a2 pState=:{ps_pre_def_symbols} + #! cons_id = ps_pre_def_symbols.[PD_ConsSymbol] + = (PE_List [PE_Ident cons_id.pds_ident, a1, a2], pState) + +class try a :: !Token !*ParseState -> (!Optional a, !*ParseState) +class want a :: !*ParseState -> (!a, !*ParseState) + +stringToIdent :: !String !IdentClass !*ParseState -> (!Ident, !*ParseState) +stringToIdent ident ident_class pState=:{ps_hash_table} + # (ident, ps_hash_table) = putIdentInHashTable ident ident_class ps_hash_table + = (ident, { pState & ps_hash_table = ps_hash_table } ) + +internalIdent :: !String !*ParseState -> (!Ident, !*ParseState) +internalIdent prefix pState + # ({fp_line,fp_col},pState=:{ps_hash_table}) = getPosition pState + case_string = prefix +++ toString fp_line +++ "_" +++ toString fp_col + (case_ident, ps_hash_table) = putIdentInHashTable case_string IC_Expression ps_hash_table + = (case_ident, { pState & ps_hash_table = ps_hash_table } ) + +erroneousIdent = { id_name = "", id_info = nilPtr } + +/* + Some general overloaded parsing routines +*/ + +wantSequence :: !Token !Context !*ParseState -> (!.[a],!*ParseState) | want a +wantSequence separator context pState + # (first, pState) = want pState + (token, pState) = nextToken context pState + | separator == token + # (rest, pState) = wantSequence separator context pState + = ([first : rest], pState) + // otherwise // separator <> token + = ([first], tokenBack pState) +/* +optionalSequence start_token separator context pState + # (token, pState) = nextToken context pState + | token == start_token + = wantSequence separator context pState + = ([], tokenBack pState) +*/ +parseList try_fun pState :== parse_list pState // try_fun * +//parseList try_fun pState = parse_list pState + where + // parse_list :: !*ParseState -> (tree, *ParseState) + parse_list pState + # (succ, tree, pState) = try_fun pState + | succ + # (trees, pState) = parse_list pState + = ([tree : trees], pState) + = ([], pState) + +//wantSepList msg sep_token context try_fun pState = want_list msg pState +wantSepList msg sep_token context try_fun pState :== want_list msg pState // try_fun (sep_token tryfun)* + where + want_list msg pState + # (succ, tree, pState) = try_fun pState + | succ + # (token, pState) = nextToken context pState + | token == sep_token + # (trees, pState) = optSepList sep_token context try_fun pState + = ([tree : trees], pState) + // otherwise // token <> sep_token + = ([tree], tokenBack pState) + # (token, pState) = nextToken GeneralContext pState + = ([tree], parseError "wantList" (Yes token) msg pState) + +//optSepList sep_token context try_fun pState = want_list msg pState +optSepList sep_token context try_fun pState :== want_list pState // [ try_fun (sep_token tryfun)* ] + where + want_list pState + # (succ, tree, pState) = try_fun pState + | succ + # (token, pState) = nextToken context pState + | token == sep_token + # (trees, pState) = want_list pState + = ([tree : trees], pState) + // otherwise // token <> sep_token + = ([tree], tokenBack pState) + = ([], pState) + +//wantList msg try_fun pState = want_list msg pState +wantList msg try_fun pState :== want_list msg pState // try_fun + + where + want_list msg pState + # (succ, tree, pState) = try_fun pState + | succ + # (trees, pState) = parseList try_fun pState + = ([tree : trees], pState) + # (token, pState) = nextToken GeneralContext pState + = ([tree], parseError "wantList" (Yes token) msg pState) +/* +instance want (a,b) | want a & want b +where + want pState + # (x, pState) = want pState + (y, pState) = want pState + = ((x,y), pState) +*/ +wantIdents :: !Context !IdentClass !ParseState -> (![Ident], !ParseState) +wantIdents context ident_class pState + # (first_name, pState) = want pState + (first_ident, pState) = stringToIdent first_name ident_class pState + (token, pState) = nextToken context pState + | token == CommaToken + # (rest, pState) = wantIdents context ident_class pState + = ([first_ident : rest], pState) + = ([first_ident], tokenBack pState) + +optionalPriority :: !Bool !Token !ParseState -> (Priority, !ParseState) +optionalPriority isinfix (PriorityToken prio) pState + = (prio, pState) +optionalPriority isinfix token pState + | isinfix + = (DummyPriority, tokenBack pState) + = (NoPrio, tokenBack pState) + +/* + Modules +*/ + +:: ParseContext :== Int + +cICLContext :== 1 +cGlobalContext :== 2 +cDCLContext :== 0 +cLocalContext :== 1 + +SetGlobalContext iclmodule + | iclmodule + = cICLContext bitor cGlobalContext + = cDCLContext bitor cGlobalContext + +SetLocalContext context :== context bitand (bitnot cGlobalContext) + +isLocalContext context :== context bitand cGlobalContext == 0 +isGlobalContext context :== not (isLocalContext context) + +isDclContext context :== context bitand cICLContext == 0 +isIclContext context :== not (isDclContext context) + +cWantIclFile :== True +cWantDclFile :== False + +wantModule :: !Bool !Ident !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) +wantModule iclmodule file_id=:{id_name} hash_table error searchPaths pre_def_symbols files + # file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") + = case openScanner file_name searchPaths files of + (Yes scanState, files) -> initModule file_name scanState pre_def_symbols files + (No , files) -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in + (False, mod, hash_table, error <<< "Could not open: " <<< file_name, pre_def_symbols, files) +where + initModule :: String ScanState !*PredefinedSymbols *Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) + initModule file_name scanState pre_def_symbols files + # (succ, mod_type, mod_name, scanState) = try_module_header iclmodule scanState + | succ + # pState = { ps_scanState = scanState + , ps_error = { pea_file = error, pea_ok = True } + , ps_skipping = False + , ps_hash_table = hash_table + , ps_pre_def_symbols = pre_def_symbols + } + pState = verify_name mod_name id_name file_name pState + (mod_ident, pState) = stringToIdent mod_name IC_Module pState + pState = check_layout_rule pState + (defs, pState) = want_definitions (SetGlobalContext iclmodule) pState + {ps_scanState,ps_hash_table,ps_error,ps_pre_def_symbols} + = pState +// RWS ... + defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics") + [PD_Import imports \\ PD_Import imports <- defs] + defs +// ... RWS + mod = { mod_name = mod_ident, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = defs } + = ( ps_error.pea_ok + , mod, ps_hash_table + , ps_error.pea_file + , ps_pre_def_symbols + , closeScanner ps_scanState files + ) + // otherwise // ~ succ + # mod = { mod_name = file_id, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = [] } + = (False, mod, hash_table, error <<< '[' <<< file_id <<< "]: " <<< "incorrect module header", pre_def_symbols, files) + + try_module_header :: !Bool !ScanState -> (!Bool,!ModuleKind,!String,!ScanState) + try_module_header is_icl_mod scanState + # (token, scanState) = nextToken GeneralContext scanState + | is_icl_mod + | token == ModuleToken + # (token, scanState) = nextToken GeneralContext scanState + = try_module_name token MK_Main scanState + | token == ImpModuleToken + = try_module_token MK_Module scanState + | token == SysModuleToken + = try_module_token MK_System scanState + = (False, MK_None, "", tokenBack scanState) + | token == DefModuleToken + = try_module_token MK_Module scanState + | token == SysModuleToken + = try_module_token MK_System scanState + = (False, MK_None, "", tokenBack scanState) + + try_module_token :: !ModuleKind !ScanState -> (!Bool,!ModuleKind!,!String,!ScanState) + try_module_token mod_type scanState + # (token, scanState) = nextToken GeneralContext scanState + | token == ModuleToken + # (token, scanState) = nextToken GeneralContext scanState + = try_module_name token mod_type scanState + = (False, mod_type, "", tokenBack scanState) + + try_module_name (IdentToken name) mod_type scanState + = (True, mod_type, name, scanState) //-->> ("module",name) + try_module_name token mod_type scanState + = (False, mod_type, "", tokenBack scanState) + + verify_name name id_name file_name pState=:{ps_error={pea_file}} + | name == id_name + = pState + # pea_file = pea_file <<< "Module name \"" <<< name <<< "\" does not match file name \"" <<< file_name <<< "\"\n" + = { pState & ps_error = { pea_file = pea_file, pea_ok = False }} + + check_layout_rule pState + # (token, pState) = nextToken GeneralContext pState + use_layout = token <> SemicolonToken && token <> EndOfFileToken // '&& token <> EndOfFileToken' to handle end groups of empty modules + | use_layout = appScanState (setUseLayout use_layout) (tokenBack pState) + = appScanState (setUseLayout use_layout) pState + + want_definitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState) + want_definitions context pState + = want_acc_definitions [] pState + where + want_acc_definitions :: ![ParsedDefinition] !ParseState -> (![ParsedDefinition], !ParseState) + want_acc_definitions acc pState + # (defs, pState) = wantDefinitions context pState + acc = acc ++ defs + pState = wantEndModule pState + (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = (acc, pState) + # pState = parseError "want definitions" (Yes token) "End of file" pState + pState = wantEndOfDefinition "definitions" pState + = want_acc_definitions acc pState +/* + [Definition] on local and global level +*/ + +wantDefinitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState) +wantDefinitions context pState + = parseList (tryDefinition context) pState + +DummyPriority :== Prio LeftAssoc 9 + +cHasPriority :== True +cHasNoPriority :== False + +tryDefinition :: !ParseContext !ParseState -> (!Bool, ParsedDefinition, !ParseState) +tryDefinition context pState + # (token, pState) = nextToken GeneralContext pState + (fname, linenr, pState) = getFileAndLineNr pState + = try_definition context token (LinePos fname linenr) pState +where + try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState) + try_definition context DoubleColonToken pos pState + # (def, pState) = wantTypeDef context pos pState + = (True, def, pState) + try_definition _ ImportToken pos pState +// RWS ... + # (token, pState) = nextToken FunctionContext pState + | token == CodeToken && isIclContext context + # (importedObjects, pState) = wantCodeImports pState + = (True, PD_ImportedObjects importedObjects, pState) + # pState = tokenBack pState +// ... RWS + # (imports, pState) = wantImports pState + = (True, PD_Import imports, pState) + try_definition _ FromToken pos 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 context ClassToken pos pState + # (classdef, pState) = wantClassDefinition context pos pState + = (True, classdef, pState) + try_definition context InstanceToken pos pState + # (instdef, pState) = wantInstanceDeclaration context pos pState + = (True, instdef, pState) + try_definition context token pos pState + | isLhsStartToken token + # (lhs, pState) = want_lhs_of_def token pState + (token, pState) = nextToken FunctionContext pState + (def, pState) = want_rhs_of_def context lhs token (determine_position lhs pos) pState //-->> token + = (True, def, pState) -->> def + with + determine_position (Yes (name, _), _) (LinePos f l) = FunPos f l name.id_name + determine_position lhs pos = pos + = (False, abort "no def(1)", tokenBack pState) + + want_lhs_of_def :: !Token !ParseState -> (!(Optional (Ident, Bool), ![ParsedExpr]), !ParseState) + want_lhs_of_def token pState + # (succ, fname, is_infix, pState) = try_function_symbol token pState + | succ + # (args, pState) = parseList trySimpleLhsExpression pState + = ((Yes (fname, is_infix), args), pState) + # (_, exp, pState) = trySimpleLhsExpression pState + = ((No, [exp]), pState) + where + try_function_symbol :: !Token !ParseState -> (!Bool, Ident, !Bool, !ParseState) // (Success, Ident, Infix, ParseState) + try_function_symbol (IdentToken name) pState + # (id, pState) = stringToIdent name IC_Expression pState + = (True, id, False, pState) + try_function_symbol OpenToken pState + # (token, pState) = nextToken FunctionContext pState + = case token of + (IdentToken name) + # (token, pState) = nextToken FunctionContext pState + | CloseToken == token + # (id, pState) = stringToIdent name IC_Expression pState + -> (True, id, True, pState) + -> (False, abort "no name", False, tokenBack (tokenBack (tokenBack pState))) + _ + -> (False, abort "no name", False, tokenBack (tokenBack pState)) + try_function_symbol token pState + = (False, abort "name", False, tokenBack pState) + + want_rhs_of_def :: !ParseContext !(Optional (Ident, Bool), [ParsedExpr]) !Token !Position !ParseState -> (ParsedDefinition, !ParseState) + want_rhs_of_def context (opt_name, args) DoubleColonToken pos pState + # (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState + (tspec, pState) = want pState // SymbolType + | isDclContext context + # (specials, pState) = optionalSpecials pState + = (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition (1)" pState) + = (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) SP_None, wantEndOfDefinition "type definition (2)" pState) + want_rhs_of_def context (opt_name, args) (PriorityToken prio) pos pState + # (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState + (token, pState) = nextToken TypeContext pState + | token == DoubleColonToken + # (tspec, pState) = want pState + | isDclContext context + # (specials, pState) = optionalSpecials pState + = (PD_TypeSpec pos name prio (Yes tspec) specials, wantEndOfDefinition "type definition (3)" pState) + = (PD_TypeSpec pos name prio (Yes tspec) SP_None, wantEndOfDefinition "type definition (4)" pState) + = (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type defenition (5)" (tokenBack pState)) + want_rhs_of_def context (No, args) token pos pState + # pState = want_node_def_token pState token + (rhs, pState) = wantRhs isEqualToken (tokenBack pState) + | isGlobalContext context + = (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState) + = (PD_NodeDef pos (combine_args args) rhs, pState) + where + want_node_def_token s EqualToken = s + want_node_def_token s DefinesColonToken = replaceToken EqualToken s + want_node_def_token s token = parseError "RHS" (Yes token) "defines token (= or =:)" s + + combine_args [arg] = arg + combine_args args = PE_List args + want_rhs_of_def context (Yes (name, False), []) token pos pState + | isIclContext context && isLocalContext context && (token == DefinesColonToken || token == EqualToken) + # (rhs, pState) = wantRhs (\_ -> True) (tokenBack pState) + = (PD_NodeDef pos (PE_Ident name) rhs, pState) + want_rhs_of_def context (Yes (name, is_infix), args) token pos pState + # (fun_kind, code_allowed, pState) = token_to_fun_kind pState token + (token, pState) = nextToken FunctionContext pState + | isIclContext context && token == CodeToken + # (rhs, pState) = wantCodeRhs pState + | code_allowed + = (PD_Function pos name is_infix args rhs fun_kind, pState) + // otherwise // ~ code_allowed + = (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" pState) + # pState = tokenBack (tokenBack pState) + (rhs, pState) = wantRhs isRhsStartToken pState + = case fun_kind of + FK_Function | isDclContext context + -> (PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState) + FK_Caf | ~(isEmpty args) + -> (PD_Function pos name is_infix [] rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState) + _ -> (PD_Function pos name is_infix args rhs fun_kind, pState) + where + token_to_fun_kind s BarToken = (FK_Function, False, s) + token_to_fun_kind s (SeqLetToken _) = (FK_Function, False, s) + token_to_fun_kind s EqualToken = (FK_Function, True, s) + token_to_fun_kind s ColonDefinesToken = (FK_Macro, False, s) + token_to_fun_kind s DoubleArrowToken = (FK_Function, True, s) + token_to_fun_kind s DefinesColonToken = (FK_Caf, False, s) + token_to_fun_kind s token = (FK_Unknown, False, parseError "RHS" (Yes token) "defines token (=, => or =:) or argument" s) + + check_name_and_fixity No hasprio pState + = (erroneousIdent, False, parseError "Definition" No "identifier" pState) + check_name_and_fixity (Yes (name,is_infix)) hasprio pState + | not is_infix && hasprio // XXXXXXX + = (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState) + = (name, is_infix, pState) + +isEqualToken :: !Token -> Bool +isEqualToken EqualToken = True +isEqualToken _ = False + +isRhsStartToken :: !Token -> Bool +isRhsStartToken EqualToken = True +isRhsStartToken ColonDefinesToken = True +isRhsStartToken DefinesColonToken = True +isRhsStartToken _ = False + +optionalSpecials :: !ParseState -> (!Specials, !ParseState) +optionalSpecials pState + # (token, pState) = nextToken TypeContext pState + | token == SpecialToken + # (specials, pState) = wantList "<special statement>" try_substitutions pState + = (SP_ParsedSubstitutions specials, wantEndGroup "specials" pState) + // otherwise // token <> SpecialToken + = (SP_None, tokenBack pState) +where + try_substitutions pState + # (succ, type_var, pState) = tryTypeVar pState + | succ + # (subst, pState) = want_rest_substitutions type_var pState + = (True, subst, wantEndOfDefinition "substitution" pState) + = (False, [], pState) + + want_rest_substitutions type_var pState + # pState = wantToken GeneralContext "specials" EqualToken pState + (type, pState) = want pState + (token, pState) = nextToken GeneralContext pState + | token == CommaToken + # (next_type_var, pState) = want pState + (substs, pState) = want_rest_substitutions next_type_var pState + = ([{ bind_src = type, bind_dst = type_var } : substs], pState) + = ([{ bind_src = type, bind_dst = type_var }], tokenBack pState) +/* + For parsing right-hand sides of functions only +*/ + +wantCodeRhs :: !ParseState -> (Rhs, !ParseState) +wantCodeRhs pState + # (expr, pState) = want_code_expr pState + = ( { rhs_alts = UnGuardedExpr + { ewl_nodes = [] + , ewl_locals = LocalParsedDefs [] + , ewl_expr = expr + } + , rhs_locals = LocalParsedDefs [] + } + , wantEndOfDefinition "code rhs" pState + ) +where + want_code_expr :: !ParseState -> (!ParsedExpr, !ParseState) + want_code_expr pState + # (token, pState) = nextToken CodeContext pState + = case token of + OpenToken + # (input, pState) = want_bindings [] True pState + pState = wantToken CodeContext "input bindings of code block" CloseToken pState + pState = wantToken CodeContext "output bindings of code block" OpenToken pState + (out, pState) = want_bindings [] False pState + pState = wantToken CodeContext "output bindings of code block" CloseToken pState + (token, pState) = nextToken CodeContext pState + -> case token of + CodeBlockToken the_code + -> (PE_Any_Code input out the_code, pState) + _ -> (PE_Any_Code input out [] , parseError "code rhs (any code)" (Yes token) "code block" pState) + InlineToken + # (token, pState) = nextToken CodeContext pState + -> case token of + CodeBlockToken the_code + -> (PE_ABC_Code the_code True, pState) + token + -> (PE_ABC_Code [] True, parseError "inline code" (Yes token) "code block" pState) + CodeBlockToken the_code + -> (PE_ABC_Code the_code False, pState) + token + -> (PE_Empty, parseError "code rhs" (Yes token) "<code rhs>" pState) + + want_bindings :: !(CodeBinding Ident) !Bool !ParseState -> (!CodeBinding Ident, !ParseState) + want_bindings acc mayBeEmpty pState + # (token, pState) = nextToken CodeContext pState + = case token of + IdentToken name + # (token, pState) = nextToken CodeContext pState + | token == EqualToken || token == DefinesColonToken + # (token, pState) = nextToken CodeContext pState + -> case token of + IdentToken value + # (ident, pState) = stringToIdent name IC_Expression pState + acc = [{ bind_dst = ident, bind_src = value }: acc] + (token, pState) = nextToken CodeContext pState + | token == CommaToken + -> want_bindings acc mayBeEmpty pState + // token <> CommaToken + -> (reverse acc, tokenBack pState) + token + -> (acc, parseError "bindings in code block" (Yes token) "value" pState) + // token <> EqualToken && token <> DefinesColonToken + -> (acc, parseError "bindings in code block" (Yes token) "= or =:" pState) + CloseToken + | mayBeEmpty + -> (acc, tokenBack pState) // to handle empty input bindings + -> (acc, parseError "code bindings" (Yes token) "output bindings" pState) + token + -> (acc, parseError "bindings in code block" (Yes token) "identifier" pState) +/* + For parsing right-hand sides of functions and case expressions +*/ + + +/* Syntax: + FunctionAltDefRhs = FunctionBody // Rhs + [ LocalFunctionAltDefs ] + FunctionBody = exprWithLocals // OptGuardedAlts : GuardedAlts + | GuardedAlts // : UnGuardedExpr + GuardedAlts = { [ LetBefore ] '|' [ StrictLet ] Guard FunctionBody }+ [ ExprWithLocals ] + ExprWithLocals = [ LetBefore ] sep RootExpression endOfDefinition [ LocalFunctionDefs ] +*/ + +wantRhs :: !(!Token -> Bool) !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs +wantRhs separator pState + # (alts, pState) = want_LetsFunctionBody separator pState + (locals, pState) = optionalLocals WhereToken pState + = ({ rhs_alts = alts, rhs_locals = locals}, pState) +where + want_LetsFunctionBody :: !(!Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) + want_LetsFunctionBody sep pState + # (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token pState + = want_FunctionBody token nodeDefs [] sep pState + + want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) + want_FunctionBody BarToken nodeDefs alts sep pState +// # (lets, pState) = want_StrictLet pState // removed from 2.0 + # (token, pState) = nextToken FunctionContext pState + | token == OtherwiseToken + # (token, pState) = nextToken FunctionContext pState + (nodeDefs2, token, pState) = want_LetBefores token pState + = case token of + BarToken + # pState = parseError "RHS: default alternative" No "root expression instead of guarded expression" pState + -> root_expression token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState + _ -> root_expression token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState + | token == LetToken True + # pState = parseError "RHS" No "No 'let!' in this version of Clean" pState + = root_expression token nodeDefs (reverse alts) sep pState + # (guard, pState) = wantRhsExpressionT token pState + (token, pState) = nextToken FunctionContext pState + (nodeDefs2, token, pState) = want_LetBefores token pState + | token == BarToken // nested guard + # (position, pState) = getPosition pState + offside = position.fp_col + (expr, pState) = want_FunctionBody token nodeDefs2 [] sep pState + pState = wantEndNestedGuard (default_found expr) offside pState + alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr } + (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token pState + = want_FunctionBody token nodeDefs [alt:alts] sep pState + // otherwise + # (expr, pState) = root_expression token nodeDefs2 [] sep pState + alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr } + (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token pState + = want_FunctionBody token nodeDefs [alt:alts] sep pState + want_FunctionBody token nodeDefs alts sep pState + = root_expression token nodeDefs (reverse alts) sep pState + + root_expression :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) + root_expression token nodeDefs [] sep pState + # (expr,pState) = want_OptExprWithLocals token nodeDefs sep pState + = case expr of + Yes expr -> ( UnGuardedExpr expr, pState) + No -> ( UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs []} + , parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState + ) + root_expression token nodeDefs alts sep pState + # (expr,pState) = want_OptExprWithLocals token nodeDefs sep pState + = (GuardedAlts alts expr, pState) + + default_found (GuardedAlts _ No) = False + default_found _ = True + + want_OptExprWithLocals :: !Token ![NodeDefWithLocals] !(Token -> Bool) !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState) + want_OptExprWithLocals DoubleArrowToken nodeDefs sep pState + = want_OptExprWithLocals EqualToken nodeDefs sep (replaceToken EqualToken pState) + want_OptExprWithLocals token nodeDefs sep pState + | sep token + # (expr, pState) = wantExpression cIsNotAPattern pState + pState = wantEndRootExpression pState + (locals,pState) = optionalLocals WithToken pState + = ( Yes { ewl_nodes = nodeDefs + , ewl_expr = expr + , ewl_locals = locals + } + , pState + ) + = (No, tokenBack pState) + +/* want_StrictLet :: !ParseState -> ([NodeDefWithLocals] , !ParseState) // Removed from the language !? + want_StrictLet pState + # (token, pState) = nextToken FunctionContext pState + | token == LetToken True + # (let_defs, pState) = wantList "<sequential node defs>" (try_LetDef True) pState + pState = wantToken FunctionContext "strict let" InToken pState + = (let_defs, pState) + = ([], tokenBack pState) +*/ + want_LetBefores :: !Token !ParseState -> (![NodeDefWithLocals], !Token, !ParseState) + want_LetBefores (SeqLetToken strict) pState + # (let_defs, pState) = wantList "<sequential node defs>" (try_LetDef strict) pState + (token, pState) = nextToken FunctionContext pState + (token, pState) = opt_End_Group token pState + (more_let_defs, token, pState) = want_LetBefores token pState + = (let_defs ++ more_let_defs, token, pState) + where + opt_End_Group token pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + | token == EndGroupToken + = nextToken FunctionContext pState + // otherwise // token <> EndGroupToken + = (ErrorToken "End group missing in let befores", parseError "RHS: Let befores" (Yes token) "Generated End Group (due to layout)" pState) + | otherwise // not ss_useLayout + = (token, pState) + want_LetBefores token pState + = ([], token, pState) + + try_LetDef :: !Bool !ParseState -> (!Bool, NodeDefWithLocals, !ParseState) + try_LetDef strict pState + # (succ, lhs_exp, pState) = trySimpleLhsExpression pState + | succ + # pState = wantToken FunctionContext "let definition" EqualToken pState + (rhs_exp, pState) = wantExpression cIsNotAPattern pState + pState = wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp) + (locals , pState) = optionalLocals WithToken pState + = ( True + , { ndwl_strict = strict + , ndwl_def = { bind_dst = lhs_exp + , bind_src = rhs_exp + } + , ndwl_locals = locals + } + , pState + ) + // otherwise // ~ succ + = (False, abort "no definition", pState) + +optionalLocals :: !Token !ParseState -> (!LocalDefs, !ParseState) +optionalLocals dem_token pState + # (off_token, pState) = nextToken FunctionContext pState + | dem_token == off_token + = wantLocals pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | off_token == CurlyOpenToken && ~ ss_useLayout + = wantLocals (tokenBack pState) + // otherwise + = (LocalParsedDefs [], tokenBack pState) + +wantLocals :: !ParseState -> (LocalDefs, !ParseState) +wantLocals pState + # pState = wantBeginGroup "local definitions" pState + (defs, pState) = wantDefinitions cLocalContext pState + = (LocalParsedDefs defs, wantEndLocals pState) + +/* + imports and exports +*/ + +wantImports :: !ParseState -> (![ParsedImport], !ParseState) +wantImports pState + # (names, pState) = wantIdents FunctionContext IC_Module pState + (file_name, line_nr, pState) = getFileAndLineNr pState + pState = wantEndOfDefinition "imports" pState + = (map (\name -> { import_module = name, import_symbols = [], import_file_position = (file_name, line_nr)}) names, pState) + +wantFromImports :: !ParseState -> (!ParsedImport, !ParseState) +wantFromImports pState + # (mod_name, pState) = want pState + (mod_ident, pState) = stringToIdent mod_name IC_Module pState + pState = wantToken GeneralContext "from imports" ImportToken pState + (file_name, line_nr, pState) = getFileAndLineNr pState + (import_symbols, pState) = wantSequence CommaToken GeneralContext pState + pState = wantEndOfDefinition "from imports" pState + = ( { import_module = mod_ident, import_symbols = import_symbols, import_file_position = (file_name, line_nr) }, pState) + +// RWS ... +instance want ImportedObject where + want pState + # (token, pState) = nextToken GeneralContext pState + | token == IdentToken "library" + # (token, pState) = nextToken GeneralContext pState + = want_import_string token cIsImportedLibrary pState + = want_import_string token cIsImportedObject pState + where + want_import_string :: Token Bool ParseState -> (ImportedObject, ParseState) + want_import_string (StringToken string) isLibrary pState + = ({io_is_library = isLibrary, io_name = string}, pState) + want_import_string token isLibrary pState + = ({io_is_library = isLibrary, io_name = ""}, parseError "import code declaration" (Yes token) "imported item" pState) + +wantCodeImports :: !ParseState -> (![ImportedObject], !ParseState) +wantCodeImports pState + # pState = wantToken GeneralContext "import code declaration" FromToken pState + (importObjects, pState) = wantSequence CommaToken GeneralContext pState + = (importObjects, wantEndOfDefinition "import code declaration" pState) +// ... RWS + +instance want ImportDeclaration +where + want pState + # (token, pState) = nextToken GeneralContext pState + = case token of + DoubleColonToken + # (name, pState) = wantUpperCaseName "import type" pState + (type_id, pState) = stringToIdent name IC_Type pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == OpenToken + # (conses, pState) = want_names (wantUpperCaseName "import type (..)") IC_Expression CloseToken pState + -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } (Yes conses), pState) + | token == CurlyOpenToken + # (fields, pState) = want_names (wantLowerCaseName "import record fields") (IC_Field type_id) CurlyCloseToken pState + -> (ID_Record { ii_ident = type_id, ii_extended = ii_extended } (Yes fields), pState) + -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } No, tokenBack pState) + ClassToken + # (name, pState) = want pState + (class_id, pState) = stringToIdent name IC_Class pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == OpenToken + # (members, pState) = want_names want IC_Expression CloseToken pState + -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } (Yes members), pState) + -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } No, pState) + InstanceToken + # (class_name, pState) = want pState + (ii_extended, pState) = optional_extension pState + (types, pState) = wantList "instance types" tryBrackType pState + (class_id, pState) = stringToIdent class_name IC_Class pState + (inst_id, pState) = stringToIdent class_name (IC_Instance types) pState + (context, pState) = optionalContext pState + -> (ID_Instance { ii_ident = class_id, ii_extended = ii_extended } inst_id (types,context), pState) + IdentToken fun_name + # (fun_id, pState) = stringToIdent fun_name IC_Expression pState + (ii_extended, pState) = optional_extension pState + -> (ID_Function { ii_ident = fun_id, ii_extended = ii_extended }, pState) + token + # (fun_id, pState) = stringToIdent "dummy" IC_Expression pState + -> ( ID_Function { ii_ident = fun_id, ii_extended = False } + , parseError "from import" (Yes token) "imported item" pState + ) + where + want_names want_fun ident_kind close_token pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + = ([], wantToken FunctionContext "import declaration" close_token pState) + = want_list_of_names want_fun ident_kind close_token (tokenBack pState) + + want_list_of_names want_fun ident_kind close_token pState + # (name, pState) = want_fun pState + (name_id, pState) = stringToIdent name ident_kind pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == CommaToken + # (names, pState) = want_list_of_names want_fun ident_kind close_token pState + = ([{ ii_ident = name_id, ii_extended = ii_extended } : names], pState) + | token == close_token + = ([{ ii_ident = name_id, ii_extended = ii_extended }], pState) + = ([{ ii_ident = name_id, ii_extended = ii_extended }], parseError "ImportDeclaration" (Yes token) ")" pState) + + optional_extension pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + = (True, pState) + = (False, tokenBack pState) + + optional_extension_with_next_token pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + # (token, pState) = nextToken FunctionContext 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 +*/ + +cIsAGlobalContext :== True +cIsNotAGlobalContext :== False + +cMightBeAClass :== True +cIsNotAClass :== False + + +wantClassDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState) +wantClassDefinition context pos pState + # (might_be_a_class, class_or_member_name, prio, pState) = want_class_or_member_name pState + (class_variables, pState) = wantList "class variable(s)" try_class_variable pState + (class_arity, class_args, class_cons_vars) = convert_class_variables class_variables 0 0 + (contexts, pState) = optionalContext pState + (token, pState) = nextToken TypeContext pState + | token == DoubleColonToken + = want_overloaded_function pos class_or_member_name prio class_arity class_args class_cons_vars contexts pState + | might_be_a_class + | token == WhereToken + # (class_id, pState) = stringToIdent class_or_member_name IC_Class pState + (members, pState) = wantDefinitions context pState + class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, + class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + = (PD_Class class_def members, wantEndGroup "class" pState) + | isEmpty contexts + = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>: contexts" pState) + // otherwise + # pState = tokenBack pState + (class_id, pState) = stringToIdent class_or_member_name IC_Class pState + class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, + class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + pState = wantEndOfDefinition "class definition" pState + = (PD_Class class_def [], pState) + = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>" pState) + where + want_class_or_member_name pState + # (token, pState) = nextToken TypeContext pState + | token == OpenToken + # (member_name, pState) = want pState + pState = wantToken GeneralContext "class definition" CloseToken pState + (token, pState) = nextToken FunctionContext pState + (prio, pState) = optionalPriority cIsInfix token pState + = (cIsNotAClass, member_name, prio, pState) + # (class_name, pState) = want_name token pState + = (cMightBeAClass, class_name, NoPrio, pState) + where + want_name (IdentToken name) pState + = (name, pState) + want_name token pState + = ("", parseError "Class Definition" (Yes token) "<identifier>" pState) + + want_overloaded_function pos member_name prio class_arity class_args class_cons_vars contexts pState + # (tspec, pState) = want pState + (member_id, pState) = stringToIdent member_name IC_Expression pState + (class_id, pState) = stringToIdent member_name IC_Class pState + member = PD_TypeSpec pos member_id prio (Yes tspec) SP_None + class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, + class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + pState = wantEndOfDefinition "overloaded function" pState + = (PD_Class class_def [member], pState) + + try_class_variable pState + # (token, pState) = nextToken TypeContext pState + | token == DotToken + # (type_var, pState) = wantTypeVar pState + = (True, (True, type_var), pState) + # (succ, type_var, pState) = tryTypeVarT token pState + = (succ, (False, type_var), pState) + + convert_class_variables [] arg_nr cons_vars + = (arg_nr, [], cons_vars) + convert_class_variables [(annot, var) : class_vars] arg_nr cons_vars + # (arity, class_vars, cons_vars) = convert_class_variables class_vars (inc arg_nr) cons_vars + | annot + = (arity, [var : class_vars], cons_vars bitor (1 << arg_nr)) + = (arity, [var : class_vars], cons_vars) + +// Sjaak ... +wantInstanceDeclaration :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState) +wantInstanceDeclaration context pi_pos pState + # (class_name, pState) = want pState + (pi_class, pState) = stringToIdent class_name IC_Class pState + ((pi_types, pi_context), pState) = want_instance_type pState + (pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState + | isIclContext context + # pState = wantToken FunctionContext "instance declaration" WhereToken pState + pState = wantBeginGroup "instance" pState + (pi_members, pState) = wantDefinitions context pState + pState = wantEndLocals pState + + = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, + pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos }, pState) + // otherwise // ~ (isIclContext context) + # (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (pi_types_and_contexts, pState) = want_instance_types pState + (idents, pState) = seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState + = (PD_Instances +// [ { pi_class = pi_class, pi_ident = pi_ident, pi_types = type, pi_context = context // voor martin + [ { pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context + , pi_members = [], pi_specials = SP_None, pi_pos = pi_pos} + \\ (type,context) <- [ (pi_types, pi_context) : pi_types_and_contexts ] + & ident <- [ pi_ident : idents ] + ] + , pState + ) + // otherwise // token <> CommaToken + # (specials, pState) = optionalSpecials (tokenBack pState) + pState = wantEndOfDefinition "instance declaration" pState + = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, + pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState) +// ... Sjaak +where + want_instance_type pState + # (pi_types, pState) = wantList "instance types" tryBrackType pState +// # (pi_types, pState) = wantList "instance types" tryType pState // This accepts 1.3 syntax, but is wrong for multiparameter classes + (pi_context, pState) = optionalContext pState + = ((pi_types, pi_context), pState) + want_instance_types pState + # (type_and_context, pState) = want_instance_type pState + (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (types, pState) = want_instance_types pState + = ([type_and_context:types], pState) + // otherwise // token <> CommaToken + = ([type_and_context], pState) + +optionalContext :: !ParseState -> ([TypeContext],ParseState) +optionalContext pState + # (token, pState) = nextToken TypeContext pState + | token == BarToken + = want_contexts pState + = ([], tokenBack pState) +where + want_contexts pState + # (contexts, pState) = want_context pState + (token, pState) = nextToken TypeContext pState + | token == AndToken + # (more_contexts, pState) = want_contexts pState + = (contexts ++ more_contexts, pState) + = (contexts, tokenBack pState) + + want_context pState + # (class_names, pState) = wantSequence CommaToken TypeContext pState + (types, pState) = wantList "type arguments" tryBrackType pState + = build_contexts class_names types (length types) pState + where + build_contexts [] types arity pState + = ([], pState) + build_contexts [class_name : class_names] types arity pState + # (contexts, pState) = build_contexts class_names types arity pState + (class_ident, pState) = stringToIdent class_name IC_Class pState + tc_class = { glob_object = MakeDefinedSymbol class_ident NoIndex (length types), glob_module = NoIndex } + = ([{ tc_class = tc_class, tc_types = types, tc_var = nilPtr } : contexts], pState) + +optionalCoercions :: !ParseState -> ([AttrInequality], ParseState) +optionalCoercions pState + # (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (token, pState) = nextToken TypeContext pState + | token == SquareOpenToken + # (inequals, pState) = want_inequalities pState + = (inequals, wantToken FunctionContext "coercions" SquareCloseToken pState) + = ([], parseError "Function type: coersions" (Yes token) "[" pState) + = ([], tokenBack pState) + where + want_inequalities pState + # (token, pState) = nextToken TypeContext pState + (_, inequals, pState) = want_attr_inequality token pState + (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (more_inequals, pState) = want_inequalities pState + = (inequals ++ more_inequals, pState) + = (inequals, tokenBack pState) + want_attr_inequality (IdentToken var_name) pState + | isLowerCaseName var_name + # (off_ident, pState) = stringToIdent var_name IC_TypeAttr pState + (token, pState) = nextToken TypeContext pState + | token == LessThanOrEqualToken + # (var_name, pState) = wantLowerCaseName "attribute inequality" pState + (dem_ident, pState) = stringToIdent var_name IC_TypeAttr pState + ai_demanded = makeAttributeVar dem_ident + = (ai_demanded, [{ ai_demanded = ai_demanded, ai_offered = makeAttributeVar off_ident }], pState) + # (ai_demanded, inequals, pState) = want_attr_inequality token pState + = (ai_demanded, [{ ai_demanded = ai_demanded, ai_offered = makeAttributeVar off_ident } : inequals], pState) + want_attr_inequality token pState + # erroneous_attr_var = makeAttributeVar erroneousIdent + = ( erroneous_attr_var + , [{ ai_demanded = erroneous_attr_var, ai_offered = erroneous_attr_var }] + , parseError "Function type: optional coercions" (Yes token) "<attribute variable>" pState + ) + +/* + Type definitions +*/ + +wantTypeVar :: ! ParseState -> (!TypeVar, !ParseState) +wantTypeVar pState + # (succ, type_var, pState) = tryTypeVar pState + | succ + = (type_var, pState) + # (token, pState) = nextToken TypeContext pState + = (MakeTypeVar erroneousIdent, parseError "Type Variable" (Yes token) "type variable" pState) + +tryAttributedTypeVar :: !ParseState -> (!Bool, ATypeVar, !ParseState) +tryAttributedTypeVar pState + # (token, pState) = nextToken TypeContext pState + | is_type_arg_token token + # (aOrA, annot, attr, pState) = optionalAnnotAndAttr (tokenBack pState) + (succ, type_var, pState) = tryTypeVar pState + | succ + = (True, { atv_attribute = attr, atv_annotation = annot, atv_variable = type_var }, pState) + | aOrA // annot <> AN_None || attr <> TA_None + # (token, pState) = nextToken TypeContext pState + = (False, no_type_var, parseError "Attributed type var" (Yes token) "type variabele after annotation or attribute" pState) + // otherwise + = (False, no_type_var, tokenBack pState) + // otherwise + = (False, no_type_var, tokenBack pState) +where + is_type_arg_token (IdentToken t) = isLowerCaseName t + is_type_arg_token DotToken = True + is_type_arg_token AsteriskToken = True + is_type_arg_token t = False + + no_type_var = abort "tryAttributedTypeVar: No type var" + +wantTypeDef :: !ParseContext !Position !ParseState -> (ParsedDefinition, !ParseState) +wantTypeDef context pos pState + # (type_lhs, annot, pState) = want_type_lhs pos pState + (token, pState) = nextToken TypeContext pState + (def, pState) = want_type_rhs context type_lhs token annot pState + pState = wantEndOfDefinition "type definition (6)" pState + = (def, pState) +where + want_type_lhs :: !Position !ParseState -> (!ParsedTypeDef, !Annotation, !ParseState) + want_type_lhs pos pState + # (_, annot, attr, pState) = optionalAnnotAndAttr pState + (name, pState) = wantConstructorName "Type name" pState + (ident, pState) = stringToIdent name IC_Type pState // -->> ("Type name",name) + (args, pState) = parseList tryAttributedTypeVar pState + (contexts, pState) = optionalContext pState + = (MakeTypeDef ident args (ConsList []) attr contexts pos, annot, pState) + + want_type_rhs :: !ParseContext !ParsedTypeDef !Token !Annotation !ParseState -> (ParsedDefinition, !ParseState) + want_type_rhs context td=:{td_name,td_attribute} EqualToken annot pState + # name = td_name.id_name + pState = verify_annot_attr annot td_attribute name pState + (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState + (token, pState) = nextToken TypeContext pState + (token, pState) = case token of // Make the ':' optional for now to handle 1.3 files + ColonToken -> nextToken TypeContext (parseWarning "type RHS" ":-symbol after extential quantified variable should be removed" pState) + _ -> (token, pState) + = case token of + CurlyOpenToken + # (fields, pState) = wantFields td_name pState + pState = wantToken TypeContext "record type def" CurlyCloseToken pState + (rec_cons_ident, pState) = stringToIdent ("_" + name) IC_Expression pState + -> (PD_Type { td & td_rhs = SelectorList rec_cons_ident exi_vars fields }, pState) + ColonToken + | isEmpty exi_vars + -> (PD_Erroneous, parseError "Algebraic type" No "no colon, :," pState) + -> (PD_Erroneous, parseError "Algebraic type" No "in this version of Clean no colon, :, after quantified variables" pState) + _ + # (condefs, pState) = want_constructor_list exi_vars token pState + td = { td & td_rhs = ConsList condefs } + | annot == AN_None + -> (PD_Type td, pState) + -> (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState) + want_type_rhs context td=:{td_attribute} ColonDefinesToken annot pState // type Macro + # name = td.td_name.id_name + pState = verify_annot_attr annot td_attribute name pState + (atype, pState) = want pState // Atype + td = {td & td_rhs = TypeSpec atype} + | annot == AN_None + = (PD_Type td, pState) + = (PD_Type td, parseError "Type synonym" No ("No lhs strictness annotation for the type synonym "+name) pState) + want_type_rhs context td=:{td_attribute} token annot pState + | isIclContext context + = (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState) + | td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None + # (td_attribute, properties) = determine_properties annot td_attribute + # td = { td & td_attribute = td_attribute, td_rhs = EmptyRhs properties} + = (PD_Type td, tokenBack pState) + # name = td.td_name.id_name + = (PD_Type { td & td_rhs = EmptyRhs cAllBitsClear}, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState)) + + verify_annot_attr :: !Annotation !TypeAttribute !String !ParseState -> ParseState + verify_annot_attr annot attr name pState + | annot <> AN_None + = parseError "type definition" No ("No annotation, "+toString annot+", in the lhs of type "+name) pState + | attr == TA_None || attr == TA_Unique + = pState + = parseError "ty[e definition" No ("No attribute, "+toString attr+", in the lhs of type "+name) pState + + determine_properties :: !Annotation !TypeAttribute -> (!TypeAttribute, !BITVECT) + determine_properties annot attr + | annot == AN_Strict + | attr == TA_Anonymous + = (TA_None, cIsHyperStrict) + = (attr, cIsHyperStrict bitor cIsNonCoercible) + | attr == TA_Anonymous + = (TA_None, cAllBitsClear) + = (attr, cIsNonCoercible) + + want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState) + want_constructor_list exi_vars token pState + # (pc_cons_name, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState + (pc_arg_types, pState) = parseList tryBrackAType pState + cons = { pc_cons_name = pc_cons_name, pc_arg_types = pc_arg_types, pc_cons_arity = length pc_arg_types, + pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos} + (token, pState) = nextToken TypeContext pState + | token == BarToken + # (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState + (token, pState) = nextToken TypeContext pState + (cons_list, pState) = want_constructor_list exi_vars token pState + = ([cons : cons_list], pState) + // otherwise + = ([cons], tokenBack pState) + where + want_cons_name_and_prio :: !Token !ParseState -> (Ident, !Priority, !Position, !ParseState) + want_cons_name_and_prio tok=:(IdentToken name) pState + # (ident, pState) = stringToIdent name IC_Expression pState + (fname, linenr, pState) = getFileAndLineNr pState + (token, pState) = nextToken TypeContext pState + (prio, pState) = optionalPriority cIsNotInfix token pState + | isLowerCaseName name + = (ident, prio, LinePos fname linenr, parseError "Algebraic type: constructor definitions" (Yes tok) "constructor name" pState) + = (ident, prio, LinePos fname linenr, pState) + want_cons_name_and_prio OpenToken pState + # (name, pState) = wantConstructorName "infix constructor" pState + (fname, linenr, pState) = getFileAndLineNr pState + (ident, pState) = stringToIdent name IC_Expression pState + (token, pState) = nextToken TypeContext (wantToken TypeContext "type: constructor and prio" CloseToken pState) + (prio, pState) = optionalPriority cIsInfix token pState + = (ident, prio, LinePos fname linenr, pState) + want_cons_name_and_prio token pState + = (erroneousIdent, NoPrio, NoPos, parseError "Algebraic type: constructor list" (Yes token) "constructor name" pState) + +makeAttributeVar name :== { av_name = name, av_info_ptr = nilPtr } + +optionalAnnotAndAttr :: !ParseState -> (!Bool, !Annotation, !TypeAttribute, !ParseState) +optionalAnnotAndAttr pState + # (token, pState) = nextToken TypeContext pState + | token == ExclamationToken + # (token, pState) = nextToken TypeContext pState + (_ , attr, pState) = optional_attribute token pState + = (True, AN_Strict, attr, pState) + | otherwise // token <> ExclamationToken + # (succ, attr, pState) = optional_attribute token pState + = (succ, AN_None, attr, pState) +where + optional_attribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState) + optional_attribute DotToken pState = (True, TA_Anonymous, pState) + optional_attribute AsteriskToken pState = (True, TA_Unique, pState) + optional_attribute (IdentToken id) pState + | isLowerCaseName id + # (token, pState) = nextToken TypeContext pState + | ColonToken == token + # (ident, pState) = stringToIdent id IC_TypeAttr pState + = (True, TA_Var (makeAttributeVar ident), pState) + = (False, TA_None, tokenBack (tokenBack pState)) + optional_attribute _ pState = (False, TA_None, tokenBack pState) + + +cIsInfix :== True +cIsNotInfix :== False + +wantFields :: !Ident !*ParseState -> (![ParsedSelector], !*ParseState) +wantFields record_type pState + # (field, pState) = want_field record_type pState + (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (fields, pState) = wantFields record_type pState + = ([field : fields], pState) + = ([field], tokenBack pState) + where + want_field :: !Ident !*ParseState -> *(!ParsedSelector, !*ParseState) + want_field record_type pState + # (field_name, pState) = wantLowerCaseName "record field" pState + (fname, linenr, pState) = getFileAndLineNr pState + (ps_field_name, pState) = stringToIdent field_name (IC_Field record_type) pState + (ps_selector_name, pState) = stringToIdent field_name IC_Selector pState + (ps_field_var, pState) = stringToIdent field_name IC_Expression pState + pState = wantToken TypeContext "record field" DoubleColonToken pState + (ps_field_type, pState) = want pState + = ({ ps_field_name = ps_field_name, ps_selector_name = ps_selector_name, ps_field_type = ps_field_type, ps_field_var = ps_field_var, + ps_field_pos = LinePos fname linenr}, pState) + +makeSymbolType args result context attr_env :== + { st_vars = [], st_args = args, st_arity = length args, st_result = result, + st_context = context, st_attr_env = attr_env, st_attr_vars = [] } + +instance want SymbolType +where + want pState + # (types, pState) = parseList tryBrackAType pState + (token, pState) = nextToken TypeContext pState //-->> ("arg types:",types) + (tspec, pState) = want_rest_of_symbol_type token types pState + = (tspec, pState) + where + want_rest_of_symbol_type :: !Token ![AType] !ParseState -> (SymbolType, !ParseState) + want_rest_of_symbol_type ArrowToken types pState + # (type, pState) = want pState + (context, pState) = optionalContext pState + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType types type context attr_env, pState) + want_rest_of_symbol_type token [] pState + = (makeSymbolType [] (MakeAttributedType TE) [] [], parseError "symbol type" (Yes token) "type" pState) + want_rest_of_symbol_type token [type] pState + # (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token [type=:{at_type = TA type_symb []} : types] pState + # type = { type & at_type = TA { type_symb & type_arity = length types } types } + (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token [type=:{at_type = TV tv} : types] pState + # type = { type & at_type = CV tv :@: types } + (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token types pState + = (makeSymbolType [] (MakeAttributedType TE) [] [], parseError "symbol type" (Yes token) "->" pState) -->> types + +/* + Types +*/ + +nameToTypeVar name pState + # last_char_index = size name - 1 + | name.[last_char_index] == '^' + # new_name = name % (0, last_char_index - 1) + # (ident, pState) = stringToIdent new_name IC_Type pState + = (GTV (MakeTypeVar ident), pState) + # (ident, pState) = stringToIdent name IC_Type pState + = (TV (MakeTypeVar ident), pState) + +instance want TypeVar +where + want pState + # (token, pState) = nextToken TypeContext pState + = case token of + IdentToken name + | isLowerCaseName name + # (ident, pState) = stringToIdent name IC_Type pState + -> (MakeTypeVar ident, pState) + -> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState) + _ + -> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState) + +adjustAttribute :: !TypeAttribute Type *ParseState -> (TypeAttribute,*ParseState) +adjustAttribute TA_Anonymous (TV {tv_name={id_name}}) pState + # (ident, pState) = stringToIdent id_name IC_TypeAttr pState + = (TA_Var (makeAttributeVar ident), pState) +adjustAttribute TA_Anonymous (GTV {tv_name={id_name}}) pState + # (ident, pState) = stringToIdent id_name IC_TypeAttr pState + = (TA_Var (makeAttributeVar ident), pState) +adjustAttribute attr type pState + = (attr, pState) + +stringToType :: !String !ParseState -> (!Type, !ParseState) +stringToType name pState + # (id, pState) = stringToIdent name IC_Type pState + | isLowerCaseName name + = nameToTypeVar name pState + = (TA (MakeNewTypeSymbIdent id 0) [], pState) +/* | isUpperCaseName name + = (TA (MakeNewTypeSymbIdent id 0) [], pState) + = nameToTypeVar name pState +*/ +/* +stringToAType :: !String !Annotation !TypeAttribute !ParseState -> (!AType, !ParseState) +stringToAType name annot attr pState + # (id, pState) = stringToIdent name IC_Type pState + | isUpperCaseName name + = ({ at_annotation = annot, at_attribute = attr, at_type = TA (MakeNewTypeSymbIdent id 0) []}, pState) + # (type_var, pState) = nameToTypeVar name pState + = build_attributed_type_var attr annot type_var name pState +where + build_attributed_type_var TA_Anonymous annot type_var type_var_name pState + # (attr_id, pState) = stringToIdent type_var_name IC_TypeAttr pState + = ({ at_annotation = annot, at_attribute = TA_Var (makeAttributeVar attr_id), at_type = type_var }, pState) + build_attributed_type_var attr annot type_var _ pState + = ({ at_annotation = annot, at_attribute = attr, at_type = type_var }, pState) +*/ + +instance want AType +where + want pState = wantAType pState + +instance want Type +where + want pState = wantType pState + +wantType :: !ParseState -> (!Type,!ParseState) +wantType pState + # (succ, atype, pState) = tryAType False AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + | succ&&succ2 + = (type, pState) + // otherwise //~ succ + # (token, pState) = nextToken TypeContext pState + = (type, parseError "type" (Yes token) "type" pState) + +wantAType :: !ParseState -> (!AType,!ParseState) +wantAType pState + # (succ, atype, pState) = tryAType True AN_None TA_None pState + | succ + = (atype, pState) + // otherwise //~ succ + # (token, pState) = nextToken TypeContext pState + = (atype, parseError "atype" (Yes token) "attributed and annotated type" pState) + +tryType :: !ParseState -> (!Bool,!Type,!ParseState) +tryType pState + # (succ, atype, pState) = tryAType False AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + = (succ&&succ2, type, pState) + +tryAType :: !Bool !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) +tryAType tryAA annot attr pState + # (types, pState) = parseList tryBrackAType pState + | isEmpty types + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState) + # (token, pState) = nextToken TypeContext pState + | token == ArrowToken + = tryFunctionType types annot attr pState + // otherwise + # pState = tokenBack pState + = tryApplicationType types annot attr pState + +tryFunctionType :: ![AType] !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) +tryFunctionType types annot attr pState + # (rtype, pState) = wantAType pState + = ( True + , make_curry_type annot attr types rtype + , pState + ) +where + make_curry_type annot attr [t1] res_type + = {at_annotation = annot, at_attribute = attr, at_type = t1 --> res_type} + make_curry_type annot attr [t1:tr] res_type + = {at_annotation = annot, at_attribute = attr, at_type = t1 --> make_curry_type AN_None TA_None tr res_type} + make_curry_type _ _ _ _ = abort "make_curry_type: wrong assumption" + +tryApplicationType :: ![AType] !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) +tryApplicationType [type1:types_rest] annot attr pState + # (annot, pState) = determAnnot annot type1.at_annotation pState + type = type1.at_type + (attr, pState) = determAttr attr type1.at_attribute type pState + | isEmpty types_rest + = ( True + , {at_annotation = annot, at_attribute = attr, at_type = type} + , pState + ) + // otherwise // type application + # (type, pState) = convert_list_of_types type1.at_type types_rest pState + = ( True + , {at_annotation = annot, at_attribute = attr, at_type = type} + , pState + ) +where + convert_list_of_types (TA sym []) types pState + = (TA { sym & type_arity = length types } types, pState) + convert_list_of_types (TV tv) types pState + = (CV tv :@: types, pState) + convert_list_of_types _ types pState + = (TE, parseError "Type" No "ordinary type variable" pState) +tryApplicationType _ annot attr pState + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState) + +tryBrackType :: !ParseState -> (!Bool, Type, !ParseState) +tryBrackType pState + # (succ, atype, pState) = trySimpleType AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + = (succ&&succ2, type, pState) + +tryBrackAType :: !ParseState -> (!Bool, AType, !ParseState) +tryBrackAType pState + # (_, annot, attr, pState) = optionalAnnotAndAttr pState + = trySimpleType annot attr pState + +trySimpleType :: !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState) +trySimpleType annot attr pState + # (token, pState) = nextToken TypeContext pState + = trySimpleTypeT token annot attr pState + +trySimpleTypeT :: !Token !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState) +trySimpleTypeT (IdentToken id) annot attr pState + | isLowerCaseName id + # (typevar, pState) = nameToTypeVar id pState + (attr, pState) = adjustAttribute attr typevar pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = typevar}, pState) + | otherwise // | isUpperCaseName id || isFunnyIdName id + # (type, pState) = stringToType id pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState) +trySimpleTypeT SquareOpenToken annot attr pState + # (token, pState) = nextToken TypeContext pState + | token == SquareCloseToken + # (list_symbol, pState) = makeListTypeSymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol []}, pState) + # (type, pState) = wantAType (tokenBack pState) + (token, pState) = nextToken TypeContext pState + | token == SquareCloseToken + # (list_symbol, pState) = makeListTypeSymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol [type]}, pState) + // otherwise // token <> SquareCloseToken + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState) +trySimpleTypeT OpenToken annot attr pState + # (token, pState) = nextToken TypeContext pState + | token == CommaToken + # (tup_arity, pState) = determine_arity_of_tuple 2 pState + (tuple_symbol, pState) = makeTupleTypeSymbol tup_arity 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol []}, pState) + // otherwise // token <> CommaToken + # (atype, pState) = wantAType (tokenBack pState) + (token, pState) = nextToken TypeContext pState + | token == CloseToken + # (annot, pState) = determAnnot annot atype.at_annotation pState + type = atype.at_type + (attr, pState) = determAttr attr atype.at_attribute type pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState) + | token == CommaToken // TupleType + # (atypes, pState) = wantSequence CommaToken TypeContext pState + pState = wantToken TypeContext "tuple type" CloseToken pState + atypes = [atype:atypes] + arity = length atypes + (tuple_symbol, pState) = makeTupleTypeSymbol arity arity pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol atypes}, pState) + // otherwise // token <> CloseToken && token <> CommaToken + = (False, atype, parseError "Simple type" (Yes token) "')' or ','" pState) +where + determine_arity_of_tuple :: !Int !ParseState -> (!Int, !ParseState) + determine_arity_of_tuple arity pState + # (token, pState) = nextToken TypeContext pState + | CommaToken == token + = determine_arity_of_tuple (inc arity) pState + | CloseToken == token + = (arity, pState) + = (arity, parseError "tuple type" (Yes token) ")" pState) +trySimpleTypeT CurlyOpenToken annot attr pState + # (token, pState) = nextToken TypeContext pState + | token == CurlyCloseToken + # (array_symbol, pState) = makeLazyArraySymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState) + | token == HashToken + # (token, pState) = nextToken TypeContext pState + | token == CurlyCloseToken + # (array_symbol, pState) = makeUnboxedArraySymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState) + // otherwise // token <> CurlyCloseToken + # (atype, pState) = wantAType (tokenBack pState) + pState = wantToken TypeContext "unboxed array type" CurlyCloseToken pState + (array_symbol, pState) = makeUnboxedArraySymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState) + | token == ExclamationToken + # (token, pState) = nextToken TypeContext pState + | token == CurlyCloseToken + # (array_symbol, pState) = makeStrictArraySymbol 0 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState) + // otherwise // token <> CurlyCloseToken + # (atype,pState) = wantAType (tokenBack pState) + pState = wantToken TypeContext "strict array type" CurlyCloseToken pState + (array_symbol, pState) = makeStrictArraySymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState) + // otherwise + # (atype,pState) = wantAType (tokenBack pState) + pState = wantToken TypeContext "lazy array type" CurlyCloseToken pState + (array_symbol, pState) = makeLazyArraySymbol 1 pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState) +trySimpleTypeT StringTypeToken annot attr pState + # (type, pState) = makeStringTypeSymbol pState + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA type []}, pState) +trySimpleTypeT token annot attr pState + # (bt, pState) = try token pState + = case bt of + Yes bt -> (True , {at_annotation = annot, at_attribute = attr, at_type = TB bt}, pState) + no -> (False, {at_annotation = annot, at_attribute = attr, at_type = TE} , pState) + +instance try BasicType +where + try IntTypeToken pState = (Yes BT_Int , pState) + try CharTypeToken pState = (Yes BT_Char , pState) + try BoolTypeToken pState = (Yes BT_Bool , pState) + try RealTypeToken pState = (Yes BT_Real , pState) + try DynamicTypeToken pState = (Yes BT_Dynamic , pState) + try FileTypeToken pState = (Yes BT_File , pState) + try WorldTypeToken pState = (Yes BT_World , pState) + try _ pState = (No , tokenBack pState) + +determAnnot :: !Annotation !Annotation !ParseState -> (!Annotation, !ParseState) +determAnnot AN_None annot2 pState = (annot2, pState) +determAnnot annot1 AN_None pState = (annot1, pState) +determAnnot annot1 annot2 pState + = (annot1, parseError "simple type" No ("More type annotations, "+toString annot1+" and "+toString annot2+", than") pState) + +determAttr :: !TypeAttribute !TypeAttribute !Type !ParseState -> (!TypeAttribute, !ParseState) +determAttr TA_None attr2 type pState = adjustAttribute attr2 type pState +determAttr attr1 TA_None type pState = adjustAttribute attr1 type pState +determAttr attr1 attr2 type pState + = (attr1, parseError "simple type" No ("More type attributes, "+toString attr1+" and "+toString attr2+", than") pState) + +wantDynamicType :: !*ParseState -> *(!DynamicType,!*ParseState) +wantDynamicType pState + # (type_vars, pState) = optionalQuantifiedVariables UniversalQuantifier pState + (type, pState) = want pState + = ({ dt_uni_vars = type_vars, dt_type = type, dt_global_vars = [] }, pState) + +:: QuantifierKind = UniversalQuantifier | ExistentialQuantifier + +instance == QuantifierKind +where + (==) UniversalQuantifier UniversalQuantifier + = True + (==) ExistentialQuantifier ExistentialQuantifier + = True + (==) _ _ + = False + +instance try QuantifierKind +where + try (IdentToken name) pState + | name == "A" + # (token, pState) = nextToken TypeContext pState + | token == DotToken + = (Yes UniversalQuantifier, pState) + = (No, tokenBack (tokenBack pState)) + | name == "E" + # (token, pState) = nextToken TypeContext pState + | token == DotToken + = (Yes ExistentialQuantifier, pState) + = (No, tokenBack (tokenBack pState)) + try token pState + = (No, tokenBack pState) + +optionalQuantifiedVariables :: !QuantifierKind !*ParseState -> *(![ATypeVar],!*ParseState) +optionalQuantifiedVariables req_quant pState + # (token, pState) = nextToken TypeContext pState + (optional_quantifier, pState) = try token pState + = case optional_quantifier of + Yes off_quant + # (vars, pState) = wantList "quantified variable(s)" try_Attributed_TypeVar pState + | req_quant == off_quant + -> (vars, pState) + -> (vars, parseError "optional quantified variables" No "illegal quantifier" pState) + No + -> ([], pState) +where + try_Attributed_TypeVar :: !ParseState -> (Bool,ATypeVar,ParseState) + try_Attributed_TypeVar pState + # (token, pState) = nextToken TypeContext pState + = case token of + DotToken + # (succ,typevar, pState) = tryTypeVar pState + | succ + # atypevar = {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + _ + # (succ,typevar, pState) = tryTypeVar (tokenBack pState) + | succ + # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + +tryATypeToType :: !AType !ParseState -> (!Bool, !Type, !ParseState) +tryATypeToType atype pState + | atype.at_annotation <> AN_None + = ( False + , atype.at_type + , parseError "simple type" No ("type instead of type annotation "+toString atype.at_annotation) pState + ) + | atype.at_attribute <> TA_None + = ( False + , atype.at_type + , parseError "simple type" No ("type instead of type attribute "+toString atype.at_attribute) pState + ) + // otherwise + = (True, atype.at_type, pState) + +/* + Expressions +*/ +/* +wantMainExp :: !ParseState -> (ParsedExpr, !ParseState) +wantMainExp pState + # (exp, pState) = wantExpression cIsNotAPattern pState + = (exp, wantEndOfFileToken pState) +*/ +cIsAPattern :== True +cIsNotAPattern :== False + +wantExpression :: !Bool !ParseState -> (!ParsedExpr, !ParseState) +wantExpression is_pattern pState + # (token, pState) = nextToken FunctionContext pState + | is_pattern + = wantLhsExpressionT token pState + = wantRhsExpressionT token pState + +wantRhsExpressionT :: !Token !ParseState -> (!ParsedExpr, !ParseState) +wantRhsExpressionT token pState + # (succ, expr, pState) = trySimpleRhsExpressionT token pState + | succ + # (exprs, pState) = parseList trySimpleRhsExpression pState + = (combineExpressions expr exprs, pState) + = (PE_Empty, parseError "RHS expression" (Yes token) "<expression>" pState) + +wantLhsExpressionT :: !Token !ParseState -> (!ParsedExpr, !ParseState) +wantLhsExpressionT token pState + # (succ, expr, pState) = trySimpleLhsExpressionT token pState + | succ + # (exprs, pState) = parseList trySimpleLhsExpression pState + = (combineExpressions expr exprs, pState) + = (PE_Empty, parseError "LHS expression" (Yes token) "<expression>" pState) + +combineExpressions expr [] + = expr +combineExpressions expr exprs + = make_app_exp expr exprs +where + make_app_exp exp [] + = exp + make_app_exp (PE_Bound be=:{ bind_src}) exps + = PE_Bound { be & bind_src = make_app_exp bind_src exps } + make_app_exp exp exprs + = PE_List [exp : exprs] + +trySimpleLhsExpression :: !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleLhsExpression pState + # (token, pState) = nextToken FunctionContext pState + = trySimpleLhsExpressionT token pState + +trySimpleLhsExpressionT :: !Token !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleLhsExpressionT token pState + # (succ, expr, pState) = trySimpleExpressionT token cIsAPattern pState + | succ + # (token, pState) = nextToken FunctionContext pState + | token == DoubleColonToken + # (dyn_type, pState) = wantDynamicType pState + = (True, PE_DynamicPattern expr dyn_type, pState) + = (True, expr, tokenBack pState) + = (False, PE_Empty, pState) + +trySimpleRhsExpression :: !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleRhsExpression pState + # (token, pState) = nextToken FunctionContext pState + = trySimpleRhsExpressionT token pState + +trySimpleRhsExpressionT :: !Token !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleRhsExpressionT token pState + # (succ, expr, pState) = trySimpleExpressionT token cIsNotAPattern pState + | succ + # (expr, pState) = extend_expr_with_selectors expr pState + = (True, expr, pState) + = (False, PE_Empty, pState) +where + extend_expr_with_selectors :: !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState) + extend_expr_with_selectors exp pState + # (token, pState) = nextToken FunctionContext pState + | token == DotToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (PE_Selection cNonUniqueSelection exp selectors, pState) + | token == ExclamationToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (PE_Selection cUniqueSelection exp selectors, pState) + | otherwise + = (exp, tokenBack pState) + +wantSelectors :: Token *ParseState -> *(![ParsedSelection], !*ParseState) +wantSelectors token pState + # (selector, pState) = want_selector token pState + (token, pState) = nextToken FunctionContext pState + | token == DotToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (selector ++ selectors, pState) + = (selector, tokenBack pState) +where + want_selector :: !Token !*ParseState -> *(![ParsedSelection], !*ParseState) + want_selector SquareOpenToken pState + # (array_selectors, pState) = want_array_selectors pState + = (array_selectors, wantToken FunctionContext "array selector" SquareCloseToken pState) + where + want_array_selectors :: !*ParseState -> *(![ParsedSelection], !*ParseState) + want_array_selectors pState + # (index_expr, pState) = wantExpression cIsNotAPattern pState + selector = PS_Array index_expr + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (selectors, pState) = want_array_selectors pState + = ([selector : selectors], pState) + = ([selector], tokenBack pState) + + want_selector (IdentToken name) pState + | isUpperCaseName name + # (field, pState) = want (wantToken FunctionContext "array selector" DotToken pState) + (field_id, pState) = stringToIdent field IC_Selector pState + (type_id, pState) = stringToIdent name IC_Type pState + = ([PS_Record field_id (Yes type_id)], pState) + # (field_id, pState) = stringToIdent name IC_Selector pState + = ([PS_Record field_id No], pState) + want_selector token pState + = ([PS_Erroneous], parseError "simple RHS expression" (Yes token) "<selector>" pState) + +trySimpleExpression :: !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleExpression is_pattern pState + | is_pattern + = trySimpleLhsExpression pState + = trySimpleRhsExpression pState + +trySimpleExpressionT :: !Token !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimpleExpressionT (IdentToken name) is_pattern pState + | isLowerCaseName name + # (id, pState) = stringToIdent name IC_Expression pState + (token, pState) = nextToken FunctionContext pState + | token == DefinesColonToken + # (succ, expr, pState) = trySimpleExpression is_pattern pState + | succ + = (True, PE_Bound { bind_dst = id, bind_src = expr }, pState) + = (True, PE_Empty, parseError "simple expression" No "expression" pState) + = (True, PE_Ident id, tokenBack pState) +trySimpleExpressionT (IdentToken name) is_pattern pState +// | isUpperCaseName name || ~ is_pattern + # (id, pState) = stringToIdent name IC_Expression pState + = (True, PE_Ident id, pState) +trySimpleExpressionT SquareOpenToken is_pattern pState + # (list_expr, pState) = wantListExp is_pattern pState + = (True, list_expr, pState) +trySimpleExpressionT OpenToken is_pattern pState + # (args=:[exp:exps], pState) = want_expression_list is_pattern pState + pState = wantToken FunctionContext "expression list" CloseToken pState + | isEmpty exps + = case exp of + PE_Ident id + -> (True, PE_List [exp], pState) + _ + -> (True, exp, pState) + // # (token,pState) = nextToken FunctionContext pState // for debugging + // pState = tokenBack pState -->> ("PE_tuple",args,token) + = (True, PE_Tuple args, pState) +where + want_expression_list is_pattern pState + # (expr, pState) = wantExpression is_pattern pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (exprs, pState) = want_expression_list is_pattern pState + = ([expr : exprs], pState) + = ([expr], tokenBack pState) +trySimpleExpressionT CurlyOpenToken is_pattern pState + # (rec_or_aray_exp, pState) = wantRecordOrArrayExp is_pattern pState + = (True, rec_or_aray_exp, pState) +trySimpleExpressionT (IntToken int) is_pattern pState + = (True, PE_Basic (BVI int), pState) +trySimpleExpressionT (StringToken string) is_pattern pState + = (True, PE_Basic (BVS string), pState) +trySimpleExpressionT (BoolToken bool) is_pattern pState + = (True, PE_Basic (BVB bool), pState) +trySimpleExpressionT (CharToken char) is_pattern pState + = (True, PE_Basic (BVC char), pState) +trySimpleExpressionT (RealToken real) is_pattern pState + = (True, PE_Basic (BVR real), pState) +trySimpleExpressionT token is_pattern pState + | is_pattern + | token == WildCardToken + = (True, PE_WildCard, pState) + = (False, PE_Empty, tokenBack pState) + = trySimpleNonLhsExpressionT token pState + +trySimpleNonLhsExpressionT BackSlashToken pState + # (lam_ident, pState) = internalIdent "\\" pState + (lam_args, pState) = wantList "arguments" trySimpleLhsExpression pState + // pState = wantToken FunctionContext "lambda expression" ArrowToken pState + pState = want_lambda_sep pState + (exp, pState) = wantExpression cIsNotAPattern pState + = (True, PE_Lambda lam_ident lam_args exp, pState) + where + want_lambda_sep pState + # (token, pState) = nextToken FunctionContext pState + = case token of + ArrowToken -> pState + EqualToken -> pState + DotToken -> pState + _ -> parseError "lambda expression" (Yes token) "-> or =" (tokenBack pState) +//trySimpleNonLhsExpressionT (LetToken strict) pState +trySimpleNonLhsExpressionT (LetToken strict=:False) pState // let! is not supported in Clean 2.0 + # (let_binds, pState) = wantLocals pState + pState = wantToken FunctionContext "let expression" InToken pState + (let_expr, pState) = wantExpression cIsNotAPattern pState + = (True, PE_Let strict let_binds let_expr, pState) +trySimpleNonLhsExpressionT WildCardToken pState + = (True, PE_WildCard, pState) +trySimpleNonLhsExpressionT CaseToken pState + # (case_exp, pState) = wantCaseExp pState + = (True, case_exp, pState) +trySimpleNonLhsExpressionT IfToken pState + # (if_ident, pState) = internalIdent "_if" pState + (cond_exp, pState) = want_simple_expression "condition of if" pState + (then_exp, pState) = want_simple_expression "then-part of if" pState + (else_exp, pState) = want_simple_expression "else-part of if" pState + = (True, PE_If if_ident cond_exp then_exp else_exp, pState) +where + want_simple_expression error pState + # (succ, expr, pState) = trySimpleRhsExpression pState + | succ + = (expr, pState) + = (PE_Empty, parseError error No "<expression>" pState) +trySimpleNonLhsExpressionT DynamicToken pState + # (dyn_expr, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken FunctionContext pState + | token == DoubleColonToken + # (dyn_type, pState) = wantDynamicType pState + = (True, PE_Dynamic dyn_expr (Yes dyn_type), pState) + = (True, PE_Dynamic dyn_expr No, tokenBack pState) +trySimpleNonLhsExpressionT token pState + = (False, PE_Empty, tokenBack pState) + +wantListExp :: !Bool !ParseState -> (ParsedExpr, !ParseState) +wantListExp is_pattern pState + # (token, pState) = nextToken FunctionContext pState + = case token of + SquareCloseToken + -> makeNilExpression pState + _ -> want_LGraphExpr token [] pState +where + want_list acc pState + # (token, pState) = nextToken FunctionContext pState + = case token of + SquareCloseToken + # (nil_expr, pState) = makeNilExpression pState + -> gen_cons_nodes acc nil_expr pState + CommaToken + # (token, pState) = nextToken FunctionContext pState + -> want_LGraphExpr token acc pState + ColonToken + # (token, pState) = nextToken FunctionContext pState + (exp, pState) = wantRhsExpressionT token pState + pState = wantToken FunctionContext "list" SquareCloseToken pState + -> gen_cons_nodes acc exp pState + DotDotToken + | length acc > 2 || isEmpty acc + # (nil_expr, pState) = makeNilExpression pState + pState = parseError "list expression" No "one or two expressions before .." pState + -> gen_cons_nodes acc nil_expr pState + # (token, pState) = nextToken FunctionContext pState + -> case token of + SquareCloseToken + -> case acc of + [e] -> (PE_Sequ (SQ_From e), pState) + [e2,e1] + -> (PE_Sequ (SQ_FromThen e1 e2), pState) + _ -> abort "Error 1 in WantListExp" + _ # (exp, pState) = wantRhsExpressionT token pState + pState = wantToken FunctionContext "dot dot expression" SquareCloseToken pState + -> case acc of + [e] -> (PE_Sequ (SQ_FromTo e exp), pState) + [e2,e1] + -> (PE_Sequ (SQ_FromThenTo e1 e2 exp), pState) + _ -> abort "Error 2 in WantListExp" + DoubleBackSlashToken + | length acc == 1 + -> wantComprehension cIsListGenerator (acc!!0) pState + // otherwise // length acc <> 1 + # (nil_expr, pState) = makeNilExpression pState + pState = parseError "list comprehension" No "one expressions before \\\\" pState + -> gen_cons_nodes acc nil_expr pState + _ # (nil_expr, pState) = makeNilExpression pState + pState = parseError "list" (Yes token) "list element separator" pState + -> gen_cons_nodes acc nil_expr pState + + want_LGraphExpr token acc pState + = case token of + CharListToken chars + -> want_list (add_chars (fromString chars) acc) pState + with + add_chars [] acc = acc + add_chars [c:r] acc = add_chars r [PE_Basic (BVC (toString ['\'',c,'\''])): acc] + _ # (exp, pState) = (if is_pattern (wantLhsExpressionT token) (wantRhsExpressionT token)) pState + -> want_list [exp: acc] pState + + gen_cons_nodes [] exp pState + = (exp, pState) + gen_cons_nodes [e:r] exp pState + # (exp, pState) = makeConsExpression e exp pState + = gen_cons_nodes r exp pState + +/** + (List and Array) Comprehensions +**/ + +wantComprehension :: !GeneratorKind !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState) +wantComprehension gen_kind exp pState + # (qualifiers, pState) = wantQualifiers 0 0 pState + | gen_kind == cIsListGenerator + = (PE_Compr cIsListGenerator exp qualifiers, wantToken FunctionContext "list comprehension" SquareCloseToken pState) + = (PE_Compr cIsArrayGenerator exp qualifiers, wantToken FunctionContext "array comprehension" CurlyCloseToken pState) + +wantQualifiers :: !Int !Int !ParseState -> (![Qualifier], !ParseState) +wantQualifiers nr_of_quals nr_of_gens pState + # (qual, nr_of_gens, pState) = want_qualifier nr_of_quals nr_of_gens pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (quals, pState) = wantQualifiers (inc nr_of_quals) nr_of_gens pState + = ([qual : quals], pState) + = ([qual], tokenBack pState) +where + + want_qualifier :: !Int !Int !ParseState -> (!Qualifier, !Int, !ParseState) + want_qualifier qual_nr gen_nr pState + # (lhs_expr, pState) = wantExpression cIsAPattern pState + (token, pState) = nextToken FunctionContext pState + | token == LeftArrowToken + = want_generators cIsListGenerator qual_nr gen_nr lhs_expr pState + | token == LeftArrowColonToken + = want_generators cIsArrayGenerator qual_nr gen_nr lhs_expr pState + = ({qual_generators = [], qual_filter = No, qual_fun_id = { id_name = "", id_info = nilPtr}}, gen_nr, + parseError "comprehension: qualifier" (Yes token) "qualifier(s)" pState) + + want_generators :: !GeneratorKind !Int !Int !ParsedExpr !ParseState -> (!Qualifier, !Int, !ParseState) + want_generators gen_kind qual_nr gen_nr pattern_exp pState + # (gen_expr, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken FunctionContext pState + (gen_var, pState) = stringToIdent ("tl" +++ toString gen_nr) IC_Expression pState + generator = { gen_kind = gen_kind, gen_expr = gen_expr, gen_pattern = pattern_exp, gen_var = gen_var } + | token == BarToken + # (filter_expr, pState) = wantExpression cIsNotAPattern pState + (qual_fun_id, pState) = stringToIdent ("_compr" +++ toString qual_nr) IC_Expression pState + = ({qual_generators = [generator], qual_filter = Yes filter_expr, qual_fun_id = qual_fun_id }, inc gen_nr, pState) + | token == AndToken + # (qualifier, gen_nr, pState) = want_qualifier qual_nr (inc gen_nr) pState + = ({qualifier & qual_generators = [ generator : qualifier.qual_generators] }, gen_nr, pState) + # (qual_fun_id, pState) = stringToIdent ("_compr" +++ toString qual_nr) IC_Expression pState + = ({qual_generators = [generator], qual_filter = No, qual_fun_id = qual_fun_id}, inc gen_nr, tokenBack pState) + +/** + Case Expressions +**/ + +wantCaseExp :: !ParseState -> (ParsedExpr, !ParseState) +wantCaseExp pState + # (case_ident, pState) = internalIdent "_c" pState + (case_exp, pState) = wantExpression cIsNotAPattern pState + pState = wantToken FunctionContext "case expression" OfToken pState + pState = wantBeginGroup "case" pState + (case_alts, pState) = parseList tryCaseAlt pState + (found, alt, pState) = tryLastCaseAlt pState + | found + = (PE_Case case_ident case_exp (case_alts++[alt]), wantEndCase pState) + = (PE_Case case_ident case_exp case_alts, wantEndCase pState) +where + tryCaseAlt :: !ParseState -> (!Bool, CaseAlt, !ParseState) + tryCaseAlt pState + # (succ, pattern, pState) = try_pattern pState + | succ + # (rhs, pState) = wantRhs caseSeperator pState + = (True, { calt_pattern = pattern, calt_rhs = rhs }, pState) // -->> ("case alt", pattern) + // otherwise // ~ succ + = (False, abort "no case alt", pState) + + tryLastCaseAlt :: !ParseState -> (!Bool, CaseAlt, !ParseState) + tryLastCaseAlt pState + # (token, pState) = nextToken FunctionContext pState + | caseSeperator token + # pState = tokenBack pState + (rhs, pState) = wantRhs caseSeperator pState + = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) // -->> ("default case alt") + | token == OtherwiseToken + # (token, pState) = nextToken FunctionContext pState + pState = tokenBack pState + | caseSeperator token + # (rhs, pState) = wantRhs caseSeperator pState + = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) // -->> ("default case alt") + = (False, abort "no case alt", pState) + = (False, abort "no case alt", tokenBack pState) + + caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.x case expressions + + try_pattern :: !ParseState -> (!Bool, ParsedExpr, !ParseState) + try_pattern pState + # (succ, expr, pState) = trySimpleLhsExpression pState + | succ + # (succ, expr2, pState) = trySimpleLhsExpression pState + | succ + # (exprs, pState) = parseList trySimpleLhsExpression pState + = (True, PE_List [expr,expr2 : exprs], pState) + = (True, expr, pState) + = (False, abort "no expression", pState) + +:: NestedUpdate = + { nu_selectors :: ![ParsedSelection] + , nu_update_expr :: !ParsedExpr + } +errorIdent :: Ident +errorIdent + = {id_name = "<<error>>", id_info = nilPtr} + +buildNodeDef :: ParsedExpr ParsedExpr -> ParsedDefinition +buildNodeDef lhsExpr rhsExpr + = PD_NodeDef NoPos lhsExpr rhs + where + rhs = + { rhs_alts + = UnGuardedExpr + { ewl_nodes = [] + , ewl_locals = LocalParsedDefs [] + , ewl_expr = rhsExpr + } + , rhs_locals + = LocalParsedDefs [] + } + +/** + Record expressions +**/ + +wantRecordOrArrayExp :: !Bool !ParseState -> (ParsedExpr, !ParseState) +wantRecordOrArrayExp is_pattern pState + # (token, pState) = nextToken FunctionContext pState + | token == CurlyCloseToken + = (PE_ArrayDenot [], pState) + | is_pattern + | token == SquareOpenToken + // # (elems, pState) = want_array_assignments cIsAPattern pState // currently no array selections in pattern PK + // = (PE_Array PE_Empty elems [], wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState) + = (PE_Empty, parseError "array selection" No "No array selection in pattern" pState) + // otherwise // is_pattern && token <> SquareOpenToken + = want_record_pattern token pState + // otherwise // ~ is_pattern + # (opt_type, pState) = try_type_specification token pState + = case opt_type of + Yes _ + -> want_record opt_type pState + _ + # (succ, field, pState) = try_field_assignment token pState + | succ + # (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments cIsNotAPattern token pState + -> (PE_Record PE_Empty No [ field : fields ], wantToken FunctionContext "record or array" CurlyCloseToken pState) + | token == CurlyCloseToken + -> (PE_Record PE_Empty No [ field ], pState) + -> (PE_Record PE_Empty No [ field ], parseError "record or array" (Yes token) "}" pState) + # (expr, pState) = wantRhsExpressionT token pState + (token, pState) = nextToken FunctionContext pState + | token == AndToken + # (token, pState) = nextToken FunctionContext pState + -> want_record_or_array_update token expr pState + | token == DoubleBackSlashToken + -> wantComprehension cIsArrayGenerator expr pState + # (elems, pState) = want_array_elems token pState + -> (PE_ArrayDenot [expr : elems], pState) +where + want_array_elems CurlyCloseToken pState + = ([], pState) + want_array_elems CommaToken pState + # (elem, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken FunctionContext pState + (elems, pState) = want_array_elems token pState + = ([elem : elems], pState) + want_array_elems token pState + = ([], parseError "array elements" (Yes token) "<array denotation>" pState) + + want_record_pattern (IdentToken ident) pState + | isUpperCaseName ident + # pState = wantToken FunctionContext "record pattern" BarToken pState + (type_id, pState) = stringToIdent ident IC_Type pState + (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments cIsAPattern token pState + = (PE_Record PE_Empty (Yes type_id) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + want_record_pattern token pState + # (fields, pState) = want_field_assignments cIsAPattern token pState + = (PE_Record PE_Empty No fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + + try_type_specification (IdentToken ident) pState + | isUpperCaseName ident || isFunnyIdName ident + # (token, pState) = nextToken FunctionContext pState + | token == BarToken + # (type_id, pState) = stringToIdent ident IC_Type pState + = (Yes type_id, pState) + = (No, tokenBack pState) + = (No, pState) + try_type_specification _ pState + = (No, pState) + + want_updates :: Token ParsedExpr ParseState -> (ParsedExpr, ParseState) + want_updates token update_expr pState + # (updates, pState) + = parse_updates token update_expr pState + = transform_record_or_array_update update_expr updates pState + where + parse_updates :: Token ParsedExpr ParseState -> ([NestedUpdate], ParseState) + parse_updates token update_expr pState + # (update, pState) = want_update token pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (updates, pState) = parse_updates token update_expr pState + = ([update : updates], pState) + // otherwise + = ([update], tokenBack pState) + + want_update :: Token ParseState -> (NestedUpdate, ParseState) + want_update token pState + # (selectors, pState) = wantSelectors token pState + (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (expr, pState) = wantExpression cIsNotAPattern pState + = ({nu_selectors = selectors, nu_update_expr = expr}, pState) + = ({nu_selectors = selectors, nu_update_expr = PE_Empty}, parseError "field assignment" (Yes token) "=" pState) + + transform_record_or_array_update :: ParsedExpr [NestedUpdate] ParseState -> (ParsedExpr, ParseState) + transform_record_or_array_update expr updates pState + | is_record_update sortedUpdates + = transform_record_update expr groupedUpdates pState + // otherwise + = transform_array_update expr updates pState + where + sortedUpdates + // sort updates by first field name, array updates last + = sortBy smaller_update updates + where + smaller_update :: NestedUpdate NestedUpdate -> Bool + smaller_update a b + = smaller_selector (hd a.nu_selectors) (hd b.nu_selectors) + where + smaller_selector :: ParsedSelection ParsedSelection -> Bool + smaller_selector (PS_Record ident1 _) (PS_Record ident2 _) + = ident1.id_name < ident2.id_name + smaller_selector (PS_Record _ _) _ + = True + smaller_selector _ _ + = False + + groupedUpdates + // group nested updates by first field name + = groupBy equal_update sortedUpdates + where + equal_update :: NestedUpdate NestedUpdate -> Bool + equal_update a b + = equal_selectors a.nu_selectors b.nu_selectors + where + equal_selectors :: [ParsedSelection] [ParsedSelection] -> Bool + equal_selectors [PS_Record ident1 _ : [_]] [PS_Record ident2 _ : [_]] + = ident1.id_name == ident2.id_name + equal_selectors _ _ + = False + + is_record_update [{nu_selectors=[select : _]} : _] + = is_record_select select + is_record_update updates + = False + + is_record_select (PS_Record _ _) + = True + is_record_select _ + = False + + transform_record_update :: ParsedExpr ![[NestedUpdate]] ParseState -> (ParsedExpr, ParseState) + transform_record_update expr groupedUpdates pState + # (assignments, (optionalIdent, pState)) + = mapSt transform_update groupedUpdates (No, pState) + updateExpr + = build_update optionalIdent expr assignments + = (updateExpr, pState) + where + // transform one group of nested updates with the same first field + // for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2}, + // (id is ident to shared expression that's being updated) + transform_update :: [NestedUpdate] (Optional Ident, ParseState) -> (FieldAssignment, (Optional Ident, ParseState)) + transform_update [{nu_selectors=[PS_Record fieldIdent _], nu_update_expr}] state + = ({bind_dst = fieldIdent, bind_src = nu_update_expr}, state) + transform_update updates=:[{nu_selectors=[PS_Record fieldIdent _ : _]} : _] (optionalIdent, pState) + # (shareIdent, pState) + = make_ident optionalIdent pState + select + = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent No] + (update_expr, pState) + = transform_record_or_array_update select (map sub_update updates) pState + = ({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent, pState)) + where + make_ident :: (Optional Ident) ParseState -> (Ident, ParseState) + make_ident (Yes ident) pState + = (ident, pState) + make_ident No pState + = internalIdent "s;" pState + + sub_update :: NestedUpdate -> NestedUpdate + sub_update update=:{nu_selectors} + = {update & nu_selectors = tl nu_selectors} + transform_update _ (_, pState) + # pState + = parseError "record or array" No "field assignments mixed with array assignments not" /* expected */ pState + = ({bind_dst = errorIdent, bind_src = PE_Empty}, (No, pState)) + + build_update :: (Optional Ident) ParsedExpr [FieldAssignment] -> ParsedExpr + build_update No expr assignments + = PE_Record expr No assignments + build_update (Yes ident) expr assignments + = PE_Let False (LocalParsedDefs [buildNodeDef (PE_Ident ident) expr]) + (PE_Record (PE_Ident ident) No assignments) + + transform_array_update :: ParsedExpr [NestedUpdate] ParseState -> (ParsedExpr, ParseState) + transform_array_update expr updates pState + // transform {<e> & [i].<...> = e1, ... } to {{<e> & [i1].<...> = e1} & ...} + = foldSt transform_update updates (expr, pState) + where + transform_update :: NestedUpdate (ParsedExpr, ParseState) -> (ParsedExpr, ParseState) + transform_update {nu_selectors, nu_update_expr} (expr1, pState) + = build_update expr1 (split_selectors nu_selectors) nu_update_expr pState + where + // split selectors into final record selectors and initial selectors + // (resulting selectors are reversed) + // for example: [i1].[i2].f.[i3].g.h -> (h.g, [i3].f.[i2].[i1]) + split_selectors selectors + = span is_record_select (reverse selectors) + + build_update :: ParsedExpr ([ParsedSelection], [ParsedSelection]) ParsedExpr ParseState -> (ParsedExpr, ParseState) + build_update expr ([], initial_selectors) update_expr pState + = (PE_Update expr (reverse initial_selectors) update_expr, pState) + // transform {<e> & <...>.[i].f.g. = e1} to + // let + // index_id = i + // (element_id, array_id) = <e>!<...>.[index_id] + // in {array_id & [index_id] = {element_id & f.g = e1}} + build_update expr (record_selectors, [PS_Array index : initial_selectors]) update_expr pState + # (index_id, pState) + = internalIdent "i;" pState + # (element_id, pState) + = internalIdent "e;" pState + # (array_id, pState) + = internalIdent "a;" pState + index_def + = buildNodeDef (PE_Ident index_id) index + select_def + = buildNodeDef + (PE_Tuple [PE_Ident element_id, PE_Ident array_id]) + (PE_Selection cUniqueSelection expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors])) + (updated_element, pState) + = transform_record_update + (PE_Ident element_id) + [[{nu_selectors=(reverse record_selectors), nu_update_expr=update_expr}]] pState + = (PE_Let False + (LocalParsedDefs [index_def, select_def]) + (PE_Update (PE_Ident array_id) (reverse [PS_Array (PE_Ident index_id) : initial_selectors]) updated_element), pState) + + want_field_assignments is_pattern token=:(IdentToken ident) pState + | isLowerCaseName ident + # (field, pState) = want_field_expression is_pattern ident pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments is_pattern token pState + = ([ field : fields ], pState) + = ([ field ], tokenBack pState) + where + want_field_expression is_pattern ident pState + # (field_id, pState) = stringToIdent ident IC_Selector pState + (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (field_expr, pState) = wantExpression is_pattern pState + = ({ bind_src = field_expr, bind_dst = field_id}, pState) + = ({ bind_src = PE_Empty, bind_dst = field_id}, tokenBack pState) + want_field_assignments is_pattern token pState + = ([], parseError "record or array field assignments" (Yes token) "field name" pState) + + try_field_assignment (IdentToken ident) pState + | isLowerCaseName ident + # (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (field_expr, pState) = wantExpression cIsNotAPattern pState + (field_id, pState) = stringToIdent ident IC_Selector pState + = (True, { bind_src = field_expr, bind_dst = field_id}, pState) + = (False, abort "no field", tokenBack pState) + = (False, abort "no field", pState) + try_field_assignment _ pState + = (False, abort "no field", pState) + + want_record type pState + # (token1, pState) = nextToken FunctionContext pState + (token2, pState) = nextToken FunctionContext pState + | isDefinesFieldToken token2 + # (fields, pState) = want_field_assignments cIsNotAPattern token1 (tokenBack pState) + = (PE_Record PE_Empty type fields, wantToken FunctionContext "record" CurlyCloseToken pState) + = want_record_update type token1 (tokenBack pState) + where + want_record_update :: !(Optional Ident) !Token !ParseState -> (!ParsedExpr, !ParseState) + want_record_update type token pState + # (expr, pState) = wantRhsExpressionT token pState + pState = wantToken FunctionContext "record update" AndToken pState + (token, pState) = nextToken FunctionContext pState + = want_update expr token pState + + want_update :: !ParsedExpr !Token !ParseState -> (!ParsedExpr, !ParseState) + want_update exp token pState + # (update_expr, pState) = want_updates token exp pState + // (qualifiers, pState) = try_qualifiers pState // Bug: for RWS + = (update_expr, wantToken FunctionContext "record update" CurlyCloseToken pState) + where + try_qualifiers pState + # (token, pState) = nextToken FunctionContext pState + | token == DoubleBackSlashToken + = wantQualifiers 0 0 pState + = ([], tokenBack pState) + + want_record_or_array_update token expr pState + = want_update expr token pState + + want_array_assignments is_pattern pState + # (assign, pState) = want_array_assignment is_pattern pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # pState = wantToken FunctionContext "array assignments" SquareOpenToken pState + (assigns, pState) = want_array_assignments is_pattern pState + = ([ assign : assigns ], pState) + = ([ assign ], tokenBack pState) + where + want_array_assignment is_pattern pState + # (index_exp, pState) = wantExpression cIsNotAPattern pState + pState = wantToken FunctionContext "array assignment" SquareCloseToken pState + pState = wantToken FunctionContext "array assignment" EqualToken pState + (pattern_exp, pState) = wantExpression is_pattern pState + = ({bind_dst = index_exp, bind_src = pattern_exp}, pState) + +/** + End of definitions +**/ + +skipToEndOfDefinition :: !ParseState -> (!Token, !ParseState) +skipToEndOfDefinition pState + # (token, pState) = nextToken FunctionContext pState + = case token of + NewDefinitionToken -> (token, pState) + EndGroupToken -> (token, pState) + EndOfFileToken -> (token, pState) +// SemicolonToken -> (token, pState) // might be useful in non layout mode. + _ -> skipToEndOfDefinition pState -->> (token,"skipped") + +wantEndOfDefinition :: String !ParseState -> ParseState +wantEndOfDefinition msg pState=:{ps_skipping} + | ps_skipping + # (token, pState) = skipToEndOfDefinition {pState & ps_skipping = False} + // (pos,pState) = getPosition pState // for debugging + = want_end_of_definition token msg pState //-->> ("restart parsing at ",token, pos) + # (token, pState) = nextToken FunctionContext pState + = want_end_of_definition token msg pState +where + want_end_of_definition :: !Token String !ParseState -> ParseState + want_end_of_definition token msg pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = case token of + NewDefinitionToken -> pState // -->> "end of definition found due to NewDefinitionToken" + EndOfFileToken -> tokenBack pState // -->> "end of definition found due to EndOfFileToken" + EndGroupToken -> tokenBack pState // -->> "end of definition found due to EndGroupToken" + InToken -> tokenBack pState // -->> "end of definition found due to InToken" + WhereToken -> tokenBack pState // -->> "end of definition found due to WhereToken" + BarToken -> tokenBack pState // -->> "end of definition found due to BarToken" + EqualToken -> tokenBack pState // -->> "end of definition found due to EqualToken" + ArrowToken -> tokenBack pState // -->> "end of definition found due to ArrowToken" + SeqLetToken _ -> tokenBack pState // -->> "end of definition found due to SeqLetToken" + SemicolonToken # (token, pState) = nextToken FunctionContext pState + -> case token of + NewDefinitionToken -> pState // -->> "end of definition found due to SemicolonToken and NewDefinitionToken" + _ -> tokenBack pState// -->> "end of definition found due to SemicolonToken" + token -> wantEndOfDefinition "" (parseError msg (Yes token) "end of definition" pState) + // otherwise // ~ ss_useLayout + = case token of + CurlyCloseToken -> tokenBack pState + SemicolonToken -> pState + EndOfFileToken -> tokenBack pState // -->> "end of definition found due to EndOfFileToken" + token -> wantEndOfDefinition "" (parseError msg (Yes token) "end of definition" pState) + +wantEndRootExpression :: !ParseState -> ParseState +wantEndRootExpression pState=:{ps_skipping} + | ps_skipping + = wantEndOfDefinition "root expression" pState + # (token, pState) = nextToken FunctionContext pState + (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = case token of + NewDefinitionToken -> pState + EndOfFileToken -> tokenBack pState + EndGroupToken -> tokenBack pState + EqualToken -> tokenBack pState + ArrowToken -> tokenBack pState + WhereToken -> tokenBack pState + WithToken -> tokenBack pState + BarToken -> tokenBack pState + InToken -> tokenBack pState + CloseToken -> tokenBack pState + (SeqLetToken _) -> tokenBack pState + SemicolonToken # (token, pState) = nextToken FunctionContext pState + -> case token of + NewDefinitionToken -> pState + _ -> tokenBack pState + token -> wantEndOfDefinition "root expression" (parseError "root expression" (Yes token) "end of root expression" pState) + // otherwise // ~ ss_useLayout + = case token of + SemicolonToken -> pState + CurlyCloseToken -> tokenBack pState + EqualToken -> tokenBack pState // Do we really want to allow all of these tokens + ArrowToken -> tokenBack pState + (SeqLetToken _) -> tokenBack pState + WhereToken -> tokenBack pState + WithToken -> tokenBack pState + BarToken -> tokenBack pState + EndOfFileToken -> tokenBack pState + token -> wantEndOfDefinition "root expression" (parseError "root expression" (Yes token) "end of root expression" pState) + +wantEndGroup :: String !ParseState -> ParseState +wantEndGroup msg pState + # (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = case token of + EndGroupToken -> pState + _ -> parseError msg (Yes token) "end of group with layout" pState + // ~ ss_useLayout + | token == CurlyCloseToken + = pState + // otherwise // token <> CurlyCloseToken + = parseError msg (Yes token) "end of group without layout, }," pState + +wantEndModule :: !ParseState -> ParseState +wantEndModule pState + # (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout && token == EndGroupToken + = pState + = parseError "Definition" (Yes token) "Unexpected token in input: definition" pState + +wantEndNestedGuard :: !Bool !Int !ParseState -> ParseState +wantEndNestedGuard defaultFound offside pState + | ~ defaultFound + = parseError "nested guards" No "sorry, but for the time being there is a default alternative for nested guards" pState + # (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + # ({fp_col}, pState) = getPosition pState + | fp_col < offside || (end_Nested_Guard token && fp_col == offside) + = tokenBack pState + // otherwise + = parseError "nested guards" (Yes token) "=, ->, | or # at offside position, or end of function definition" pState + // ~ ss_useLayout + | token == SemicolonToken + = pState + | defaultFound + = tokenBack pState + // otherwise + = parseError "nested guards" (Yes token) "End of nested guards, ;," pState +where + end_Nested_Guard EqualToken = True + end_Nested_Guard BarToken = True + end_Nested_Guard ArrowToken = True + end_Nested_Guard (SeqLetToken _) = True + end_Nested_Guard _ = False + +wantEndLocals :: !ParseState -> ParseState +wantEndLocals pState + # (ss_useLayout, pState) = accScanState UseLayout pState + (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + | ss_useLayout + = case token of + EndGroupToken -> pState + _ -> parseError "local definitions" (Yes token) "end of locals with layout" pState + // ~ ss_useLayout + | token == CurlyCloseToken + # (token, pState) = nextToken FunctionContext pState + | token == SemicolonToken + = pState + = tokenBack pState + // otherwise // token <> CurlyCloseToken + = parseError "local definitions" (Yes token) "end of locals without layout, }," pState + +wantEndCase :: !ParseState -> ParseState +wantEndCase pState + # (ss_useLayout, pState) = accScanState UseLayout pState + (token, pState) = nextToken FunctionContext pState + | token == EndOfFileToken + = tokenBack pState + | ss_useLayout + = case token of + EndGroupToken -> pState + CloseToken -> tokenBack (appScanState dropOffsidePosition pState) + SquareCloseToken -> tokenBack (appScanState dropOffsidePosition pState) + SemicolonToken -> tokenBack (appScanState dropOffsidePosition pState) + _ -> parseError "case expression" (Yes token) "end of case with layout" pState + // ~ ss_useLayout + | token == CurlyCloseToken + = pState + // otherwise // token <> CurlyCloseToken + = parseError "case expression" (Yes token) "end of group without layout, }," pState + +wantBeginGroup :: String !ParseState -> ParseState +wantBeginGroup msg pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = pState + // otherwise // ~ ss_uselayout + # (token, pState) = nextToken FunctionContext pState + = case token of + CurlyOpenToken + -> pState + _ -> parseError msg (Yes token) "begin group without layout, {," pState + +/* + Functions on the parse pState +*/ +/* +instance insertToken ParseState +where + insertToken t c pState = appScanState (insertToken t c) pState + +instance currentToken ParseState +where + currentToken pState = accScanState currentToken pState +*/ +instance replaceToken ParseState +where + replaceToken t pState = appScanState (replaceToken t) pState + +instance tokenBack ParseState +where + tokenBack pState=:{ps_skipping} + | ps_skipping + = pState + = appScanState tokenBack pState + +instance nextToken ParseState +where + nextToken :: !Context !ParseState -> (!Token, !ParseState) + nextToken context pState + | pState.ps_skipping // in error recovery from parse error + = (ErrorToken "Skipping", pState) + = accScanState (nextToken context) pState + +instance getPosition ParseState +where + getPosition pState = accScanState getPosition pState + +parseWarning :: !{# Char} !{# Char} !ParseState -> ParseState +parseWarning act msg pState + | pState.ps_skipping + = pState + | otherwise // not pState.ps_skipping + # (pos,pState) = getPosition pState + (filename,pState=:{ps_error={pea_file,pea_ok}}) = accScanState getFilename pState + pea_file = pea_file + <<< "Parse warning [" + <<< filename <<< "," + <<< pos + <<< (if (size act > 0) ("," + act) "") <<< "]: " + <<< msg + <<< "\n" + = { pState + & ps_error = { pea_file = pea_file, pea_ok = pea_ok } + } + +parseError :: !{# Char} !(Optional Token) !{# Char} !ParseState -> ParseState +parseError act opt_token msg pState + | pState.ps_skipping + = pState + | otherwise // not pState.ps_skipping + # (pos,pState) = getPosition pState + (filename,pState=:{ps_error={pea_file}}) = accScanState getFilename pState + pea_file = pea_file + <<< "Parse error [" + <<< filename <<< "," + <<< pos + <<< (if (size act > 0) ("," + act) "") <<< "]: " + <<< msg + pea_file = case opt_token of + Yes token -> pea_file <<< " expected instead of " <<< token <<< "\n" + No -> pea_file <<< " expected\n" + pState = { pState + & ps_skipping = True + , ps_error = { pea_file = pea_file, pea_ok = False } + } + = case opt_token of + Yes _ -> tokenBack pState + No -> pState + +getFileAndLineNr :: !ParseState -> (!String, !Int, !ParseState) +getFileAndLineNr pState =: {ps_scanState} + # (filename,scanState) = getFilename ps_scanState + ({fp_line},scanState) = getPosition scanState + = (filename, fp_line, {pState & ps_scanState = scanState} ) + +/* + Simple parse functions +*/ + +wantToken :: !Context !{#Char} !Token !ParseState -> ParseState +wantToken context act dem_token pState + # (token, pState) = nextToken context pState + | dem_token == token + = pState // -->> (token,"wanted and consumed") + = parseError act (Yes token) (toString dem_token) pState + +instance want Priority +where + want pState + # (token, pState) = nextToken FunctionContext pState + = case token of + PriorityToken prio + -> (prio, pState) + _ + -> (NoPrio, parseError "Priority" (Yes token) "with" pState) + +instance want {# Char} +where + want pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name -> (name, pState) + _ -> ("", parseError "String" (Yes token) "identifier" pState) + +tryTypeVar :: !ParseState -> (!Bool, TypeVar, !ParseState) +tryTypeVar pState + # (token, pState) = nextToken TypeContext pState + = tryTypeVarT token pState + +tryTypeVarT :: !Token !ParseState -> (!Bool, TypeVar, !ParseState) +tryTypeVarT (IdentToken name) pState + | isUpperCaseName name + = (False, abort "no UC ident", pState) + # (id, pState) = stringToIdent name IC_Type pState + = (True, MakeTypeVar id, pState) +tryTypeVarT token pState + = (False, abort "no type variable", tokenBack pState) + +wantUpperCaseName :: !String !ParseState -> (!String, !ParseState) +wantUpperCaseName string pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isUpperCaseName name + -> (name, pState) + _ + -> ("dummy uppercase name", parseError string (Yes token) "upper case ident" pState) + +wantLowerCaseName :: !String !ParseState -> (!String, !ParseState) +wantLowerCaseName string pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isLowerCaseName name + -> (name, pState) + _ + -> ("dummy lowercase name", parseError string (Yes token) "lower case ident" pState) + +wantConstructorName :: !String !ParseState -> (!String, !ParseState) +wantConstructorName string pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isUpperCaseName name || isFunnyIdName name + -> (name, pState) + _ + -> ("", parseError string (Yes token) "upper case ident" pState) + +/* +isTypeStartToken :: ! Token -> Bool +isTypeStartToken (IdentToken id) = True +isTypeStartToken SquareOpenToken = True +isTypeStartToken CurlyOpenToken = True +isTypeStartToken OpenToken = True +isTypeStartToken IntTypeToken = True +isTypeStartToken CharTypeToken = True +isTypeStartToken BoolTypeToken = True +isTypeStartToken VoidTypeToken = True +isTypeStartToken StringTypeToken = True +isTypeStartToken RealTypeToken = True +isTypeStartToken DynamicTypeToken = True +isTypeStartToken ExclamationToken = True +isTypeStartToken DotToken = True +isTypeStartToken AsteriskToken = True +isTypeStartToken token = False + +isIdentToken :: ! Token -> Bool +isIdentToken (IdentToken id) = True +isIdentToken t = False + +isTypeDefToken :: ! Token -> Bool +isTypeDefToken DoubleColonToken = True +isTypeDefToken token = False + +isDefinesTypeToken :: !Token -> Bool +isDefinesTypeToken EqualToken = True +isDefinesTypeToken ColonDefinesToken = True +isDefinesTypeToken token = False + +isUpperCaseIdent :: ! Token -> Bool +isUpperCaseIdent (IdentToken name) = isUpperCaseName name +isUpperCaseIdent token = False +*/ +isDefinesFieldToken :: ! Token -> Bool +isDefinesFieldToken EqualToken = True +isDefinesFieldToken CurlyCloseToken = True +isDefinesFieldToken CommaToken = True +isDefinesFieldToken token = False + + //---------------// + //--- Tracing ---// +//---------------// + +(-->>) val _ :== val +//(-->>) val message :== val ---> ("Parser",message) diff --git a/frontend/part.icl b/frontend/part.icl new file mode 100644 index 0000000..8a080e2 --- /dev/null +++ b/frontend/part.icl @@ -0,0 +1,92 @@ +module part + +import StdEnv + +import syntax, transform, checksupport, StdCompare, check, utilities + +:: PartitioningInfo = + { pi_marks :: !.{# Int} + , pi_next_num :: !Int + , pi_next_group :: !Int + , pi_groups :: ![[Int]] + , pi_deps :: ![Int] + } + +NotChecked :== -1 + +Start = 3 + +partitionateFunctions :: !*{# FunDef} !*{# FunDef} -> (!{! Group}, !*{# FunDef}, !*{# FunDef}) +partitionateFunctions fun_defs inst_defs + #! nr_of_functions = size fun_defs + nr_of_instances = size inst_defs + #! max_fun_nr = nr_of_functions + nr_of_instances + # partitioning_info = { pi_marks = createArray max_fun_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } + (fun_defs, inst_defs, {pi_groups,pi_next_group}) = partitionate_functions 0 max_fun_nr nr_of_functions fun_defs inst_defs partitioning_info + groups = { {group_members = group} \\ group <- reverse pi_groups } + = (groups, fun_defs, inst_defs) +where + partitionate_functions :: !Int !Int !Int !*{# FunDef} !*{# FunDef} !*PartitioningInfo -> (!*{# FunDef}, !*{# FunDef}, !*PartitioningInfo) + partitionate_functions from_index max_fun_nr nr_of_functions fun_defs inst_defs pi=:{pi_marks} + | from_index == max_fun_nr + = (fun_defs, inst_defs, pi) + | pi_marks.[from_index] == NotChecked + # (_, fun_defs, inst_defs, pi) = partitionate_function from_index max_fun_nr nr_of_functions fun_defs inst_defs pi + = partitionate_functions (inc from_index) max_fun_nr nr_of_functions fun_defs inst_defs pi + = partitionate_functions (inc from_index) max_fun_nr nr_of_functions fun_defs inst_defs pi + + partitionate_function :: !Int !Int !Int !*{# FunDef} !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*{# FunDef}, !*PartitioningInfo) + partitionate_function fun_index max_fun_nr nr_of_functions fun_defs inst_defs pi=:{pi_next_num} + | fun_index < nr_of_functions + #! fd = fun_defs.[fun_index] + | fd.fun_kind + # {fi_calls,fi_instance_calls} = fd.fun_info + (min_dep, fun_defs, inst_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr nr_of_functions fun_defs inst_defs (push_on_dep_stack fun_index pi) + (min_dep, fun_defs, inst_defs, pi) = visit_functions fi_calls min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi + = try_to_close_group fun_index pi_next_num min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi + #! fd = inst_defs.[fun_index-nr_of_functions] + # {fi_calls,fi_instance_calls} = fd.fun_info + (min_dep, fun_defs, inst_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr nr_of_functions fun_defs inst_defs (push_on_dep_stack fun_index pi) + (min_dep, fun_defs, inst_defs, pi) = visit_functions fi_calls min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi + = try_to_close_group fun_index pi_next_num min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi + + push_on_dep_stack :: !Int !*PartitioningInfo -> *PartitioningInfo; + push_on_dep_stack fun_index pi=:{pi_deps,pi_marks,pi_next_num} + = { pi & pi_deps = [fun_index : pi_deps], pi_marks = { pi_marks & [fun_index] = pi_next_num}, pi_next_num = inc pi_next_num} + + visit_functions :: ![FunCall] !Int !Int !Int !*{# FunDef} !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*{# FunDef}, !*PartitioningInfo) + visit_functions [{fc_index}:funs] min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi=:{pi_marks} + #! mark = pi_marks.[fc_index] + | mark == NotChecked + # (mark, fun_defs, inst_defs, pi) = partitionate_function fc_index max_fun_nr nr_of_functions fun_defs inst_defs pi + = visit_functions funs (min min_dep mark) max_fun_nr nr_of_functions fun_defs inst_defs pi + = visit_functions funs (min min_dep mark) max_fun_nr nr_of_functions fun_defs inst_defs pi + visit_functions [] min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi + = (min_dep, fun_defs, inst_defs, pi) + + + try_to_close_group :: !Int !Int !Int !Int !Int !*{# FunDef} !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*{# FunDef}, !*PartitioningInfo) + try_to_close_group fun_index fun_nr min_dep max_fun_nr nr_of_functions fun_defs inst_defs pi=:{pi_marks, pi_deps, pi_groups, pi_next_group} + | fun_nr <= min_dep + # (pi_deps, pi_marks, group, fun_defs, inst_defs) + = close_group fun_index pi_deps pi_marks [] max_fun_nr nr_of_functions pi_next_group fun_defs inst_defs + + pi = { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_next_group = inc pi_next_group, pi_groups = [group : pi_groups] } + = (max_fun_nr, fun_defs, inst_defs, pi) + = (min_dep, fun_defs, inst_defs, pi) + where + close_group :: !Int ![Int] !*{# Int} ![Int] !Int !Int !Index !*{# FunDef} !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef}, !*{# FunDef}) + close_group fun_index [d:ds] marks group max_fun_nr nr_of_functions group_number fun_defs inst_defs + #! fd = fun_defs.[d] + # marks = { marks & [d] = max_fun_nr } + | d < nr_of_functions + #! fd = fun_defs.[d] + # fun_defs = { fun_defs & [d] = { fd & fun_info.fi_group_index = group_number }} + | d == fun_index + = (ds, marks, [d : group], fun_defs, inst_defs) + = close_group fun_index ds marks group max_fun_nr nr_of_functions group_number fun_defs inst_defs + #! fd = inst_defs.[d-nr_of_functions] + # inst_defs = { inst_defs & [d] = { fd & fun_info.fi_group_index = group_number }} + | d == fun_index + = (ds, marks, [d : group], fun_defs, inst_defs) + = close_group fun_index ds marks group max_fun_nr nr_of_functions group_number fun_defs inst_defs diff --git a/frontend/postparse.dcl b/frontend/postparse.dcl new file mode 100644 index 0000000..b8778aa --- /dev/null +++ b/frontend/postparse.dcl @@ -0,0 +1,8 @@ +definition module postparse + +import StdEnv + +import syntax, parse, predef + +scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ScannedModule, !Int, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) diff --git a/frontend/postparse.icl b/frontend/postparse.icl new file mode 100644 index 0000000..31d295f --- /dev/null +++ b/frontend/postparse.icl @@ -0,0 +1,813 @@ +implementation module postparse + +import StdEnv +import syntax, parse, predef, utilities, StdCompare +import RWSDebug + +/** + +**/ + +cIsAGlobalDef :== True +cIsNotAGlobalDef :== False + +:: PredefinedIdents :== {!Ident} + +SelectPredefinedIdents :: *PredefinedSymbols -> (!PredefinedIdents, !*PredefinedSymbols) +SelectPredefinedIdents predefs + = selectIdents 0 (createArray PD_NrOfPredefSymbols {id_name="", id_info = nilPtr}) predefs + where + selectIdents i idents symbols + | i == PD_NrOfPredefSymbols + = (idents, symbols) + // otherwise + #! symbol = symbols.[i] + = selectIdents (i+1) {idents & [i] = symbol.pds_ident} symbols + +predef :: Int PredefinedIdents -> ParsedExpr +predef index ids + = PE_Ident ids.[index] + +(##) infixl 9 +(##) f a + :== \idents -> apply (f idents) (toParsedExpr a idents) + +(#<) a b + :== predef PD_SmallerFun ## a ## b + +// apply :: ParsedExpr ParsedExpr -> ParsedExpr + +apply :: ParsedExpr ParsedExpr -> ParsedExpr +apply (PE_List application) a + = PE_List (application ++ [a]) +apply f a + = PE_List [f, a] + +class toParsedExpr a :: !a !PredefinedIdents -> ParsedExpr + +instance toParsedExpr [a] | toParsedExpr a where + toParsedExpr [] ids + = predef PD_NilSymbol ids + toParsedExpr [hd:tl] ids + = (predef PD_ConsSymbol ## hd ## tl) ids + +//instance toParsedExpr a where +// toParsedExpr _ _ +// = abort "toParsedExpr (a) shouldn't be called" + +instance toParsedExpr ParsedExpr where + toParsedExpr x _ + = x + +instance toParsedExpr Int where + toParsedExpr x _ + = PE_Basic (BVI (toString x)) + +instance toParsedExpr Char where + toParsedExpr x _ + = PE_Basic (BVC (toString x)) + +instance toParsedExpr Ident where + toParsedExpr x _ + = PE_Ident x + +postParseError pos msg ps=:{ca_error={pea_file}} + # (filename, line, funname) = get_file_and_line_nr pos + pea_file = pea_file <<< "Post Parse Error [" <<< filename <<< "," <<< line // PK + pea_file = case funname of + Yes name -> pea_file <<< "," <<< name + No -> pea_file + pea_file = pea_file <<< "]: " <<< msg <<< ".\n" + = {ps & ca_error = { pea_file = pea_file, pea_ok = False }} +where + get_file_and_line_nr (FunPos filename linenr funname) + = (filename, linenr, Yes funname) + get_file_and_line_nr (LinePos filename linenr) + = (filename, linenr, No) + +:: *CollectAdmin = + { ca_error :: !ParseErrorAdmin + , ca_fun_count :: !Int + , ca_predefs :: !PredefinedIdents + } + +class collectFunctions a :: a !CollectAdmin -> (a, ![FunDef], !CollectAdmin) + +instance collectFunctions ParsedExpr +where + collectFunctions (PE_List exprs) ca + # (exprs, fun_defs, ca) = collectFunctions exprs ca + = (PE_List exprs, fun_defs, ca) + collectFunctions (PE_Bound bound_expr) ca + # (bound_expr, fun_defs, ca) = collectFunctions bound_expr ca + = (PE_Bound bound_expr, fun_defs, ca) + collectFunctions (PE_Lambda lam_ident args res) ca + # fun_count = ca.ca_fun_count + next_fun_count = inc fun_count + ((args,res), fun_defs, ca) = collectFunctions (args,res) {ca & ca_fun_count = next_fun_count} + fun_def = transformLambda lam_ident args res + = (PE_Let cIsStrict (CollectedLocalDefs { loc_functions = { ir_from = fun_count, ir_to = next_fun_count }, loc_nodes = [] }) + (PE_Ident lam_ident), [fun_def : fun_defs], ca) + collectFunctions (PE_Record rec_expr type_name fields) ca + # ((rec_expr,fields), fun_defs, ca) = collectFunctions (rec_expr,fields) ca + = (PE_Record rec_expr type_name fields, fun_defs, ca) + collectFunctions (PE_Tuple exprs) ca + # (exprs, fun_defs, ca) = collectFunctions exprs ca + = (PE_Tuple exprs, fun_defs, ca) + collectFunctions (PE_Selection is_unique expr selectors) ca + # ((expr, selectors), fun_defs, ca) = collectFunctions (expr, selectors) ca + = (PE_Selection is_unique expr selectors, fun_defs, ca) + collectFunctions (PE_Update expr1 updates expr2) ca + # ((expr1, (updates, expr2)), fun_defs, ca) = collectFunctions (expr1, (updates, expr2)) ca + = (PE_Update expr1 updates expr2, fun_defs, ca) + collectFunctions (PE_Case case_ident pattern_expr case_alts) ca + # ((pattern_expr,case_alts), fun_defs, ca) = collectFunctions (pattern_expr,case_alts) ca + = (PE_Case case_ident pattern_expr case_alts, fun_defs, ca) + collectFunctions (PE_If if_ident c t e) ca + # true_pattern = PE_Basic (BVB True) + false_pattern = PE_WildCard // PE_Basic (BVB False) + = collectFunctions (PE_Case if_ident c + [ {calt_pattern = true_pattern , calt_rhs = exprToRhs t} + , {calt_pattern = false_pattern, calt_rhs = exprToRhs e} + ]) ca + where + exprToRhs expr + = { rhs_alts = UnGuardedExpr + { ewl_nodes = [] + , ewl_expr = expr + , ewl_locals = LocalParsedDefs [] + } + , rhs_locals = LocalParsedDefs [] + } + collectFunctions (PE_Let strict locals in_expr) ca + # ((node_defs,in_expr), fun_defs, ca) = collectFunctions (locals,in_expr) ca + = (PE_Let strict node_defs in_expr, fun_defs, ca) + collectFunctions (PE_Compr gen_kind expr qualifiers) ca=:{ca_predefs} + = transformComprehension gen_kind expr qualifiers ca + collectFunctions (PE_Array expr assignments _) ca=:{ca_predefs} + = collectFunctions (transformArrayUpdate expr assignments ca_predefs) ca + collectFunctions (PE_Sequ sequence) ca=:{ca_predefs} + = collectFunctions (transformSequence sequence ca_predefs) ca + collectFunctions (PE_ArrayDenot exprs) ca=:{ca_predefs} + = collectFunctions (transformArrayDenot exprs ca_predefs) ca + collectFunctions expr ca + = (expr, [], ca) + +instance collectFunctions [a] | collectFunctions a +where + collectFunctions [x:xs] ca + # (x, fun_defs_in_x, ca) = collectFunctions x ca + (xs, fun_defs_in_xs, ca) = collectFunctions xs ca + = ([x:xs], fun_defs_in_x ++ fun_defs_in_xs, ca) + collectFunctions [] ca + = ([], [], ca) + +instance collectFunctions (a,b) | collectFunctions a & collectFunctions b +where + collectFunctions (x,y) ca + # (x, fun_defs_in_x, ca) = collectFunctions x ca + (y, fun_defs_in_y, ca) = collectFunctions y ca + = ((x,y), fun_defs_in_x ++ fun_defs_in_y, ca) + +instance collectFunctions Qualifier +where + collectFunctions qual=:{qual_generators, qual_filter} ca + # ((qual_generators, qual_filter), fun_defs, ca) = collectFunctions (qual_generators, qual_filter) ca + = ({ qual & qual_generators = qual_generators, qual_filter = qual_filter }, fun_defs, ca) + +instance collectFunctions Generator +where + collectFunctions gen=:{gen_pattern,gen_expr} ca + # ((gen_pattern,gen_expr), fun_defs, ca) = collectFunctions (gen_pattern,gen_expr) ca + = ({gen & gen_pattern = gen_pattern, gen_expr = gen_expr}, fun_defs, ca) + + +instance collectFunctions (Optional a) | collectFunctions a +where + collectFunctions (Yes expr) ca + # (expr, fun_defs, ca) = collectFunctions expr ca + = (Yes expr, fun_defs, ca) + collectFunctions No ca + = (No, [], ca) + +instance collectFunctions ParsedSelection +where + collectFunctions (PS_Array index_expr) ca + # (index_expr, fun_defs, ca) = collectFunctions index_expr ca + = (PS_Array index_expr, fun_defs, ca) + collectFunctions expr ca + = (expr, [], ca) + +instance collectFunctions CaseAlt +where + collectFunctions calt=:{calt_pattern,calt_rhs} ca + # ((calt_pattern,calt_rhs), fun_defs, ca) = collectFunctions (calt_pattern,calt_rhs) ca + = ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, fun_defs, ca) + + +instance collectFunctions Sequence +where + collectFunctions (SQ_FromThen from_expr then_expr) ca + # ((from_expr,then_expr), fun_defs, ca) = collectFunctions (from_expr,then_expr) ca + = (SQ_FromThen from_expr then_expr, fun_defs, ca) + collectFunctions (SQ_FromThenTo from_expr then_expr to_expr) ca + # ((from_expr,(then_expr,to_expr)), fun_defs, ca) = collectFunctions (from_expr,(then_expr,to_expr)) ca + = (SQ_FromThenTo from_expr then_expr to_expr, fun_defs, ca) + collectFunctions (SQ_FromTo from_expr to_expr) ca + # ((from_expr,to_expr), fun_defs, ca) = collectFunctions (from_expr,to_expr) ca + = (SQ_FromTo from_expr to_expr, fun_defs, ca) + collectFunctions (SQ_From from_expr) ca + # (from_expr, fun_defs, ca) = collectFunctions from_expr ca + = (SQ_From from_expr, fun_defs, ca) + +instance collectFunctions Bind a b | collectFunctions a & collectFunctions b +where + collectFunctions bind=:{bind_src,bind_dst} ca + # ((bind_src,bind_dst), fun_defs, ca) = collectFunctions (bind_src,bind_dst) ca + = ({ bind_src = bind_src, bind_dst = bind_dst }, fun_defs, ca) + +instance collectFunctions OptGuardedAlts +where + collectFunctions (GuardedAlts guarded_exprs (Yes def_expr)) ca + # ((guarded_exprs, def_expr), fun_defs, ca) = collectFunctions (guarded_exprs, def_expr) ca + = (GuardedAlts guarded_exprs (Yes def_expr), fun_defs, ca) + collectFunctions (GuardedAlts guarded_exprs No) ca + # (guarded_exprs, fun_defs, ca) = collectFunctions guarded_exprs ca + = (GuardedAlts guarded_exprs No, fun_defs, ca) + collectFunctions (UnGuardedExpr unguarded_expr) ca + # (unguarded_expr, fun_defs, ca) = collectFunctions unguarded_expr ca + = (UnGuardedExpr unguarded_expr, fun_defs, ca) + +instance collectFunctions GuardedExpr +where + collectFunctions alt=:{alt_nodes,alt_guard,alt_expr} ca + # ((alt_nodes, (alt_guard, alt_expr)), fun_defs, ca) = + collectFunctions (alt_nodes, (alt_guard, alt_expr)) ca + = ({alt & alt_nodes = alt_nodes, alt_guard = alt_guard, alt_expr = alt_expr}, fun_defs, ca) + +instance collectFunctions ExprWithLocalDefs +where + collectFunctions expr=:{ewl_nodes, ewl_expr,ewl_locals} ca + # ((ewl_nodes, (ewl_expr, ewl_locals)), fun_defs, ca) = collectFunctions (ewl_nodes, (ewl_expr, ewl_locals)) ca + = ({expr & ewl_nodes = ewl_nodes, ewl_expr = ewl_expr, ewl_locals = ewl_locals}, fun_defs, ca) + +instance collectFunctions NodeDefWithLocals +where + collectFunctions node_def=:{ndwl_def, ndwl_locals} ca + # (( ndwl_def, ndwl_locals), fun_defs, ca) = collectFunctions (ndwl_def, ndwl_locals) ca + = ({node_def & ndwl_def = ndwl_def, ndwl_locals = ndwl_locals}, fun_defs, ca) + +instance collectFunctions Rhs +where + collectFunctions {rhs_alts, rhs_locals} ca + # ((rhs_alts, rhs_locals), fun_defs, ca) = collectFunctions (rhs_alts, rhs_locals) ca + = ({rhs_alts = rhs_alts, rhs_locals = rhs_locals}, fun_defs, ca) + +instance collectFunctions LocalDefs +where + collectFunctions (LocalParsedDefs locals) ca + # (fun_defs, node_defs, ca) = reorganizeLocalDefinitions locals ca + ir_from = ca.ca_fun_count + ir_to = ca.ca_fun_count + length fun_defs + (node_defs, fun_defs_in_node_defs, ca) = collect_functions_in_node_defs node_defs {ca & ca_fun_count = ir_to} + (fun_defs, collected_fun_defs, ca) = reorganizeLocalDefinitionsOfFunctions fun_defs ca + = (CollectedLocalDefs { loc_functions = { ir_from = ir_from, ir_to = ir_to }, loc_nodes = node_defs }, + fun_defs ++ fun_defs_in_node_defs ++ collected_fun_defs, ca) + + where + collect_functions_in_node_defs [ (node_def_type, bind) : node_defs ] ca + # (bind, fun_defs_in_bind, ca) = collectFunctions bind ca + (node_defs, fun_defs_in_node_defs, ca) = collect_functions_in_node_defs node_defs ca + = ([(node_def_type, bind):node_defs], fun_defs_in_bind ++ fun_defs_in_node_defs, ca) + collect_functions_in_node_defs [] ca + = ([], [], ca) + +instance collectFunctions NodeDef a | collectFunctions a +where + collectFunctions node_def=:{nd_dst,nd_alts,nd_locals} ca + # ((nd_dst,(nd_alts,nd_locals)), fun_defs, ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) ca + = ({ node_def & nd_dst = nd_dst, nd_alts = nd_alts, nd_locals = nd_locals }, fun_defs, ca) + +/* +instance collectFunctions a +where + collectFunctions e ca + = (e, [], ca) +*/ + +instance collectFunctions Ident +where + collectFunctions e ca + = (e, [], ca) + +NoCollectedLocalDefs :== CollectedLocalDefs { loc_functions = { ir_from = 0, ir_to = 0 }, loc_nodes = [] } + +transformLambda lam_ident args result + # lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs }, + rhs_locals = NoCollectedLocalDefs } + lam_body = [{pb_args = args, pb_rhs = lam_rhs }] + fun_def = MakeNewFunction lam_ident (length args) lam_body FK_Function NoPrio No NoPos + = fun_def + +makeNilExpression ca=:{ca_predefs} + #! nil_id = ca_predefs.[PD_NilSymbol] + = (PE_List [PE_Ident nil_id], ca) +makeConsExpression a1 a2 ca=:{ca_predefs} + #! cons_id = ca_predefs.[PD_ConsSymbol] + = (PE_List [PE_Ident cons_id, a1, a2], ca) + +transformComprehension gen_kind expr qualifiers ca + | gen_kind == cIsListGenerator + # (nil_expr, ca) = makeNilExpression ca + = build_list_comprehension expr nil_expr qualifiers ca + // gen_kind == cIsArrayGenerator + = abort "transformComprehension: cIsArrayGenerator NYI" ---> "transformComprehension: cIsArrayGenerator NYI" // PK +where + + build_list_comprehension expr nil_case [] ca + # (expr, fun_defs, ca) = collectFunctions expr ca + (cons_expr, ca) = makeConsExpression expr nil_case ca + = (cons_expr, fun_defs, ca) + build_list_comprehension expr nil_case [qual: quals] ca + # fun_count = ca.ca_fun_count + next_fun_count = inc fun_count + ({qual_generators,qual_fun_id,qual_filter}, fun_defs, ca) = collectFunctions qual {ca & ca_fun_count = next_fun_count} + (cons_patterns, nil_patterns, tail_args, args, arity, opt_index, sizes, selections, ca) + = build_patterns qual_generators ca + (selectId,ca) = get_predef_id PD_AndOp ca /* ????????? */ + (incId,ca) = get_predef_id PD_IncFun ca + (smallerId,ca) = get_predef_id PD_SmallerFun ca + (cons_patterns, nil_patterns, tail_args, args, arity) + = add_index cons_patterns nil_patterns tail_args args arity incId opt_index + tail_call = PE_List [PE_Ident qual_fun_id : tail_args] + (compr, tail_fun_defs, ca) = build_list_comprehension expr tail_call quals ca + (andId,ca) = get_predef_id PD_AndOp ca + bound_checks = make_bounds_check opt_index smallerId andId sizes + guard = combine_guards qual_filter bound_checks andId + fun_def = build_generator_function guard qual_fun_id compr nil_case arity cons_patterns nil_patterns + gen_appl = PE_List [PE_Ident fun_def.fun_symb : args] + = (PE_Let cIsStrict (CollectedLocalDefs { loc_functions = { ir_from = fun_count, ir_to = next_fun_count }, loc_nodes = [] }) gen_appl, + [fun_def : fun_defs ++ tail_fun_defs], ca) + where + // +++ combine + build_generator_function No qual_fun_id expr nil_case arity cons_patterns nil_patterns + # cons_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = expr, ewl_locals = NoCollectedLocalDefs }, rhs_locals = NoCollectedLocalDefs } + nil_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = nil_case, ewl_locals = NoCollectedLocalDefs }, rhs_locals = NoCollectedLocalDefs } + body = [{pb_args = cons_patterns, pb_rhs = cons_rhs },{pb_args = nil_patterns, pb_rhs = nil_rhs }] + fun_def = MakeNewFunction qual_fun_id arity body FK_Function NoPrio No NoPos + = fun_def + build_generator_function (Yes guard) qual_fun_id expr nil_case arity cons_patterns nil_patterns + # cons_rhs = { rhs_alts = GuardedAlts [{alt_nodes = [], alt_guard = guard, alt_expr = UnGuardedExpr { ewl_nodes = [], ewl_expr = expr, ewl_locals = NoCollectedLocalDefs}}] No, rhs_locals = NoCollectedLocalDefs } + nil_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = nil_case, ewl_locals = NoCollectedLocalDefs }, rhs_locals = NoCollectedLocalDefs } + body = [{pb_args = cons_patterns, pb_rhs = cons_rhs },{pb_args = nil_patterns, pb_rhs = nil_rhs }] + fun_def = MakeNewFunction qual_fun_id arity body FK_Function NoPrio No NoPos + = fun_def + + build_patterns [{gen_pattern,gen_expr,gen_var} : gens] ca + | gen_kind == cIsListGenerator + # tail_arg = PE_Ident gen_var + (cons_pattern, ca) = makeConsExpression gen_pattern tail_arg ca + nil_pattern = PE_WildCard + (cons_patterns, nil_patterns, tail_args, gen_exprs, nr_of_args, opt_index, sizes, selections, ca) + = build_patterns gens ca + = ([cons_pattern : cons_patterns], [nil_pattern : nil_patterns], [tail_arg : tail_args], [gen_expr : gen_exprs], + inc nr_of_args, opt_index, sizes, selections, ca) + // gen_kind == cIsArrayGenerator + # array_arg = PE_Ident gen_var + (cons_patterns, nil_patterns, tail_args, gen_exprs, nr_of_args, opt_index, sizes, selections, ca) + = build_patterns gens ca + index_ident = get_index_ident opt_index gen_var + selection = make_selection gen_pattern array index + = ([array_arg : cons_patterns], [array_arg : nil_patterns], [array_arg : tail_args], [gen_expr : gen_exprs], + inc nr_of_args, Yes index_ident, sizes, selections, ca) + where + get_index_ident No var + = PE_Ident var + get_index_ident (Yes var) _ + = var + build_patterns [] ca + = ([], [], [], [], 0, No, [], [], ca) + + add_index cons_patterns nil_patterns tail_args gen_exprs arity _ _ + = (cons_patterns, nil_patterns, tail_args, gen_exprs, arity) + add_index cons_patterns nil_patterns tail_args gen_exprs arity incId (Yes index) + = ([index : cons_patterns], [PE_WildCard : nil_patterns], [next_index : tail_args], [PE_Basic (BVI "0") : gen_exprs], arity+1) + where + next_index + = PE_List [PE_Ident incId, index] + + make_selection pattern array index + = PD_NodeDef (PE_List [Arity2TupleConsIndex, array, pattern]) (PE_List [selectId, array, index]) + + combine_guards No No _ + = No + combine_guards a No _ + = a + combine_guards No b _ + = b + combine_guards (Yes a) (Yes b) andId + = Yes (PE_List [PE_Ident andId, a, b]) + + get_predef_id predef_index ca=:{ca_predefs} + #! symb = ca_predefs.[predef_index] + = (symb, ca) + + make_bounds_check _ _ _ [] + = No + make_bounds_check (Yes index) andId smallerId [size : sizes] + = combine_guards (Yes check) (make_bounds_check (Yes index) andId smallerId sizes) andId + where + check + = PE_List [PE_Ident smallerId, index, size] + + +transformSequence :: Sequence -> PredefinedIdents -> ParsedExpr +transformSequence (SQ_FromThen frm then) + = predef PD_FromThen ## frm ## then +transformSequence (SQ_FromThenTo frm then to) + = predef PD_FromThenTo ## frm ## then ## to +transformSequence (SQ_From frm) + = predef PD_From ## frm +transformSequence (SQ_FromTo frm to) + = predef PD_FromTo ## frm ## to + +transformArrayUpdate :: ParsedExpr [ElemAssignment] PredefinedIdents -> ParsedExpr +transformArrayUpdate expr updates pi + = foldr (update (predef PD_ArrayUpdateFun)) expr updates + where + update updateIdent {bind_src=value, bind_dst=index} expr + = (updateIdent ## expr ## index ## value) pi + +transformArrayDenot :: [ParsedExpr] PredefinedIdents -> ParsedExpr +transformArrayDenot exprs pi + = PE_Array + ((predef PD__CreateArrayFun ## length exprs) pi) + [{bind_dst=toParsedExpr i pi, bind_src=expr} \\ expr <- exprs & i <- [0..]] + [] + +scanModules [] parsed_modules fun_count hash_table err_file searchPaths predefs files + = (True, parsed_modules, [], fun_count, hash_table, err_file, predefs, files) +scanModules [{import_module,import_symbols} : mods] parsed_modules fun_count hash_table err_file searchPaths predefs files + # (found, mod) = try_to_find import_module parsed_modules + | found + = scanModules mods parsed_modules fun_count hash_table err_file searchPaths predefs files + # (succ, parsed_modules, local_fun_defs, fun_count, hash_table, err_file, predefs, files) + = parseAndScanDclModule import_module parsed_modules fun_count hash_table err_file searchPaths predefs files + (mods_succ, parsed_modules, local_fun_defs_in_imports, fun_count, hash_table, err_file, predefs, files) + = scanModules mods parsed_modules fun_count hash_table err_file searchPaths predefs files + = (succ && mods_succ, parsed_modules, local_fun_defs ++ local_fun_defs_in_imports, fun_count, hash_table, err_file, predefs, files) +where + try_to_find mod_id [] + = (False, abort "module not found") + try_to_find mod_id [pmod : pmods] + | mod_id == pmod.mod_name + = (True, pmod) + = try_to_find mod_id pmods + +MakeEmptyModule name :== { mod_name = name, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], + mod_defs = { def_types = [], def_constructors = [], def_selectors = [], def_classes = [], def_macros = { ir_from = 0, ir_to = 0 }, + def_members = [], def_funtypes = [], def_instances = [] } } + +parseAndScanDclModule :: !Ident ![ScannedModule] !Int !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> *(!Bool, ![ScannedModule], ![FunDef], !Int, !*HashTable, !*File, !*PredefinedSymbols, !*Files); +parseAndScanDclModule dcl_module parsed_modules fun_count hash_table err_file searchPaths predefs files + # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile dcl_module hash_table err_file searchPaths predefs files + | parse_ok + = scan_dcl_module mod parsed_modules fun_count hash_table err_file searchPaths predefs files + = (False, [ MakeEmptyModule mod.mod_name : parsed_modules ], [], fun_count, hash_table, err_file, predefs, files) +where + scan_dcl_module mod=:{mod_defs = pdefs} parsed_modules fun_count hash_table err_file searchPaths predefs files + # (predefIdents, predefs) = SelectPredefinedIdents predefs + # state = {ca_error = { pea_file = err_file, pea_ok = True }, ca_fun_count = 0, ca_predefs = predefIdents} + (_, defs, imports, imported_objects, state) = reorganizeDefinitions False pdefs 0 0 0 state + macro_count = length defs.def_macros + fun_count + (macro_defs, local_fun_defs, {ca_fun_count=new_fun_count, ca_error={pea_file,pea_ok}, ca_predefs}) + = reorganizeLocalDefinitionsOfFunctions defs.def_macros {state & ca_fun_count = macro_count} + mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros = { ir_from = fun_count, ir_to = macro_count } }} + (import_ok, parsed_modules, imported_local_fun_defs, fun_count, hash_table, err_file, predefs, files) + = scanModules imports [mod : parsed_modules] new_fun_count hash_table pea_file searchPaths predefs files + = (pea_ok && import_ok, parsed_modules, macro_defs ++ local_fun_defs ++ imported_local_fun_defs, fun_count, hash_table, err_file, predefs, files) + +scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ScannedModule, !Int, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) +scanModule mod=:{mod_name,mod_type,mod_defs = pdefs} hash_table err_file searchPaths predefs files + # (predefIdents, predefs) = SelectPredefinedIdents predefs + # state = {ca_fun_count = 0, ca_error = { pea_file = err_file, pea_ok = True }, ca_predefs = predefIdents} + (fun_defs, defs, imports, imported_objects, ca) = reorganizeDefinitions True pdefs 0 0 0 state + fun_count = length fun_defs + macro_count = length defs.def_macros + (fun_defs, local_defs, ca) = reorganizeLocalDefinitionsOfFunctions (fun_defs ++ defs.def_macros) {ca & ca_fun_count = fun_count + macro_count} + (def_instances, local_defs_in_insts, {ca_fun_count=tot_fun_count, ca_error = {pea_file,pea_ok}, ca_predefs}) + = reorganizeLocalDefinitionsOfInstances defs.def_instances ca + (import_ok, parsed_modules, local_defs_in_dcl, tot_fun_count, hash_table, err_file, ca_predefs, files) + = scan_dcl_module mod_name mod_type tot_fun_count hash_table pea_file predefs files + (import_ok, parsed_modules, local_defs_in_imports, tot_fun_count, hash_table, err_file, ca_predefs, files) + = scanModules imports parsed_modules tot_fun_count hash_table err_file searchPaths ca_predefs files + mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_instances = def_instances, + def_macros = { ir_from = fun_count, ir_to = fun_count + macro_count } }} + [dcl_mod : modules] = reverse parsed_modules + all_local_defs = fun_defs ++ local_defs ++ local_defs_in_insts ++ local_defs_in_dcl ++ local_defs_in_imports + (pre_def_mod, ca_predefs) = buildPredefinedModule ca_predefs + = (pea_ok && import_ok, mod, fun_count, all_local_defs, dcl_mod, pre_def_mod, modules, hash_table, err_file, ca_predefs, files) +where + scan_dcl_module mod_name MK_Main fun_count hash_table err_file predefs files + = (True, [MakeEmptyModule mod_name ], [], fun_count, hash_table, err_file, predefs, files) + scan_dcl_module mod_name MK_None fun_count hash_table err_file predefs files + = (True, [MakeEmptyModule mod_name ], [], fun_count, hash_table, err_file, predefs , files) + scan_dcl_module mod_name kind fun_count hash_table err_file predefs files + = parseAndScanDclModule mod_name [] fun_count hash_table err_file searchPaths predefs files + +reorganizeLocalDefinitionsOfInstances [] ca + = ([], [], ca) +reorganizeLocalDefinitionsOfInstances [inst=:{pi_members} : insts] ca + # (pi_members, local_defs, ca) = reorganizeLocalDefinitionsOfFunctions pi_members ca + (insts, local_defs_in_insts, ca) = reorganizeLocalDefinitionsOfInstances insts ca + = ([{inst & pi_members = pi_members } : insts], local_defs ++ local_defs_in_insts, ca) + +reorganizeLocalDefinitionsOfFunction fun_def=:{fun_body = ParsedBody bodies} ca + # (bodies, rhs_fun_defs, ca) = collect_local_definitions_in_bodies bodies ca + = ({fun_def & fun_body = ParsedBody bodies}, rhs_fun_defs, ca) +where + collect_local_definitions_in_bodies [pb=:{pb_rhs} : bodies] ca + # (pb_rhs, rhs_fun_defs, ca) = collectFunctions pb_rhs ca + (bodies, body_fun_defs, ca) = collect_local_definitions_in_bodies bodies ca + = ([ { pb & pb_rhs = pb_rhs } : bodies], rhs_fun_defs ++ body_fun_defs, ca) + collect_local_definitions_in_bodies [] ca + = ([], [], ca) + +reorganizeLocalDefinitionsOfFunctions [] ca + = ([], [], ca) +reorganizeLocalDefinitionsOfFunctions [fun_def : fun_defs] ca + # (fun_def, rhs_fun_defs, ca) = reorganizeLocalDefinitionsOfFunction fun_def ca + (fun_defs, rhss_fun_defs, ca) = reorganizeLocalDefinitionsOfFunctions fun_defs ca + = ([fun_def : fun_defs], rhs_fun_defs ++ rhss_fun_defs, ca) + + +MakeNewFunction name arity body kind prio opt_type pos + :== { fun_symb = name, fun_arity = arity, fun_priority = prio, fun_type = opt_type, fun_kind = kind, + fun_body = ParsedBody body, fun_pos = pos, fun_lifted = 0, fun_index = NoIndex, fun_info = EmptyFunInfo } + +collectFunctionBodies :: !Ident !Int !Priority !FunKind ![ParsedDefinition] !*CollectAdmin + -> (![ParsedBody], !FunKind, ![ParsedDefinition], !*CollectAdmin) +collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Function pos name is_infix args rhs new_fun_kind : defs] ca + | belongsToTypeSpec fun_name fun_prio name is_infix + # (new_fun_kind, ca) = combine_fun_kinds pos fun_kind new_fun_kind ca + (bodies, new_fun_kind, rest_defs, ca) = collectFunctionBodies fun_name fun_arity fun_prio new_fun_kind defs ca + act_arity = length args + | fun_arity == act_arity + = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, ca) + = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, + postParseError pos ("This alternative has " + toString act_arity + + (if (act_arity == 1)" argument instead of " " arguments instead of ") + toString fun_arity + ) ca + ) + = ([], fun_kind, all_defs, ca) + where + combine_fun_kinds pos FK_Unknown fun_kind ca + = (fun_kind, ca) + combine_fun_kinds pos fun_kind new_fun_kind ca + | fun_kind == new_fun_kind + = (fun_kind, ca) + = (fun_kind, postParseError pos "illegal combination of function alternatives" ca) +collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca + = ([], fun_kind, defs, ca) + +reorganizeDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_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) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : 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) +reorganizeDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] cons_count sel_count mem_count ca + = case defs of + [PD_Function pos name is_infix args rhs fun_kind : defs] + | fun_name <> name + -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos ("function alternative for "+++fun_name.id_name+++" expected") ca) + | not (sameFixity prio is_infix) + -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "infix of type specification and alternative should match" ca) + // | 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) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : 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) + // -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function body expected (1)" ca) + _ + -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function alternative expected (2)" ca) +// ... PK +reorganizeDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_arity}) specials : defs] cons_count sel_count mem_count ca + # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca + (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_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 = MakeNewFunction name fun_type.st_arity bodies fun_kind prio (Yes fun_type) pos + | icl_module + = ([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) +reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs} : defs] cons_count sel_count mem_count ca + # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count + (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + type_def = { type_def & td_rhs = AlgType cons_symbs } + c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = cons_defs ++ c_defs.def_constructors } + = (fun_defs, c_defs, imports, imported_objects, ca) +where + determine_symbols_of_conses [{pc_cons_name,pc_cons_arity} : conses] next_cons_index + # cons = { ds_ident = pc_cons_name, ds_arity = pc_cons_arity, ds_index = next_cons_index } + (conses, next_cons_index) = determine_symbols_of_conses conses (inc next_cons_index) + = ([cons : conses], next_cons_index) + determine_symbols_of_conses [] next_cons_index + = ([], next_cons_index) +reorganizeDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorList rec_cons_id exivars sel_defs, td_pos } : defs] cons_count sel_count mem_count ca + # (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count + (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs (inc cons_count) new_count mem_count ca + cons_arity = new_count - sel_count + cons_def = { pc_cons_name = rec_cons_id, pc_cons_prio = NoPrio, pc_cons_arity = cons_arity, pc_cons_pos = td_pos, + pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars } + type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = td_name, ds_arity = cons_arity, ds_index = cons_count }, + rt_fields = { sel \\ sel <- sel_syms }}} + c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [cons_def : c_defs.def_constructors], + def_selectors = sel_defs ++ c_defs.def_selectors } + = (fun_defs, c_defs, imports, imported_objects, ca) +where + determine_symbols_of_selectors [{ps_field_name,ps_field_var} : sels] next_selector_index + # field = { fs_name = ps_field_name, fs_var = ps_field_var, fs_index = next_selector_index } + (fields, next_selector_index) = determine_symbols_of_selectors sels (inc next_selector_index) + = ([field : fields], next_selector_index) + determine_symbols_of_selectors [] next_selector_index + = ([], next_selector_index) + +reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = TypeSpec type} : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count 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) +reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs properties} : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count 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) +reorganizeDefinitions icl_module [PD_Class class_def=:{class_name,class_arity,class_args} members : defs] cons_count sel_count mem_count ca + # type_context = { tc_class = {glob_module = NoIndex, glob_object = {ds_ident = class_name, 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) = reorganize_member_defs mem_defs mem_count + (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count (mem_count + class_size) 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) +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 + # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca + | isEmpty bodies + # mem_def = { me_symb = name, me_type = { type & st_context = [type_context : st_context ]}, me_pos = pos, me_priority = prio, + me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr } + ( mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca + = ([mem_def : mem_defs], mem_macros, ca) + # macro = MakeNewFunction name st_arity bodies FK_Macro prio opt_type pos + (mem_defs, mem_macros,ca) = check_symbols_of_class_members defs type_context ca + = (mem_defs, [macro : mem_macros], ca) + check_symbols_of_class_members [PD_TypeSpec fun_pos fun_name prio No specials : defs] type_context ca + = case defs of + [PD_Function pos name is_infix args rhs fun_kind : defs] + | 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 + (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca + macro = MakeNewFunction name fun_arity bodies FK_Macro prio No pos + -> (mem_defs, [macro : mem_macros], ca) + -> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca) + _ + -> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca) + check_symbols_of_class_members [PD_Function fun_pos name is_infix args rhs fun_kind : defs] type_context 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 + (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca + macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] FK_Macro prio No fun_pos + = (mem_defs, [macro : mem_macros], ca) + check_symbols_of_class_members [] type_context ca + = ([], [], ca) + + reorganize_member_defs mem_defs first_mem_index + # mem_defs = sort mem_defs + = determine_indexes_of_class_members mem_defs first_mem_index 0 + + determine_indexes_of_class_members [member=:{me_symb,me_type}:members] first_mem_index mem_offset + #! (member_symbols, member_defs, last_mem_offset) = determine_indexes_of_class_members members first_mem_index (inc mem_offset) + = ([{ds_ident = me_symb, ds_index = first_mem_index + mem_offset, ds_arity = me_type.st_arity } : member_symbols], + [ { member & me_offset = mem_offset } : member_defs], last_mem_offset) + determine_indexes_of_class_members [] first_mem_index last_mem_offset + = ([], [], last_mem_offset) + + +reorganizeDefinitions icl_module [PD_Instance class_instance=:{pi_members,pi_pos} : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_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, + postParseError pi_pos "instance specifications of members not allowed" ca) +where + collect_member_instances [PD_Function pos name is_infix args rhs fun_kind : defs] ca + # fun_arity = length args + prio = if is_infix (Prio NoAssoc 9) NoPrio + (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca + (fun_defs, ca) = collect_member_instances defs ca + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos + = ([ fun : fun_defs ], ca) + collect_member_instances [PD_TypeSpec fun_pos fun_name prio type specials : defs] ca + = case defs of + [PD_Function pos name is_infix args rhs fun_kind : defs] + | belongsToTypeSpec fun_name prio name is_infix + # (fun_arity, ca) = determineArity args type pos ca + (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca + (fun_defs, ca) = collect_member_instances defs ca + fun = MakeNewFunction name fun_arity [ { pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio type pos + -> ([ fun : fun_defs ], ca) + _ + -> collect_member_instances defs (postParseError fun_pos "function body expected" ca) + collect_member_instances [] ca + = ([], ca) +reorganizeDefinitions icl_module [PD_Instances class_instances : defs] cons_count sel_count mem_count ca + = reorganizeDefinitions icl_module ([PD_Instance class_instance \\ class_instance <- class_instances] ++ defs) cons_count sel_count mem_count ca +reorganizeDefinitions icl_module [PD_Import new_imports : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + = (fun_defs, c_defs, new_imports ++ imports, imported_objects, ca) +// RWS ... +reorganizeDefinitions icl_module [PD_ImportedObjects new_imported_objects : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + = (fun_defs, c_defs, imports, new_imported_objects ++ imported_objects, ca) +// ... RWS +reorganizeDefinitions icl_module [def:defs] _ _ _ ca + = abort ("reorganizeDefinitions does not match" ---> def) + +reorganizeDefinitions icl_module [] _ _ _ ca + = ([], { def_types = [], def_constructors = [], def_selectors = [], def_macros = [], def_classes = [], def_members = [], + def_instances = [], def_funtypes = [] }, [], [], ca) + +checkRhsOfNodeDef pos { rhs_alts = UnGuardedExpr {ewl_expr,ewl_nodes = [],ewl_locals = LocalParsedDefs []}, rhs_locals = LocalParsedDefs []} ca + = (ewl_expr, ca) +checkRhsOfNodeDef pos rhs ca + = (PE_Empty, postParseError pos "illegal node definition" ca) + +reorganizeLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca + # (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca + = (fun_defs, [(No, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals }) : node_defs], ca) +// = (fun_defs, [(No, { bind_dst = pattern, bind_src = rhs_expr }) : node_defs], ca) +reorganizeLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] 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, node_defs, ca) = reorganizeLocalDefinitions defs ca + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos + = ([ fun : fun_defs ], node_defs, ca) +reorganizeLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca + = case defs of + [PD_Function pos name is_infix args rhs fun_kind : defs] + | belongsToTypeSpec name1 prio name is_infix + # (fun_arity, ca) = determineArity args type pos ca + # (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca + (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio type pos + -> ([fun : fun_defs], node_defs, ca) + -> reorganizeLocalDefinitions defs (postParseError pos "function body expected" ca) + [PD_NodeDef pos pattern=:(PE_Ident id) {rhs_alts,rhs_locals} : defs] + | belongsToTypeSpec name1 prio id False + # (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca +// (rhs_expr, ca) = checkRhsOfNodeDef pos rhs ca + -> (fun_defs, [(type, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals }) : node_defs], ca) +// -> (fun_defs, [(type, { bind_dst = pattern, bind_src = rhs_expr }) : node_defs], ca) + -> reorganizeLocalDefinitions defs (postParseError pos "function body expected" ca) + _ + -> reorganizeLocalDefinitions defs (postParseError pos1 "function body expected" ca) +reorganizeLocalDefinitions [] ca + = ([], [], ca) + + +belongsToTypeSpec name prio new_name is_infix :== + name == new_name && sameFixity prio is_infix + +determineArity args (Yes {st_arity}) pos ca + # arity = length args + | arity == st_arity + = (arity, ca) +determineArity args No pos ca + = (length args, ca) + +sameFixity (Prio _ _) is_infix = is_infix +sameFixity NoPrio is_infix = not is_infix + + + diff --git a/frontend/predef.dcl b/frontend/predef.dcl new file mode 100644 index 0000000..585a764 --- /dev/null +++ b/frontend/predef.dcl @@ -0,0 +1,90 @@ +definition module predef + + +import syntax, hashtable + +:: PredefinedSymbols :== {# PredefinedSymbol} + +:: PredefinedSymbol = + { pds_ident :: !Ident + , pds_module :: !Index + , pds_def :: !Index + } + +/* identifiers not present the hastable */ + + + +PD_PredefinedModule :== 0 + +PD_StringType :== 1 +PD_ListType :== 2 +PD_Arity2TupleType :== 3 +PD_Arity32TupleType :== 33 + +PD_LazyArrayType :== 34 +PD_StrictArrayType :== 35 +PD_UnboxedArrayType :== 36 + +PD_ConsSymbol :== 37 +PD_NilSymbol :== 38 +PD_Arity2TupleSymbol :== 39 +PD_Arity32TupleSymbol :== 69 + +PD_TypeVar_a0 :== 70 +PD_TypeVar_a31 :== 101 + +PD_TypeCodeMember :== 123 + +/* identifiers present in the hastable */ + +PD_StdArray :== 102 +PD_StdEnum :== 103 +PD_StdBool :== 104 + +PD_AndOp :== 105 +PD_OrOp :== 106 + + +/* Array functions */ + +PD_ArrayClass :== 107 + +PD_CreateArrayFun :== 108 +PD__CreateArrayFun :== 109 +PD_ArraySelectFun :== 110 +PD_UnqArraySelectFun :== 111 +PD_ArrayUpdateFun :== 112 +PD_ArrayReplaceFun :== 113 +PD_ArraySizeFun :== 114 +PD_UnqArraySizeFun :== 115 + +/* Enum/Comprehension functions */ + +PD_SmallerFun :== 116 +PD_IncFun :== 117 +PD_From :== 118 +PD_FromThen :== 119 +PD_FromTo :== 120 +PD_FromThenTo :== 121 + +/* Dynamics */ + +PD_TypeCodeClass :== 122 + +PD_TypeObjectType :== 124 +PD_TypeConsSymbol :== 125 +PD_unify :== 126 +PD_variablePlaceholder :== 127 +PD_StdDynamics :== 128 +PD_undo_indirections :== 129 + +PD_NrOfPredefSymbols :== 130 + + +GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 +GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2 + +buildPredefinedSymbols :: !*HashTable -> (!.PredefinedSymbols,!*HashTable) + +buildPredefinedModule :: !*PredefinedSymbols -> (!ScannedModule, !.PredefinedSymbols) diff --git a/frontend/predef.icl b/frontend/predef.icl new file mode 100644 index 0000000..403233e --- /dev/null +++ b/frontend/predef.icl @@ -0,0 +1,272 @@ +implementation module predef + +import syntax, hashtable + +:: PredefinedSymbols :== {# PredefinedSymbol} + +:: PredefinedSymbol = + { pds_ident :: !Ident + , pds_module :: !Index + , pds_def :: !Index + } + +/* identifiers not present the hastable */ + + +PD_PredefinedModule :== 0 + +PD_StringType :== 1 +PD_ListType :== 2 +PD_Arity2TupleType :== 3 +PD_Arity32TupleType :== 33 + +PD_LazyArrayType :== 34 +PD_StrictArrayType :== 35 +PD_UnboxedArrayType :== 36 + +PD_ConsSymbol :== 37 +PD_NilSymbol :== 38 +PD_Arity2TupleSymbol :== 39 +PD_Arity32TupleSymbol :== 69 + +PD_TypeVar_a0 :== 70 +PD_TypeVar_a31 :== 101 + +PD_TypeCodeMember :== 123 + +/* identifiers present in the hastable */ + +PD_StdArray :== 102 +PD_StdEnum :== 103 +PD_StdBool :== 104 + +PD_AndOp :== 105 +PD_OrOp :== 106 + + +/* Array functions */ + +PD_ArrayClass :== 107 + +PD_CreateArrayFun :== 108 +PD__CreateArrayFun :== 109 +PD_ArraySelectFun :== 110 +PD_UnqArraySelectFun :== 111 +PD_ArrayUpdateFun :== 112 +PD_ArrayReplaceFun :== 113 +PD_ArraySizeFun :== 114 +PD_UnqArraySizeFun :== 115 + +/* Enum/Comprehension functions */ + +PD_SmallerFun :== 116 +PD_IncFun :== 117 +PD_From :== 118 +PD_FromThen :== 119 +PD_FromTo :== 120 +PD_FromThenTo :== 121 + +/* Dynamics */ + +PD_TypeCodeClass :== 122 + +PD_TypeObjectType :== 124 +PD_TypeConsSymbol :== 125 +PD_unify :== 126 +PD_variablePlaceholder :== 127 +PD_StdDynamics :== 128 +PD_undo_indirections :== 129 + +PD_NrOfPredefSymbols :== 130 + + +(<<=) infixl +(<<=) state val + :== let (array, symbol_table) = state + (name, index) = val + (id_info, new_symbol_table) = newPtr EmptySymbolTableEntry symbol_table + in ({ array & [index] = { pds_ident = { id_name = name, id_info = id_info }, pds_module = NoIndex, pds_def = NoIndex } }, new_symbol_table) + +(<<-) infixl +(<<-) (array, hash_table) (name, table_kind, index) + # (id, hash_table) = putIdentInHashTable name table_kind hash_table + = ({ array & [index] = { pds_ident = id, pds_module = NoIndex, pds_def = NoIndex } }, hash_table) + +GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 +GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2 + +buildPredefinedSymbols :: !*HashTable -> (!.PredefinedSymbols,!*HashTable) +buildPredefinedSymbols hash_table=:{hte_symbol_heap} + # predef_symbol_table = createArray PD_NrOfPredefSymbols { pds_ident = { id_name = "", id_info = nilPtr }, pds_module = NoIndex, pds_def = NoIndex } + (predef_symbol_table, hte_symbol_heap) = fill_table_without_hashing (predef_symbol_table, hte_symbol_heap) + = fill_table_with_hashing (predef_symbol_table, { hash_table & hte_symbol_heap = hte_symbol_heap }) +where + fill_table_without_hashing tables + = build_variables 0 32 (build_tuples 2 32 tables) + <<= ("_predefined", PD_PredefinedModule) + <<= ("_string", PD_StringType) + <<= ("_list", PD_ListType) <<= ("_cons", PD_ConsSymbol) <<= ("_nil", PD_NilSymbol) + <<= ("_array", PD_LazyArrayType) <<= ("_!array", PD_StrictArrayType) <<= ("_#array", PD_UnboxedArrayType) + <<= ("_type_code", PD_TypeCodeMember) + where + + build_tuples tup_arity max_arity tables + | tup_arity > max_arity + = tables + # tup_name = "_tuple" +++ toString tup_arity + = build_tuples (inc tup_arity) max_arity (tables <<= (tup_name, GetTupleTypeIndex tup_arity) + <<= (tup_name, GetTupleConsIndex tup_arity)) + + build_variables var_number max_arity tables + | var_number == max_arity + = tables + # var_name = "a" +++ toString var_number + = build_variables (inc var_number) max_arity (tables <<= (var_name, PD_TypeVar_a0 + var_number)) + + fill_table_with_hashing tables + = tables <<- ("StdArray", IC_Module, PD_StdArray) <<- ("StdEnum", IC_Module, PD_StdEnum) <<- ("StdBool", IC_Module, PD_StdBool) + <<- ("&&", IC_Expression, PD_AndOp) <<- ("||", IC_Expression, PD_OrOp) + <<- ("Array", IC_Class, PD_ArrayClass) + <<- ("createArray", IC_Expression, PD_CreateArrayFun) + <<- ("_createArray", IC_Expression, PD__CreateArrayFun) + <<- ("select", IC_Expression, PD_ArraySelectFun) + <<- ("uselect", IC_Expression, PD_UnqArraySelectFun) <<- ("update", IC_Expression, PD_ArrayUpdateFun) + <<- ("replace", IC_Expression, PD_ArrayReplaceFun) <<- ("size", IC_Expression, PD_ArraySizeFun) + <<- ("usize", IC_Expression, PD_UnqArraySizeFun) + <<- ("_smaller", IC_Expression, PD_SmallerFun) <<- ("_inc", IC_Expression, PD_IncFun) + <<- ("_from", IC_Expression, PD_From) <<- ("_from_then", IC_Expression, PD_FromThen) + <<- ("_from_to", IC_Expression, PD_FromTo) <<- ("_from_then_to", IC_Expression, PD_FromThenTo) + + <<- ("TC", IC_Class, PD_TypeCodeClass) + <<- ("T_ypeObjectType", IC_Type, PD_TypeObjectType) + <<- ("T_ypeConsSymbol", IC_Expression, PD_TypeConsSymbol) + <<- ("P_laceholder", IC_Expression, PD_variablePlaceholder) + <<- ("_unify", IC_Expression, PD_unify) + <<- ("StdDynamics", IC_Module, PD_StdDynamics) + <<- ("_undo_indirections", IC_Expression, PD_undo_indirections) + + +MakeTupleConsSymbIndex arity :== arity - 2 + cArity2TupleConsSymbIndex +MakeTupleTypeSymbIndex arity :== arity - 2 + cArity2TupleTypeSymbIndex + +MakeNilExpression pre_def_symbols :== PE_List [PE_Ident pre_def_symbols.[PD_NilSymbol]] +MakeConsExpression a1 a2 pre_def_symbols :== PE_List [PE_Ident pre_def_symbols.[PD_ConsSymbol], a1, a2] + +MaxTupleArity :== 32 + +cLazyArray :== 0 +cStrictArray :== 1 +cUnboxedArray :== 2 + +cConsSymbIndex :== 0 +cNilSymbIndex :== 1 +cArity2TupleConsSymbIndex :== 2 +//Arity32TupleConsSymbIndex :== 32 + +cListTypeSymbIndex :== 0 +cArity2TupleTypeSymbIndex :== 1 +//Arity32TupleTypeSymbIndex :== 31 +cLazyArraySymbIndex :== 32 +cStrictArraySymbIndex :== 33 +cUnboxedArraySymbIndex :== 34 + +cLastPredefinedConstructor :== 32 +cLastPredefinedType :== 34 + +cTCClassSymbIndex :== 0 + +cTCMemberSymbIndex :== 0 + +cTCInstanceSymbIndex :== 0 + + +buildPredefinedModule :: !*PredefinedSymbols -> (!ScannedModule, !.PredefinedSymbols) +buildPredefinedModule pre_def_symbols + # (type_var_id, pre_def_symbols) = pre_def_symbols![PD_TypeVar_a0] + (cons_id, pre_def_symbols) = pre_def_symbols![PD_ConsSymbol] + (nil_id, pre_def_symbols) = pre_def_symbols![PD_NilSymbol] + (string_id, pre_def_symbols) = pre_def_symbols![PD_StringType] + (list_id, pre_def_symbols) = pre_def_symbols![PD_ListType] + (unb_array_id, pre_def_symbols) = pre_def_symbols![PD_UnboxedArrayType] + (pre_mod_symb, pre_def_symbols) = pre_def_symbols![PD_PredefinedModule] + (cons_symb, pre_def_symbols) = new_defined_symbol PD_ConsSymbol 2 cConsSymbIndex pre_def_symbols + (nil_symb, pre_def_symbols) = new_defined_symbol PD_NilSymbol 0 cNilSymbIndex pre_def_symbols + pre_mod_id = pre_mod_symb.pds_ident + + type_var = MakeTypeVar type_var_id.pds_ident + type_var_with_attr = MakeAttributedType (TV type_var) + list_type = MakeAttributedType (TA (MakeNewTypeSymbIdent list_id.pds_ident 1) [type_var_with_attr]) + unb_arr_of_char_type = MakeAttributedType (TA (MakeNewTypeSymbIdent unb_array_id.pds_ident 1) [MakeAttributedType (TB BT_Char)]) + + (string_def, pre_def_symbols) = make_type_def PD_StringType [] (SynType unb_arr_of_char_type) pre_def_symbols + (list_def, pre_def_symbols) = make_type_def PD_ListType [type_var] (AlgType [cons_symb,nil_symb]) pre_def_symbols + + cons_def = { pc_cons_name = cons_id.pds_ident, pc_cons_arity = 2, pc_arg_types = [type_var_with_attr, list_type], + pc_cons_prio = NoPrio, pc_exi_vars = [], pc_cons_pos = PreDefPos pre_mod_id} + nil_def = { pc_cons_name = nil_id.pds_ident, pc_cons_arity = 0, pc_arg_types = [], + pc_cons_prio = NoPrio, pc_exi_vars = [], pc_cons_pos = PreDefPos pre_mod_id} + + (array_def, pre_def_symbols) = make_type_def PD_LazyArrayType [type_var] (AbstractType cAllBitsClear) pre_def_symbols + (strict_def, pre_def_symbols) = make_type_def PD_StrictArrayType [type_var] (AbstractType cIsHyperStrict) pre_def_symbols + (unboxed_def, pre_def_symbols) = make_type_def PD_UnboxedArrayType [type_var] (AbstractType cIsHyperStrict) pre_def_symbols + + (type_defs, cons_defs, pre_def_symbols) = add_tuple_defs pre_mod_id MaxTupleArity [array_def,strict_def,unboxed_def] [] pre_def_symbols + (class_def, member_def, pre_def_symbols) = make_TC_class_def pre_def_symbols + = ({ mod_name = pre_mod_id, mod_type = MK_System, mod_imports = [], mod_imported_objects = [], + mod_defs = { + def_types = [string_def, list_def : type_defs], def_constructors = [cons_def, nil_def : cons_defs], def_selectors = [], def_classes = [class_def], + def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], def_funtypes = [], def_instances = [] }}, pre_def_symbols) +where + add_tuple_defs pre_mod_id tup_arity type_defs cons_defs pre_def_symbols + | tup_arity >= 2 + # (type_vars, pre_def_symbols) = make_type_vars tup_arity [] pre_def_symbols + (tuple_id, pre_def_symbols) = pre_def_symbols![GetTupleConsIndex tup_arity] + tuple_cons_symb = { ds_ident = tuple_id.pds_ident, ds_index = MakeTupleConsSymbIndex tup_arity, ds_arity = tup_arity } + + (tuple_type_def, pre_def_symbols) = make_type_def (GetTupleTypeIndex tup_arity) type_vars (AlgType [tuple_cons_symb]) pre_def_symbols + tuple_cons_def = { pc_cons_name = tuple_id.pds_ident, pc_cons_arity = tup_arity, pc_cons_pos = PreDefPos pre_mod_id, + pc_arg_types = [ MakeAttributedType (TV tv) \\ tv <- type_vars], pc_cons_prio = NoPrio, pc_exi_vars = []} + = add_tuple_defs pre_mod_id (dec tup_arity) [tuple_type_def : type_defs] [tuple_cons_def : cons_defs] pre_def_symbols + = (type_defs, cons_defs, pre_def_symbols) + where + make_type_vars nr_of_vars type_vars pre_def_symbols + | nr_of_vars == 0 + = (type_vars, pre_def_symbols) + # nr_of_vars = dec nr_of_vars + #! var_id = pre_def_symbols.[PD_TypeVar_a0 + nr_of_vars] + = make_type_vars nr_of_vars [MakeTypeVar var_id.pds_ident : type_vars] pre_def_symbols + + new_defined_symbol symbol_index arity ds_index pre_def_symbols + #! ds_ident = pre_def_symbols.[symbol_index] + = ({ ds_ident = ds_ident.pds_ident, ds_arity = 2, ds_index = ds_index }, pre_def_symbols) + + make_type_def type_cons_index type_vars type_rhs pre_def_symbols + #! type_ident = pre_def_symbols.[type_cons_index] + = (MakeTypeDef type_ident.pds_ident (map (\tv -> MakeAttributedTypeVar tv) type_vars) type_rhs TA_None [] NoPos, pre_def_symbols) + + make_TC_class_def pre_def_symbols + # (tc_class_name, pre_def_symbols) = pre_def_symbols![PD_TypeCodeClass] + (type_var_id, pre_def_symbols) = pre_def_symbols![PD_TypeVar_a0] + (tc_member_name, pre_def_symbols) = pre_def_symbols![PD_TypeCodeMember] + + class_var = MakeTypeVar type_var_id.pds_ident + + me_type = { st_vars = [], st_args = [], st_arity = 0, + st_result = { at_attribute = TA_None, at_annotation = AN_None, at_type = TV class_var }, + st_context = [ {tc_class = {glob_module = NoIndex, glob_object = {ds_ident = tc_class_name.pds_ident, ds_arity = 1, ds_index = NoIndex }}, + tc_types = [ TV class_var ], tc_var = nilPtr }], + st_attr_vars = [], st_attr_env = [] } + + member_def = { me_symb = tc_member_name.pds_ident, me_type = me_type, me_pos = NoPos, me_priority = NoPrio, + me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr } + + class_def = { class_name = tc_class_name.pds_ident, class_arity = 1, class_args = [class_var], class_context = [], + class_members = {{ds_ident = tc_member_name.pds_ident, ds_index = cTCMemberSymbIndex, ds_arity = 0 }}, class_cons_vars = 0, + class_dictionary = { ds_ident = { tc_class_name.pds_ident & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, class_pos = NoPos } + + = (class_def, member_def, pre_def_symbols) + + + + + diff --git a/frontend/refmark.dcl b/frontend/refmark.dcl new file mode 100644 index 0000000..0b8a1a3 --- /dev/null +++ b/frontend/refmark.dcl @@ -0,0 +1,6 @@ +definition module refmark + +import syntax, checksupport, unitype + +makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !{# CommonDefs } !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) diff --git a/frontend/refmark.icl b/frontend/refmark.icl new file mode 100644 index 0000000..9b54103 --- /dev/null +++ b/frontend/refmark.icl @@ -0,0 +1,591 @@ +implementation module refmark + +import StdEnv +import syntax, Heap, typesupport, check, overloading, unitype, utilities, RWSDebug + + +NotASelector :== -1 + +class refMark expr :: ![[FreeVar]] !Int !expr !*VarHeap -> *VarHeap + + +instance refMark [a] | refMark a +where + refMark free_vars sel list var_heap + = foldSt (refMark free_vars sel) list var_heap + +collectAllSelections [] cum_sels + = cum_sels +collectAllSelections [{su_multiply,su_uniquely} : sels ] cum_sels + = collectAllSelections sels (su_uniquely ++ su_multiply ++ cum_sels) + +addSelection var_expr_ptr sel [] + = [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] } ] +addSelection var_expr_ptr sel sels=:[selection=:{ su_field,su_multiply,su_uniquely } : selections] + | sel == su_field + = [ { selection & su_multiply = su_multiply ++ [var_expr_ptr : su_multiply], su_uniquely = [] } : selections ] + | sel < su_field + = [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] } : sels ] + = [ selection : addSelection var_expr_ptr sel selections ] + +saveOccurrences free_vars var_heap + = foldSt (foldSt save_occurrence) free_vars var_heap +where + save_occurrence {fv_name,fv_info_ptr} var_heap + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap + = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = RC_Unused, occ_previous = [occ_ref_count : occ_previous] } ) + + +adjustRefCount sel RC_Unused var_expr_ptr + | sel == NotASelector + = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [var_expr_ptr] } + # sel_ref = { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] } + = RC_Used {rcu_multiply = [], rcu_selectively = [{ su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] }], rcu_uniquely = [] } +adjustRefCount sel (RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}) var_expr_ptr + | sel == NotASelector + # rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]) + = RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] } + # rcu_selectively = addSelection var_expr_ptr sel rcu_selectively + rcu_multiply = rcu_uniquely ++ rcu_multiply + = RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = rcu_selectively } + +markPatternVariables sel used_pattern_vars var_heap + | sel == NotASelector + = foldSt mark_variable [ fv \\ (fv,_) <- used_pattern_vars ] var_heap + = mark_pattern_variable sel used_pattern_vars var_heap +where + mark_pattern_variable sel [] var_heap + = var_heap + mark_pattern_variable sel [(fv, var_number) : used_pattern_vars ] var_heap + | sel == var_number + = mark_variable fv var_heap + = mark_pattern_variable sel used_pattern_vars var_heap + + mark_variable {fv_info_ptr} var_heap + # (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap + = case occ_ref_count of + RC_Unused + # occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [nilPtr] } + -> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } ) + RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively} + # occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply), + rcu_selectively = [], rcu_uniquely = [] } + -> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } ) + + +instance refMark BoundVar +where + refMark free_vars sel {var_name,var_expr_ptr,var_info_ptr} var_heap + # (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap + occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr + = case var_occ.occ_bind of + OB_OpenLet let_expr + # var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr }) + -> refMark free_vars sel let_expr var_heap + OB_Pattern used_pattern_vars occ_bind + -> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })) + _ + -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }) + +instance refMark Expression +where + refMark free_vars sel (Var var) var_heap + = refMark free_vars sel var var_heap + refMark free_vars sel (App {app_args}) var_heap + = refMark free_vars NotASelector app_args var_heap + refMark free_vars sel (fun @ args) var_heap + = refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap) + refMark free_vars sel (Let {let_strict,let_binds,let_expr}) var_heap + # let_vars = [ bind_dst \\ {bind_dst} <- let_binds ] + new_free_vars = [ let_vars : free_vars] + | let_strict + # (observing, var_heap) = binds_are_observing let_binds var_heap + | observing + # var_heap = saveOccurrences free_vars var_heap + var_heap = refMark new_free_vars NotASelector let_binds var_heap + var_heap = saveOccurrences new_free_vars var_heap + var_heap = refMark new_free_vars sel let_expr var_heap + = let_combine free_vars var_heap + = refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_binds var_heap) + # var_heap = foldSt bind_variable let_binds var_heap + = refMark new_free_vars sel let_expr var_heap + + where + binds_are_observing binds var_heap + = foldr bind_is_observing (True, var_heap) binds + where + bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) + #! info = sreadPtr fv_info_ptr var_heap + # (VI_Occurrence {occ_observing}) = info + = (occ_observing && observe, var_heap) + + let_combine free_vars var_heap + = foldSt (foldSt let_combine_ref_count) free_vars var_heap + where + let_combine_ref_count {fv_info_ptr} var_heap + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count, pre_pref_recount:occ_previouses]}, var_heap) + = readPtr fv_info_ptr var_heap + comb_ref_count = parCombineRefCount (seqCombineRefCount prev_ref_count occ_ref_count) pre_pref_recount + = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses }) + + bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap + # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap + = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src }) + + refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap + = refMarkOfCase free_vars sel case_expr case_guards case_default var_heap + refMark free_vars sel (Selection _ expr selectors) var_heap + = refMark free_vars (field_number selectors) expr var_heap + where + field_number [ RecordSelection _ field_nr : _ ] + = field_nr + field_number _ + = NotASelector + refMark free_vars sel (Update expr1 selectors expr2) var_heap + = refMark free_vars NotASelector expr2 (refMark free_vars NotASelector expr1 var_heap) + refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap + = ref_mark_of_record_expression free_vars expression expressions var_heap + where + ref_mark_of_record_expression free_vars (Var var) fields var_heap + = ref_mark_of_fields 0 free_vars fields var var_heap + ref_mark_of_record_expression free_vars expression fields var_heap + # var_heap = refMark free_vars NotASelector expression var_heap + = foldSt (ref_mark_of_field free_vars) fields var_heap + + ref_mark_of_fields field_nr free_vars [] var var_heap + = var_heap + ref_mark_of_fields field_nr free_vars [{bind_src = EE} : fields] var var_heap + # var_heap = refMark free_vars field_nr var var_heap + = ref_mark_of_fields (inc field_nr) free_vars fields var var_heap + ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var var_heap + # var_heap = refMark free_vars NotASelector bind_src var_heap + = ref_mark_of_fields (inc field_nr) free_vars fields var var_heap + + ref_mark_of_field free_vars {bind_src} var_heap + = refMark free_vars NotASelector bind_src var_heap + + refMark free_vars sel (TupleSelect _ arg_nr expr) var_heap + = refMark free_vars arg_nr expr var_heap + refMark free_vars sel (MatchExpr _ _ expr) var_heap + = refMark free_vars sel expr var_heap + refMark free_vars sel EE var_heap + = var_heap + refMark _ _ _ var_heap + = var_heap + + +isUsed RC_Unused = False +isUsed _ = True + +instance refMark Bind a b | refMark a +where + refMark free_vars sel {bind_src} var_heap + = refMark free_vars NotASelector bind_src var_heap + +instance refMark Selection +where + refMark free_vars _ (ArraySelection _ _ index_expr) var_heap + = refMark free_vars NotASelector index_expr var_heap + +collectUsedFreeVariables free_vars var_heap + = foldSt collectUsedVariables free_vars ([], var_heap) + +collectUsedVariables free_vars (collected_vars, var_heap) + = foldSt collect_used_var free_vars (collected_vars, var_heap) +where + collect_used_var fv=:{fv_info_ptr} (collected_vars, var_heap) + # (VI_Occurrence occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap + | isUsed occ_ref_count + = ([ fv : collected_vars ], var_heap) + = (collected_vars, var_heap) + +collectPatternsVariables pattern_vars + = collect_used_vars pattern_vars 0 [] +where + collect_used_vars [ fv=:{fv_count} : pattern_vars ] arg_nr collected_vars + | fv_count > 0 + = collect_used_vars pattern_vars (inc arg_nr) [ (fv, arg_nr) : collected_vars ] + = collect_used_vars pattern_vars (inc arg_nr) collected_vars + collect_used_vars [] arg_nr collected_vars + = collected_vars + +markVariables variables var_heap + = foldSt markVariable variables var_heap + +markVariable {fv_name,fv_info_ptr} var_heap + # (VI_Occurrence var_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap + = case occ_ref_count of + RC_Unused + -> var_heap + RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively} + # rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply) + -> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & + occ_ref_count = RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }}) +// ---> ("markVariable", fv_name, rcu_multiply) + +collectLocalLetVars free_vars var_heap + = foldSt (foldSt collect_local_let_var) free_vars ([], var_heap) +where + collect_local_let_var fv=:{fv_info_ptr} (collected_vars, var_heap) + # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap + = case var_occ.occ_bind of + OB_OpenLet _ + -> ([ fv_info_ptr : collected_vars], var_heap) + _ + -> (collected_vars, var_heap) + +collectUsedLetVars local_vars (used_vars, var_heap) + = foldSt collect_local_let_var local_vars (used_vars, var_heap) +where + collect_local_let_var fv_info_ptr (used_vars, var_heap) + # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap + = case var_occ.occ_bind of + OB_LockedLet let_expr + -> ([ fv_info_ptr : used_vars], var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_OpenLet let_expr })) + _ + -> (used_vars, var_heap) + +setUsedLetVars used_vars var_heap + = foldSt set_used_let_var used_vars var_heap +where + set_used_let_var fv_info_ptr var_heap + # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap + = case var_occ.occ_bind of + OB_OpenLet let_expr + -> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_LockedLet let_expr }) + _ + -> var_heap + +refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) defaul var_heap + = ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap +where + ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns defaul var_heap + # (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap + = case occ_bind of + OB_Empty + # (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + -> ref_mark_of_algebraic_case_with_variable_pattern var_info_ptr var_expr_ptr var_occ free_vars sel local_lets patterns defaul var_heap + _ + -> ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap + ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap + = ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap + + ref_mark_of_algebraic_case_with_variable_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused} + free_vars sel local_lets patterns case_default var_heap + # (_, pattern_depth, used_lets, var_heap) + = foldSt (ref_mark_of_algebraic_pattern free_vars sel (Yes var_info_ptr) local_lets) patterns (False, 0, [], var_heap) + var_heap = refMarkOfDefault False pattern_depth free_vars sel case_default used_lets var_heap + (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap + = case var_occ.occ_ref_count of + RC_Unused + -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & + occ_ref_count = RC_Used { rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = [] }}) + RC_Used rcu + -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & + occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }}) + ref_mark_of_algebraic_case_with_variable_pattern var_info_ptr var_expr_ptr var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} + free_vars sel local_lets patterns case_default var_heap + # var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]), + rcu_uniquely = [], rcu_selectively = [] }} + var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ ) + (with_pattern_bindings, pattern_depth, used_lets, var_heap) + = foldSt (ref_mark_of_algebraic_pattern free_vars sel (Yes var_info_ptr) local_lets) patterns (False, 0, [], var_heap) + = refMarkOfDefault False pattern_depth free_vars sel case_default used_lets var_heap + + ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_default var_heap + # var_heap = refMark free_vars NotASelector expr var_heap + (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + (with_pattern_bindings, pattern_depth, used_lets, var_heap) + = foldSt (ref_mark_of_algebraic_pattern free_vars sel No local_lets) patterns (False, 0, [], var_heap) + = refMarkOfDefault with_pattern_bindings pattern_depth free_vars sel case_default used_lets var_heap + + ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets {ap_vars,ap_expr} + (with_pattern_bindings, pattern_depth, used_lets, var_heap) + # pattern_depth = inc pattern_depth + var_heap = saveOccurrences free_vars var_heap + used_pattern_vars = collectPatternsVariables ap_vars + var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap + var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel ap_expr var_heap + var_heap = restore_bindinding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap + (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) + = (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap) + + bind_optional_pattern_variable _ [] var_heap + = var_heap + bind_optional_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap + # (VI_Occurrence var_occ=:{occ_bind}, var_heap) = readPtr var_info_ptr var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_Pattern used_pattern_vars occ_bind }) + bind_optional_pattern_variable _ used_pattern_vars var_heap + = var_heap + + restore_bindinding_of_pattern_variable _ [] var_heap + = var_heap + restore_bindinding_of_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap + # (VI_Occurrence var_occ=:{occ_bind=OB_Pattern used_pattern_vars occ_bind}, var_heap) = readPtr var_info_ptr var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = occ_bind}) + restore_bindinding_of_pattern_variable _ used_pattern_vars var_heap + = var_heap + +refMarkOfCase free_vars sel expr (BasicPatterns type patterns) defaul var_heap + # var_heap = refMark free_vars NotASelector expr var_heap + (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets) patterns (0, [], var_heap) + = refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap +where + ref_mark_of_basic_pattern free_vars sel local_lets {bp_expr} (pattern_depth, used_lets, var_heap) + # pattern_depth = inc pattern_depth + var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars sel bp_expr var_heap + (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) + = (pattern_depth, used_lets, var_heap) + +refMarkOfCase free_vars sel expr (DynamicPatterns patterns) defaul var_heap + # var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars NotASelector expr var_heap + (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap + var_heap = parCombine free_vars var_heap + (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets) patterns (0, [], var_heap) + = refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap +where + ref_mark_of_dynamic_pattern free_vars sel local_lets {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap) + # pattern_depth = inc pattern_depth + var_heap = saveOccurrences free_vars var_heap + used_pattern_vars = collectPatternsVariables [dp_var] + var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel dp_rhs var_heap + (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) + = (pattern_depth, used_lets, var_heap) + +refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap + # pattern_depth = inc pattern_depth + var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars sel expr var_heap + var_heap = setUsedLetVars used_lets var_heap + = caseCombine do_par_combine free_vars var_heap pattern_depth +refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap + # var_heap = setUsedLetVars used_lets var_heap + = caseCombine do_par_combine free_vars var_heap pattern_depth + +parCombine free_vars var_heap + = foldSt (foldSt (par_combine)) free_vars var_heap +where + par_combine {fv_info_ptr} var_heap + #! old_info = sreadPtr fv_info_ptr var_heap + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count:prev_counts]}) = old_info + = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & + occ_ref_count = parCombineRefCount occ_ref_count prev_ref_count , occ_previous = prev_counts }) + + +caseCombine do_par_combine free_vars var_heap depth + = foldSt (foldSt (case_combine do_par_combine depth)) free_vars var_heap +where + case_combine do_par_combine depth {fv_name,fv_info_ptr} var_heap + #! old_info = sreadPtr fv_info_ptr var_heap + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}) = old_info + (occ_ref_count, occ_previous) = case_combine_ref_counts do_par_combine occ_ref_count occ_previous (dec depth) + = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous }) +// ---> ("case_combine", fv_name, occ_ref_count) + + case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] 0 + | do_par_combine + # new_comb_ref_count = parCombineRefCount comb_ref_count occ_ref_count + = (new_comb_ref_count, occ_previous) + // ---> ("parCombineRefCount", comb_ref_count, occ_ref_count, new_comb_ref_count) + # new_comb_ref_count = seqCombineRefCount comb_ref_count occ_ref_count + = (new_comb_ref_count, occ_previous) + // ---> ("seqCombineRefCount", comb_ref_count, occ_ref_count, new_comb_ref_count) + case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] depth + # new_comb_ref_count = case_combine_ref_count comb_ref_count occ_ref_count + = case_combine_ref_counts do_par_combine new_comb_ref_count occ_previous (dec depth) +// ---> ("case_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count) + + case_combine_ref_count RC_Unused ref_count + = ref_count + case_combine_ref_count ref_count RC_Unused + = ref_count + case_combine_ref_count (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2) + = RC_Used { rcu_uniquely = rcu_uniquely ++ ref_count2.rcu_uniquely, rcu_multiply = rcu_multiply ++ ref_count2.rcu_multiply, + rcu_selectively = case_combine_of_selections rcu_selectively ref_count2.rcu_selectively } + where + case_combine_of_selections [] sels + = sels + case_combine_of_selections sels [] + = sels + case_combine_of_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2] + | su_field == sel2.su_field + # sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply, su_uniquely = sel2.su_uniquely ++ su_uniquely } + = [ sel1 : case_combine_of_selections sels1 sels2 ] + | su_field < sel2.su_field + = [sel1 : case_combine_of_selections sels1 sl2 ] + = [sel2 : case_combine_of_selections sl1 sels2 ] + +parCombineRefCount RC_Unused ref_count + = ref_count +parCombineRefCount ref_count RC_Unused + = ref_count +parCombineRefCount (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2) + # rcu_multiply = ref_count2.rcu_uniquely ++ ref_count2.rcu_multiply ++ rcu_uniquely ++ rcu_multiply + | isEmpty rcu_multiply + = RC_Used { rcu_multiply = [], rcu_uniquely = [], rcu_selectively = par_combine_selections rcu_selectively ref_count2.rcu_selectively } + # rcu_multiply = collectAllSelections ref_count2.rcu_selectively (collectAllSelections rcu_selectively rcu_multiply) + = RC_Used { rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] } +where + par_combine_selections [] sels + = sels + par_combine_selections sels [] + = sels + par_combine_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2] + | su_field == sel2.su_field + # sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply ++ sel2.su_uniquely ++ su_uniquely, su_uniquely = [] } + = [ sel1 : par_combine_selections sels1 sels2 ] + | su_field < sel2.su_field + = [sel1 : par_combine_selections sels1 sl2 ] + = [sel2 : par_combine_selections sl1 sels2 ] + +seqCombineRefCount RC_Unused ref_count + = ref_count +seqCombineRefCount ref_count RC_Unused + = ref_count +seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref) + # rcu_multiply = prim_ref.rcu_uniquely ++ prim_ref.rcu_multiply ++ sec_ref.rcu_multiply + | isEmpty rcu_multiply + | isEmpty sec_ref.rcu_uniquely /* so sec_ref contains selections only */ + # rcu_selectively = seq_combine_selections sec_ref.rcu_selectively prim_ref.rcu_selectively /* rcu_selectively can't be empty */ + = RC_Used { rcu_uniquely = [], rcu_multiply = [], rcu_selectively = rcu_selectively } + # prim_selections = make_primary_selections_on_unique prim_ref.rcu_selectively + rcu_selectively = seq_combine_selections sec_ref.rcu_selectively prim_selections + = RC_Used { sec_ref & rcu_selectively = rcu_selectively } + = RC_Used { sec_ref & rcu_multiply = collectAllSelections prim_ref.rcu_selectively rcu_multiply } + where + seq_combine_selections [] sels + = sels + seq_combine_selections sels [] + = sels + seq_combine_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2] + | su_field == sel2.su_field + # sel1 = { sel1 & su_multiply = sel2.su_multiply ++ sel2.su_uniquely ++ su_multiply } + = [ sel1 : seq_combine_selections sels1 sels2 ] + | su_field < sel2.su_field + = [sel1 : seq_combine_selections sels1 sl2 ] + = [sel2 : seq_combine_selections sl1 sels2 ] + + make_primary_selections_on_unique [sel=:{su_multiply, su_uniquely } : sels] + = [ { sel & su_multiply = su_uniquely ++ su_multiply, su_uniquely = [] } : make_primary_selections_on_unique sels ] + make_primary_selections_on_unique [] + = [] + +makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !{# CommonDefs } !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +makeSharedReferencesNonUnique [] fun_defs coercion_env subst defs var_heap expr_heap error + = (fun_defs, coercion_env, subst, var_heap, expr_heap, error) +makeSharedReferencesNonUnique [fun : funs] fun_defs coercion_env subst defs var_heap expr_heap error + #! fun_def = fun_defs.[fun] + # (coercion_env, subst, var_heap, expr_heap, error) + = make_shared_references_of_funcion_non_unique fun_def coercion_env subst defs var_heap expr_heap error + = makeSharedReferencesNonUnique funs fun_defs coercion_env subst defs var_heap expr_heap error +where + make_shared_references_of_funcion_non_unique {fun_symb, fun_pos, fun_body = TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}} + coercion_env subst defs var_heap expr_heap error + # variables = tb_args ++ fi_local_vars + (subst, var_heap, expr_heap) = clear_occurrences variables subst defs var_heap expr_heap + var_heap = refMark [tb_args] NotASelector tb_rhs var_heap + position = newPosition fun_symb fun_pos + (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap + (setErrorAdmin position error) + = (coercion_env, subst, var_heap, expr_heap, error) + + where + clear_occurrences vars subst defs var_heap expr_heap + = foldSt (initial_occurrence defs) vars (subst, var_heap, expr_heap) + where + initial_occurrence defs {fv_name,fv_info_ptr} (subst, var_heap, expr_heap) + # (VI_Type {at_type,at_attribute}, var_heap) = readPtr fv_info_ptr var_heap + = case at_type of + TempV tv_number + #! is_oberving = hasObservingType subst.[tv_number] defs + -> (subst, var_heap <:= (fv_info_ptr, + VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], + occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap) + _ + -> (subst, var_heap <:= (fv_info_ptr, + VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], + occ_observing = False, occ_bind = OB_Empty }), expr_heap) + + + make_shared_vars_non_unique vars coercion_env var_heap expr_heap error + = foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars + + make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) fv=:{fv_name,fv_info_ptr} + #! var_info = sreadPtr fv_info_ptr var_heap + # (VI_Occurrence occ) = var_info + = case occ.occ_ref_count of + RC_Used {rcu_multiply,rcu_selectively} + # (coercion_env, expr_heap, error) = make_shared_occurrences_non_unique fv rcu_multiply (coercion_env, expr_heap, error) +// (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error) + -> (coercion_env, var_heap, expr_heap, error) + _ + -> (coercion_env, var_heap, expr_heap, error) + + make_shared_occurrences_non_unique fv multiply (coercion_env, expr_heap, error) + = foldSt (make_shared_occurrence_non_unique fv) multiply (coercion_env, expr_heap, error) + + make_shared_occurrence_non_unique free_var var_expr_ptr (coercion_env, expr_heap, error) + | isNilPtr var_expr_ptr + = (coercion_env, expr_heap, error) + #! expr_info = sreadPtr var_expr_ptr expr_heap + # (EI_Attribute sa_attr_nr) = expr_info + # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env + | succ +// ---> ("make_shared_occurrence_non_unique", free_var) + = (coercion_env, expr_heap, error) + = (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error) + + make_selection_non_unique fv {su_multiply} cee + = make_shared_occurrences_non_unique fv su_multiply cee + +hasObservingType TE defs + = True +hasObservingType (TB basic_type) defs + = True +hasObservingType (TempV var_number) defs + = True +hasObservingType (TA {type_index = {glob_object,glob_module}} type_args) defs + # {td_properties} = defs.[glob_module].com_type_defs.[glob_object] + = True +// = foldSt (\ {at_type} ok -> ok && hasObservingType at_type defs) type_args (td_properties bitand cIsHyperStrict <> 0) +hasObservingType type defs + = False + + +instance <<< ReferenceCount +where + (<<<) file RC_Unused = file + (<<<) file (RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}) = file <<< '\n' <<< "M:" <<< rcu_multiply <<< " U:" <<< rcu_uniquely <<< " S:" <<< rcu_selectively + +instance <<< SelectiveUse +where + (<<<) file {su_field,su_multiply,su_uniquely} = file <<< su_field <<< " M:" <<< su_multiply <<< " U:" <<< su_uniquely + + + +instance <<< Ptr v +where + (<<<) file ptr = file <<< '[' <<< ptrToInt ptr <<< ']' + + +instance <<< FreeVar +where + (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< fv_info_ptr + + +import Debug + +show + = debugShowWithOptions [DebugMaxChars 80, DebugMaxDepth 5] + +instance <<< VarInfo +where + (<<<) file vi + = file <<< show vi + + diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl new file mode 100644 index 0000000..79aec04 --- /dev/null +++ b/frontend/scanner.dcl @@ -0,0 +1,155 @@ +definition module scanner + +import StdEnv, general + +:: SearchPaths :== [String] + +:: * ScanState + +:: *Input + +:: * InputStream + +:: LongToken + +:: Buffer x + +:: FilePosition = {fp_line :: !Int, fp_col :: !Int} + +instance <<< FilePosition + +:: Token + = IdentToken !.String // an identifier + | IntToken !.String // an integer + | RealToken !.String // a real + | StringToken !.String // a string + | CharToken !.String // a character + | CharListToken !.String // a character list '{char}*' + | BoolToken !Bool // a boolean + | OpenToken // ( + | CloseToken // ) + | CurlyOpenToken // { + | CurlyCloseToken // } + | SquareOpenToken // [ + | SquareCloseToken // ] + + | DotToken // . + | SemicolonToken // ; + | ColonToken // : + | DoubleColonToken // :: + | CommaToken // , + | ExclamationToken // ! + | BarToken // | + | ArrowToken // -> + | DoubleArrowToken // => + | EqualToken // = + | DefinesColonToken // =: + | ColonDefinesToken // :== + | WildCardToken // _ + | BackSlashToken // \ + | DoubleBackSlashToken // \\ + | LeftArrowToken // <- + | LeftArrowColonToken // <-: + | DotDotToken // .. + | AndToken // & + | HashToken // # + | AsteriskToken // * + | LessThanOrEqualToken // <= + + | ModuleToken // module + | ImpModuleToken // implementation + | DefModuleToken // definition + | SysModuleToken // system + + | ImportToken // import + | FromToken // from + | SpecialToken // special + + | IntTypeToken // Int + | CharTypeToken // Char + | RealTypeToken // Real + | BoolTypeToken // Bool + | StringTypeToken // String + | FileTypeToken // File + | WorldTypeToken // World + | VoidTypeToken // Void + | LeftAssocToken // left + | RightAssocToken // right + | ClassToken // class + | InstanceToken // instance + | OtherwiseToken // otherwise + + | IfToken // if + | WhereToken // where + | WithToken // with + | CaseToken // case + | OfToken // of + | LetToken Bool // let!, let + | SeqLetToken Bool // Let!, Let + | InToken // in + + | DynamicToken // dynamic + | DynamicTypeToken // Dynamic + + + | PriorityToken Priority // infixX N + + | CodeToken // code + | InlineToken // inline + | CodeBlockToken [String] // {...} + + | NewDefinitionToken // generated automatically + | EndGroupToken // generated automatically + | EndOfFileToken // end of file + | ErrorToken String // if an error occured + +:: Context + = GeneralContext + | TypeContext + | FunctionContext + | CodeContext + +:: Assoc = LeftAssoc | RightAssoc | NoAssoc + +:: Priority = Prio Assoc Int | NoPrio + +class getFilename state :: !*state -> (!String,!*state) +instance getFilename ScanState + +class tokenBack state :: !*state -> !*state +instance tokenBack ScanState + +class nextToken state :: !Context !*state -> (!Token, !*state) +instance nextToken ScanState + +class currentToken state :: !*state -> (!Token, !*state) +instance currentToken ScanState + +class insertToken state :: !Token !Context !*state -> *state +instance insertToken ScanState + +class replaceToken state :: !Token !*state -> *state +instance replaceToken ScanState + +class getPosition state :: !*state -> (!FilePosition,!*state) // Position of current Token (or Char) +instance getPosition ScanState + +openScanner :: !String !SearchPaths !*Files -> (!Optional ScanState, !*Files) +closeScanner :: !ScanState !*Files -> *Files + +setUseLayout :: !Bool !ScanState -> ScanState +UseLayout :: !ScanState -> (!Bool, !ScanState) +dropOffsidePosition :: !ScanState -> ScanState + +isLhsStartToken :: ! Token -> Bool +isOffsideToken :: ! Token -> Bool +isEndGroupToken :: ! Token -> Bool + +instance == Token + +instance <<< Token + +instance toString Token, Priority + +instance < Priority + diff --git a/frontend/scanner.icl b/frontend/scanner.icl new file mode 100644 index 0000000..89e34da --- /dev/null +++ b/frontend/scanner.icl @@ -0,0 +1,1518 @@ +implementation module scanner + +import StdEnv, compare_constructor, StdCompare, general + +from utilities import revCharListToString, isSpecialChar + +/* +Known bug: +functions names starting with '->' require a ';' after the type. Solutions: +1) Make '->' an ordinary token. This implies that we have to write 'a-> .b' instead + of 'a->.b'. +2) re-scan token in new context. Requires substantial changes. +3) Determine offsides before token is generated. Tricky since we do not know the + actual context of the new token or/and have to take care of generating the right + amount of offsides. +*/ +:: SearchPaths :== [String] + +:: * ScanState = + { ss_input :: ScanInput + , ss_offsides :: ! [(Int, Bool) ] // (column, defines newDefinition) + , ss_useLayout :: ! Bool + , ss_tokenBuffer :: ! Buffer LongToken + } + +:: * ScanInput + = Input Input + | PushedToken LongToken ScanInput + +:: * Input = + { inp_stream :: ! InputStream + , inp_filename :: String + , inp_pos :: ! FilePosition + , inp_tabsize :: ! Int + , inp_charBuffer :: ! Buffer (Char,FilePosition) + //, inp_curToken :: ! [ Char ] + } + +:: * InputStream + = InFile ! * File + | InLOC ! [Char] + | OldChar ! Char ! FilePosition ! InputStream + | OldChars ! [Char] ! InputStream + | OldToken ! LongToken ! InputStream + +:: FilePosition = + { fp_line :: ! Int + , fp_col :: ! Int + } + +:: LongToken = + { lt_position :: ! FilePosition // Start position of this token + , lt_token :: ! Token // The token itself +// , lt_chars :: ! [Char] // The chars in this token +// , lt_context :: ! Context // The context of the scanning of this token + } + +:: Buffer x + = Buffer0 + | Buffer1 x + | Buffer2 x x + | Buffer3 x x x // buffer size is 3. + +:: Token + = IdentToken ! .String // an identifier + | IntToken !.String // an integer + | RealToken !.String // a real + | StringToken !.String // a string + | CharToken !.String // a character + | CharListToken !.String // a character list '{char}*' + | BoolToken !Bool // a boolean + | OpenToken // ( + | CloseToken // ) + | CurlyOpenToken // { + | CurlyCloseToken // } + | SquareOpenToken // [ + | SquareCloseToken // ] + + | DotToken // . + | SemicolonToken // ; + | ColonToken // : + | DoubleColonToken // :: + | CommaToken // , + | ExclamationToken // ! + | BarToken // | + | ArrowToken // -> + | DoubleArrowToken // => + | EqualToken // = + | DefinesColonToken // =: + | ColonDefinesToken // :== + | WildCardToken // _ + | BackSlashToken // \ + | DoubleBackSlashToken // \\ + | LeftArrowToken // <- + | LeftArrowColonToken // <-: + | DotDotToken // .. + | AndToken // & + | HashToken // # + | AsteriskToken // * + | LessThanOrEqualToken // <= + + | ModuleToken // module + | ImpModuleToken // implementation + | DefModuleToken // definition + | SysModuleToken // system + + | ImportToken // import + | FromToken // from + | SpecialToken // special + + | IntTypeToken // Int + | CharTypeToken // Char + | RealTypeToken // Real + | BoolTypeToken // Bool + | StringTypeToken // String + | FileTypeToken // File + | WorldTypeToken // World + | VoidTypeToken // Void + | LeftAssocToken // left + | RightAssocToken // right + | ClassToken // class + | InstanceToken // instance + | OtherwiseToken // otherwise + + | IfToken // if + | WhereToken // where + | WithToken // with + | CaseToken // case + | OfToken // of + | LetToken Bool // let!, let + | SeqLetToken Bool // #!, # + | InToken // in + + | DynamicToken // dynamic + | DynamicTypeToken // Dynamic + + | PriorityToken Priority // infixX N + + | CodeToken // code + | InlineToken // inline + | CodeBlockToken [String] // {...} + + | NewDefinitionToken // generated automatically, OffsideToken. + | EndGroupToken // generated automatically + | EndOfFileToken // end of file + | ErrorToken String // an error has occured + +:: Context + = GeneralContext + | TypeContext + | FunctionContext + | CodeContext + +instance == Context +where + (==) co1 co2 = equal_constructor co1 co2 + +:: Assoc + = LeftAssoc + | RightAssoc + | NoAssoc + +:: Priority + = Prio Assoc Int + | NoPrio + +// +// Macros for error messages +// +ScanErrIllegal :== "illegal char in input" +ScanErrCharErr :== "wrong character denotation" +ScanErrNLString :== "new line in string denotation" +ScanErrWild :== "ident should not start with _" + +class getFilename state :: !*state -> (!String,!*state) + +instance getFilename ScanInput +where + getFilename (Input input) + # (filename,input) = input!inp_filename + = (filename,Input input) + getFilename (PushedToken tok input) + # (filename,input) = getFilename input + = (filename,PushedToken tok input) + +instance getFilename ScanState +where + getFilename scanState=:{ss_input} + # (filename,ss_input) = getFilename ss_input + = (filename,{scanState & ss_input = ss_input }) + +class getPosition state :: !*state -> (!FilePosition,!*state) // Position of current Token (or Char) + +instance getPosition ScanState +where + getPosition scanState=:{ss_tokenBuffer} + | isEmptyBuffer ss_tokenBuffer + = getCharPosition scanState + # (ltok,_) = get ss_tokenBuffer + = (ltok.lt_position, scanState) + +instance getPosition Input +where + getPosition input=:{inp_pos} = (inp_pos, input) + +class getCharPosition state :: !*state -> (FilePosition,!*state) + +instance getCharPosition ScanState +where + getCharPosition scanState=:{ss_input=Input input} + # (pos,input) = getPosition input + = (pos,{ scanState & ss_input = Input input }) + getCharPosition scanState=:{ss_input=PushedToken longToken _} + = (longToken.lt_position,scanState) + +instance getCharPosition Input +where getCharPosition input=:{inp_pos} = (inp_pos, input) + +class nextToken state :: !Context !*state -> (!Token, !*state) + +instance nextToken ScanState +where + nextToken newContext scanState=:{ss_input=input=:PushedToken token=:{lt_position,lt_token/*,lt_context*/} rest,ss_tokenBuffer} +// | lt_context == newContext || ~ (contextDependent lt_token) || isGeneratedToken lt_token +// | True + = ( lt_token + , { scanState + & ss_input = rest + , ss_tokenBuffer = store token ss_tokenBuffer + } + ) //-->> ("nextToken: pushed token", lt_token) +/* = nextToken newContext { scanState & ss_input = pushTokensBack input} + where + pushTokensBack input=:(Input _) = input + pushTokensBack (PushedToken token input) + # (Input input=:{inp_stream}) = pushTokensBack input + = Input + { input + & inp_stream = OldToken token inp_stream + } //-->> ("pushTokensBack",token) +*/ nextToken context scanState=:{ss_input=Input inp,ss_tokenBuffer,ss_offsides,ss_useLayout} + # (error, c, inp) = SkipWhites inp + (pos, inp) = inp!inp_pos + scanState = {scanState & ss_input = Input inp } + = case error of + Yes string -> ( ErrorToken string + , { scanState + & ss_tokenBuffer = store + { lt_position = pos + , lt_token = ErrorToken string + // , lt_chars = [] + // , lt_context = context + } + scanState.ss_tokenBuffer + } + ) -->> ("Error token generated",string) + no -> determineToken c scanState + where + determineToken c scanState=:{ss_input=Input inp} + # (eof, inp) = EndOfInput inp + (pos, inp) = inp!inp_pos + | eof && c == NewLineChar + # newToken = EndOfFileToken + = checkOffside pos newToken + { scanState + & ss_tokenBuffer = store + { lt_position = pos + , lt_token = newToken + // , lt_chars = [] + // , lt_context = context + } + scanState.ss_tokenBuffer + , ss_input = Input inp + } // -->> (EndOfFileToken,pos) + // otherwise // ~ (eof && c == NewLineChar) + # (token, inp) = Scan c inp /* {inp & inp_curToken = [c]}*/ context + // # (chars, inp) = inp!inp_curToken + = checkOffside pos token + { scanState + & ss_input = Input inp + , ss_tokenBuffer = store + { lt_position = pos + , lt_token = token + // , lt_chars = reverse chars + // , lt_context = context + } + ss_tokenBuffer + } // -->> (token,pos) + nextToken _ _ = abort "Scanner: Error in nextToken" + +class tokenBack state :: !*state -> !*state + +instance tokenBack ScanState +where + tokenBack scanState=:{ss_tokenBuffer, ss_input} + | isEmptyBuffer ss_tokenBuffer = abort "tokenBack with empty token buffer" + # (tok, buf) = get ss_tokenBuffer + = { scanState + & ss_tokenBuffer = buf + , ss_input = PushedToken tok ss_input + + } // -->> ("tokenBack", tok, buf) + +class currentToken state :: !*state -> (!Token, !*state) + +instance currentToken ScanState +where currentToken scanState=:{ss_tokenBuffer} + | isEmptyBuffer ss_tokenBuffer + = (ErrorToken "dummy", scanState) + = ((head ss_tokenBuffer).lt_token, scanState) + +class insertToken state :: !Token !Context !*state -> *state + +instance insertToken ScanState +where + insertToken t c scanState +/* # chars = if (isGeneratedToken t) + [] + (fromString (toString t)) +*/ # (pos, scanState=:{ss_input}) = getPosition scanState + = { scanState + & ss_input = PushedToken + { lt_position = pos + , lt_token = t + // , lt_chars = chars + // , lt_context = c + } + ss_input + } +/* +isGeneratedToken :: !Token -> Bool +isGeneratedToken NewDefinitionToken = True +isGeneratedToken EndGroupToken = True +isGeneratedToken (CodeBlockToken _) = True +isGeneratedToken _ = False +*/ + +class replaceToken state :: !Token !*state -> *state + +instance replaceToken ScanState +where + replaceToken tok scanState=:{ss_tokenBuffer} + # (longToken,buffer) = get ss_tokenBuffer + = { scanState + & ss_tokenBuffer = store { longToken & lt_token = tok } buffer + } + +SkipWhites :: !Input -> (!Optional String, !Char, !Input) +SkipWhites input + # (eof, c, input) = ReadChar input + | eof = (No, NewLineChar, input) // -->> "EOF in SkipWhites" + | IsWhiteSpace c = SkipWhites input + = TryScanComment c input + +TryScanComment :: !Char !Input -> (!Optional String, !Char, !Input) +TryScanComment c1=:'/' input + # (eof,c2, input) = ReadChar input + | eof = (No, c1, input) + = case c2 of + '/' -> SkipWhites (SkipToEndOfLine input) + '*' -> case ScanComment input of + (No,input) -> SkipWhites input + (er,input) -> (er, c1, input) + _ -> (No, c1, charBack input) +TryScanComment c input + = (No, c, input) + +ScanComment :: !Input -> (!Optional String, !Input) +ScanComment input + # (eof1, c1, input) = ReadChar input + | eof1 = (Yes "end of file encountered inside comment", input) + | c1 == '/' + # (eof2, c2, input) = ReadChar input + | eof2 = (Yes "end of file encountered inside comment", input) + = case c2 of + '/' -> ScanComment (SkipToEndOfLine input) + '*' -> case ScanComment input of + (No, input) -> ScanComment input + error -> error + _ -> ScanComment input + | c1 == '*' + # (eof2, c2, input) = ReadChar input + | eof2 = (Yes "end of file encountered inside comment", input) + | c2 == '/' = (No, input) + = ScanComment input + | otherwise = ScanComment input + +SkipToEndOfLine :: !Input -> !Input +SkipToEndOfLine input + # (eof, c, input) = ReadChar input + | eof = input + | c==NewLineChar = input + = SkipToEndOfLine input +/* +SkipToChar :: ! Char ! Input -> Input +SkipToChar c input + # (eof, c1, input) = ReadChar input + | eof || c1 == c = input + = SkipToChar c input +*/ +Scan :: !Char !Input !Context -> (!Token, !Input) +Scan '(' input co = (OpenToken, input) +Scan ')' input co = (CloseToken, input) +Scan '{' input CodeContext = ScanCodeBlock input +Scan '{' input co = (CurlyOpenToken, input) +Scan '}' input co = (CurlyCloseToken, input) +Scan '[' input co = (SquareOpenToken, input) +Scan ']' input co = (SquareCloseToken, input) +Scan c0=:'|' input co + # (eof, c1, input) = ReadChar input + | eof = (BarToken, input) + | isSpecialChar c1 = ScanOperator 1 input [c1, c0] co + = (BarToken, charBack input) +Scan ',' input co = (CommaToken, input) +Scan ';' input co = (SemicolonToken, input) +Scan '#' input TypeContext = (HashToken, input) +Scan c0=:'#' input co + # (strict, input) = determineStrictness input + | strict + = (SeqLetToken strict, input) + # (eof,c1, input) = ReadChar input + | eof + = (SeqLetToken False, input) + | isSpecialChar c1 + = ScanOperator 1 input [c1, c0] co + // otherwise + = (SeqLetToken strict, charBack input) +Scan '*' input TypeContext = (AsteriskToken, input) +Scan c0=:'&' input co + # (eof, c1, input) = ReadChar input + | eof = (AndToken, input) + | isSpecialChar c1 = ScanOperator 1 input [c1, c0] co + = (AndToken, charBack input) +Scan c0=:'.' input co + = case co of + TypeContext + + -> (DotToken, input) + _ # (eof, c1, input) = ReadChar input + | eof -> (DotToken, input) + | c1 <> '.' -> (DotToken, charBack input) + # (eof, c2, input) = ReadChar input + | eof -> (DotDotToken, input) + | isSpecialChar c2 + -> ScanOperator 2 input [c2, c1, c0] co + -> (DotDotToken, charBack input) +Scan '!' input TypeContext = (ExclamationToken, input) +Scan '\\' input co + # (eof, c, input) = ReadChar input + | eof = (BackSlashToken, input) + | c == '\\' = (DoubleBackSlashToken, input) + = (BackSlashToken, charBack input) +Scan c0=:'_' input co + # (eof, c1, input) = ReadChar input + | eof = (WildCardToken, input) + | IsIdentChar c1 co = ScanIdent 1 input [c1, c0] co +// | isSpecialChar c1 = ScanOperator 1 input [c1, c0] co + = (WildCardToken, charBack input) +Scan c0=:'<' input TypeContext + # (eof, c1, input) = ReadChar input + | eof = (ErrorToken "< just before end of file in TypeContext", input) + | c1 == '=' = (LessThanOrEqualToken, input) + = ScanOperator 0 (charBack input) [c0] TypeContext +Scan c0=:'<' input co + # (eof, c1, input) = ReadChar input + | eof = (IdentToken "<", input) + | c1 <> '-' = ScanOperator 0 (charBack input) [c0] co + # (eof, c2, input) = ReadChar input + | eof = (LeftArrowToken, input) + | c2 == ':' + # (eof, c3, input) = ReadChar input + | eof = (LeftArrowColonToken, input) + | isSpecialChar c3 = ScanOperator 3 input [c3, c2, c1, c0] co + = (LeftArrowColonToken, charBack input) + | isSpecialChar c2 = ScanOperator 2 input [c2, c1, c0] co + = (LeftArrowToken, charBack input) +Scan c0=:'-' input co + # (eof, c1, input) = ReadChar input + | eof = (IdentToken "-", input) + # new = newExp input.inp_charBuffer + | IsDigit c1 && new = ScanNumeral 1 input [c1,c0] + | c1 <> '>' = ScanOperator 0 (charBack input) [c0] co + | co == TypeContext = (ArrowToken, input) // -> is a reserved symbol in a type context + // Can cause an error when token (like ->.) is read in wrong context + # (eof, c2, input) = ReadChar input + | eof = (ArrowToken, input) + | isSpecialChar c2 = ScanOperator 2 input [c2, c1, c0] co + = (ArrowToken, charBack input) +Scan c0=:'+' input co + # (eof, c1, input) = ReadChar input + | eof = (IdentToken "+", input) + # new = newExp input.inp_charBuffer + | IsDigit c1 && new = ScanNumeral 1 input [c1,c0] + = ScanOperator 0 (charBack input) [c0] co +Scan c0=:'=' input co + # (eof, c, input) = ReadChar input + | eof = (EqualToken, input) + | c == ':' = (DefinesColonToken, input) + | c == '>' = (DoubleArrowToken, input) + | isSpecialChar c = ScanOperator 1 input [c, c0] co + = (EqualToken, charBack input) +Scan c0=:':' input co + # (eof,c1, input) = ReadChar input + | eof = (ColonToken, input) + | c1 == ':' = (DoubleColonToken, input) + | c1 <> '=' + | isSpecialChar c1 = ScanOperator 1 input [c1, c0] co + = (ColonToken, charBack input) + # (eof, c2, input) = ReadChar input + | eof = ScanOperator 1 input [c1, c0] co + | c2 == '=' = (ColonDefinesToken, input) + = ScanOperator 1 (charBack input) [c1, c0] co +Scan c0=:'\'' input co = ScanChar input [c0] +Scan c0=:'\"' input co = ScanString 0 input [c0] +Scan c input co + | IsDigit c = ScanNumeral 0 input [c] + | IsIdentChar c co = ScanIdent 0 input [c] co + | isSpecialChar c = ScanOperator 0 input [c] co + = (ErrorToken ScanErrIllegal, input) + +newExp :: !(Buffer (Char,FilePosition)) -> Bool +newExp buffer + # (c, _) = case buffer of + Buffer3 _ _ cp -> cp + _ -> (' ',{fp_line=0,fp_col=0}) + = new_exp_char c +where + new_exp_char ',' = True + new_exp_char '[' = True + new_exp_char '(' = True + new_exp_char '/' = True // to handle end of comment symbol: */ + new_exp_char c = isSpace c + +ScanIdent :: !Int !Input ![Char] !Context -> (!Token, !Input) +ScanIdent n input token co + # (eof, c, input) = ReadChar input + | eof = CheckReserved co (revCharListToString n token) input + | IsIdentChar c co = ScanIdent (n + 1) input [c:token] co + = CheckReserved co (revCharListToString n token) (charBack input) + + +ScanOperator :: !Int !Input ![Char] !Context -> (!Token, !Input) +ScanOperator n input token co + # (eof, c, input) = ReadChar input + | eof = (IdentToken (revCharListToString n token), input) + | isSpecialChar c = ScanOperator (n + 1) input [c:token] co + = CheckReserved co (revCharListToString n token) (charBack input) + +CheckReserved :: !Context !String !Input -> (!Token, !Input) +CheckReserved GeneralContext s i = CheckGeneralContext s i +CheckReserved TypeContext s i = CheckTypeContext s i +CheckReserved FunctionContext s i = CheckFunctContext s i +CheckReserved CodeContext s i = CheckCodeContext s i + +CheckGeneralContext :: !String !Input -> (!Token, !Input) +CheckGeneralContext s input + = case s of + "module" -> (ModuleToken , input) + "definition" -> (DefModuleToken , input) + "implementation" -> (ImpModuleToken , input) + "system" -> (SysModuleToken , input) + "import" -> (ImportToken , input) + "from" -> (FromToken , input) + "in" -> (InToken , input) + s -> CheckEveryContext s input + +CheckEveryContext :: !String !Input -> (!Token, !Input) +CheckEveryContext s input + = case s of + "where" -> (WhereToken , input) + "with" -> (WithToken , input) + "class" -> (ClassToken , input) + "instance" -> (InstanceToken , input) + "otherwise" -> (OtherwiseToken , input) +// "!" -> (ExclamationToken , input) +// "::" -> (DoubleColonToken , input) + "*/" -> (ErrorToken "Unexpected end of comment, */", input) + "infixr" # (error, n, input) = GetPrio input + -> case error of + Yes err -> (ErrorToken err , input) //-->> ("Error token generated: "+err) + No -> (PriorityToken (Prio RightAssoc n) , input) + "infixl" # (error, n, input) = GetPrio input + -> case error of + Yes err -> (ErrorToken err , input) //-->> ("Error token generated: "+err) + No -> (PriorityToken (Prio LeftAssoc n) , input) + "infix" # (error, n, input) = GetPrio input + -> case error of + Yes err -> (ErrorToken err , input) //-->> ("Error token generated: "+err) + No -> (PriorityToken (Prio NoAssoc n) , input) + s -> (IdentToken s , input) + +CheckTypeContext :: !String !Input -> (!Token, !Input) +CheckTypeContext s input + = case s of + "Int" -> (IntTypeToken , input) + "Char" -> (CharTypeToken , input) + "Real" -> (RealTypeToken , input) + "Bool" -> (BoolTypeToken , input) + "String" -> (StringTypeToken , input) + "File" -> (FileTypeToken , input) + "World" -> (WorldTypeToken , input) + "Dynamic" -> (DynamicTypeToken , input) + "special" -> (SpecialToken , input) + "from" -> (FromToken , input) + s -> CheckEveryContext s input + +CheckFunctContext :: !String !Input -> (!Token, !Input) +CheckFunctContext s input + = case s of + "if" -> (IfToken , input) + "True" -> (BoolToken True , input) + "False" -> (BoolToken False , input) + "case" -> (CaseToken , input) + "of" -> (OfToken , input) + "system" -> (SysModuleToken , input) + "import" -> (ImportToken , input) + "from" -> (FromToken , input) + "let" # (strict, input) = determineStrictness input + -> (LetToken strict, input) +// "Let" # (strict, input) = determineStrictness input +// -> (SeqLetToken strict , input) + "in" -> (InToken , input) + "dynamic" -> (DynamicToken , input) + "code" -> (CodeToken , input) + s -> CheckEveryContext s input + +CheckCodeContext :: !String !Input -> (!Token, !Input) +CheckCodeContext s input + = case s of + "inline" -> (InlineToken , input) + s -> CheckEveryContext s input + +GetPrio :: !Input -> (!Optional String, !Int, !Input) +GetPrio input + # (error, c, input) = SkipWhites input + | IsDigit c + = (error, digitToInt c, input) + = (error, defaultPrio , charBack input) +where defaultPrio = 0 + +determineStrictness :: !Input -> (!Bool, !Input) +determineStrictness input + # (eof, c, input) = ReadChar input + | eof = (False, input) + | c == '!' = (True, input) + = (False, charBack input) + +ScanCodeBlock :: !Input -> (!Token, !Input) +ScanCodeBlock input + = scan_code_block [] input +where + scan_code_block :: ![String] !Input -> (!Token,!Input) + scan_code_block acc input + # (eof, c, input) = ReadChar input + | c == '}' + = (CodeBlockToken (reverse acc), input) + | isNewLine c + | eof + = (ErrorToken "eof in code block", input) + = scan_code_block acc input + | IsWhiteSpace c + = scan_code_block acc input + # (line, input) = ReadLine input + = scan_code_block [toString c+stripNewline line:acc] input + +stripNewline :: !String -> String +stripNewline string + # size = size string + = case size of + 0 -> string + 1 | isNewLine string.[0] + -> "" + -> string + _ | isNewLine string.[size-1] + | isNewLine string.[size-2] + -> string%(0,size-3) + -> string%(0,size-2) + -> string + + +ScanNumeral :: !Int !Input [Char] -> (!Token, !Input) +ScanNumeral n input chars=:['0':r] + | isEmpty r || r == ['+'] + # (eof, c, input) = ReadChar input + | eof = (IntToken (revCharListToString n chars), input) + | c == 'x' + # (eof, c1, input) = ReadChar input + | eof = (IntToken "0", charBack input) + | isHexDigit c1 = ScanHexNumeral (hexDigitToInt c1) input + = (IntToken "0", charBack (charBack input)) + | isOctDigit c = ScanOctNumeral (digitToInt c) input + | c == '.' = TestFraction n input chars + = (IntToken "0", charBack input) + | r == ['-'] + # (eof, c, input) = ReadChar input + | eof = (IntToken (revCharListToString n chars), input) + | c == 'x' + # (eof, c1, input) = ReadChar input + | eof = (IntToken "0", charBack input) + | isHexDigit c1 = ScanHexNumeral (~ (hexDigitToInt c1)) input + = (IntToken "0", charBack (charBack input)) + | isOctDigit c = ScanOctNumeral (~ (digitToInt c)) input + | c == '.' = TestFraction n input chars + = (IntToken "0", charBack input) +ScanNumeral n input chars + # (eof, c, input) = ReadChar input + | eof = (IntToken (revCharListToString n chars), input) + | IsDigit c = ScanNumeral (n + 1) input [c:chars] + | c == 'E' = ScanExponentSign (n + 1) input [c:chars] + | c == '.' = TestFraction n input chars + = (IntToken (revCharListToString n chars), charBack input) + +TestFraction :: !Int !Input ![Char] -> (!Token, !Input) +TestFraction n input chars + # (eof, c, input) = ReadChar input + | eof = (ErrorToken ("Incorrect Real at end of file: "+(revCharListToString (n+1) ['.':chars])), input) + | IsDigit c = ScanFraction (n + 2) input [c,'.':chars] + = (IntToken (revCharListToString n chars), charBack (charBack input)) + +ScanFraction :: !Int !Input ![Char] -> (!Token, !Input) +ScanFraction n input chars + # (eof, c, input) = ReadChar input + | eof = (RealToken (revCharListToString n chars), input) + | c == 'E' = case chars of + [c:_] | IsDigit c -> ScanExponentSign (n + 1) input [c:chars] + _ -> ScanExponentSign (n + 2) input [c,'0':chars] + | IsDigit c = ScanFraction (n + 1) input [c:chars] + = case chars of + [c:_] | IsDigit c -> (RealToken (revCharListToString n chars), charBack input) + _ -> (RealToken (revCharListToString (n+1) ['0':chars]), charBack input) + +ScanExponentSign :: !Int !Input ![Char] -> (!Token, !Input) +ScanExponentSign n input chars + # (eof, c, input) = ReadChar input + | eof = (RealToken (revCharListToString n chars), input) + | c == '+' = ScanExponent n input chars + | c == '-' || IsDigit c = ScanExponent (n+1) input [c:chars] + | otherwise = (ErrorToken ("Digit or sign expected after "+revCharListToString n chars), charBack input) + +ScanExponent :: !Int !Input ![Char] -> (!Token, !Input) +ScanExponent n input chars + # (eof, c, input) = ReadChar input + | eof = (RealToken (revCharListToString n chars), input) + | IsDigit c = ScanExponent (n + 1) input [c:chars] + = case chars of + [c:_] | IsDigit c -> (RealToken (revCharListToString n chars), charBack input) + _ -> (ErrorToken ("Digit expected after "+revCharListToString n chars), charBack input) + +ScanHexNumeral :: !Int !Input -> (!Token, !Input) +ScanHexNumeral n input + # (eof, c, input) = ReadChar input + | eof = (IntToken (toString n), input) + | isHexDigit c = ScanHexNumeral (n*16+hexDigitToInt c) input + = (IntToken (toString n), charBack input) + +ScanOctNumeral :: !Int !Input -> (!Token, !Input) +ScanOctNumeral n input + # (eof, c, input) = ReadChar input + | eof = (IntToken (toString n), input) + | isOctDigit c = ScanOctNumeral (n*8+digitToInt c) input + = (IntToken (toString n), charBack input) + +ScanChar :: !Input ![Char] -> (!Token, !Input) +ScanChar input chars + # (eof, c, input) = ReadChar input + | eof = (ErrorToken "End of file inside Char denotation", input) + | '\\' <> c = ScanEndOfChar 1 [c: chars] input + # (chars, n, input) = ScanBSChar 0 chars input + = ScanEndOfChar n chars input + +ScanBSChar :: !Int ![Char] !Input -> (![Char], !Int, !Input) +ScanBSChar n chars input + # (eof, c, input) = ReadChar input + | eof = (chars, n, input) + = case c of + 'n' -> (['n','\\':chars], n + 2, input) + 'r' -> (['r','\\':chars], n + 2, input) + 'f' -> (['f','\\':chars], n + 2, input) + 'b' -> (['b','\\':chars], n + 2, input) + 't' -> (['t','\\':chars], n + 2, input) + 'v' -> (['v','\\':chars], n + 2, input) + '\\' -> (['\\','\\':chars], n + 2, input) + '"' -> (['"' ,'\\':chars], n + 2, input) + '\'' -> (['\'','\\':chars], n + 2, input) + 'x' # (cc,input) = ScanNumChar Hex isHexDigit 2 0 input // max 2 characters + -> to_chars cc n input + 'd' # (cc,input) = ScanNumChar Dec isDigit 3 0 input // max 3 characters + -> to_chars cc n input + c | IsOct c + # (cc,input) = ScanNumChar Oct IsOct 2 (digitToInt c) input // max 3 characters, including current + -> to_chars cc n input + -> ([c:chars], n + 1, input) +where + ScanNumChar base valid 0 acc input + = (acc, input) + ScanNumChar base valid n acc input + # (eof, c, input) = ReadChar input + | eof = (acc, input) + | valid c = ScanNumChar base valid (n-1) (base*acc+digitToInt c) input + = (acc, charBack input) + Hex = 16 + Oct = 8 + Dec = 10 + + to_chars cc n input + = case toChar cc of + '\n' -> (['n','\\':chars], n + 2, input) + '\r' -> (['r','\\':chars], n + 2, input) + '\f' -> (['f','\\':chars], n + 2, input) + '\b' -> (['b','\\':chars], n + 2, input) + '\t' -> (['t','\\':chars], n + 2, input) + '\v' -> (['v','\\':chars], n + 2, input) + '\\' -> (['\\','\\':chars], n + 2, input) +// '"' -> (['"' ,'\\':chars], n + 2, input) + '\'' -> (['\'','\\':chars], n + 2, input) + c -> ([c:chars], n + 1, input) + +ScanEndOfChar :: !Int ![Char] !Input -> (!Token, !Input) +ScanEndOfChar n chars input + # (eof, c, input) = ReadChar input + | eof = (ErrorToken "End of file inside char denotation", input) + | '\'' == c = (CharToken (revCharListToString (n + 1) [c:chars]), input) + = ScanCharList (n+1) [c:chars] input +// = (ErrorToken ScanErrCharErr, input) + +ScanCharList :: !Int ![Char] !Input -> (!Token, !Input) +ScanCharList n chars input + # (eof, c, input) = ReadChar input + | eof = (ErrorToken "End of file inside char list denotation", input) + = case c of + '\'' # charList = revCharListToString n chars % (1,n) // without '\'' + -> (CharListToken charList, input) + '\\' # (chars, n, input) = ScanBSChar n chars input + -> ScanCharList n chars input + NewLineChar -> (ErrorToken "newline in char list", input) + _ -> ScanCharList (n+1) [c:chars] input + +ScanString :: !Int !Input ![Char] -> (!Token, !Input) +ScanString n input chars + # (eof, c, input) = ReadChar input + | eof = (ErrorToken "End of file inside String denotation", input) + = case c of + '\\' # (chars, n, input) = ScanBSChar n chars input + -> ScanString n input chars + '\"' -> (StringToken (revCharListToString (n + 1) [c:chars]), input) + NewLineChar -> (ErrorToken ScanErrNLString, input) + _ -> ScanString (n + 1) input [c:chars] + +/* + some predicates on tokens +*/ + +isLhsStartToken :: ! Token -> Bool +isLhsStartToken OpenToken = True +isLhsStartToken SquareOpenToken = True +isLhsStartToken CurlyOpenToken = True +isLhsStartToken (IdentToken id) = True +isLhsStartToken token = False + +isOffsideToken :: ! Token -> Bool +isOffsideToken NewDefinitionToken = True +isOffsideToken EndGroupToken = True +isOffsideToken EndOfFileToken = True +isOffsideToken token = False + +isEndGroupToken :: ! Token -> Bool +isEndGroupToken EndGroupToken = True +isEndGroupToken CurlyCloseToken = True +isEndGroupToken token = False +/* +contextDependent :: !Token -> Bool +contextDependent HashToken = True +//contextDependent (SeqLetToken _) = True // Do not do this XXXXXX +contextDependent _ = False +*/ +/* + character functions +*/ + +//IsWhiteSpace :: Char -> Bool +IsWhiteSpace c :== isSpace c + +//IsDigit :: Char -> Bool +IsDigit c :== isDigit c + +IsOct c :== '0' <= c && c <= '7' + +//IsHex c :== isDigit c || ('A' <= c && c <= 'F') || ('a' <= c && c <= 'f') +/* +isHexDigit :: !Char -> Bool // Defined in StdChar +isHexDigit c + | isDigit c + = True + | c < 'g' + = c >= 'a' + | c < 'G' + = c >= 'A' + = False +*/ +//IsIdentChar :: !Char !Context -> Bool +//IsIdentChar c co +// :== isAlphanum c || c == '_' || c == '`' || (c == '^' && co == TypeContext) + +hexDigitToInt :: !Char -> Int +hexDigitToInt 'a' = 10 +hexDigitToInt 'A' = 10 +hexDigitToInt 'b' = 11 +hexDigitToInt 'B' = 11 +hexDigitToInt 'c' = 12 +hexDigitToInt 'C' = 12 +hexDigitToInt 'd' = 13 +hexDigitToInt 'D' = 13 +hexDigitToInt 'e' = 14 +hexDigitToInt 'E' = 14 +hexDigitToInt 'f' = 15 +hexDigitToInt 'F' = 15 +hexDigitToInt c = digitToInt c + +IsIdentChar :: !Char !Context -> Bool +IsIdentChar c _ | isAlphanum c = True +IsIdentChar '_' _ = True +IsIdentChar '`' _ = True +IsIdentChar '^' TypeContext = True +IsIdentChar _ _ = False + +/* + Input functions +*/ + +EndOfInput :: !Input -> (!Bool, !Input) +EndOfInput input=:{inp_stream = InFile file} + # (endoffile, file) = fend file + = (endoffile, { input & inp_stream = InFile file }) +EndOfInput f=:{inp_stream = InLOC []} = (True, f) +EndOfInput input = (False, input) + +ReadChar :: !Input -> (!Bool, !Char, !Input) // Bool indicates end of file, we read always newlines in an empty file +ReadChar input=:{inp_stream = InFile file, inp_pos, inp_tabsize, inp_charBuffer /*, inp_curToken*/} + #! (s, file) = freadline file + eof = s == "" + | eof + # c = NewLineChar + pos = NextPos c inp_pos inp_tabsize + = ( eof + , c + , { input + & inp_stream = InFile file + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) // -->> ("EOF in " + input.inp_filename + " found in ReadChar") + // otherwise // s <> "" + # chars = fromString s + = ReadChar { input & inp_stream = OldChars chars (InFile file) } +/* #! (eof, file) = fend file // old, too slow + | eof + # c = NewLineChar + pos = NextPos c inp_pos inp_tabsize + = ( eof + , c + , { input + & inp_stream = InFile file + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) // -->> ("EOF in " + input.inp_filename + " found in ReadChar") + #! (ok, c, file) = freadc file + | ok + # pos = NextPos c inp_pos inp_tabsize + (c,input`) = correctNewline c pos inp_tabsize (InFile file) + = ( False + , c + , { input + & inp_stream = input` + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) + = abort "ReadChar failure" */ +ReadChar input =: {inp_stream = OldChar c pos oldfile, inp_charBuffer /*, inp_curToken*/} + = ( False + , c + , { input + & inp_stream = oldfile + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) +ReadChar input =: {inp_stream = OldChars [c:rest] stream, inp_pos, inp_tabsize, inp_charBuffer /*, inp_curToken*/} + # pos = NextPos c inp_pos inp_tabsize + (c,input`) = correctNewline c pos inp_tabsize (OldChars rest stream) + = ( False + , c + , { input + & inp_stream = input` + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) +ReadChar input =: {inp_stream = OldChars [] stream, inp_pos} + = ReadChar {input & inp_stream = stream} +ReadChar input =: {inp_stream = InLOC [c : r], inp_pos, inp_tabsize /*, inp_curToken*/, inp_charBuffer} + # pos = NextPos c inp_pos inp_tabsize + = ( False + , c + , { input + & inp_stream = InLOC r + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) +ReadChar input =: {inp_stream = InLOC [], inp_pos, inp_tabsize /*, inp_curToken*/, inp_charBuffer} + # c = NewLineChar + pos = NextPos c inp_pos inp_tabsize + = ( True + , c + , { input + & inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c:inp_curToken] + } + ) + //-->> ("EOF of InLOC found in ReadChar") +/* +ReadChar input =: {inp_stream = OldToken {lt_chars,lt_position} stream, inp_charBuffer} + # pos = lt_position + c = hd lt_chars + = ( False + , c + , { input + & inp_stream = OldChars (tl lt_chars) stream + , inp_pos = pos + , inp_charBuffer = store (c,pos) inp_charBuffer + // , inp_curToken = [c] + } + ) +*/ +ReadLine :: !Input -> (!String, !Input) +ReadLine input=:{inp_stream = OldChars cs oldfile, inp_pos} + # input = {input & inp_stream = oldfile, inp_pos = NextPos CRChar inp_pos 0} + | isEmpty cs = ReadLine input + | otherwise = (toString cs, input) +ReadLine input=:{inp_stream = InFile infile,inp_pos} + # (eof, file) = fend infile + | eof = ("", {input & inp_stream = InFile file}) + # (l, file ) = freadline file + = (l, {input & inp_stream = InFile file, inp_pos = NextPos CRChar inp_pos 0}) +ReadLine input =: {inp_stream = InLOC [a : c], inp_pos, inp_tabsize} + | a==NewLineChar= ("\n", {input & inp_stream = InLOC c, inp_pos = inp_pos}) + # (line, input) = ReadLine {input & inp_stream = InLOC c, inp_pos = inp_pos} + = (toString a + line, input) +ReadLine input=:{inp_stream = OldChar c p oldfile} + # input = {input & inp_stream = oldfile} + | c==NewLineChar= ("\n", input) + # (line, input) = ReadLine input + = (toString c + line, input) +ReadLine input = ("", input) + +NextPos :: !Char !FilePosition !Int -> FilePosition +NextPos c pos=:{fp_line, fp_col} t + = case c of + LFChar -> NextPos CRChar pos t // -->> "LF in Nextpos" + CRChar -> {fp_line = fp_line + 1, fp_col = 0} // -->> ("line " +toString (fp_line + 1)) + '\t' -> {pos & fp_col = t * (fp_col / t + 1)} + _ -> {pos & fp_col = fp_col + 1} + +correctNewline :: !Char !FilePosition !Int !InputStream -> (!Char, !InputStream) +correctNewline c pos tab_size (InFile file) // Correct newline convention: Mac: CR, Unix: LF, DOS CR LF + = case c of + LFChar -> (NewLineChar,InFile file) //-->> "UNIX newline" + CRChar + # (ok,c2,file) = freadc file + | ok + | c2 == LFChar -> (NewLineChar,InFile file) // -->> "DOS newline corrected" + -> (NewLineChar,OldChar c2 (NextPos c2 pos tab_size) (InFile file)) + -> (NewLineChar, InFile file) + _ -> (c, InFile file) +correctNewline c pos tab_size (OldChars [] input) + = correctNewline c pos tab_size input +correctNewline c pos tab_size (OldChars chars input) + = case c of + LFChar -> (NewLineChar,OldChars chars input) //-->> "UNIX newline" + CRChar + # [c2:rest] = chars + | c2 == LFChar -> (NewLineChar,OldChars rest input) // -->> "DOS newline corrected" + -> (NewLineChar,OldChars chars input) + _ -> (c,OldChars chars input) +correctNewline c _ _ input = (c, input) + +charBack :: !Input -> Input +charBack input=:{inp_stream,inp_charBuffer} + | isEmptyBuffer inp_charBuffer + = abort "charBack with empty character buffer" + # ((c,p),rest) = get inp_charBuffer + = { input + & inp_stream = OldChar c p inp_stream + , inp_charBuffer = rest + } + +qw s :== "\"" + s + "\"" + +instance <<< Token +where + (<<<) f t = f <<< (toString t) + +instance <<< LongToken +where + (<<<) f lt = f <<< lt.lt_token <<< " from " <<< lt.lt_position + +instance <<< FilePosition +where + (<<<) f {fp_line,fp_col} = f <<< fp_line <<< ";" <<< fp_col + +instance toString Token +where + toString (IdentToken id) = id // qw id + toString (IntToken id) = id + toString (RealToken id) = id + toString (StringToken id) = id + toString (CharToken id) = id + toString (CharListToken id) = "['"+id+"']" + toString (BoolToken id) = toString id + toString OpenToken = "(" + toString CloseToken = ")" + toString CurlyOpenToken = "{" + toString CurlyCloseToken = "}" + toString SquareOpenToken = "[" + toString SquareCloseToken = "]" + toString DotToken = "." + toString SemicolonToken = ";" + toString ColonToken = ": (ColonToken)" + toString DoubleColonToken = "::" + toString CommaToken = "," + toString ExclamationToken = "!" + toString BarToken = "|" + toString ArrowToken = "->" + toString DoubleArrowToken = "=>" + toString EqualToken = "=" + toString DefinesColonToken = "=:" + toString ColonDefinesToken = ":==" + toString WildCardToken = "_" + toString BackSlashToken = "\\" + toString DoubleBackSlashToken = "\\\\" + toString LeftArrowToken = "<-" + toString LeftArrowColonToken = "<-:" + toString DotDotToken = ".." + toString AndToken = "&" + toString HashToken = "#" + toString AsteriskToken = "*" + toString LessThanOrEqualToken = "<=" + toString ModuleToken = "module" + toString ImpModuleToken = "implementation" + toString DefModuleToken = "definition" + toString SysModuleToken = "system" + toString ImportToken = "import" + toString FromToken = "from" + toString SpecialToken = "special" + toString IntTypeToken = "Int" + toString CharTypeToken = "Char" + toString RealTypeToken = "Real" + toString BoolTypeToken = "Bool" + toString StringTypeToken = "String" + toString LeftAssocToken = "left" + toString RightAssocToken = "right" + toString ClassToken = "class" + toString InstanceToken = "instance" + toString OtherwiseToken = "otherwise" + toString IfToken = "if" + toString WhereToken = "where" + toString WithToken = "with" + toString CaseToken = "case" + toString OfToken = "of" + toString (LetToken strict) + | strict = "let!" + = "let" + toString (SeqLetToken strict) + | strict = "#!" + = "#" + toString InToken = "in" + + toString DynamicToken = "dynamic" + toString DynamicTypeToken = "Dynamic" + + toString (PriorityToken priority) = toString priority + toString NewDefinitionToken = "offside token (new def)" + toString EndGroupToken = "offside token (end group)" + toString EndOfFileToken = "end of file" + toString (ErrorToken id) = "Scanner error: " + id + toString CodeToken = "code" + toString InlineToken = "inline" + toString (CodeBlockToken the_code) = "<code block>" + toString token = "toString (Token) does not know this token" + +instance == Token +where + (==) token1 token2 + = equal_constructor token1 token2 && equal_args_of_tokens token1 token2 + where + equal_args_of_tokens :: !Token !Token -> Bool + equal_args_of_tokens (IdentToken id1) (IdentToken id2) = id1 == id2 + equal_args_of_tokens (RealToken real1) (RealToken real2) = real1 == real2 + equal_args_of_tokens (StringToken string1) (StringToken string2) = string1 == string2 + equal_args_of_tokens (CharToken char1) (CharToken char2) = char1 == char2 + equal_args_of_tokens (CharListToken chars1) (CharListToken chars2) = chars1 == chars2 + equal_args_of_tokens (BoolToken bool1) (BoolToken bool2) = bool1 == bool2 + equal_args_of_tokens (IntToken int1) (IntToken int2) = int1 == int2 + equal_args_of_tokens (LetToken l1) (LetToken l2) = l1 == l2 + equal_args_of_tokens (SeqLetToken l1) (SeqLetToken l2) = l1 == l2 + equal_args_of_tokens (ErrorToken id1) (ErrorToken id2) = id1 == id2 + equal_args_of_tokens _ _ = True + +instance < Priority +where + (<) (Prio assoc1 prio1) (Prio assoc2 prio2) + = prio1 < prio2 || prio1 == prio2 && assoc1 < assoc2 + (<) _ _ = abort "< of these Priorities (NoPrio) is undefined" + +instance < Assoc +where + (<) _ LeftAssoc = True + (<) LeftAssoc _ = False + (<) _ _ = True + +instance toString Priority +where + toString (Prio assoc prio) = toString assoc + toString prio + toString NoPrio = "infix" + +instance toString Assoc +where + toString LeftAssoc = "infixl " + toString RightAssoc = "infixr " + toString NoAssoc = "infix " + + +openScanner :: !String !SearchPaths !*Files -> (!Optional ScanState, !*Files) +openScanner file_name searchPaths files + = case fopenInSearchPaths file_name searchPaths FReadData files of + (No, files) + -> (No, files) + (Yes file, files) + -> (Yes { ss_input = Input + { inp_stream = InFile file + , inp_filename = file_name + , inp_pos = {fp_line = 1, fp_col = 0} + , inp_tabsize = 4 + , inp_charBuffer = Buffer0 + // , inp_curToken = [] + } + , ss_offsides = [(1,False)] // to generate offsides between global definitions + , ss_useLayout = False + , ss_tokenBuffer = Buffer0 + } + , files + ) + +fopenInSearchPaths :: !{#Char} [!{#Char}] !Int !*f -> (Optional *File,!*f) | FileSystem f +fopenInSearchPaths fileName [] mode f + = (No, f) +fopenInSearchPaths fileName [path : paths] mode f + # (opened, file, f) + = fopen (path + fileName) mode f + | opened + = (Yes file, f) + // otherwise + = fopenInSearchPaths fileName paths mode f + +closeScanner :: !ScanState !*Files -> *Files +closeScanner scanState=:{ss_input=PushedToken _ input} files + = closeScanner {scanState & ss_input = input} files +closeScanner {ss_input=Input {inp_stream}} files + = case get_file inp_stream of + Yes file # (_,files) = fclose file files + -> files + No -> files +where + get_file (InFile file) = Yes file + get_file (OldChar _ _ stream) = get_file stream + get_file (OldChars _ stream) = get_file stream + get_file (OldToken _ stream) = get_file stream + get_file (InLOC _ ) = No + +NewLineChar :== '\n' +LFChar :== '\xA' +CRChar :== '\xD' + +//isNewLine c :== c == LFChar || c == CRChar +isNewLine :: !Char -> Bool +isNewLine LFChar = True +isNewLine CRChar = True +isNewLine _ = False + + //------------------------// + //--- Offside handling ---// +//------------------------// + +UseLayout :: !ScanState -> (!Bool, !ScanState) +UseLayout scanState = scanState!ss_useLayout + +setUseLayout :: !Bool !ScanState -> ScanState +setUseLayout b ss = { ss & ss_useLayout = b } // -->> ("uselayout set to ",b) + +checkOffside :: !FilePosition !Token !ScanState -> (Token,ScanState) +checkOffside pos token scanState=:{ss_offsides,ss_useLayout,ss_input} + | ~ ss_useLayout + = (token, scanState) //-->> (token,pos,"No layout rule applied") + | isEmpty ss_offsides + = newOffside token scanState //-->> "Empty offside stack" + # (os_col, new_def) = hd ss_offsides + col = pos.fp_col + | col == os_col && canBeOffside token + # scanState = tokenBack scanState + newToken = NewDefinitionToken + = ( newToken + , { scanState + & ss_tokenBuffer + = store + { lt_position = pos + , lt_token = newToken + // , lt_chars = [] + // , lt_context = FunctionContext + } + scanState.ss_tokenBuffer + } + ) -->> (token,"NewDefinitionToken generated col==os && canBeOffside",pos,ss_offsides) + | col < os_col && token <> InToken + # (n,os_col,offsides) = scan_offsides 0 col os_col ss_offsides + scanState = { scanState & ss_offsides = offsides } -->> (n,"end groups",offsides,new_def) + scanState = snd (newOffside token scanState) + scanState = case new_def && col == os_col && canBeOffside token of + True + # scanState = tokenBack scanState + newToken = NewDefinitionToken + -> { scanState + & ss_tokenBuffer + = store + { lt_position = pos + , lt_token = newToken + // , lt_chars = [] + // , lt_context = FunctionContext + } + scanState.ss_tokenBuffer + } -->> ("new definition generated",token) + False + -> scanState + = gen_end_groups n scanState + with + newToken = EndGroupToken + scan_offsides n col os_col [] + = (n, os_col, []) + scan_offsides n col _ offsides=:[(os_col,b):r] + | col < os_col + = scan_offsides (inc n) col os_col r + = (n, os_col, offsides) + gen_end_groups n scanState + # scanState = tokenBack scanState // push current token back + scanState = { scanState + & ss_tokenBuffer + = store + { lt_position = pos + , lt_token = newToken + // , lt_chars = [] + // , lt_context = FunctionContext + } + scanState.ss_tokenBuffer + } // insert EndGroupToken + | n == 1 + // # (new_offsides, scanState) = scanState!ss_offsides // for tracing XXX + = (newToken, scanState) // -->> ("new offsides",new_offsides) + = gen_end_groups (dec n) scanState + | token == InToken + # scanState = tokenBack { scanState & ss_offsides = tl ss_offsides } + newToken = EndGroupToken + = ( newToken + , { scanState + & ss_tokenBuffer + = store + { lt_position = pos + , lt_token = newToken + // , lt_chars = [] + // , lt_context = FunctionContext + } + scanState.ss_tokenBuffer + } + ) -->> (token,"EndGroupToken generated: in",pos,ss_offsides) + // otherwise + = newOffside token scanState +where + newOffside token scanState=:{ss_offsides} + | definesOffside token + # ( _, scanState ) = nextToken FunctionContext scanState + ( os_pos, scanState ) = getPosition scanState // next token defines offside position + scanState = tokenBack scanState + os = os_pos.fp_col + | os == 1 + # scanState = tokenBack scanState + newToken = ErrorToken "groups should not start in column 1" + = ( newToken + , { scanState + & ss_tokenBuffer + = store + { lt_position = pos + , lt_token = newToken + // , lt_chars = ['groups should not start in column 1'] + // , lt_context = FunctionContext + } + scanState.ss_tokenBuffer + } + ) + // otherwise // os <> 1 + = ( token + , { scanState + & ss_offsides = [ (os, needsNewDefinitionToken token) : ss_offsides ] + } + ) -->> (token,pos,"New offside defined at ",os_pos,[ (os, token == CaseToken) : ss_offsides ]) + // otherwise // ~ (definesOffside token) + = (token, scanState) -->> (token,pos," not offside") + +definesOffside :: !Token -> Bool +definesOffside (LetToken _) = True +definesOffside (SeqLetToken _) = True +definesOffside WhereToken = True +definesOffside WithToken = True +definesOffside SpecialToken = True +definesOffside OfToken = True +//definesOffside BarToken = True // There are too many BarTokens in Clean +definesOffside _ = False + +needsNewDefinitionToken :: !Token -> Bool +needsNewDefinitionToken OfToken = True +//needsNewDefinitionToken WithToken = True +needsNewDefinitionToken SpecialToken = True +needsNewDefinitionToken _ = False +/* +repeatedOffside :: !Token -> Bool +repeatedOffside BarToken = True +repeatedOffside EqualToken = True +repeatedOffside (SeqLetToken _) = True +repeatedOffside _ = False +*/ +canBeOffside :: !Token -> Bool +canBeOffside EqualToken = False +canBeOffside ColonDefinesToken = False +canBeOffside DefinesColonToken = False +canBeOffside (SeqLetToken _) = False +canBeOffside WhereToken = False +canBeOffside SpecialToken = False +canBeOffside WithToken = False +canBeOffside BarToken = False +//canBeOffside CurlyOpenToken = False // not allowed for record patterns +canBeOffside (CodeBlockToken _) = False +canBeOffside _ = True + +dropOffsidePosition :: !ScanState -> ScanState +dropOffsidePosition scanState=:{ss_offsides} = { scanState & ss_offsides = drop 1 ss_offsides } + +/* +addOffsidePosition :: !ScanState -> (Int, ScanState) +addOffsidePosition scanState=:{ss_useLayout} + | ss_useLayout + # (position,scanState=:{ss_offsides}) = getPosition scanState + new_offside = position.fp_col + = (new_offside, { scanState & ss_offsides = [(new_offside,False): ss_offsides] }) + | otherwise + = (1, scanState) + +atOffsidePosition :: !ScanState -> (!Bool, !ScanState) +atOffsidePosition scanState=:{ss_offsides=[(col,_):_]} + # (position, scanState) = getPosition scanState + = (position.fp_col == col, scanState) -->> ("atOffsidePosition",position.fp_col,col) +atOffsidePosition scanState + = (False, scanState) +*/ + //-----------------------// + //--- Buffer handling ---// +//-----------------------// + +store :: !x !(Buffer x) -> Buffer x +store x Buffer0 = Buffer1 x +store x (Buffer1 y) = Buffer2 x y +store x (Buffer2 y z) = Buffer3 x y z +store x (Buffer3 y z _) = Buffer3 x y z + +isEmptyBuffer :: !(Buffer x) -> Bool +isEmptyBuffer Buffer0 = True +isEmptyBuffer _ = False + +get :: !(Buffer x) -> (x,Buffer x) +get Buffer0 = abort "get from empty buffer" +get (Buffer1 x) = (x, Buffer0) +get (Buffer2 x y) = (x, Buffer1 y) +get (Buffer3 x y z) = (x, Buffer2 y z) + +head :: !(Buffer x) -> x +head Buffer0 = abort "head of empty buffer" +head (Buffer1 x) = x +head (Buffer2 x _) = x +head (Buffer3 x _ _) = x + +instance <<< (Buffer a) | <<< a +where + (<<<) file Buffer0 = file <<< "Empty buffer" + (<<<) file (Buffer1 x) = file <<< "Buffer1 (" <<< x <<< ")" + (<<<) file (Buffer2 x y) = file <<< "Buffer2 (" <<< x <<< ") (" <<< y <<< ")" + (<<<) file (Buffer3 x y z) = file <<< "Buffer3 (" <<< x <<< ") (" <<< y <<< ") (" <<< z <<< ")" + + //---------------// + //--- Tracing ---// +//---------------// + +(-->>) val _ :== val +//(-->>) val message :== val ---> ("Scanner",message) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl new file mode 100644 index 0000000..6b0e72a --- /dev/null +++ b/frontend/syntax.dcl @@ -0,0 +1,1192 @@ +definition module syntax + +import StdEnv + +import scanner, general, typeproperties, Heap + +:: Ident = + { id_name :: !String + , id_info :: !SymbolPtr + } + +instance toString Ident + + +/* Each Identifier is equipped with a pointer to a SymbolTableEntry that is + used for binding the identifier with its definition. +*/ + +:: SymbolTable :== Heap SymbolTableEntry +:: SymbolPtr :== Ptr SymbolTableEntry + +:: SymbolTableEntry = + { ste_kind :: !STE_Kind + , ste_index :: !Index + , ste_def_level :: !Level + , ste_previous :: SymbolTableEntry + } + +:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr} + +:: STE_Kind = STE_FunctionOrMacro ![Index] + | STE_Type + | STE_Constructor + | STE_Selector ![Global Index] + | STE_Field !Ident + | STE_Class + | STE_Member + | STE_Instance + | STE_Variable !VarInfoPtr + | STE_TypeVariable !TypeVarInfoPtr + | STE_TypeAttribute !AttrVarInfoPtr + | STE_BoundTypeVariable !STE_BoundTypeVariable + | STE_BoundType !AType + | STE_Imported !STE_Kind !Index + | STE_DclFunction + | STE_Module !(Module (CollectedDefinitions ClassInstance IndexRange)) + | STE_OpenModule !Int !(Module (CollectedDefinitions ClassInstance IndexRange)) + | STE_ClosedModule + | STE_LockedModule + | STE_Empty + /* for creating class dictionaries */ + | STE_DictType !CheckedTypeDef + | STE_DictCons !ConsDef + | STE_DictField !SelectorDef + | STE_Called ![Index] /* used during macro expansion to indicate that this function is called */ + +:: Global object = + { glob_object :: !object + , glob_module :: !Index + } + +:: Module defs = + { mod_name :: !Ident + , mod_type :: !ModuleKind + , mod_imports :: ![ParsedImport] +// RWS ... + , mod_imported_objects :: ![ImportedObject] +// ... RWS +// , mod_exports :: ![Export] + , mod_defs :: !defs + } + +:: ParsedModule :== Module [ParsedDefinition] +:: ScannedModule :== Module (CollectedDefinitions (ParsedInstance FunDef) IndexRange) + + +:: ModuleKind = MK_Main | MK_Module | MK_System | MK_None + +:: RhsDefsOfType = ConsList ![ParsedConstructor] + | SelectorList !Ident ![ATypeVar] ![ParsedSelector] + | TypeSpec !AType + | EmptyRhs !BITVECT + + +:: CollectedDefinitions instance_kind macro_defs = + { def_types :: ![TypeDef TypeRhs] + , def_constructors :: ![ParsedConstructor] + , def_selectors :: ![ParsedSelector] + , def_macros :: !macro_defs + , def_classes :: ![ClassDef] + , def_members :: ![MemberDef] + , def_funtypes :: ![FunType] + , def_instances :: ![instance_kind] + } + +:: LocalDefs = LocalParsedDefs [ParsedDefinition] + | CollectedLocalDefs CollectedLocalDefs + +:: IndexRange = { ir_from :: !Index, ir_to :: !Index } + +:: Index :== Int +NoIndex :== -1 + + +:: Level :== Int +NotALevel :== -1 + +:: CollectedLocalDefs = + { loc_functions :: !IndexRange + , loc_nodes :: ![(Optional SymbolType, NodeDef ParsedExpr)] + } + +:: NodeDef dst = + { nd_dst ::!dst, + nd_alts ::!OptGuardedAlts, + nd_locals ::!LocalDefs + } + +:: Rhs = + { rhs_alts :: !OptGuardedAlts + , rhs_locals :: !LocalDefs + } + + +cIsAFunction :== True +cIsNotAFunction :== False + +:: ParsedDefinition + = PD_Function Position Ident Bool [ParsedExpr] Rhs FunKind + | PD_NodeDef Position ParsedExpr Rhs + | PD_Type ParsedTypeDef + | PD_TypeSpec Position Ident Priority (Optional SymbolType) Specials + | PD_Class ClassDef [ParsedDefinition] + | PD_Instance (ParsedInstance ParsedDefinition) + | PD_Instances [ParsedInstance ParsedDefinition] + | PD_Import [ParsedImport] +// RWS ... + | PD_ImportedObjects [ImportedObject] +// ... RWS + | PD_Erroneous + +:: FunKind = FK_Function | FK_Macro | FK_Caf | FK_Unknown + +:: ParsedSelector = + { ps_field_name :: !Ident + , ps_selector_name :: !Ident + , ps_field_type :: !AType + , ps_field_var :: !Ident + , ps_field_pos :: !Position + } + +:: ParsedConstructor = + { pc_cons_name :: !Ident + , pc_cons_arity :: !Int + , pc_exi_vars :: ![ATypeVar] + , pc_arg_types :: ![AType] + , pc_cons_prio :: !Priority + , pc_cons_pos :: !Position + } + +:: ParsedInstance member = + { pi_class :: !Ident + , pi_ident :: !Ident + , pi_types :: ![Type] + , pi_context :: ![TypeContext] + , pi_pos :: !Position + , pi_members :: ![member] + , pi_specials :: !Specials + } + +/* + Objects of type Specials are used to specify specialized instances of overloaded functions. + These can only occur in definition modules. After parsing the SP_ParsedSubstitutions alternative + is used to indicate the specific instantiation. The SP_Substitutions alternative is used to deduce + the type of the specialized version. Finally the SP_ContextTypes alternative is set and used during + the typing to check whether the this instance has been used. The auxiliary SP_Index alternative is used + to store the index of the function that has been specialized. +*/ + + +:: Specials + = SP_ParsedSubstitutions ![Env Type TypeVar] + | SP_Substitutions ![SpecialSubstitution] + | SP_ContextTypes ![Special] + | SP_FunIndex !Index + | SP_TypeOffset !Int + | SP_None + +:: SpecialSubstitution = + { ss_environ :: !Env Type TypeVar + , ss_context :: ![TypeContext] + , ss_vars :: ![TypeVar] + , ss_attrs :: ![AttributeVar] + } + +:: Special = + { spec_index :: !Global Index + , spec_types :: ![[Type]] + , spec_vars :: ![TypeVar] + , spec_attrs :: ![AttributeVar] + } + +:: AttrInequality = + { ai_demanded :: !AttributeVar + , ai_offered :: !AttributeVar + } + + +:: DefinedSymbol = + { ds_ident :: !Ident + , ds_arity :: !Int + , ds_index :: !Index + } + +:: ClassDef = + { class_name :: !Ident + , class_arity :: !Int + , class_args :: ![TypeVar] + , class_context :: ![TypeContext] + , class_members :: !{# DefinedSymbol} + , class_dictionary :: !DefinedSymbol + , class_pos :: !Position + , class_cons_vars :: !BITVECT + } + +:: MemberDef = + { me_symb :: !Ident + , me_class :: !Global Index + , me_offset :: !Index + , me_type :: !SymbolType + , me_type_ptr :: !VarInfoPtr + , me_class_vars :: ![TypeVar] + , me_pos :: !Position + , me_priority :: !Priority + } + +:: InstanceType = + { it_vars :: [TypeVar] + , it_types :: ![Type] + , it_attr_vars :: [AttributeVar] + , it_context :: ![TypeContext] + } + +:: ClassInstance = + { ins_class :: !Global DefinedSymbol + , ins_ident :: !Ident + , ins_type :: !InstanceType + , ins_members :: !{# DefinedSymbol} + , ins_specials :: !Specials + , ins_pos :: !Position + } + +/* +:: Export = + { export_class :: Ident + , export_types :: [Type] + } +*/ +:: Import from_symbol = + { import_module :: !Ident + , import_symbols :: ![from_symbol] + , import_file_position:: !(!FileName, !Int) // for error messages // MW++ + } + +instance toString (Import from_symbol), AttributeVar, TypeAttribute, Annotation + +:: ParsedImport :== Import ImportDeclaration + +:: ImportedIdent = + { ii_ident :: !Ident + , ii_extended :: !Bool + } + +:: ImportDeclaration = ID_Function !ImportedIdent + | ID_Class !ImportedIdent !(Optional [ImportedIdent]) + | ID_Type !ImportedIdent !(Optional [ImportedIdent]) + | ID_Record !ImportedIdent !(Optional [ImportedIdent]) + | ID_Instance !ImportedIdent !Ident !(![Type],![TypeContext]) + +/* MOVE +:: ExplicitImports :== (![AtomicImport], ![StructureImport]) +:: AtomicImport :== (!Ident, !AtomType) +:: StructureImport :== (!Ident, !StructureInfo, !StructureType, !OptimizeInfo) + +:: AtomType = AT_Function | AT_Class | AT_Instance | AT_RecordType | AT_AlgType | AT_Type + +:: StructureInfo = SI_DotDot + // The .. notation was used for the structure + // (currently nothing is known about the elements) + | SI_Elements ![Ident] !Bool + // list of elements, that were not imported yet. + // Bool: the elements were listed explicitly in the structure +:: StructureType = ST_AlgType | ST_RecordType | ST_Class + +:: IdentWithKind :== (!Ident, !STE_Kind) +:: IdentWithCKind :== (!Ident, !ConsequenceKind) + +:: OptimizeInfo :== (Optional !Index) +*/ + +// RWS ... +cIsImportedLibrary :== True +cIsImportedObject :== False +:: ImportedObject = + { io_is_library :: !Bool + , io_name :: !{#Char} + } +// ... RWS + +:: RecordType = + { rt_constructor :: !DefinedSymbol + , rt_fields :: !{# FieldSymbol} + } + +:: FieldSymbol = + { fs_name :: !Ident + , fs_var :: !Ident + , fs_index :: !Index + } + +:: TypeRhs = AlgType ![DefinedSymbol] + | SynType !AType + | RecordType !RecordType + | AbstractType !BITVECT + | UnknownType + +:: ParsedTypeDef :== TypeDef RhsDefsOfType +:: CheckedTypeDef :== TypeDef TypeRhs + +/* +cIsHyperStrict :== True +cIsNotHyperStrict :== False +*/ + +cAllBitsClear :== 0 + +cIsHyperStrict :== 1 +cIsNonCoercible :== 2 +// cMayBeNonCoercible :== 4 + +:: TypeDef type_rhs = + { td_name :: !Ident + , td_index :: !Int + , td_arity :: !Int + , td_args :: ![ATypeVar] + , td_attrs :: ![AttributeVar] + , td_context :: ![TypeContext] + , td_rhs :: !type_rhs + , td_attribute :: !TypeAttribute + , td_pos :: !Position + } + +:: TypeDefInfo = + { tdi_kinds :: ![TypeKind] + , tdi_properties :: !BITVECT + , tdi_group :: ![Global Index] + , tdi_group_nr :: !Int + , tdi_group_vars :: ![Int] + , tdi_cons_vars :: ![Int] + , tdi_classification :: !TypeClassification + } + +:: TypeDefInfos :== {# .{# TypeDefInfo}} + +:: FunType = + { ft_symb :: !Ident + , ft_arity :: !Int + , ft_priority :: !Priority + , ft_type :: !SymbolType + , ft_pos :: !Position + , ft_specials :: !Specials + , ft_type_ptr :: !VarInfoPtr + } + +:: FreeVar = + { fv_def_level :: !Level + , fv_name :: !Ident + , fv_info_ptr :: !VarInfoPtr +// , fv_expr_ptr :: !ExprInfoPtr + , fv_count :: !Int + } + +:: FunCall = + { fc_level :: !Level + , fc_index :: !Index + } + +:: FunInfo = + { fi_calls :: ![FunCall] + , fi_group_index :: !Index + , fi_def_level :: !Level + , fi_free_vars :: ![FreeVar] + , fi_local_vars :: ![FreeVar] + , fi_dynamics :: ![ExprInfoPtr] + } + +:: ParsedBody = + { pb_args :: ![ParsedExpr] + , pb_rhs :: !Rhs + } + +:: CheckedBody = + { cb_args :: ![FreeVar] + , cb_rhs :: ![Expression] + } + +:: TransformedBody = + { tb_args :: ![FreeVar] + , tb_rhs :: !Expression + } + +:: FunctionBody = ParsedBody ![ParsedBody] + | CheckedBody !CheckedBody + /* The next three constructors are used during macro expansion (module transform) */ + | PartioningMacro + | PartioningFunction !CheckedBody !Int + | RhsMacroBody !CheckedBody + /* macro expansion transforms a CheckedBody into a TransformedBody */ + | TransformedBody !TransformedBody + | Expanding + | BackendBody ![BackendBody] + +:: BackendBody = + { bb_args :: ![FunctionPattern] + , bb_rhs :: !Expression + } + +:: FunDef = + { fun_symb :: !Ident + , fun_arity :: !Int + , fun_priority :: !Priority + , fun_body :: !FunctionBody + , fun_type :: !Optional SymbolType + , fun_pos :: !Position + , fun_index :: !Int + , fun_kind :: !FunKind + , fun_lifted :: !Int +// , fun_type_ptr :: !TypeVarInfoPtr + , fun_info :: !FunInfo + } + +cIsAGlobalVar :== True +cIsALocalVar :== False + +:: ConsClasses = + { cc_size ::!Int + , cc_args ::![ConsClass] + } + +:: ConsClass :== Int + +:: OptionalVariable :== Optional (Bind Ident VarInfoPtr) + +:: AuxiliaryPattern + = AP_Algebraic !(Global DefinedSymbol) !Index [AuxiliaryPattern] OptionalVariable + | AP_Variable !Ident !VarInfoPtr OptionalVariable + | AP_Basic !BasicValue OptionalVariable + | AP_Dynamic !AuxiliaryPattern !DynamicType !OptionalVariable + | AP_Constant !AP_Kind !(Global DefinedSymbol) !Priority + | AP_WildCard OptionalVariable + | AP_Empty !Ident + +:: AP_Kind = APK_Constructor !Index | APK_Macro + +:: VarInfo = VI_Empty | VI_Type !AType | VI_Occurrence !Occurrence | VI_UsedVar (!Ident, ![Int]) | + VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr | + VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ | + VI_AccVar !ConsClass /* used during fusion to determine accumulating parameters of functions */ | + VI_Alias !BoundVar /* used for resolving aliases just before type checking (in transform) */ | + /* used during elimination and lifting of cases */ + VI_FreeVar !Ident !VarInfoPtr !Int !AType | VI_BoundVar !AType | VI_LocalVar | + VI_Forward !BoundVar | VI_LetVar !LetVarInfo | VI_LetExpression !LetExpressionInfo | VI_CaseVar !VarInfoPtr | + VI_CorrespondenceNumber !Int | VI_SequenceNumber !Int | + VI_Used | /* for indicating that an imported function has been used */ + VI_PropagationType !SymbolType | /* for storing the type with propagation environment of an imported function */ + VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */ + VI_Record ![AuxiliaryPattern] | + VI_Pattern !AuxiliaryPattern | + VI_Default !Int /* used during conversion of dynamics; the Int indiacted the refenrence count */ + +:: VarInfoPtr :== Ptr VarInfo + +:: LetVarInfo = + { lvi_count :: !Int + , lvi_depth :: !Int + , lvi_new :: !Bool + , lvi_var :: !Ident + , lvi_expression :: !Expression + , lvi_previous :: ![PreviousLetVarInfo] + } + +:: PreviousLetVarInfo = + { plvi_count :: !Int + , plvi_depth :: !Int + , plvi_new :: !Bool + } + +:: LetExpressionStatus = LES_Untouched | LES_Moved | LES_Updated !Expression + +:: LetExpressionInfo = + { lei_count :: !Int + , lei_depth :: !Int + , lei_strict :: !Bool + , lei_var :: !FreeVar + , lei_expression :: !Expression +// , lei_moved :: !Bool +// , lei_updated_expr :: !Optional Expression + , lei_status :: !LetExpressionStatus + , lei_type :: !AType + } + +cNotVarNumber :== -1 + +:: BoundVar = + { var_name :: !Ident + , var_info_ptr :: !VarInfoPtr + , var_expr_ptr :: !ExprInfoPtr + } + +/* +cRecursiveAppl :== True +cNonRecursiveAppl :== False + +:: ApplicationKind :== Bool +*/ + +:: TypeSymbIdent = + { type_name :: !Ident +// , type_appl_kind :: !ApplicationKind + , type_arity :: !Int + , type_index :: !Global Index + , type_prop :: !TypeSymbProperties + } + +:: TypeSymbProperties = + { tsp_sign :: !SignClassification + , tsp_propagation :: !PropClassification + , tsp_coercible :: !Bool + } + +:: SymbKind = SK_Unknown + | SK_Function !(Global Index) + | SK_OverloadedFunction !(Global Index) + | SK_Constructor !(Global Index) + | SK_Macro !(Global Index) +// | SK_RecordSelector !(Global Index) + | SK_GeneratedFunction !FunctionInfoPtr !Index + | SK_TypeCode + +// MW2 moved some type definitions + +/* Some auxiliary type definitions used during fusion. Actually, these definitions + should have been given in seperate module. Unfortunately, Clean's module system + forbids cyclic dependencies between def modules. + +*/ + +:: FunctionHeap :== Heap FunctionInfo + +:: FunctionInfoPtr :== Ptr FunctionInfo + +:: FunctionInfo = FI_Empty | FI_Function !GeneratedFunction + +:: Producer = PR_Empty + | PR_Function !SymbIdent !Index + | PR_Class !App ![BoundVar] ![Type] +// | PR_Constructor !SymbIdent ![Expression] + | PR_GeneratedFunction !SymbIdent !Index + +:: InstanceInfo = II_Empty | II_Node !{! Producer} !FunctionInfoPtr !InstanceInfo !InstanceInfo + +:: GeneratedFunction = + { gf_fun_def :: !FunDef + , gf_instance_info :: !InstanceInfo + , gf_cons_args :: !ConsClasses + , gf_fun_index :: !Index + } + +/* ... main type definitions continued .... */ + +:: ExpressionHeap :== Heap ExprInfo + +:: ExprInfoPtr :== Ptr ExprInfo + +:: TempLocalVar :== Int + +:: DynamicPtr :== ExprInfoPtr + +:: ExprInfo = EI_Empty + + /* For handling overloading */ + + | EI_Overloaded !OverloadedCall /* initial, set by the type checker */ + | EI_Instance !(Global DefinedSymbol) ![Expression] /* intermedediate, used during resolving of overloading */ + | EI_Selection ![Selection] !BoundVar ![Expression] /* intermedediate, used during resolving of overloading */ + | EI_Context ![Expression] /* intermedediate, used during resolving of overloading */ + + /* For handling dynamics */ + + | EI_Dynamic !(Optional DynamicType) + | EI_DynamicType !DynamicType ![DynamicPtr] +// | EI_DynamicType !DynamicType !(Optional ExprInfoPtr) + + /* Auxiliary, was EI_DynamicType before checking */ + + | EI_DynamicTypeWithVars ![TypeVar] !DynamicType ![DynamicPtr] +// | EI_DynamicTypeWithVars ![TypeVar] !DynamicType !(Optional ExprInfoPtr) + + /* Auxiliary, used during type checking */ + + | EI_TempDynamicType !(Optional DynamicType) !AType ![TypeContext] !ExprInfoPtr !SymbIdent +// | EI_TempDynamicPattern ![TypeVar] !DynamicType !(Optional ExprInfoPtr) ![TempLocalVar] !AType ![TypeContext] !ExprInfoPtr !SymbIdent + | EI_TempDynamicPattern ![TypeVar] !DynamicType ![DynamicPtr] ![TempLocalVar] !AType ![TypeContext] !ExprInfoPtr !SymbIdent + + | EI_TypeOfDynamic ![VarInfoPtr] !TypeCodeExpression /* Final */ + | EI_TypeOfDynamicPattern ![VarInfoPtr] !TypeCodeExpression /* Final */ + + | EI_TypeCode !TypeCodeExpression + | EI_TypeCodes ![TypeCodeExpression] + + | EI_Attribute !Int + + + /* EI_ClassTypes is used to store the instance types of a class These type are used during fusion to generate proper types for + the fusion result (i.e. the resulting function after elimination of dictionaries) */ + + | EI_ClassTypes ![Type] + | EI_CaseType !CaseType + | EI_LetType ![AType] + | EI_CaseTypeAndRefCounts !CaseType !RefCountsInCase + | EI_LetTypeAndRefCounts ![AType] ![Int] + + /* for converting case into function patterns the following auxiliary constuctors are used */ + + | EI_Default !Expression !AType !ExprInfoPtr + | EI_DefaultFunction !SymbIdent ![Expression] + +:: RefCountsInCase = + { rcc_all_variables :: ![CountedVariable] + , rcc_default_variables :: ![CountedVariable] + , rcc_pattern_variables :: ![[CountedVariable]] + } + +:: CountedVariable = + { cv_variable :: !VarInfoPtr + , cv_count :: !Int + } + +/* +:: UnboundVariable = + { free_name :: !Ident + , free_info_ptr :: !VarInfoPtr + , free_selections :: ![Int] + } +*/ + +/* + OverloadedCall contains (type) information about functions that are overloaded. This structure is built during type checking + and used after (standard) unification to insert the proper instances of the corresponding functions. + +*/ + +:: OverloadedCall = + { oc_symbol :: !SymbIdent + , oc_context :: ![TypeContext] + , oc_specials :: ![Special] + } + +/* + CaseType contains the type information needed to type the corresponding case construct: + ct_pattern_type : the type of the pattern + ct_result_type : the type of the result (of each pattern) + ct_cons_types : the types of the arguments of each pattern constructor +*/ + +:: CaseType = + { ct_pattern_type :: !AType + , ct_result_type :: !AType + , ct_cons_types :: ![[AType]] + } + +:: SymbIdent = + { symb_name :: !Ident + , symb_kind :: !SymbKind + , symb_arity :: !Int + } + +:: ConsDef = + { cons_symb :: !Ident + , cons_type :: !SymbolType + , cons_arg_vars :: ![[ATypeVar]] + , cons_priority :: !Priority + , cons_index :: !Index + , cons_type_index :: !Index + , cons_exi_vars :: ![ATypeVar] +// , cons_exi_attrs :: ![AttributeVar] + , cons_type_ptr :: !VarInfoPtr + , cons_pos :: !Position + } + +:: SelectorDef = + { sd_symb :: !Ident + , sd_field :: !Ident + , sd_type :: !SymbolType + , sd_exi_vars :: ![ATypeVar] +// , sd_exi_attrs :: ![AttributeVar] + , sd_field_nr :: !Int + , sd_type_index :: !Int + , sd_type_ptr :: !VarInfoPtr + , sd_pos :: !Position + } + +:: SymbolType = + { st_vars :: ![TypeVar] + , st_args :: ![AType] + , st_arity :: !Int + , st_result :: !AType + , st_context :: ![TypeContext] + , st_attr_vars :: ![AttributeVar] + , st_attr_env :: ![AttrInequality] + } + +:: TypeContext = + { tc_class :: !Global DefinedSymbol + , tc_types :: ![Type] + , tc_var :: !VarInfoPtr + } + +:: AType = + { at_attribute :: !TypeAttribute + , at_annotation :: !Annotation + , at_type :: !Type + } + +:: TempAttrId :== Int +:: TempVarId :== Int + + +:: Type = TA !TypeSymbIdent ![AType] + | (-->) infixr 9 !AType !AType + | (:@:) infixl 9 !ConsVariable ![AType] + | TB !BasicType + +// | TFA [ATypeVar] Type + + | GTV !TypeVar + | TV !TypeVar + | TempV !TempVarId /* Auxiliary, used during type checking */ + + + | TQV TypeVar + | TempQV !TempVarId /* Auxiliary, used during type checking */ + + | TLifted !TypeVar /* Auxiliary, used during type checking of lifted arguments */ + | TE + +:: ConsVariable = CV !TypeVar + | TempCV !TempVarId + | TempQCV !TempVarId + +:: DynamicType = + { dt_uni_vars :: ![ATypeVar] + , dt_global_vars :: ![TypeVar] + , dt_type :: !AType + } + +:: KindHeap :== Heap KindInfo +:: KindInfoPtr :== Ptr KindInfo + +:: KindInfo = KI_Var !KindInfoPtr + | KI_Indirection !KindInfo + | KI_Arrow ![KindInfo] + | KI_Const + + | KI_ConsVar + + | KI_VarBind !KindInfoPtr + | KI_NormVar !Int + +:: TypeVarInfo = TVI_Empty + | TVI_Type !Type + | TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr + | TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo + | TVI_Attribute TypeAttribute + | TVI_CorrespondenceNumber !Int + | TVI_Used /* to administer that this variable is encountered (in checkOpenTypes) */ +// | TVI_Clean !Int /* to keep the unique number that has been assigned to this variable during 'clean_up' */ + | TVI_TypeCode !TypeCodeExpression + +:: TypeVarInfoPtr :== Ptr TypeVarInfo +:: TypeVarHeap :== Heap TypeVarInfo + +:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId +:: AttrVarInfoPtr :== Ptr AttrVarInfo +:: AttrVarHeap :== Heap AttrVarInfo + +:: TypeHeaps = + { th_vars :: ! .TypeVarHeap + , th_attrs :: ! .AttrVarHeap + } + +:: TypeVar = + { tv_name :: !Ident + , tv_info_ptr :: !TypeVarInfoPtr + } + +:: ATypeVar = + { atv_attribute :: !TypeAttribute + , atv_annotation :: !Annotation + , atv_variable :: !TypeVar + } + +:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar !AttributeVar | TA_TempVar !Int /* | TA_TempExVar !Int */ + | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute | TA_Omega + +:: AttributeVar = + { av_name :: !Ident + , av_info_ptr :: !AttrVarInfoPtr + } + +:: Annotation = AN_Strict | AN_None + +:: BasicType = BT_Int | BT_Char | BT_Real | BT_Bool | BT_Dynamic + | BT_File | BT_World + | BT_String !Type /* the internal string type synonym only used to type string denotations */ + +:: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String + + +:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow !Int + +/* A few obscure type definitions */ + +:: Occurrence = + { occ_ref_count :: !ReferenceCount +// , occ_aliases :: ![[(FreeVar,Int)]] +// , occ_expression :: !Expression + , occ_bind :: !OccurrenceBinding + , occ_observing :: !Bool +// , occ_attribute :: !ExprInfoPtr + , occ_previous :: ![ReferenceCount] + } + +:: ReferenceCount = RC_Used !RC_Used | RC_Unused + +:: SelectiveUse = { su_field :: !Int, su_multiply :: ![ExprInfoPtr], su_uniquely :: ![ExprInfoPtr] } + +:: RC_Used = { rcu_multiply :: ![ExprInfoPtr], rcu_selectively :: ![SelectiveUse], rcu_uniquely :: ![ExprInfoPtr] } + +:: OccurrenceBinding = OB_Empty | OB_OpenLet !Expression | OB_LockedLet !Expression + | OB_Pattern ![(FreeVar, Int)] !OccurrenceBinding +// | OB_Closed !LetOccurrences | OB_Marked !LetOccurrences + +/* +:: LetOccurrences = + { lo_used_lets :: ![FreeVar] + , lo_free_variables :: ![(FreeVar, ReferenceCount)] + } +*/ +:: OptGuardedAlts = GuardedAlts ![GuardedExpr] !(Optional ExprWithLocalDefs) + | UnGuardedExpr !ExprWithLocalDefs + +:: GuardedExpr = + { alt_nodes :: ![NodeDefWithLocals] + , alt_guard :: !ParsedExpr + , alt_expr :: !OptGuardedAlts + } + +:: ExprWithLocalDefs = + { ewl_nodes :: ![NodeDefWithLocals] + , ewl_expr :: !ParsedExpr + , ewl_locals :: !LocalDefs + } + +:: NodeDefWithLocals = + { ndwl_strict :: !Bool + , ndwl_def :: !Bind ParsedExpr ParsedExpr + , ndwl_locals :: !LocalDefs + } + +:: CaseAlt = + { calt_pattern :: !ParsedExpr + , calt_rhs :: !Rhs + } + +:: LocalDef :== ParsedDefinition + +cUniqueSelection :== True +cNonUniqueSelection :== False + +:: ParsedExpr = PE_List ![ParsedExpr] + | PE_Ident !Ident + | PE_Basic !BasicValue + | PE_Bound !BoundExpr + | PE_Lambda !Ident ![ParsedExpr] !ParsedExpr + | PE_Tuple ![ParsedExpr] + | PE_Record !ParsedExpr !(Optional Ident) ![FieldAssignment] + | PE_Array !ParsedExpr ![ElemAssignment] ![Qualifier] + | PE_ArrayDenot ![ParsedExpr] + | PE_Selection !Bool !ParsedExpr ![ParsedSelection] + | PE_Update !ParsedExpr [ParsedSelection] ParsedExpr + | PE_Case !Ident !ParsedExpr [CaseAlt] + | PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr + | PE_Let !Bool !LocalDefs !ParsedExpr + | PE_Compr !GeneratorKind !ParsedExpr ![Qualifier] + | PE_Sequ Sequence + | PE_WildCard + | PE_Field !ParsedExpr !(Global FieldSymbol) /* Auxiliary, used during checking */ + + | PE_ABC_Code ![String] !Bool + | PE_Any_Code !(CodeBinding Ident) !(CodeBinding Ident) ![String] + + | PE_DynamicPattern !ParsedExpr !DynamicType + | PE_Dynamic !ParsedExpr !(Optional DynamicType) + | PE_Empty + +:: ParsedSelection = PS_Record !Ident !(Optional Ident) + | PS_Array !ParsedExpr + | PS_Erroneous + +:: GeneratorKind :== Bool + +cIsListGenerator :== True +cIsArrayGenerator :== False + +:: Generator = + { gen_kind :: !GeneratorKind + , gen_pattern :: !ParsedExpr + , gen_expr :: !ParsedExpr + , gen_var :: !Ident + } + +:: Qualifier = + { qual_generators :: ![Generator] + , qual_filter :: !Optional ParsedExpr + , qual_fun_id :: !Ident + } + +:: Sequence = SQ_FromThen ParsedExpr ParsedExpr + | SQ_FromThenTo ParsedExpr ParsedExpr ParsedExpr + | SQ_From ParsedExpr + | SQ_FromTo ParsedExpr ParsedExpr + +:: BoundExpr :== Bind ParsedExpr Ident + +:: FieldAssignment :== Bind ParsedExpr Ident + +:: ElemAssignment :== Bind ParsedExpr ParsedExpr + + +cIsStrict :== True +cIsNotStrict :== False + +/* +:: SelectorKind = SEK_Normal | SEK_First | SEK_Next | SEK_Last + +:: ArraySelector = DictionarySelection !(Global DefinedSymbol) !Int !Expression + | SelectorInstance !(Global DefinedSymbol) +*/ +:: Expression = Var !BoundVar + | App !App + | (@) infixl 9 !Expression ![Expression] + | Let !Let + | Case !Case +// | RecordSelect !SelectorKind !(Global DefinedSymbol) !Int !Expression +// | ArraySelect !SelectorKind !ArraySelector !Expression !Expression + | Selection !(Optional (Global DefinedSymbol)) !Expression ![Selection] + | Update !Expression ![Selection] Expression + | RecordUpdate !(Global DefinedSymbol) !Expression ![Bind Expression (Global FieldSymbol)] + | TupleSelect !DefinedSymbol !Int !Expression + | Lambda .[FreeVar] !Expression + | BasicExpr !BasicValue !BasicType + | WildCard + | Conditional !Conditional + + | AnyCodeExpr !(CodeBinding BoundVar) !(CodeBinding FreeVar) ![String] + | ABCCodeExpr ![String] !Bool + + | MatchExpr !(Optional (Global DefinedSymbol)) !(Global DefinedSymbol) !Expression + | FreeVar FreeVar + | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + + | DynamicExpr !DynamicExpr +// | TypeCase !TypeCase + + | TypeCodeExpression !TypeCodeExpression + | EE + + +:: CodeBinding variable :== Env String variable + +:: App = + { app_symb :: !SymbIdent + , app_args :: ![Expression] + , app_info_ptr :: !ExprInfoPtr + } + +:: Case = + { case_expr :: !Expression +// , case_guards :: ![PatternExpression] + , case_guards :: !CasePatterns + , case_default :: !Optional Expression + , case_ident :: !Optional Ident + , case_info_ptr :: !ExprInfoPtr + } + +:: Let = + { let_strict :: !Bool + , let_binds :: !(Env Expression FreeVar) + , let_expr :: !Expression + , let_info_ptr :: !ExprInfoPtr + } + +:: Conditional = + { if_cond :: !Expression + , if_then :: !Expression + , if_else :: !Optional Expression + } + +/* +:: Conditional = + { if_cond :: !Condition + , if_then :: !Expression + , if_else :: !Optional Expression + } + + +:: Condition = + { con_positive :: !Bool + , con_expression :: !Expression + } +*/ + +:: DynamicExpr = + { dyn_expr :: !Expression + , dyn_opt_type :: !Optional DynamicType + , dyn_info_ptr :: !ExprInfoPtr + , dyn_uni_vars :: ![VarInfoPtr] /* filled after type checking */ + , dyn_type_code :: !TypeCodeExpression /* filled after type checking */ + } + +:: CasePatterns = AlgebraicPatterns !(Global Index) ![AlgebraicPattern] + | BasicPatterns !BasicType [BasicPattern] + | DynamicPatterns [DynamicPattern] /* auxiliary */ + | NoPattern /* auxiliary */ + +:: Selection = RecordSelection !(Global DefinedSymbol) !Int + | ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression + | DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression + +:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr + +:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent | GTT_Function + +/* +:: PatternExpression = + { guard_pattern :: !GuardPattern + , guard_expr :: !Expression + } + +:: GuardPattern = BasicPattern !BasicValue | AlgebraicPattern !(Global DefinedSymbol) ![FreeVar] | VariablePattern !FreeVar +*/ + +:: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar) + | FP_Algebraic !(Global DefinedSymbol) ![FunctionPattern] !(Optional FreeVar) + | FP_Variable !FreeVar + | FP_Dynamic ![VarInfoPtr] !FreeVar !TypeCodeExpression !(Optional FreeVar) + | FP_Empty + +:: AlgebraicPattern = + { ap_symbol :: !(Global DefinedSymbol) + , ap_vars :: ![FreeVar] + , ap_expr :: !Expression + } + +:: BasicPattern = + { bp_value :: !BasicValue + , bp_expr :: !Expression + } + +:: TypeCase = + { type_case_dynamic :: !Expression + , type_case_patterns :: ![DynamicPattern] + , type_case_default :: !Optional Expression + , type_case_info_ptr :: !ExprInfoPtr + } + +:: DynamicPattern = + { dp_var :: !FreeVar + , dp_type :: !ExprInfoPtr + , dp_type_patterns_vars :: ![VarInfoPtr] /* filled after type checking */ + , dp_type_code :: !TypeCodeExpression /* filled after type checking */ + , dp_rhs :: !Expression + } + +/* + error handling +*/ + +:: Position = FunPos FileName LineNr FunctName + | LinePos FileName LineNr + | PreDefPos Ident + | NoPos + +:: IdentPos = + { ip_ident :: !Ident + , ip_line :: !Int + , ip_file :: !FileName + } + +:: FileName :== String + +:: FunctName :== String + +:: LineNr :== Int + +cNotALineNumber :== -1 + +/* Used for hashing identifiers */ + +instance == ModuleKind, Ident +instance <<< Module a | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, Global object | <<< object, + Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, Bind a b | <<< a & <<< b, ParsedConstructor, TypeDef a | <<< a, TypeVarInfo, + BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns, + Optional a | <<< a + +instance == TypeAttribute +instance == Annotation +/* +ErrorToString :: Error -> String + +*/ + +EmptySymbolTableEntry :== + { ste_kind = STE_Empty, ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" } + +cNotAGroupNumber :== -1 + +EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group = [], tdi_group_vars = [], tdi_cons_vars = [], + tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber } + +MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr } +MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr } + +MakeAttributedType type :== { at_attribute = TA_None, at_annotation = AN_None, at_type = type } +MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = type_var } + +EmptyFunInfo :== { fi_calls = [], fi_group_index = NoIndex, fi_def_level = NotALevel, + fi_free_vars = [], fi_local_vars = [], fi_dynamics = [] } + +BottomSignClass :== { sc_pos_vect = 0, sc_neg_vect = 0 } +PostiveSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } + +NoPropClass :== 0 +PropClass :== bitnot 0 + +MakeNewTypeSymbIdent name arity + :== MakeTypeSymbIdent { glob_object = NoIndex, glob_module = NoIndex } name arity + +MakeTypeSymbIdent type_index name arity + :== { type_name = name, type_arity = arity, type_index = type_index, + type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }} + +MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity } +MakeConstant name :== MakeSymbIdent name 0 + +ParsedSelectorToSelectorDef ps var_ptr :== + { sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos = ps.ps_field_pos, sd_type_index = NoIndex, + sd_exi_vars = [], /* sd_exi_attrs = [], */ sd_type_ptr = var_ptr, sd_field = ps.ps_field_name, + sd_type = { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [], + st_attr_env = [], st_attr_vars = [] }} + +ParsedConstructorToConsDef pc var_ptr :== + { cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex, + cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE, + st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []}, + cons_exi_vars = pc.pc_exi_vars, /* cons_exi_attrs = [], */ cons_type_ptr = var_ptr, cons_arg_vars = [] } + +ParsedInstanceToClassInstance pi members :== + { ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident, + ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [], + it_context = pi.pi_context }, ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos } + +MakeTypeDef name lhs rhs attr contexts pos :== + { td_name = name, td_index = -1, td_arity = length lhs, td_args = lhs, td_attrs = [], td_attribute = attr, td_context = contexts, + td_pos = pos, td_rhs = rhs } + +MakeDefinedSymbol ident index arity :== { ds_ident = ident, ds_arity = arity, ds_index = index } + +MakeNewFunctionType name arity prio type pos specials var_ptr + :== { ft_symb = name, ft_arity = arity, ft_priority = prio, ft_type = type, ft_pos = pos, ft_specials = specials, ft_type_ptr = var_ptr } + diff --git a/frontend/syntax.icl b/frontend/syntax.icl new file mode 100644 index 0000000..abf9140 --- /dev/null +++ b/frontend/syntax.icl @@ -0,0 +1,1774 @@ +implementation module syntax + +import StdEnv, compare_constructor + +import RWSDebug + +import scanner, general, Heap, typeproperties, utilities + +:: Ident = + { id_name :: !String + , id_info :: !SymbolPtr + } + +instance toString Ident +where toString {id_name} = id_name + +instance toString (Import from_symbol) +where toString {import_module} = toString import_module + + +/* Each Identifier is equipped with a pointer to a SymbolTableEntry that is + used for binding the identifier with its definition. +*/ + +:: SymbolTable :== Heap SymbolTableEntry +:: SymbolPtr :== Ptr SymbolTableEntry + +:: SymbolTableEntry = + { ste_kind :: !STE_Kind + , ste_index :: !Index + , ste_def_level :: !Level + , ste_previous :: SymbolTableEntry + } + +:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr} + +:: STE_Kind = STE_FunctionOrMacro ![Index] + | STE_Type + | STE_Constructor + | STE_Selector ![Global Index] + | STE_Field !Ident + | STE_Class + | STE_Member + | STE_Instance + | STE_Variable !VarInfoPtr + | STE_TypeVariable !TypeVarInfoPtr + | STE_TypeAttribute !AttrVarInfoPtr + | STE_BoundTypeVariable !STE_BoundTypeVariable + | STE_BoundType !AType + | STE_Imported !STE_Kind !Index + | STE_DclFunction + | STE_Module !(Module (CollectedDefinitions ClassInstance IndexRange)) + | STE_OpenModule !Int !(Module (CollectedDefinitions ClassInstance IndexRange)) + | STE_ClosedModule + | STE_LockedModule + | STE_Empty + | STE_DictType !CheckedTypeDef + | STE_DictCons !ConsDef + | STE_DictField !SelectorDef + | STE_Called ![Index] /* used during macro expansion to indicate that this function is called */ + +:: Global object = + { glob_object :: !object + , glob_module :: !Index + } + +:: Module defs = + { mod_name :: !Ident + , mod_type :: !ModuleKind + , mod_imports :: ![ParsedImport] +// RWS ... + , mod_imported_objects :: ![ImportedObject] +// ... RWS + , mod_defs :: !defs + } + +:: ParsedModule :== Module [ParsedDefinition] +:: ScannedModule :== Module (CollectedDefinitions (ParsedInstance FunDef) IndexRange) + + +:: ModuleKind = MK_Main | MK_Module | MK_System | MK_None + +:: RhsDefsOfType = ConsList ![ParsedConstructor] + | SelectorList !Ident ![ATypeVar] ![ParsedSelector] + | TypeSpec !AType + | EmptyRhs !BITVECT + + +:: CollectedDefinitions instance_kind macro_defs = + { def_types :: ![TypeDef TypeRhs] + , def_constructors :: ![ParsedConstructor] + , def_selectors :: ![ParsedSelector] + , def_macros :: !macro_defs + , def_classes :: ![ClassDef] + , def_members :: ![MemberDef] + , def_funtypes :: ![FunType] + , def_instances :: ![instance_kind] + } + +:: LocalDefs = LocalParsedDefs [ParsedDefinition] | CollectedLocalDefs CollectedLocalDefs + +:: IndexRange = { ir_from :: !Index, ir_to :: !Index } + +:: Index :== Int +NoIndex :== -1 + + +:: Level :== Int +NotALevel :== -1 + +:: CollectedLocalDefs = + { loc_functions :: !IndexRange + , loc_nodes :: ![(Optional SymbolType, NodeDef ParsedExpr)] + } + +:: NodeDef dst = + { nd_dst ::!dst, + nd_alts ::!OptGuardedAlts, + nd_locals ::!LocalDefs + } + +:: Rhs = + { rhs_alts :: !OptGuardedAlts + , rhs_locals :: !LocalDefs + } + +cIsAFunction :== True +cIsNotAFunction :== False + +:: ParsedDefinition + = PD_Function Position Ident Bool [ParsedExpr] Rhs FunKind + | PD_NodeDef Position ParsedExpr Rhs + | PD_Type ParsedTypeDef + | PD_TypeSpec Position Ident Priority (Optional SymbolType) Specials + | PD_Class ClassDef [ParsedDefinition] + | PD_Instance (ParsedInstance ParsedDefinition) + | PD_Instances [ParsedInstance ParsedDefinition] + | PD_Import [ParsedImport] +// RWS ... + | PD_ImportedObjects [ImportedObject] +// ... RWS + | PD_Erroneous + +:: FunKind = FK_Function | FK_Macro | FK_Caf | FK_Unknown + +:: ParsedSelector = + { ps_field_name :: !Ident + , ps_selector_name :: !Ident + , ps_field_type :: !AType + , ps_field_var :: !Ident + , ps_field_pos :: !Position + } + +:: ParsedConstructor = + { pc_cons_name :: !Ident + , pc_cons_arity :: !Int + , pc_exi_vars :: ![ATypeVar] + , pc_arg_types :: ![AType] + , pc_cons_prio :: !Priority + , pc_cons_pos :: !Position + } + +:: ParsedInstance member = + { pi_class :: !Ident + , pi_ident :: !Ident + , pi_types :: ![Type] + , pi_context :: ![TypeContext] + , pi_pos :: !Position + , pi_members :: ![member] + , pi_specials :: !Specials + } + + +:: Specials + = SP_ParsedSubstitutions ![Env Type TypeVar] + | SP_Substitutions ![SpecialSubstitution] + | SP_ContextTypes ![Special] + | SP_FunIndex !Index + | SP_TypeOffset !Int + | SP_None + +:: SpecialSubstitution = + { ss_environ :: !Env Type TypeVar + , ss_context :: ![TypeContext] + , ss_vars :: ![TypeVar] + , ss_attrs :: ![AttributeVar] + } + +:: Special = + { spec_index :: !Global Index + , spec_types :: ![[Type]] + , spec_vars :: ![TypeVar] + , spec_attrs :: ![AttributeVar] + } + + +:: AttrInequality = + { ai_demanded :: !AttributeVar + , ai_offered :: !AttributeVar + } + +:: DefinedSymbol = + { ds_ident :: !Ident + , ds_arity :: !Int + , ds_index :: !Index + } + +:: ClassSymbIdent = + { cs_name :: !Ident + , cs_arity :: !Int + , cs_index :: !Int + } + +:: ClassDef = + { class_name :: !Ident + , class_arity :: !Int + , class_args :: ![TypeVar] + , class_context :: ![TypeContext] + , class_members :: !{# DefinedSymbol} + , class_dictionary :: !DefinedSymbol + , class_pos :: !Position + , class_cons_vars :: !BITVECT + } + +:: MemberDef = + { me_symb :: !Ident + , me_class :: !Global Index + , me_offset :: !Index + , me_type :: !SymbolType + , me_type_ptr :: !VarInfoPtr + , me_class_vars :: ![TypeVar] + , me_pos :: !Position + , me_priority :: !Priority + } + + +:: InstanceType = + { it_vars :: [TypeVar] + , it_types :: ![Type] + , it_attr_vars :: [AttributeVar] + , it_context :: ![TypeContext] + } + +:: ClassInstance = + { ins_class :: !Global DefinedSymbol + , ins_ident :: !Ident + , ins_type :: !InstanceType + , ins_members :: !{# DefinedSymbol} + , ins_specials :: !Specials + , ins_pos :: !Position + } + +:: Import from_symbol = + { import_module :: !Ident + , import_symbols :: ![from_symbol] + , import_file_position:: !(!FileName, !Int) // for error messages // MW++ + } + +:: ParsedImport :== Import ImportDeclaration + +:: ImportedIdent = + { ii_ident :: !Ident + , ii_extended :: !Bool + } + +:: ImportDeclaration = ID_Function !ImportedIdent + | ID_Class !ImportedIdent !(Optional [ImportedIdent]) + | ID_Type !ImportedIdent !(Optional [ImportedIdent]) + | ID_Record !ImportedIdent !(Optional [ImportedIdent]) + | ID_Instance !ImportedIdent !Ident !(![Type],![TypeContext]) + +// MW2 moved some type definitions + +// RWS ... +cIsImportedLibrary :== True +cIsImportedObject :== False +:: ImportedObject = + { io_is_library :: !Bool + , io_name :: !{#Char} + } +// ... RWS + +:: RecordType = + { rt_constructor :: !DefinedSymbol + , rt_fields :: !{# FieldSymbol} + } + +:: FieldSymbol = + { fs_name :: !Ident + , fs_var :: !Ident + , fs_index :: !Index + } + + +:: TypeRhs = AlgType ![DefinedSymbol] + | SynType !AType + | RecordType !RecordType + | AbstractType !BITVECT + | UnknownType + +:: ParsedTypeDef :== TypeDef RhsDefsOfType +:: CheckedTypeDef :== TypeDef TypeRhs + +cAllBitsClear :== 0 + +cIsHyperStrict :== 1 +cIsNonCoercible :== 2 +cMayBeNonCoercible :== 4 + +:: TypeDef type_rhs = + { td_name :: !Ident + , td_index :: !Int + , td_arity :: !Int + , td_args :: ![ATypeVar] + , td_attrs :: ![AttributeVar] + , td_context :: ![TypeContext] + , td_rhs :: !type_rhs + , td_attribute :: !TypeAttribute + , td_pos :: !Position + } + +:: FunType = + { ft_symb :: !Ident + , ft_arity :: !Int + , ft_priority :: !Priority + , ft_type :: !SymbolType + , ft_pos :: !Position + , ft_specials :: !Specials + , ft_type_ptr :: !VarInfoPtr + } + +:: FreeVar = + { fv_def_level :: !Level + , fv_name :: !Ident + , fv_info_ptr :: !VarInfoPtr + , fv_count :: !Int + } + +:: FunCall = + { fc_level :: !Level + , fc_index :: !Index + } + +:: FunInfo = + { fi_calls :: ![FunCall] + , fi_group_index :: !Index + , fi_def_level :: !Level + , fi_free_vars :: ![FreeVar] + , fi_local_vars :: ![FreeVar] + , fi_dynamics :: ![ExprInfoPtr] + } + +:: ParsedBody = + { pb_args :: ![ParsedExpr] + , pb_rhs :: !Rhs + } + +:: CheckedBody = + { cb_args :: ![FreeVar] + , cb_rhs :: ![Expression] + } + +:: TransformedBody = + { tb_args :: ![FreeVar] + , tb_rhs :: !Expression + } + +:: FunctionBody = ParsedBody ![ParsedBody] + | CheckedBody !CheckedBody + /* The next three constructors are used during macro expansion (module transform) */ + | PartioningMacro + | PartioningFunction !CheckedBody !Int + | RhsMacroBody !CheckedBody + /* macro expansion the transforms a CheckedBody into a TransformedBody */ + | TransformedBody !TransformedBody + | Expanding + | BackendBody ![BackendBody] + +:: BackendBody = + { bb_args :: ![FunctionPattern] + , bb_rhs :: !Expression + } + +:: FunDef = + { fun_symb :: !Ident + , fun_arity :: !Int + , fun_priority :: !Priority + , fun_body :: !FunctionBody + , fun_type :: !Optional SymbolType + , fun_pos :: !Position + , fun_index :: !Int + , fun_kind :: !FunKind + , fun_lifted :: !Int +// , fun_type_ptr :: !TypeVarInfoPtr + , fun_info :: !FunInfo + } + +cIsAGlobalVar :== True +cIsALocalVar :== False + +:: ConsClasses = + { cc_size ::!Int + , cc_args ::![ConsClass] + } + +:: ConsClass :== Int + +:: OptionalVariable :== Optional (Bind Ident VarInfoPtr) + +:: AuxiliaryPattern + = AP_Algebraic !(Global DefinedSymbol) !Index [AuxiliaryPattern] OptionalVariable + | AP_Variable !Ident !VarInfoPtr OptionalVariable + | AP_Basic !BasicValue OptionalVariable + | AP_Dynamic !AuxiliaryPattern !DynamicType !OptionalVariable + | AP_Constant !AP_Kind !(Global DefinedSymbol) !Priority + | AP_WildCard OptionalVariable + | AP_Empty !Ident + +:: AP_Kind = APK_Constructor !Index | APK_Macro + +:: VarInfo = VI_Empty | VI_Type !AType | VI_Occurrence !Occurrence | VI_UsedVar (!Ident, ![Int]) | + VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr | + VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ | + VI_AccVar !ConsClass /* used during fusion to determine accumulating parameters of functions */ | + VI_Alias !BoundVar /* used for resolving aliases just before type checking (in transform) */ | + /* used during elimination and lifting of cases */ + VI_FreeVar !Ident !VarInfoPtr !Int !AType | VI_BoundVar !AType | VI_LocalVar | + VI_Forward !BoundVar | VI_LetVar !LetVarInfo | VI_LetExpression !LetExpressionInfo | VI_CaseVar !VarInfoPtr | + VI_CorrespondenceNumber !Int | VI_SequenceNumber !Int | + VI_Used | /* for indicating that an imported function has been used */ + VI_PropagationType !SymbolType | /* for storing the type with propagation environment of an imported function */ + VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */ + VI_Record ![AuxiliaryPattern] | + VI_Pattern !AuxiliaryPattern | + VI_Default !Int /* used during conversion of dynamics; the Int indiacted the refenrence count */ + +:: VarInfoPtr :== Ptr VarInfo + +:: LetVarInfo = + { lvi_count :: !Int + , lvi_depth :: !Int + , lvi_new :: !Bool + , lvi_var :: !Ident + , lvi_expression :: !Expression + , lvi_previous :: ![PreviousLetVarInfo] + } + +:: PreviousLetVarInfo = + { plvi_count :: !Int + , plvi_depth :: !Int + , plvi_new :: !Bool + } + +:: LetExpressionStatus = LES_Untouched | LES_Moved | LES_Updated !Expression + +:: LetExpressionInfo = + { lei_count :: !Int + , lei_depth :: !Int + , lei_strict :: !Bool + , lei_var :: !FreeVar + , lei_expression :: !Expression + , lei_status :: !LetExpressionStatus + , lei_type :: !AType + } + +cNotVarNumber :== -1 + +:: BoundVar = + { var_name :: !Ident + , var_info_ptr :: !VarInfoPtr + , var_expr_ptr :: !ExprInfoPtr + } + +:: TypeSymbIdent = + { type_name :: !Ident + , type_arity :: !Int + , type_index :: !Global Index + , type_prop :: !TypeSymbProperties + } + +:: TypeSymbProperties = + { tsp_sign :: !SignClassification + , tsp_propagation :: !PropClassification + , tsp_coercible :: !Bool + } + +:: SymbKind = SK_Unknown + | SK_Function !(Global Index) + | SK_OverloadedFunction !(Global Index) + | SK_Constructor !(Global Index) + | SK_Macro !(Global Index) +// | SK_RecordSelector !(Global Index) + | SK_GeneratedFunction !FunctionInfoPtr !Index + | SK_TypeCode + +// MW2 moved some type definitions + +/* Some auxiliary type definitions used during fusion. Actually, these definitions + should have beengiven in seperate module. Unfortunately, Clean's module system + forbids cyclic dependencies between def modules. + +*/ + +:: FunctionHeap :== Heap FunctionInfo + +:: FunctionInfoPtr :== Ptr FunctionInfo + +:: FunctionInfo = FI_Empty | FI_Function !GeneratedFunction + +:: Producer = PR_Empty + | PR_Function !SymbIdent !Index + | PR_Class !App ![BoundVar] ![Type] +// | PR_Constructor !SymbIdent ![Expression] + | PR_GeneratedFunction !SymbIdent !Index + +:: InstanceInfo = II_Empty | II_Node !{! Producer} !FunctionInfoPtr !InstanceInfo !InstanceInfo + +:: GeneratedFunction = + { gf_fun_def :: !FunDef + , gf_instance_info :: !InstanceInfo + , gf_cons_args :: !ConsClasses + , gf_fun_index :: !Index + } + +/* ... main type definitions continued .... */ + +:: ExpressionHeap :== Heap ExprInfo + +:: ExprInfoPtr :== Ptr ExprInfo + +:: TempLocalVar :== Int + +:: DynamicPtr :== ExprInfoPtr + +:: ExprInfo = EI_Empty + + /* For handling overloading */ + + | EI_Overloaded !OverloadedCall /* initial, set by the type checker */ + | EI_Instance !(Global DefinedSymbol) ![Expression] /* intermedediate, used during resolving of overloading */ + | EI_Selection ![Selection] !BoundVar ![Expression] /* intermedediate, used during resolving of overloading */ + | EI_Context ![Expression] /* intermedediate, used during resolving of overloading */ + + /* For handling dynamics */ + + | EI_Dynamic !(Optional DynamicType) + | EI_DynamicType !DynamicType ![DynamicPtr] + + /* Auxiliary, was EI_DynamicType before checking */ + + | EI_DynamicTypeWithVars ![TypeVar] !DynamicType ![DynamicPtr] + + /* Auxiliary, used during type checking */ + + | EI_TempDynamicType !(Optional DynamicType) !AType ![TypeContext] !ExprInfoPtr !SymbIdent + | EI_TempDynamicPattern ![TypeVar] !DynamicType ![DynamicPtr] ![TempLocalVar] !AType ![TypeContext] !ExprInfoPtr !SymbIdent + + | EI_TypeOfDynamic ![VarInfoPtr] !TypeCodeExpression /* Final */ + | EI_TypeOfDynamicPattern ![VarInfoPtr] !TypeCodeExpression /* Final */ + + | EI_TypeCode !TypeCodeExpression + | EI_TypeCodes ![TypeCodeExpression] + + | EI_Attribute !Int + + + /* EI_FreeVariables is uded to store the (free) variables occurring in the case expression */ + +// | EI_FreeVariables ![UnboundVariable] !ExprInfo + + /* EI_ClassTypes is used to store the instance types of a class These type are used during fusion to generate proper types for + the fusion result (i.e. the resulting function after elimination of dictionaries) */ + + | EI_ClassTypes ![Type] + | EI_CaseType !CaseType + | EI_LetType ![AType] + | EI_CaseTypeAndRefCounts !CaseType !RefCountsInCase + | EI_LetTypeAndRefCounts ![AType] ![Int] + + /* for converting case into function patterns the following auxiliary constuctors are used */ + + | EI_Default !Expression !AType !ExprInfoPtr + | EI_DefaultFunction !SymbIdent ![Expression] + +:: RefCountsInCase = + { rcc_all_variables :: ![CountedVariable] + , rcc_default_variables :: ![CountedVariable] + , rcc_pattern_variables :: ![[CountedVariable]] + } + +:: CountedVariable = + { cv_variable :: !VarInfoPtr + , cv_count :: !Int + } + + +/* + OverloadedCall contains (type) information about functions that are overloaded. This structure is built during type checking + and used after (standard) unification to insert the proper instances of the corresponding functions. + +*/ + +:: OverloadedCall = + { oc_symbol :: !SymbIdent + , oc_context :: ![TypeContext] + , oc_specials :: ![Special] + } + +/* + CaseType contains the type information needed to type the corresponding case construct: + ct_pattern_type : the type of the pattern + ct_result_type : the type of the result (of each pattern) + ct_cons_types : the types of the arguments of each pattern constructor +*/ + +:: CaseType = + { ct_pattern_type :: !AType + , ct_result_type :: !AType + , ct_cons_types :: ![[AType]] + } + + +:: SymbIdent = + { symb_name :: !Ident + , symb_kind :: !SymbKind + , symb_arity :: !Int + } + +:: ConsDef = + { cons_symb :: !Ident + , cons_type :: !SymbolType + , cons_arg_vars :: ![[ATypeVar]] + , cons_priority :: !Priority + , cons_index :: !Index + , cons_type_index :: !Index + , cons_exi_vars :: ![ATypeVar] +// , cons_exi_attrs :: ![AttributeVar] + , cons_type_ptr :: !VarInfoPtr + , cons_pos :: !Position + } + +:: SelectorDef = + { sd_symb :: !Ident + , sd_field :: !Ident + , sd_type :: !SymbolType + , sd_exi_vars :: ![ATypeVar] +// , sd_exi_attrs :: ![AttributeVar] + , sd_field_nr :: !Int + , sd_type_index :: !Int + , sd_type_ptr :: !VarInfoPtr + , sd_pos :: !Position + } + +:: SymbolType = + { st_vars :: ![TypeVar] + , st_args :: ![AType] + , st_arity :: !Int + , st_result :: !AType + , st_context :: ![TypeContext] + , st_attr_vars :: ![AttributeVar] + , st_attr_env :: ![AttrInequality] + } + +:: TypeContext = + { tc_class :: !Global DefinedSymbol + , tc_types :: ![Type] + , tc_var :: !VarInfoPtr + } + +:: AType = + { at_attribute :: !TypeAttribute + , at_annotation :: !Annotation + , at_type :: !Type + } + +:: TempAttrId :== Int +:: TempVarId :== Int + +:: Type = TA !TypeSymbIdent ![AType] + | (-->) infixr 9 !AType !AType + | (:@:) infixl 9 !ConsVariable ![AType] + | TB !BasicType + +// | TFA [ATypeVar] Type + + | GTV !TypeVar + | TV !TypeVar + | TempV !TempVarId /* Auxiliary, used during type checking */ + + + | TQV TypeVar + | TempQV !TempVarId /* Auxiliary, used during type checking */ + + | TLifted !TypeVar /* Auxiliary, used during type checking of lifted arguments */ + | TE + +:: ConsVariable = CV !TypeVar + | TempCV !TempVarId + | TempQCV !TempVarId + + +:: DynamicType = + { dt_uni_vars :: ![ATypeVar] + , dt_global_vars :: ![TypeVar] + , dt_type :: !AType + } + +:: KindHeap :== Heap KindInfo +:: KindInfoPtr :== Ptr KindInfo + +:: KindInfo = KI_Var !KindInfoPtr + | KI_Indirection !KindInfo + | KI_Arrow ![KindInfo] + | KI_Const + + | KI_ConsVar + + | KI_VarBind !KindInfoPtr + | KI_NormVar !Int + + +:: TypeVarInfo = TVI_Empty | TVI_Type !Type | TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr + | TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo + | TVI_Attribute TypeAttribute + | TVI_CorrespondenceNumber !Int + | TVI_Used /* to adminster that this variable is encountered (in checkOpenTypes) */ + | TVI_TypeCode !TypeCodeExpression + +:: TypeVarInfoPtr :== Ptr TypeVarInfo +:: TypeVarHeap :== Heap TypeVarInfo + +:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId +:: AttrVarInfoPtr :== Ptr AttrVarInfo +:: AttrVarHeap :== Heap AttrVarInfo + +:: TypeHeaps = + { th_vars :: ! .TypeVarHeap + , th_attrs :: ! .AttrVarHeap + } + +:: TypeVar = + { tv_name :: !Ident + , tv_info_ptr :: !TypeVarInfoPtr + } + + +:: ATypeVar = + { atv_attribute :: !TypeAttribute + , atv_annotation :: !Annotation + , atv_variable :: !TypeVar + } + +:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar !AttributeVar | TA_TempVar !Int + | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute | TA_Omega + +:: AttributeVar = + { av_name :: !Ident + , av_info_ptr :: !AttrVarInfoPtr + } + +:: Annotation = AN_Strict | AN_None + +:: BasicType = BT_Int | BT_Char | BT_Real | BT_Bool | BT_Dynamic + | BT_File | BT_World + | BT_String !Type /* the internal string type synonym only used to type string denotations */ + + +:: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String + + +:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow !Int + +:: Occurrence = + { occ_ref_count :: !ReferenceCount + , occ_bind :: !OccurrenceBinding + , occ_observing :: !Bool + , occ_previous :: ![ReferenceCount] + } + +:: ReferenceCount = RC_Used !RC_Used | RC_Unused + +:: SelectiveUse = { su_field :: !Int, su_multiply :: ![ExprInfoPtr], su_uniquely :: ![ExprInfoPtr] } + +:: RC_Used = { rcu_multiply :: ![ExprInfoPtr], rcu_selectively :: ![SelectiveUse], rcu_uniquely :: ![ExprInfoPtr] } + +:: OccurrenceBinding = OB_Empty | OB_OpenLet !Expression | OB_LockedLet !Expression + | OB_Pattern ![(FreeVar, Int)] !OccurrenceBinding +// | OB_Closed !LetOccurrences | OB_Marked !LetOccurrences + +:: TypeDefInfo = + { tdi_kinds :: ![TypeKind] + , tdi_properties :: !BITVECT + , tdi_group :: ![Global Index] + , tdi_group_nr :: !Int + , tdi_group_vars :: ![Int] + , tdi_cons_vars :: ![Int] + , tdi_classification :: !TypeClassification + } + +:: TypeDefInfos :== {# .{# TypeDefInfo}} + +:: OptGuardedAlts = GuardedAlts ![GuardedExpr] !(Optional ExprWithLocalDefs) + | UnGuardedExpr !ExprWithLocalDefs + +:: GuardedExpr = + { alt_nodes :: ![NodeDefWithLocals] + , alt_guard :: !ParsedExpr + , alt_expr :: !OptGuardedAlts + } + +:: ExprWithLocalDefs = + { ewl_nodes :: ![NodeDefWithLocals] + , ewl_expr :: !ParsedExpr + , ewl_locals :: !LocalDefs + } + +:: NodeDefWithLocals = + { ndwl_strict :: !Bool + , ndwl_def :: !Bind ParsedExpr ParsedExpr + , ndwl_locals :: !LocalDefs + } + + +:: CaseAlt = + { calt_pattern :: !ParsedExpr + , calt_rhs :: !Rhs + } + +:: LocalDef :== ParsedDefinition + +cUniqueSelection :== True +cNonUniqueSelection :== False + +:: ParsedExpr = PE_List ![ParsedExpr] + | PE_Ident !Ident + | PE_Basic !BasicValue + | PE_Bound !BoundExpr + | PE_Lambda !Ident ![ParsedExpr] !ParsedExpr + | PE_Tuple ![ParsedExpr] + | PE_Record !ParsedExpr !(Optional Ident) ![FieldAssignment] + | PE_Array !ParsedExpr ![ElemAssignment] ![Qualifier] + | PE_ArrayDenot ![ParsedExpr] + | PE_Selection !Bool !ParsedExpr ![ParsedSelection] + | PE_Update !ParsedExpr [ParsedSelection] ParsedExpr + | PE_Case !Ident !ParsedExpr [CaseAlt] + | PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr + | PE_Let !Bool !LocalDefs !ParsedExpr + | PE_Compr !GeneratorKind !ParsedExpr ![Qualifier] + | PE_Sequ Sequence + | PE_WildCard + | PE_Field !ParsedExpr !(Global FieldSymbol) /* Auxiliary, used during checking */ + + | PE_ABC_Code ![String] !Bool + | PE_Any_Code !(CodeBinding Ident) !(CodeBinding Ident) ![String] + + | PE_DynamicPattern !ParsedExpr !DynamicType + | PE_Dynamic !ParsedExpr !(Optional DynamicType) + | PE_Empty + +:: ParsedSelection = PS_Record !Ident !(Optional Ident) + | PS_Array !ParsedExpr + | PS_Erroneous + + +:: GeneratorKind :== Bool + +cIsListGenerator :== True +cIsArrayGenerator :== False + +:: Generator = + { gen_kind :: !GeneratorKind + , gen_pattern :: !ParsedExpr + , gen_expr :: !ParsedExpr + , gen_var :: !Ident + } + +:: Qualifier = + { qual_generators :: ![Generator] + , qual_filter :: !Optional ParsedExpr + , qual_fun_id :: !Ident + } + +:: Sequence = SQ_FromThen ParsedExpr ParsedExpr + | SQ_FromThenTo ParsedExpr ParsedExpr ParsedExpr + | SQ_From ParsedExpr + | SQ_FromTo ParsedExpr ParsedExpr + +:: BoundExpr :== Bind ParsedExpr Ident + +:: FieldAssignment :== Bind ParsedExpr Ident + +:: ElemAssignment :== Bind ParsedExpr ParsedExpr + +//:: NodeDef :== Bind ParsedExpr ParsedExpr + +cIsStrict :== True +cIsNotStrict :== False + +:: Expression = Var !BoundVar + | App !App + | (@) infixl 9 !Expression ![Expression] + | Let !Let + | Case !Case + | Selection !(Optional (Global DefinedSymbol)) !Expression ![Selection] + | Update !Expression ![Selection] Expression + | RecordUpdate !(Global DefinedSymbol) !Expression ![Bind Expression (Global FieldSymbol)] + | TupleSelect !DefinedSymbol !Int !Expression + | Lambda .[FreeVar] !Expression + | BasicExpr !BasicValue !BasicType + | WildCard + | Conditional !Conditional + + | AnyCodeExpr !(CodeBinding BoundVar) !(CodeBinding FreeVar) ![String] + | ABCCodeExpr ![String] !Bool + + | MatchExpr !(Optional (Global DefinedSymbol)) !(Global DefinedSymbol) !Expression + | FreeVar FreeVar + | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + + | DynamicExpr !DynamicExpr +// | TypeCase !TypeCase + + | TypeCodeExpression !TypeCodeExpression + | EE + + +:: CodeBinding variable :== Env String variable + +:: App = + { app_symb :: !SymbIdent + , app_args :: ![Expression] + , app_info_ptr :: !ExprInfoPtr + } + +:: Case = + { case_expr :: !Expression + , case_guards :: !CasePatterns + , case_default :: !Optional Expression + , case_ident :: !Optional Ident + , case_info_ptr :: !ExprInfoPtr + } + +:: Let = + { let_strict :: !Bool + , let_binds :: !(Env Expression FreeVar) + , let_expr :: !Expression + , let_info_ptr :: !ExprInfoPtr + } + + +:: DynamicExpr = + { dyn_expr :: !Expression + , dyn_opt_type :: !Optional DynamicType + , dyn_info_ptr :: !ExprInfoPtr + , dyn_uni_vars :: ![VarInfoPtr] /* filled after type checking */ + , dyn_type_code :: !TypeCodeExpression /* filled after type checking */ + } + +:: CasePatterns = AlgebraicPatterns !(Global Index) ![AlgebraicPattern] + | BasicPatterns !BasicType [BasicPattern] + | DynamicPatterns [DynamicPattern] /* auxiliary */ + | NoPattern /* auxiliary */ + + +:: Selection = RecordSelection !(Global DefinedSymbol) !Int + | ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression + | DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression + +:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr + +:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent | GTT_Function + +:: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar) + | FP_Algebraic !(Global DefinedSymbol) ![FunctionPattern] !(Optional FreeVar) + | FP_Variable !FreeVar + | FP_Dynamic ![VarInfoPtr] !FreeVar !TypeCodeExpression !(Optional FreeVar) + | FP_Empty + +:: AlgebraicPattern = + { ap_symbol :: !(Global DefinedSymbol) + , ap_vars :: ![FreeVar] + , ap_expr :: !Expression + } + +:: BasicPattern = + { bp_value :: !BasicValue + , bp_expr :: !Expression + } + +:: TypeCase = + { type_case_dynamic :: !Expression + , type_case_patterns :: ![DynamicPattern] + , type_case_default :: !Optional Expression + , type_case_info_ptr :: !ExprInfoPtr + } + +:: DynamicPattern = + { dp_var :: !FreeVar + , dp_type :: !ExprInfoPtr + , dp_type_patterns_vars :: ![VarInfoPtr] /* filled after type checking */ + , dp_type_code :: !TypeCodeExpression /* filled after type checking */ + , dp_rhs :: !Expression + } + + +:: Conditional = + { if_cond :: !Expression + , if_then :: !Expression + , if_else :: !Optional Expression + } + +/* + error handling +*/ + +:: Position = FunPos FileName LineNr FunctName + | LinePos FileName LineNr + | PreDefPos Ident + | NoPos + +:: IdentPos = + { ip_ident :: !Ident + , ip_line :: !Int + , ip_file :: !FileName + } + + +:: FileName :== String + +:: FunctName :== String + +:: LineNr :== Int + +cNotALineNumber :== -1 + +/* Used for hashing identifiers */ + +class needs_brackets a :: a -> Bool + +instance == BoundVar +where + (==) varid1 varid2 + = varid1.var_name == varid2.var_name + +instance == Ident +where + (==) id1 id2 + = id1.id_info == id2.id_info + +instance needs_brackets AType +where + needs_brackets {at_type} + = needs_brackets at_type + +instance needs_brackets Type +where + needs_brackets (TA {type_arity} _) + = type_arity > 0 + needs_brackets (_ --> _) + = True + needs_brackets (_ :@: _) + = True +/* needs_brackets (TFA _ _) + = True +*/ needs_brackets _ + = False + +instance needs_brackets Expression +where + needs_brackets (App app) + = app.app_symb.symb_arity > 0 + needs_brackets (_ @ _) + = True + needs_brackets (Let _) + = True + needs_brackets (Case _) + = True + needs_brackets (Lambda _ _) + = True + needs_brackets (Selection _ _ _) + = True + needs_brackets _ + = False + +instance needs_brackets a +where + needs_brackets _ = False + + +instance <<< BasicType +where + (<<<) file BT_Int = file <<< "Int" + (<<<) file BT_Char = file <<< "Char" + (<<<) file BT_Real = file <<< "Real" + (<<<) file BT_Bool = file <<< "Bool" +/* (<<<) file (BT_String _) = file <<< "String" */ + (<<<) file BT_Dynamic = file <<< "Dynamic" + (<<<) file BT_File = file <<< "File" + (<<<) file BT_World = file <<< "World" + +instance <<< TypeVar +where + (<<<) file varid = file <<< varid.tv_name <<< '[' <<< ptrToInt varid.tv_info_ptr <<< ']' + +instance <<< AttributeVar +where + (<<<) file {av_name,av_info_ptr} = file <<< av_name <<< '[' <<< ptrToInt av_info_ptr <<< ']' + +instance toString AttributeVar +where + toString {av_name,av_info_ptr} = toString av_name + "[" + toString (ptrToInt av_info_ptr) + "]" + +instance <<< AType +where + (<<<) file {at_annotation,at_attribute,at_type} + = file <<< at_annotation <<< at_attribute <<< at_type + +instance <<< TypeAttribute +where + (<<<) file ta + = file <<< toString ta + +instance toString TypeAttribute +where + toString (TA_Unique) + = "* " + toString (TA_TempVar tav_number) + = "u" + toString tav_number + ": " + toString (TA_Var avar) + = toString avar + ": " +/* toString (TA_TempExVar tav_number) + = "e" + toString tav_number + ": " + toString (TA_ExVar avar) + = toString avar + "': " +*/ + toString (TA_RootVar avar) + = toString avar + ": " + toString (TA_Anonymous) + = ". " + toString TA_None + = "" + toString TA_Multi + = "o " + toString TA_Omega + = "w " + toString (TA_List _ _) + = "??? " + +instance <<< Annotation +where + (<<<) file an = file <<< toString an + +instance toString Annotation +where + toString AN_Strict = "!" + toString _ = "" + +instance <<< ATypeVar +where + (<<<) file {atv_annotation,atv_attribute,atv_variable} + = file <<< atv_annotation <<< atv_attribute <<< atv_variable + +instance <<< ConsVariable +where + (<<<) file (CV tv) + = file <<< tv + (<<<) file (TempCV tv) + = file <<< "v" <<< tv <<< ' ' + +instance <<< Type +where + (<<<) file (TV varid) + = file <<< varid + (<<<) file (TempV tv_number) + = file <<< 'v' <<< tv_number <<< ' ' + (<<<) file (TA consid types) + = file <<< consid <<< " " <<< types + (<<<) file (arg_type --> res_type) + = file <<< arg_type <<< " -> " <<< res_type + (<<<) file (type :@: types) + = file <<< type <<< " @" <<< types + (<<<) file (TB tb) + = file <<< tb +/* (<<<) file (TFA vars types) + = file <<< "A." <<< vars <<< ':' <<< types +*/ (<<<) file (TQV varid) + = file <<< "E." <<< varid + (<<<) file (TempQV tv_number) + = file <<< "E." <<< tv_number <<< ' ' + (<<<) file TE + = file <<< "### EMPTY ###" +/* +instance <<< [a] | <<< , needs_brackets a +where + (<<<) file [] = file + (<<<) file [x:xs] + | needs_brackets x + = file <<< " (" <<< x <<< ')' <<< xs + = file <<< ' ' <<< x <<< xs +*/ + +instance <<< SymbolType +where + (<<<) file st=:{st_vars,st_attr_vars} + | st.st_arity == 0 + = write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_result)) + = write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_args <<< " -> " <<< st.st_result)) + +write_contexts [] file + = file +write_contexts [tc : tcs] file + = write_contexts2 tcs (file <<< " | " <<< tc) +where + write_contexts2 [] file + = file + write_contexts2 [tc : tcs] file + = write_contexts2 tcs (file <<< " & " <<< tc) + +instance <<< AttrInequality +where + (<<<) file {ai_demanded,ai_offered} + = file <<< ai_offered <<< " <= " <<< ai_demanded + +write_inequalities [] file + = file +write_inequalities [ineq:ineqs] file + = write_remaining_inequalities ineqs (file <<< ',' <<< ineq) +where + write_remaining_inequalities [] file + = file + write_remaining_inequalities [ineq:ineqs] file + = write_remaining_inequalities ineqs (file <<< ' ' <<< ineq) + +instance <<< TypeContext +where + (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types + +instance <<< SymbIdent +where + (<<<) file symb=:{symb_kind = SK_Function symb_index } = file <<< symb.symb_name <<< '.' <<< symb_index + (<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index } = file <<< symb.symb_name <<< '.' <<< symb_index + (<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index } = file <<< symb.symb_name <<< "OL" + (<<<) file symb = file <<< symb.symb_name + +instance <<< TypeSymbIdent +where + (<<<) file symb = file <<< symb.type_name <<< '.' <<< symb.type_arity + +instance <<< ClassSymbIdent +where + (<<<) file symb = file <<< symb.cs_name + +instance <<< BoundVar +where + (<<<) file {var_name,var_info_ptr,var_expr_ptr} + = file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< ',' <<< ptrToInt var_expr_ptr <<< '>' + +instance <<< Bind a b | <<< a & <<< b +where + (<<<) file {bind_src,bind_dst} = file <<< bind_dst <<< " = " <<< bind_src + + +instance <<< AlgebraicPattern +where + (<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " -> " <<< g.ap_expr + +instance <<< BasicPattern +where + (<<<) file g = file <<< g.bp_value <<< " -> " <<< g.bp_expr + +instance <<< CasePatterns +where + (<<<) file (BasicPatterns type patterns) = file <<< patterns + (<<<) file (AlgebraicPatterns type patterns) = file <<< patterns + (<<<) file (DynamicPatterns patterns) = file <<< patterns + (<<<) file NoPattern = file + +instance <<< Qualifier +where + (<<<) file {qual_generators,qual_filter = Yes qual_filter} = file <<< qual_generators <<< "| " <<< qual_filter + (<<<) file {qual_generators,qual_filter = No} = file <<< qual_generators + +instance <<< Generator +where + (<<<) file {gen_kind,gen_pattern,gen_expr} + = file <<< gen_pattern <<< (if gen_kind "<-" "<-:") <<< gen_expr + +instance <<< BasicValue +where + (<<<) file (BVI int) = file <<< int + (<<<) file (BVC char) = file <<< char + (<<<) file (BVB bool) = file <<< bool + (<<<) file (BVR real) = file <<< real + (<<<) file (BVS string) = file <<< string + +instance <<< Sequence +where + (<<<) file (SQ_From expr) = file <<< expr + (<<<) file (SQ_FromTo from_expr to_expr) = file <<< from_expr <<< ".." <<< to_expr + (<<<) file (SQ_FromThen from_expr then_expr) = file <<< from_expr <<< ',' <<< then_expr <<< ".." + (<<<) file (SQ_FromThenTo from_expr then_expr to_expr) = file <<< from_expr <<< ',' <<< then_expr <<< ".." <<< to_expr + +instance <<< Expression +where + (<<<) file (Var ident) = file <<< ident + (<<<) file (App {app_symb, app_args}) + = file <<< app_symb <<< ' ' <<< app_args + (<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')' + (<<<) file (Let {let_binds, let_expr}) = write_binds (file <<< "let " <<< '\n') let_binds <<< "in\n" <<< let_expr + where + write_binds file [] + = file + write_binds file [bind : binds] + = write_binds (file <<< bind <<< '\n') binds + (<<<) file (Case {case_expr,case_guards,case_default=No}) + = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards + (<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr}) + = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t-> " <<< def_expr + (<<<) file (BasicExpr basic_value basic_type) = file <<< basic_value + (<<<) file (Conditional {if_cond,if_then,if_else}) = + else_part (file <<< "IF " <<< if_cond <<< "\nTHEN\n" <<< if_then) if_else + where + else_part file No = file <<< '\n' + else_part file (Yes else) = file <<< "\nELSE\n" <<< else <<< '\n' + +/* (<<<) file (Conditional {if_cond = {con_positive,con_expression},if_then,if_else}) = + else_part (file <<< (if con_positive "IF " "IFNOT ") <<< con_expression <<< "\nTHEN\n" <<< if_then) if_else + where + else_part file No = file <<< '\n' + else_part file (Yes else) = file <<< "\nELSE\n" <<< else <<< '\n' +*/ + (<<<) file (Selection opt_tuple expr selectors) = file <<< expr <<< selector_kind opt_tuple <<< selectors + where + selector_kind No = '.' + selector_kind (Yes _) = '!' + (<<<) file (Update expr1 selections expr2) = file <<< '{' <<< expr1 <<< " & " <<< selections <<< " = " <<< expr2 <<< '}' + (<<<) file (RecordUpdate cons_symbol expression expressions) = file <<< '{' <<< cons_symbol <<< ' ' <<< expression <<< " & " <<< expressions <<< '}' + (<<<) file (TupleSelect field field_nr expr) = file <<< expr <<<'.' <<< field_nr + (<<<) file (Lambda vars expr) = file <<< '\\' <<< vars <<< " -> " <<< expr + (<<<) file WildCard = file <<< '_' + (<<<) file (MatchExpr _ cons expr) = file <<< cons <<< " =: " <<< expr + (<<<) file EE = file <<< "** E **" + (<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: ") dyn_uni_vars <<< dyn_type_code +// (<<<) file (TypeCase type_case) = file <<< type_case + (<<<) file (TypeCodeExpression type_code) = file <<< type_code + (<<<) file (Constant symb _ _ _) = file <<< "** Constant **" <<< symb + + (<<<) file (ABCCodeExpr code_sequence do_inline) = file <<< (if do_inline "code inline\n" "code\n") <<< code_sequence + (<<<) file (AnyCodeExpr input output code_sequence) = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence + + (<<<) file (FreeVar {fv_name}) = file <<< "FREEVAR " <<< fv_name + (<<<) file expr = abort ("<<< (Expression) [line 1290]" <<- expr) + +instance <<< TypeCase +where + (<<<) file {type_case_dynamic,type_case_patterns,type_case_default} + = file <<< "typecase " <<< type_case_dynamic <<< "of\n" <<< + type_case_patterns <<< type_case_default + +instance <<< DynamicPattern +where + (<<<) file {dp_type_patterns_vars,dp_var,dp_rhs,dp_type_code} + = writeVarPtrs (file <<< dp_var <<< " :: ") dp_type_patterns_vars <<< dp_type_code <<< " = " <<< dp_rhs + +writeVarPtrs file [] + = file +writeVarPtrs file vars + = write_var_ptrs (file <<< '<') vars <<< '>' + where + write_var_ptrs file [var] + = file <<< ptrToInt var + write_var_ptrs file [var : vars] + = write_var_ptrs (file <<< ptrToInt var <<< '.') vars + + +instance <<< TypeCodeExpression +where + (<<<) file TCE_Empty + = file + (<<<) file (TCE_Var info_ptr) + = file <<< "VAR " <<< ptrToInt info_ptr + (<<<) file (TCE_Constructor index exprs) + = file <<< "CONS " <<< index <<< ' ' <<< exprs + (<<<) file (TCE_Selector selectors info_ptr) + = file <<< "CONS " <<< selectors <<< "VAR " <<< ptrToInt info_ptr + +instance <<< Selection +where + (<<<) file (RecordSelection selector _) = file <<< selector + (<<<) file (ArraySelection _ _ index_expr) = file <<< '[' <<< index_expr <<< ']' + (<<<) file (DictionarySelection var selections _ index_expr) = file <<< '(' <<< var <<< '.' <<< selections <<< ')' <<< '[' <<< index_expr <<< ']' + +instance <<< LocalDefs +where + (<<<) file (LocalParsedDefs defs) = file <<< defs + (<<<) file (CollectedLocalDefs defs) = file <<< defs + +instance <<< NodeDef dst | <<< dst +where + (<<<) file {nd_dst,nd_alts,nd_locals} = file <<< nd_dst <<< nd_alts <<< nd_locals + + +instance <<< CollectedLocalDefs +where + (<<<) file {loc_functions,loc_nodes} + = file <<< loc_functions <<< loc_nodes +/* + (<<<) file {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} + = file <<< def_types <<< def_constructors <<< def_selectors <<< def_macros <<< def_classes <<< def_members <<< def_instances +*/ + +instance <<< ParsedExpr +where + (<<<) file (PE_List exprs) = file <<< exprs + (<<<) file (PE_Tuple args) = file <<< '(' <<< args <<< ')' + (<<<) file (PE_Basic basic_value) = file <<< basic_value + (<<<) file (PE_Selection is_unique expr selectors) = file <<< expr <<< (if is_unique '!' '.') <<< selectors + (<<<) file (PE_Update expr1 selections expr2) = file <<< '{' <<< expr1 <<< " & " <<< selections <<< " = " <<< expr2 <<< '}' + (<<<) file (PE_Record PE_Empty _ fields) = file <<< '{' <<< fields <<< '}' + (<<<) file (PE_Record rec _ fields) = file <<< '{' <<< rec <<< " & " <<< fields <<< '}' + (<<<) file (PE_Compr True expr quals) = file <<< '[' <<< expr <<< " \\ " <<< quals <<< ']' + (<<<) file (PE_Compr False expr quals) = file <<< '{' <<< expr <<< " \\ " <<< quals <<< '}' + (<<<) file (PE_Sequ seq) = file <<< '[' <<< seq <<< ']' + (<<<) file PE_Empty = file <<< "** E **" + (<<<) file (PE_Ident symb) = file <<< symb + (<<<) file PE_WildCard = file <<< '_' + (<<<) file (PE_Lambda _ exprs expr) = file <<< '\\' <<< exprs <<< " -> " <<< expr + (<<<) file (PE_Bound bind) = file <<< bind + (<<<) file (PE_Case _ expr alts) = file <<< "case " <<< expr <<< " of\n" <<< alts + (<<<) file (PE_Let _ defs expr) = file <<< "let " <<< defs <<< " in\n" <<< expr + (<<<) file (PE_DynamicPattern expr type) = file <<< expr <<< "::" <<< type + (<<<) file (PE_Dynamic expr maybetype) + = case maybetype of + Yes type + -> file <<< "dynamic " <<< expr <<< "::" <<< type + No + -> file <<< "dynamic " <<< expr + (<<<) file _ = file <<< "some expression" + + +instance <<< ParsedSelection +where + (<<<) file (PS_Record selector _) = file <<< selector + (<<<) file (PS_Array index_expr) = file <<< '[' <<< index_expr <<< ']' + (<<<) file PS_Erroneous = file <<< "Erroneous selector" // PK + +instance <<< CaseAlt +where + (<<<) file {calt_pattern,calt_rhs} = file <<< calt_pattern <<< " -> " <<< calt_rhs + +instance <<< ParsedBody +where + (<<<) file {pb_args,pb_rhs} = file <<< pb_args <<< " = " <<< pb_rhs + +instance <<< BackendBody +where + (<<<) file {bb_args,bb_rhs} = file <<< bb_args <<< " = " <<< bb_rhs + +instance <<< FunctionPattern +where + (<<<) file (FP_Basic val (Yes var)) + = file <<< var <<< "=:" <<< val + (<<<) file (FP_Basic val No) + = file <<< val + (<<<) file (FP_Algebraic constructor vars (Yes var)) + = file <<< var <<< "=:" <<< constructor <<< vars + (<<<) file (FP_Algebraic constructor vars No) + = file <<< constructor <<< vars + (<<<) file (FP_Variable var) = file <<< var + (<<<) file (FP_Dynamic vars var type_code _) + = writeVarPtrs (file <<< var <<< " :: ") vars <<< type_code + (<<<) file (FP_Empty) = file <<< '_' + + +instance <<< FunDef +where + (<<<) file {fun_symb,fun_index,fun_body=ParsedBody bodies} = file <<< fun_symb <<< '.' <<< fun_index <<< ' ' <<< bodies + (<<<) file {fun_symb,fun_index,fun_body=CheckedBody {cb_args,cb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' + <<< fun_index <<< "C " <<< cb_args <<< " = " <<< cb_rhs +// <<< fun_index <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs + (<<<) file {fun_symb,fun_index,fun_body=TransformedBody {tb_args,tb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' + <<< fun_index <<< "T " <<< tb_args <<< '[' <<< fi_calls <<< ']' <<< " = " <<< tb_rhs +// <<< fun_index <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs + (<<<) file {fun_symb,fun_index,fun_body=BackendBody body,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' + <<< fun_index <<< body <<< '\n' +instance <<< FunCall +where + (<<<) file { fc_level,fc_index } + = file <<< fc_index <<< '.' <<< fc_level + +instance <<< FreeVar +where + (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '<' <<< ptrToInt fv_info_ptr <<< '>' + +instance <<< DynamicType +where + (<<<) file {dt_uni_vars,dt_type} + | isEmpty dt_uni_vars + = file <<< dt_type + = file <<< "A." <<< dt_uni_vars <<< ":" <<< dt_type + + +instance <<< SignClassification +where + (<<<) file {sc_pos_vect,sc_neg_vect} = write_signs file sc_pos_vect sc_neg_vect 0 + where + write_signs file sc_pos_vect sc_neg_vect index + | sc_pos_vect == 0 && sc_neg_vect == 0 + = file + # index_bit = (1 << index) + | sc_pos_vect bitand index_bit == 0 + | sc_neg_vect bitand index_bit == 0 + = write_signs (file <<< 'O') sc_pos_vect sc_neg_vect (inc index) + = write_signs (file <<< '-') sc_pos_vect (sc_neg_vect bitand (bitnot index_bit)) (inc index) + | sc_neg_vect bitand index_bit == 0 + = write_signs (file <<< '+') (sc_pos_vect bitand (bitnot index_bit)) sc_neg_vect (inc index) + = write_signs (file <<< 'T') (sc_pos_vect bitand (bitnot index_bit)) (sc_neg_vect bitand (bitnot index_bit)) (inc index) + +instance <<< TypeKind +where + (<<<) file (KindVar _) = file <<< "**" + (<<<) file KindConst + = file <<< '*' + (<<<) file (KindArrow arity) + = write_kinds file arity + where + write_kinds file 1 + = file <<< "* -> *" + write_kinds file n + = write_kinds (file <<< "* -> ") (dec n) + + +instance <<< TypeDefInfo +where + (<<<) file {tdi_group,tdi_group_vars,tdi_cons_vars} + = file <<< '[' <<< tdi_group <<< '=' <<< tdi_group_vars <<< '=' <<< tdi_cons_vars <<< ']' + +instance <<< DefinedSymbol +where + (<<<) file {ds_ident} + = file <<< ds_ident + +instance <<< TypeDef a | <<< a +where + (<<<) file {td_name, td_args, td_rhs} + = file <<< ":: " <<< td_name <<< ' ' <<< td_args <<< td_rhs + +instance <<< TypeRhs +where + (<<<) file (SynType type) + = file <<< " :== " <<< type + (<<<) file (AlgType data) + = file <<< " = " <<< data + (<<<) file (RecordType record) + = file <<< " = " <<< '{' <<< record <<< '}' + (<<<) file _ + = file + + +instance <<< RecordType +where + (<<<) file {rt_fields} = iFoldSt (\index file -> file <<< rt_fields.[index]) 0 (size rt_fields) file + +instance <<< FieldSymbol +where + (<<<) file {fs_name} = file <<< fs_name + +/* + where + write_data_defs file [] + = file + write_data_defs file [d:ds] + = write_data_defs (file <<< d <<< '\n') ds +*/ + +instance <<< InstanceType +where + (<<<) file it = write_contexts it.it_context (file <<< it.it_types) + +instance <<< RhsDefsOfType +where + (<<<) file (ConsList cons_defs) = file <<< cons_defs + (<<<) file (SelectorList _ _ sel_defs) = file <<< sel_defs + (<<<) file (TypeSpec type) = file <<< type + (<<<) file _ = file + +instance <<< ParsedConstructor +where + (<<<) file {pc_cons_name,pc_arg_types} = file <<< pc_cons_name <<< pc_arg_types + +instance <<< ParsedSelector +where + (<<<) file {ps_field_name,ps_field_type} = file <<< ps_field_name <<< ps_field_type + + +instance <<< ModuleKind +where + (<<<) file kind = file + +instance <<< ConsDef +where + (<<<) file {cons_symb,cons_type} = file <<< cons_symb <<< " :: " <<< cons_type + +instance <<< SelectorDef +where + (<<<) file {sd_symb} = file <<< sd_symb + +instance <<< ClassDef +where + (<<<) file {class_name} = file <<< class_name + +instance <<< ClassInstance +where + (<<<) file {ins_class,ins_type} = file <<< ins_class <<< " :: " <<< ins_type + +instance <<< Optional a | <<< a +where + (<<<) file (Yes x) = file <<< x + (<<<) file No = file + +instance <<< Module a | <<< a +where + (<<<) file {mod_name,mod_type,mod_defs} = file <<< mod_type <<< mod_name <<< mod_defs + +instance <<< CollectedDefinitions a b | <<< a & <<< b +where + (<<<) file {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} + = file + +instance <<< ParsedDefinition +where + (<<<) file (PD_Function _ name _ exprs rhs _ ) = file <<< name <<< exprs <<< " = " <<< rhs + (<<<) file (PD_NodeDef _ pattern rhs) = file <<< pattern <<< " =: " <<< rhs + (<<<) file (PD_TypeSpec _ name prio st sp) = file <<< name <<< st + (<<<) file (PD_Type td) = file <<< td + (<<<) file _ = file + +instance <<< Rhs +where + (<<<) file {rhs_alts,rhs_locals} = file <<< rhs_alts <<< rhs_locals + +instance <<< OptGuardedAlts +where + (<<<) file (GuardedAlts guarded_exprs def_expr) = file <<<guarded_exprs <<< def_expr + (<<<) file (UnGuardedExpr unguarded_expr) = file <<< unguarded_expr + +instance <<< ExprWithLocalDefs +where + (<<<) file {ewl_expr,ewl_locals} = file <<< ewl_expr <<< ewl_locals + +instance <<< GuardedExpr +where + (<<<) file {alt_nodes,alt_guard,alt_expr} = file <<< '|' <<< alt_guard <<< alt_expr + + +instance <<< IndexRange +where + (<<<) file {ir_from,ir_to} + | ir_from == ir_to + = file + = file <<< ir_from <<< "---" <<< ir_to + +instance <<< Ident +where +// (<<<) file {id_name,id_index} = file <<< id_name <<< '.' <<< id_index + (<<<) file {id_name} = file <<< id_name + +instance <<< Global a | <<< a +where + (<<<) file {glob_object,glob_module} = file <<< glob_object <<< '.' <<< glob_module + +instance <<< Position +where + (<<<) file (FunPos file_name line func) = file <<< '[' <<< file_name <<< ',' <<< line <<< ',' <<< func <<< ']' + (<<<) file (LinePos file_name line) = file <<< '[' <<< file_name <<< ',' <<< line <<< ']' + (<<<) file _ = file + +instance <<< TypeVarInfo +where + (<<<) file TVI_Empty = file <<< "TVI_Empty" + (<<<) file (TVI_Type _) = file <<< "TVI_Type" + (<<<) file (TVI_Forward _) = file <<< "TVI_Forward" + (<<<) file (TVI_TypeKind _) = file <<< "TVI_TypeKind" + (<<<) file (TVI_SignClass _ _ _) = file <<< "TVI_SignClass" + (<<<) file (TVI_PropClass _ _ _) = file <<< "TVI_PropClass" + +instance <<< (Import from_symbol) | <<< from_symbol +where + (<<<) file {import_module, import_symbols} + = file <<< "import " <<< import_module <<< import_symbols + +instance <<< ImportDeclaration +where + (<<<) file (ID_Function ident) = file <<< ident + (<<<) file (ID_Class ident optIdents) = file <<< "class " <<< ident <<< optIdents + (<<<) file (ID_Type ident optIdents) = file <<< ":: " <<< ident <<< optIdents + (<<<) file (ID_Record ident optIdents) = file <<< ident <<< " { " <<< optIdents <<< " } " + (<<<) file (ID_Instance i1 i2 tup) = file <<< "instance " <<< i1 <<< i2 <<< tup // !ImportedIdent !Ident !(![Type],![TypeContext]) + +instance <<< ImportedIdent +where + (<<<) file {ii_ident, ii_extended} = file <<< ii_ident <<< ' ' <<< ii_extended + +instance == ModuleKind +where + (==) mk1 mk2 = equal_constructor mk1 mk2 + +instance == TypeAttribute +where + (==) attr1 attr2 = equal_constructor attr1 attr2 + +instance == Annotation +where + (==) a1 a2 = equal_constructor a1 a2 + +EmptySymbolTableEntry :== + { ste_kind = STE_Empty, ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" } + +cNotAGroupNumber :== -1 + +EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group = [], tdi_group_vars = [], tdi_cons_vars = [], + tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber } + +MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr } +MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr } + +MakeAttributedType type :== { at_attribute = TA_None, at_annotation = AN_None, at_type = type } +MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = type_var } + +EmptyFunInfo :== { fi_calls = [], fi_group_index = NoIndex, fi_def_level = NotALevel, + fi_free_vars = [], fi_local_vars = [], fi_dynamics = [] } + +BottomSignClass :== { sc_pos_vect = 0, sc_neg_vect = 0 } +PostiveSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } + +NoPropClass :== 0 +PropClass :== bitnot 0 + +MakeNewTypeSymbIdent name arity + :== MakeTypeSymbIdent { glob_object = NoIndex, glob_module = NoIndex } name arity + +MakeTypeSymbIdent type_index name arity + :== { type_name = name, type_arity = arity, type_index = type_index, + type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }} + +MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity } +MakeConstant name :== MakeSymbIdent name 0 + +ParsedSelectorToSelectorDef ps var_ptr :== + { sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos = ps.ps_field_pos, sd_type_index = NoIndex, + sd_exi_vars = [], /* sd_exi_attrs = [], */ sd_type_ptr = var_ptr, sd_field = ps.ps_field_name, + sd_type = { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [], + st_attr_env = [], st_attr_vars = [] }} + +ParsedConstructorToConsDef pc var_ptr :== + { cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex, + cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE, + st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []}, + cons_exi_vars = pc.pc_exi_vars, /* cons_exi_attrs = [], */ cons_type_ptr = var_ptr, cons_arg_vars = [] } + +ParsedInstanceToClassInstance pi members :== + { ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident, + ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [], + it_context = pi.pi_context }, ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos } + +MakeTypeDef name lhs rhs attr contexts pos :== + { td_name = name, td_index = -1, td_arity = length lhs, td_args = lhs, td_attrs = [], td_attribute = attr, td_context = contexts, + td_pos = pos, td_rhs = rhs } + +MakeDefinedSymbol ident index arity :== { ds_ident = ident, ds_arity = arity, ds_index = index } + +MakeNewFunctionType name arity prio type pos specials var_ptr + :== { ft_symb = name, ft_arity = arity, ft_priority = prio, ft_type = type, ft_pos = pos, ft_specials = specials, ft_type_ptr = var_ptr } + diff --git a/frontend/trans.dcl b/frontend/trans.dcl new file mode 100644 index 0000000..7c24ebf --- /dev/null +++ b/frontend/trans.dcl @@ -0,0 +1,21 @@ +definition module trans + +import StdEnv + +import syntax, transform + +cPassive :== -1 +cActive :== -2 +cAccumulating :== -3 + +analyseGroups :: !*{! Group} !*{#FunDef} !*VarHeap -> (!*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap) + +transformGroups :: !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*VarHeap !*TypeHeaps !*ExpressionHeap + -> (!*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) + +partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef}) + +:: ImportedConstructors :== [Global Index] + +convertSymbolType :: !{# CommonDefs} !SymbolType !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) diff --git a/frontend/trans.icl b/frontend/trans.icl new file mode 100644 index 0000000..77f7e0d --- /dev/null +++ b/frontend/trans.icl @@ -0,0 +1,1172 @@ +implementation module trans + +import StdEnv + +import syntax, transform, checksupport, StdCompare, check, utilities + +import RWSDebug + +:: PartitioningInfo = + { pi_marks :: !.{# Int} + , pi_next_num :: !Int + , pi_next_group :: !Int + , pi_groups :: ![[Int]] + , pi_deps :: ![Int] + } + +NotChecked :== -1 + +partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef}) +partitionateFunctions fun_defs ranges + #! max_fun_nr = size fun_defs + # partitioning_info = { pi_marks = createArray max_fun_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } + (fun_defs, {pi_groups,pi_next_group}) = + foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info) + groups = { {group_members = group} \\ group <- reverse pi_groups } + = (groups, fun_defs) +where + partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo) -> (!*{# FunDef}, !*PartitioningInfo) + partitionate_functions max_fun_nr ir=:{ir_from,ir_to} (fun_defs, pi=:{pi_marks}) + | ir_from == ir_to + = (fun_defs, pi) + | pi_marks.[ir_from] == NotChecked + # (_, fun_defs, pi) = partitionate_function ir_from max_fun_nr fun_defs pi + = partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi) + = partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi) + + partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo) + partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num} + #! fd = fun_defs.[fun_index] + # {fi_calls} = fd.fun_info + (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi) + = try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi + +/* + partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo) + partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num} + #! fd = fun_defs.[fun_index] + | fd.fun_kind + # {fi_calls} = fd.fun_info + (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi) + = try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi + = (max_fun_nr, fun_defs, pi) +*/ + push_on_dep_stack :: !Int !*PartitioningInfo -> *PartitioningInfo; + push_on_dep_stack fun_index pi=:{pi_deps,pi_marks,pi_next_num} + = { pi & pi_deps = [fun_index : pi_deps], pi_marks = { pi_marks & [fun_index] = pi_next_num}, pi_next_num = inc pi_next_num} + + visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo) + visit_functions [{fc_index}:funs] min_dep max_fun_nr fun_defs pi=:{pi_marks} + #! mark = pi_marks.[fc_index] + | mark == NotChecked + # (mark, fun_defs, pi) = partitionate_function fc_index max_fun_nr fun_defs pi + = visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi + = visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi + visit_functions [] min_dep max_fun_nr fun_defs pi + = (min_dep, fun_defs, pi) + + + try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo) + try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks, pi_deps, pi_groups, pi_next_group} + | fun_nr <= min_dep + # (pi_deps, pi_marks, group, fun_defs) + = close_group fun_index pi_deps pi_marks [] max_fun_nr pi_next_group fun_defs + pi = { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_next_group = inc pi_next_group, pi_groups = [group : pi_groups] } + = (max_fun_nr, fun_defs, pi) + = (min_dep, fun_defs, pi) + where + close_group :: !Int ![Int] !*{# Int} ![Int] !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef}) + close_group fun_index [d:ds] marks group max_fun_nr group_number fun_defs + # marks = { marks & [d] = max_fun_nr } + #! fd = fun_defs.[d] + # fun_defs = { fun_defs & [d] = { fd & fun_info.fi_group_index = group_number }} + | d == fun_index + = (ds, marks, [d : group], fun_defs) + = close_group fun_index ds marks [d : group] max_fun_nr group_number fun_defs + +:: BitVector :== Int + +:: *AnalyseInfo = + { ai_heap :: !*VarHeap + , ai_cons_class :: !*{! ConsClasses} + , ai_class_subst :: !* ConsClassSubst + , ai_next_var :: !Int + } + +:: ConsClassSubst :== {# ConsClass} + +/* + The argument classification (i.e. 'accumulating', 'active' or 'passive') of consumers + is represented by an negative integer value. + Possitive classifications are used to identify variables. + Unification of classifications is done on-the-fly +*/ + + +cPassive :== -1 +cActive :== -2 +cAccumulating :== -3 + +IsAVariable cons_class :== cons_class >= 0 + +combineClasses cc1 cc2 + | IsAVariable cc1 + = cAccumulating + | IsAVariable cc2 + = cAccumulating + = min cc1 cc2 + +unifyClassifications :: !ConsClass !ConsClass !*ConsClassSubst -> *ConsClassSubst +unifyClassifications cc1 cc2 subst + # (cc1,subst) = skip_indirections_of_variables cc1 subst + (cc2,subst) = skip_indirections_of_variables cc2 subst + = combine_cons_classes cc1 cc2 subst +where + + skip_indirections_of_variables :: Int !*ConsClassSubst -> (!Int,!*ConsClassSubst) + skip_indirections_of_variables cc subst + | IsAVariable cc + #! cc = skip_indirections cc subst + = (cc, subst) + = (cc, subst) + where + skip_indirections cons_var subst + #! redir = subst.[cons_var] + | IsAVariable redir + = skip_indirections redir subst + = cons_var + + combine_cons_classes :: !Int !Int !*ConsClassSubst -> *ConsClassSubst + combine_cons_classes cc1 cc2 subst + | cc1 == cc2 + = subst + | IsAVariable cc1 + #! cc_val1 = subst.[cc1] + | IsAVariable cc2 + #! cc_val2 = subst.[cc2] + = { subst & [cc2] = cc1, [cc1] = combine_cons_constants cc_val1 cc_val2 } + = { subst & [cc1] = combine_cons_constants cc_val1 cc2 } + | IsAVariable cc2 + #! cc_val2 = subst.[cc2] + = { subst & [cc2] = combine_cons_constants cc1 cc_val2 } + = subst + + combine_cons_constants cc1 cc2 + = min cc1 cc2 + +write_ptr ptr val heap mess + | isNilPtr ptr + = abort mess + = heap <:= (ptr,val) + +class consumerRequirements a :: !a !AnalyseInfo -> (!ConsClass, !AnalyseInfo) + +instance consumerRequirements BoundVar +where + consumerRequirements {var_info_ptr} ai=:{ai_heap} + #! var_info = sreadPtr var_info_ptr ai_heap + = case var_info of + VI_AccVar temp_var + -> (temp_var, ai) + _ + -> (cPassive, ai) + +instance consumerRequirements Expression where + consumerRequirements (Var var) ai + = consumerRequirements var ai + consumerRequirements (App app) ai + = consumerRequirements app ai + consumerRequirements (fun_expr @ exprs) ai + # (cc_fun, ai) = consumerRequirements fun_expr ai + ai_class_subst = unifyClassifications cActive cc_fun ai.ai_class_subst + = consumerRequirements exprs { ai & ai_class_subst = ai_class_subst } + consumerRequirements (Let {let_binds,let_expr}) ai=:{ai_next_var,ai_heap} + # (new_next_var, ai_heap) = init_variables let_binds ai_next_var ai_heap + # ai = acc_requirements_of_let_binds let_binds ai_next_var { ai & ai_next_var = new_next_var, ai_heap = ai_heap } + = consumerRequirements let_expr ai + where + init_variables [{bind_dst={fv_info_ptr}} : binds] ai_next_var ai_heap + = init_variables binds (inc ai_next_var) (write_ptr fv_info_ptr (VI_AccVar ai_next_var) ai_heap "init_variables") + init_variables [] ai_next_var ai_heap + = (ai_next_var, ai_heap) + + acc_requirements_of_let_binds [ {bind_src, bind_dst={fv_info_ptr}} : binds ] ai_next_var ai + # (bind_var, ai) = consumerRequirements bind_src ai + ai_class_subst = unifyClassifications ai_next_var bind_var ai.ai_class_subst + = acc_requirements_of_let_binds binds (inc ai_next_var) { ai & ai_class_subst = ai_class_subst } + acc_requirements_of_let_binds [] ai_next_var ai + = ai + + consumerRequirements (Case case_expr) ai + = consumerRequirements case_expr ai + consumerRequirements (BasicExpr _ _) ai + = (cPassive, ai) + consumerRequirements (MatchExpr _ _ expr) ai + = consumerRequirements expr ai + consumerRequirements (Selection _ expr selectors) ai + # (cc, ai) = consumerRequirements expr ai + ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst + ai = requirementsOfSelectors selectors { ai & ai_class_subst = ai_class_subst } + = (cPassive, ai) + consumerRequirements (Update expr1 selectors expr2) ai + # (cc, ai) = consumerRequirements expr1 ai + ai = requirementsOfSelectors selectors ai + (cc, ai) = consumerRequirements expr2 ai + = (cPassive, ai) + consumerRequirements (RecordUpdate cons_symbol expression expressions) ai + # (cc, ai) = consumerRequirements expression ai + (cc, ai) = consumerRequirements expressions ai + = (cPassive, ai) + consumerRequirements (TupleSelect tuple_symbol arg_nr expr) ai + = consumerRequirements expr ai + consumerRequirements (AnyCodeExpr _ _ _) ai + = (cPassive, ai) + consumerRequirements (ABCCodeExpr _ _) ai + = (cPassive, ai) + consumerRequirements (DynamicExpr dynamic_expr) ai + = consumerRequirements dynamic_expr ai + consumerRequirements (TypeCodeExpression _) ai + = (cPassive, ai) + consumerRequirements EE ai + = (cPassive, ai) + consumerRequirements expr ai + = abort ("consumerRequirements " <<- expr) + +requirementsOfSelectors selectors ai + = foldSt reqs_of_selector selectors ai +where + reqs_of_selector (ArraySelection _ _ index_expr) ai + # (_, ai) = consumerRequirements index_expr ai + = ai + reqs_of_selector (DictionarySelection dict_var _ _ index_expr) ai + # (_, ai) = consumerRequirements index_expr ai + (cc_var, ai) = consumerRequirements dict_var ai + = { ai & ai_class_subst = unifyClassifications cActive cc_var ai.ai_class_subst } + reqs_of_selector _ ai + = ai + +instance consumerRequirements App where + consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name}, app_args} ai=:{ai_cons_class} + | glob_module == cIclModIndex + | glob_object < size ai_cons_class + #! fun_class = ai_cons_class.[glob_object] + = reqs_of_args fun_class.cc_args app_args cPassive ai + = consumerRequirements app_args ai + = consumerRequirements app_args ai + where + reqs_of_args _ [] cumm_arg_class ai + = (cumm_arg_class, ai) + reqs_of_args [] _ cumm_arg_class ai + = (cumm_arg_class, ai) + reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class ai + # (act_cc, ai) = consumerRequirements arg ai + ai_class_subst = unifyClassifications form_cc act_cc ai.ai_class_subst + = reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) { ai & ai_class_subst = ai_class_subst } +/* + consumerRequirements {app_symb={symb_kind = SK_InternalFunction _}, app_args=[arg:_]} ai + # (cc, ai) = consumerRequirements arg ai + ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst + = (cPassive, { ai & ai_class_subst = ai_class_subst }) +*/ + consumerRequirements {app_args} ai + = consumerRequirements app_args ai + +instance consumerRequirements Case where + consumerRequirements {case_expr,case_guards,case_default} ai + # (cce, ai) = consumerRequirements case_expr ai +// ai_class_subst = unifyClassifications cActive cce ai.ai_class_subst + (ccgs, ai) = consumerRequirements (case_guards,case_default) ai //{ ai & ai_class_subst = ai_class_subst } + = (ccgs, ai) + +instance consumerRequirements DynamicExpr where + consumerRequirements {dyn_expr} ai + = consumerRequirements dyn_expr ai + +/* +instance consumerRequirements TypeCase where + consumerRequirements {type_case_dynamic,type_case_patterns,type_case_default} ai + # (_, ai) = consumerRequirements type_case_dynamic ai + (ccgs, ai) = consumerRequirements (type_case_patterns,type_case_default) ai + = (ccgs, ai) +*/ + +instance consumerRequirements DynamicPattern where + consumerRequirements {dp_rhs} ai + = consumerRequirements dp_rhs ai + +instance consumerRequirements CasePatterns where + consumerRequirements (AlgebraicPatterns type patterns) ai + = consumerRequirements patterns ai + consumerRequirements (BasicPatterns type patterns) ai + = consumerRequirements patterns ai + consumerRequirements (DynamicPatterns dyn_patterns) ai + = consumerRequirements dyn_patterns ai + +instance consumerRequirements AlgebraicPattern where + consumerRequirements {ap_vars,ap_expr} ai=:{ai_heap} + # ai_heap = bind_pattern_vars ap_vars ai_heap + = consumerRequirements ap_expr { ai & ai_heap = ai_heap } + where + bind_pattern_vars [{fv_info_ptr,fv_count} : vars] var_heap + | fv_count > 0 + = bind_pattern_vars vars (write_ptr fv_info_ptr (VI_AccVar cPassive) var_heap "bind_pattern_vars") + = bind_pattern_vars vars var_heap + bind_pattern_vars [] var_heap + = var_heap + +instance consumerRequirements BasicPattern where + consumerRequirements {bp_expr} ai + = consumerRequirements bp_expr ai + +instance consumerRequirements (Optional a) | consumerRequirements a where + consumerRequirements (Yes x) ai + = consumerRequirements x ai + consumerRequirements No ai + = (cPassive, ai) + +instance consumerRequirements (!a,!b) | consumerRequirements a & consumerRequirements b where + consumerRequirements (x, y) ai + # (ccx, ai) = consumerRequirements x ai + (ccy, ai) = consumerRequirements y ai + = (combineClasses ccx ccy, ai) + +instance consumerRequirements [a] | consumerRequirements a where + consumerRequirements [x : xs] ai + # (ccx, ai) = consumerRequirements x ai + (ccxs, ai) = consumerRequirements xs ai + = (combineClasses ccx ccxs, ai) + consumerRequirements [] ai + = (cPassive, ai) + +instance consumerRequirements (Bind a b) | consumerRequirements a where + consumerRequirements {bind_src} ai + = consumerRequirements bind_src ai + +analyseGroups :: !*{! Group} !*{#FunDef} !*VarHeap -> (!*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap) +analyseGroups groups fun_defs var_heap + #! nr_of_funs = size fun_defs + = analyse_groups 0 groups var_heap (createArray nr_of_funs { cc_size = 0, cc_args = [] }) fun_defs +where + analyse_groups group_nr groups var_heap class_env fun_defs + | group_nr == size groups + = (class_env, groups, fun_defs, var_heap) + #! fun_indexes = groups.[group_nr] + # (class_env, fun_defs, var_heap) = analyse_group fun_indexes.group_members var_heap class_env fun_defs + = analyse_groups (inc group_nr) groups var_heap class_env fun_defs + + analyse_group group var_heap class_env fun_defs + # (nr_of_vars, nr_of_local_vars, var_heap, class_env, fun_defs) = initial_cons_class group 0 0 var_heap class_env fun_defs + initial_subst = createArray (nr_of_vars + nr_of_local_vars) cPassive + (ai, fun_defs) = analyse_functions group { ai_heap = var_heap, ai_cons_class = class_env, + ai_class_subst = initial_subst, ai_next_var = nr_of_vars } fun_defs + class_env = collect_classifications group ai.ai_cons_class ai.ai_class_subst + = (class_env, fun_defs, ai.ai_heap) + + + initial_cons_class [fun : funs] next_var_number nr_of_local_vars var_heap class_env fun_defs + #! fun_def = fun_defs.[fun] + # (TransformedBody {tb_args}) = fun_def.fun_body + (fresh_vars, next_var_number, var_heap) = fresh_variables tb_args next_var_number var_heap + = initial_cons_class funs next_var_number (length fun_def.fun_info.fi_local_vars + nr_of_local_vars) var_heap + { class_env & [fun] = { cc_size = 0, cc_args = fresh_vars }} fun_defs + initial_cons_class [] next_var_number nr_of_local_vars var_heap class_env fun_defs + = (next_var_number, nr_of_local_vars, var_heap, class_env, fun_defs) + + fresh_variables [{fv_name,fv_info_ptr} : vars] next_var_number var_heap + # (fresh_vars, last_var_number, var_heap) = fresh_variables vars (inc next_var_number) var_heap + var_heap = write_ptr fv_info_ptr (VI_AccVar next_var_number) var_heap "fresh_variables" + = ([next_var_number : fresh_vars], last_var_number, var_heap) + fresh_variables [] next_var_number var_heap + = ([], next_var_number, var_heap) + + analyse_functions [fun : funs] ai fun_defs + #! fun_def = fun_defs.[fun] + # (TransformedBody {tb_rhs}) = fun_def.fun_body + (_, ai) = consumerRequirements tb_rhs ai + = analyse_functions funs ai fun_defs + analyse_functions [] ai fun_defs + = (ai, fun_defs) + + collect_classifications [] class_env class_subst + = class_env + collect_classifications [fun : funs] class_env class_subst + #! fun_class = class_env.[fun] + = collect_classifications funs { class_env & [fun] = determine_classification fun_class.cc_args class_subst } class_subst + where + determine_classification cc class_subst + # (cc_size, cc_args) = mapAndLength (skip_indirections class_subst) cc + = { cc_size = cc_size, cc_args = cc_args } + + skip_indirections class_subst cc + | IsAVariable cc + = skip_indirections class_subst class_subst.[cc] + = cc + +mapAndLength f [x : xs] + #! x = f x + (length, xs) = mapAndLength f xs + = (inc length, [x : xs]) +mapAndLength f [] + = (0, []) + +:: *TransformInfo = + { ti_fun_defs :: !*{# FunDef} + , ti_instances :: !*{! InstanceInfo } + , ti_cons_args :: !{! ConsClasses} + , ti_new_functions :: ![FunctionInfoPtr] + , ti_fun_heap :: !*FunctionHeap + , ti_var_heap :: !*VarHeap + , ti_symbol_heap :: !*ExpressionHeap + , ti_type_heaps :: !*TypeHeaps + , ti_next_fun_nr :: !Index + } + +class transform a :: !a !{# {# FunType} } !TransformInfo -> (!a, !TransformInfo) + +instance transform Expression +where + transform expr=:(App app=:{app_symb,app_args}) imported_funs ti + # (app_args, ti) = transform app_args imported_funs ti + = transformApplication { app & app_args = app_args } [] imported_funs ti + transform appl_expr=:(expr @ exprs) imported_funs ti + # (expr, ti) = transform expr imported_funs ti + (exprs, ti) = transform exprs imported_funs ti + = case expr of + App app + -> transformApplication app exprs imported_funs ti + _ + -> (expr @ exprs, ti) + transform (Let lad=:{let_binds, let_expr}) imported_funs ti + # (let_binds, ti) = transform let_binds imported_funs ti + (let_expr, ti) = transform let_expr imported_funs ti + = (Let { lad & let_binds = let_binds, let_expr = let_expr}, ti) + transform (Case case_expr) imported_funs ti +// = transformCase case_expr imported_funs ti + # (case_expr, ti) = transform case_expr imported_funs ti + = (Case case_expr, ti) + transform (Selection opt_type expr selectors) imported_funs ti + # (expr, ti) = transform expr imported_funs ti + = transformSelection opt_type selectors expr ti + transform (DynamicExpr dynamic_expr) imported_funs ti + # (dynamic_expr, ti) = transform dynamic_expr imported_funs ti + = (DynamicExpr dynamic_expr, ti) + transform expr imported_funs ti + = (expr, ti) + +neverMatchingCase = { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = No, case_info_ptr = nilPtr } + +instance transform Case +where + transform kees=:{case_expr, case_guards, case_default} imported_funs ti + # (case_expr, ti) = transform case_expr imported_funs ti + (case_guards, ti) = transform case_guards imported_funs ti + (case_default, ti) = transform case_default imported_funs ti + = ({kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default}, ti) + +instance transform DynamicExpr where + transform dyn=:{dyn_expr} imported_funs ti + # (dyn_expr, ti) = transform dyn_expr imported_funs ti + = ({dyn & dyn_expr = dyn_expr}, ti) + +instance transform DynamicPattern where + transform dp=:{dp_rhs} imported_funs ti + # (dp_rhs, ti) = transform dp_rhs imported_funs ti + = ({ dp & dp_rhs = dp_rhs }, ti) + +/* +transformCase :: !Case !*TransformInfo -> *(!Expression, !*TransformInfo) +transformCase this_case=:{case_expr,case_guards,case_default,case_ident} imported_funs ti + = case case_expr of + Case case_in_case + -> lift_case case_in_case case_guards case_default case_ident ti + App {app_symb,app_args} + -> case app_symb.symb_kind of + SK_Constructor cons_index + # (may_be_match_expr, ti) = match_and_instantiate cons_index app_args case_guards case_default ti + -> case may_be_match_expr of + Yes match_expr + -> (match_expr, ti) + No + -> (Case neverMatchingCase, ti) + _ + # (may_be_unfolded_expr, ti) = tryToUnfoldExpression app_symb app_args ti + -> case may_be_unfolded_expr of + (Yes unfolded_expr) + -> transformCase {this_case & case_expr = unfolded_expr } ti + No + # (this_case, ti) = transform this_case ti + -> (Case this_case, ti) + _ + # (this_case, ti) = transform this_case ti + -> (Case this_case, ti) + +where + lift_case :: !Case ![PatternExpression] !(Optional Expression) !(Optional Ident) !*TransformInfo -> *(!Expression, !*TransformInfo) + lift_case nested_case=:{case_guards,case_default} outer_guards outer_default outer_ident ti + # (case_guards, ti) = lift_patterns case_guards outer_guards outer_default outer_ident ti + (case_default, ti) = lift_default case_default outer_guards outer_default outer_ident ti + = (Case {nested_case & case_guards = case_guards, case_default = case_default}, ti) + + lift_patterns :: ![PatternExpression] ![PatternExpression] !(Optional Expression) !(Optional Ident) !*TransformInfo -> *(![PatternExpression], !*TransformInfo) + lift_patterns [guard=:{guard_expr}] outer_guards outer_default outer_ident ti + # (guard_expr, ti) = transformCase {case_expr = guard_expr,case_guards = outer_guards,case_default = outer_default, case_ident = outer_ident} ti + = ([{guard & guard_expr = guard_expr}], ti) + lift_patterns [guard=:{guard_expr} : nested_guards] outer_guards outer_default outer_ident ti=:{ti_var_heap} + # (outer_guards, ti_var_heap) = copy_guards outer_guards ti_var_heap + # (guard_expr, ti) = transformCase {case_expr = guard_expr,case_guards = outer_guards,case_default = outer_default, case_ident = outer_ident} { ti & ti_var_heap = ti_var_heap } + (nested_guards, ti) = lift_patterns nested_guards outer_guards outer_default outer_ident ti + = ([{guard & guard_expr = guard_expr} : nested_guards], ti) + lift_patterns [] outer_guards outer_default outer_ident ti + = ([], ti) + + copy_guards [guard : guards] var_heap + # (guard, _, var_heap) = unfold guard 0 var_heap + (guards, var_heap) = copy_guards guards var_heap + = ([ guard : guards ], var_heap) + copy_guards [] var_heap + = ([], var_heap) + + lift_default :: !(Optional Expression) ![PatternExpression] !(Optional Expression) !(Optional Ident) !*TransformInfo -> *(!Optional Expression, !*TransformInfo) + lift_default (Yes default_expr) outer_guards outer_default outer_ident ti + # (default_expr, ti) = transformCase {case_expr = default_expr, case_guards = outer_guards, case_default = outer_default, case_ident = outer_ident} ti + = (Yes default_expr, ti) + lift_default No outer_guards outer_default outer_ident ti + = (No, ti) + + match_and_instantiate :: !(Global Index) ![Expression] ![PatternExpression] !(Optional Expression) !*TransformInfo -> *(!Optional Expression, !*TransformInfo) + match_and_instantiate cons_index app_args [{guard_pattern = AlgebraicPattern {glob_module,glob_object={ds_index}} vars, guard_expr} : guards] + case_default ti + | cons_index.glob_module == glob_module && cons_index.glob_object == ds_index + # (unfolded_guard_expr, _, ti_var_heap) = unfold guard_expr 0 (bindVariables vars app_args ti.ti_var_heap) + (guard_expr, ti) = transform unfolded_guard_expr { ti & ti_var_heap = ti_var_heap } + = (Yes guard_expr, ti) + = match_and_instantiate cons_index app_args guards case_default ti + match_and_instantiate cons_index app_args [guard : guards] case_default ti + = match_and_instantiate cons_index app_args guards case_default ti + match_and_instantiate cons_index app_args [] default_expr ti + = transform default_expr ti + + +tryToUnfoldExpression :: !SymbIdent ![Expression] !*TransformInfo -> *(!Optional Expression, ! *TransformInfo) +tryToUnfoldExpression {symb_kind = SK_Function {glob_module,glob_object},symb_arity} app_args ti=:{ti_fun_defs, ti_var_heap, ti_symbol_heap} + | glob_module == cIclModIndex + #! fd = ti_fun_defs.[glob_object] + | fd.fun_arity == symb_arity + # (expr, ti_var_heap, ti_symbol_heap) = unfoldFunction fd.fun_body app_args ti_var_heap ti_symbol_heap + = (Yes expr, { ti & ti_var_heap = ti_var_heap, ti_symbol_heap = ti_symbol_heap}) + = (No, ti) + = (No, ti) +tryToUnfoldExpression {symb_kind = SK_GeneratedFunction fun_ptr fun_index,symb_arity} app_args ti=:{ti_fun_heap, ti_var_heap, ti_symbol_heap} + #! fun_info = sreadPtr fun_ptr ti_fun_heap + # (FI_Function {gf_fun_def}) = fun_info + | gf_fun_def.fun_arity == symb_arity + # (expr, ti_var_heap, ti_symbol_heap) = unfoldFunction gf_fun_def.fun_body app_args ti_var_heap ti_symbol_heap + = (Yes expr, { ti & ti_var_heap = ti_var_heap, ti_symbol_heap = ti_symbol_heap }) + = (No, ti) +tryToUnfoldExpression expr app_args ti + = (No, ti) + +unfoldFunction :: !FunctionBody ![Expression] !*VarHeap !*ExpressionHeap -> (!Expression, !*VarHeap, !*ExpressionHeap) +unfoldFunction (TransformedBody {tb_args,tb_rhs}) act_args var_heap symbol_heap + # var_heap = foldr2 (\{fv_info_ptr} arg -> writePtr fv_info_ptr (VI_Expression arg)) var_heap tb_args act_args + # (unfolded_rhs, {us_var_heap,us_symbol_heap}) = unfold tb_rhs { us_var_heap = var_heap, us_symbol_heap = symbol_heap } + = (unfolded_rhs, us_var_heap, us_symbol_heap) +*/ + +instance transform Bind a b | transform a +where + transform bind=:{bind_src} imported_funs ti + # (bind_src, ti) = transform bind_src imported_funs ti + = ({ bind & bind_src = bind_src }, ti) + +instance transform BasicPattern +where + transform pattern=:{bp_expr} imported_funs ti + # (bp_expr, ti) = transform bp_expr imported_funs ti + = ({ pattern & bp_expr = bp_expr }, ti) + +instance transform AlgebraicPattern +where + transform pattern=:{ap_expr} imported_funs ti + # (ap_expr, ti) = transform ap_expr imported_funs ti + = ({ pattern & ap_expr = ap_expr }, ti) + +instance transform CasePatterns +where + transform (AlgebraicPatterns type patterns) imported_funs ti + # (patterns, ti) = transform patterns imported_funs ti + = (AlgebraicPatterns type patterns, ti) + transform (BasicPatterns type patterns) imported_funs ti + # (patterns, ti) = transform patterns imported_funs ti + = (BasicPatterns type patterns, ti) + transform (DynamicPatterns patterns) imported_funs ti + # (patterns, ti) = transform patterns imported_funs ti + = (DynamicPatterns patterns, ti) + +instance transform Optional a | transform a +where + transform (Yes x) imported_funs ti + # (x, ti) = transform x imported_funs ti + = (Yes x, ti) + transform no imported_funs ti + = (no, ti) + +instance transform [a] | transform a +where + transform [x : xs] imported_funs ti + # (x, ti) = transform x imported_funs ti + (xs, ti) = transform xs imported_funs ti + = ([x : xs], ti) + transform [] imported_funs ti + = ([], ti) + +compareProducers prods1 prods2 + #! nr_of_prods = size prods1 + = compare_producers 0 nr_of_prods prods1 prods2 +where + compare_producers prod_index nr_of_prods prods1 prods2 + | prod_index == nr_of_prods + = Equal + # cmp = prods1.[prod_index] =< prods2.[prod_index] + | cmp == Equal + = compare_producers (inc prod_index) nr_of_prods prods1 prods2 + = cmp + +instance =< Producer +where + (=<) pr1 pr2 + | equal_constructor pr1 pr2 + = compare_constructor_arguments pr1 pr2 + | less_constructor pr1 pr2 + = Smaller + = Greater + where + compare_constructor_arguments (PR_Function _ index1) (PR_Function _ index2) + = index1 =< index2 + compare_constructor_arguments (PR_GeneratedFunction _ index1) (PR_GeneratedFunction _ index2) + = index1 =< index2 + compare_constructor_arguments (PR_Class app1 _ _) (PR_Class app2 _ _) + = app1.app_args =< app2.app_args + compare_constructor_arguments _ _ + = Equal + +cIsANewFunction :== True +cIsNotANewFunction :== False + +tryToFindInstance :: !{! Producer} !InstanceInfo !*(Heap FunctionInfo) -> (!Bool, !FunctionInfoPtr, !InstanceInfo, !.FunctionHeap) +tryToFindInstance new_prods II_Empty fun_heap + # (fun_def_ptr, fun_heap) = newPtr FI_Empty fun_heap + = (cIsANewFunction, fun_def_ptr, II_Node new_prods fun_def_ptr II_Empty II_Empty, fun_heap) +tryToFindInstance new_prods instances=:(II_Node prods fun_def_ptr left right) fun_heap + # cmp = compareProducers new_prods prods + | cmp == Equal + = (cIsNotANewFunction, fun_def_ptr, instances, fun_heap) + | cmp == Greater + # (is_new, new_fun_def_ptr, right, fun_heap) = tryToFindInstance new_prods right fun_heap + = (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap) + # (is_new, new_fun_def_ptr, left, fun_heap) = tryToFindInstance new_prods left fun_heap + = (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap) + + +generateFunction :: !FunDef ![Int] !{! Producer} !FunctionInfoPtr !{# {# FunType} } !*TransformInfo -> (!Index, !Int, !*TransformInfo) +generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = info =: {fi_group_index}} cc_args prods fun_def_ptr + imported_funs ti=:{ti_var_heap,ti_next_fun_nr,ti_new_functions,ti_fun_heap,ti_symbol_heap,ti_fun_defs,ti_type_heaps,ti_cons_args} + #! fi_group_index = max_group_index 0 prods fi_group_index ti_fun_defs ti_fun_heap ti_cons_args + # (Yes fun_type=:{st_vars,st_attr_vars,st_args,st_result}) = fd.fun_type + + th_vars = foldSt (\tv type_var_heap -> type_var_heap <:= (tv.tv_info_ptr, TVI_Type (TV tv))) st_vars ti_type_heaps.th_vars + th_attrs = foldSt (\av attr_var_heap -> attr_var_heap <:= (av.av_info_ptr, AVI_Attr (TA_Var av))) st_attr_vars ti_type_heaps.th_attrs + + (new_fun_args, new_arg_types, new_cons_args, th_vars, ti_var_heap) = determine_args cc_args 0 prods tb_args st_args th_vars ti_var_heap + + (fresh_arg_types, ti_type_heaps) = substitute new_arg_types { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (fresh_result_type, ti_type_heaps) = substitute st_result ti_type_heaps + + new_gen_fd = { gf_fun_def = { fd & fun_body = Expanding, fun_info = { info & fi_group_index = fi_group_index }}, + gf_instance_info = II_Empty, + gf_fun_index = ti_next_fun_nr, gf_cons_args = {cc_args = new_cons_args, cc_size = length new_cons_args} } + ti_fun_heap = writePtr fun_def_ptr (FI_Function new_gen_fd) ti_fun_heap + + (tb_rhs, {us_var_heap,us_symbol_heap}) = unfold tb_rhs { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap } + + (new_fun_rhs, ti) = transform tb_rhs imported_funs { ti & ti_var_heap = us_var_heap, ti_fun_heap = ti_fun_heap, ti_symbol_heap = us_symbol_heap, + ti_next_fun_nr = inc ti_next_fun_nr, ti_new_functions = [fun_def_ptr : ti_new_functions], ti_type_heaps = ti_type_heaps } + fun_arity = length new_fun_args + new_fd = { fd & fun_body = TransformedBody {tb_args = new_fun_args, tb_rhs = new_fun_rhs}, fun_arity = fun_arity, fun_index = ti_next_fun_nr, + fun_type = Yes { fun_type & st_args = fresh_arg_types, st_result = fresh_result_type }} + = (ti_next_fun_nr, fun_arity, { ti & ti_fun_heap = ti.ti_fun_heap <:= (fun_def_ptr, FI_Function { new_gen_fd & gf_fun_def = new_fd })}) +where + determine_args [] prod_index producers forms types type_var_heap var_heap + # (vars, var_heap) = new_variables forms var_heap + = (vars, types, [], type_var_heap, var_heap) + determine_args [cons_arg : cons_args ] prod_index producers [form : forms] [type : types] type_var_heap var_heap + | cons_arg == cActive + # new_args = determine_args cons_args (inc prod_index) prods forms types type_var_heap var_heap + = determine_arg producers.[prod_index] form type new_args + # (vars, types, new_cons_args, type_var_heap, var_heap) = determine_args cons_args prod_index prods forms types type_var_heap var_heap + (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ([{ form & fv_info_ptr = new_info_ptr } : vars], [type : types], [cons_arg : new_cons_args], type_var_heap, + var_heap <:= (form.fv_info_ptr, VI_Variable form.fv_name new_info_ptr)) + where +/* + build_var_args new_name arity form_vars act_vars var_heap + | arity == 0 + = (form_vars, act_vars, var_heap) + # (info_ptr, var_heap) = newPtr VI_Empty var_heap + form_var = { fv_name = new_name, fv_info_ptr = info_ptr, fv_count = 0, fv_def_level = NotALevel } + act_var = { var_name = new_name, var_info_ptr = info_ptr, var_expr_ptr = nilPtr } + = build_var_args new_name (dec arity) [form_var : form_vars] [Var act_var : act_vars] var_heap +*/ + determine_arg PR_Empty form=:{fv_name,fv_info_ptr} type (vars, types, new_cons_args, type_var_heap, var_heap) + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ([{ form & fv_info_ptr = new_info_ptr } : vars], [ type : types ], [cActive : new_cons_args], type_var_heap, + var_heap <:= (fv_info_ptr, VI_Variable fv_name new_info_ptr)) +/* + determine_arg (PR_Function symbol _) vars {fv_info_ptr,fv_name} new_cons_args var_heap + # (form_vars, act_vars, var_heap) = build_var_args fv_name symbol.symb_arity vars [] var_heap + = (form_vars, writePtr fv_info_ptr ( + VI_Expression (App { app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr })) var_heap) + determine_arg (PR_GeneratedFunction symbol _) vars {fv_info_ptr,fv_name} var_heap + # (form_vars, act_vars, var_heap) = build_var_args fv_name symbol.symb_arity vars [] var_heap + = (form_vars, writePtr fv_info_ptr ( + VI_Expression (App { app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr })) var_heap) +*/ + determine_arg (PR_Class class_app free_vars class_types) {fv_info_ptr,fv_name} type (vars, types, new_cons_args, type_var_heap, var_heap) + = (mapAppend (\{var_info_ptr,var_name} -> { fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0 }) free_vars vars, + mapAppend (\_ -> { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }) free_vars types, + mapAppend (\_ -> cActive) free_vars new_cons_args, + bind_class_types type.at_type class_types type_var_heap, + var_heap <:= (fv_info_ptr, VI_Expression (App class_app))) + + bind_class_types (TA _ context_types) instance_types type_var_heap + = bind_context_types context_types instance_types type_var_heap + where + bind_context_types [atype : atypes] [type : types] type_var_heap + = bind_context_types atypes types (bind_type atype.at_type type type_var_heap) + bind_context_types [] [] type_var_heap + = type_var_heap + bind_class_types _ _ type_var_heap + = type_var_heap + + bind_type (TV {tv_info_ptr}) type type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_Type type) + bind_type (TA _ arg_types1) (TA _ arg_types2) type_var_heap + = bind_types arg_types1 arg_types2 type_var_heap + bind_type _ _ type_var_heap + = type_var_heap + + bind_types [type1 : types1] [type2 : types2] type_var_heap + = bind_types types1 types2 (bind_type type1.at_type type2.at_type type_var_heap) + bind_types [] [] type_var_heap + = type_var_heap + + new_variables [] var_heap + = ([], var_heap) + new_variables [form=:{fv_name,fv_info_ptr}:forms] var_heap + # (vars, var_heap) = new_variables forms var_heap + (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ([{ form & fv_info_ptr = new_info_ptr } : vars], writePtr fv_info_ptr (VI_Variable fv_name new_info_ptr) var_heap) + + max_group_index prod_index producers current_max fun_defs fun_heap cons_args + | prod_index == size producers + = current_max + # current_max = max_group_index_of_producer producers.[prod_index] current_max fun_defs fun_heap cons_args + = max_group_index (inc prod_index) producers current_max fun_defs fun_heap cons_args + + max_group_index_of_producer PR_Empty current_max fun_defs fun_heap cons_args + = current_max + max_group_index_of_producer (PR_Class {app_args} _ _) current_max fun_defs fun_heap cons_args + = max_group_index_of_members app_args current_max fun_defs fun_heap cons_args + max_group_index_of_producer prod current_max fun_defs fun_heap cons_args + = abort ("trans.icl: max_group_index_of_producer" ---> prod) + + max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_name, symb_kind = SK_Function { glob_object = fun_index, glob_module = mod_index}}}) + | mod_index == cIclModIndex + | fun_index < size cons_args + # {fun_info = {fi_group_index}} = fun_defs.[fun_index] + = max fi_group_index current_max + = current_max + = current_max + max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_kind = SK_GeneratedFunction fun_ptr fun_index }}) + # (FI_Function {gf_fun_def={fun_info = {fi_group_index}}}) = sreadPtr fun_ptr fun_heap + = max fi_group_index current_max + max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_kind = SK_Constructor _}, app_args}) + = max_group_index_of_members app_args current_max fun_defs fun_heap cons_args + + max_group_index_of_members members current_max fun_defs fun_heap cons_args + = foldl (max_group_index_of_member fun_defs fun_heap cons_args) current_max members + + +transformFunctionApplication fun_def instances {cc_size, cc_args} app=:{app_symb,app_args} extra_args imported_funs ti + # (app_symb, app_args, extra_args) = complete_application app_symb fun_def.fun_arity app_args extra_args + | cc_size > 0 + # (producers, new_args, ti) = determineProducers cc_args app_args 0 (createArray cc_size PR_Empty) ti + | containsProducer cc_size producers + # (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap + | is_new + # (fun_index, fun_arity, ti) = generateFunction fun_def cc_args producers fun_def_ptr imported_funs + (update_instance_info app_symb.symb_kind instances { ti & ti_fun_heap = ti_fun_heap }) + app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr fun_index, symb_arity = length new_args} + (app_symb, app_args, extra_args) = complete_application app_symb fun_arity new_args extra_args + = (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti) + # (FI_Function {gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap + app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index, symb_arity = length new_args} + (app_symb, app_args, extra_args) = complete_application app_symb gf_fun_def.fun_arity new_args extra_args + = (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, {ti & ti_fun_heap = ti_fun_heap }) + = (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti) + = (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti) +where + update_instance_info (SK_Function {glob_object}) instances ti=:{ti_instances} + = { ti & ti_instances = { ti_instances & [glob_object] = instances } } + update_instance_info (SK_GeneratedFunction fun_def_ptr _) instances ti=:{ti_fun_heap} + # (FI_Function fun_info, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap + = { ti & ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function { fun_info & gf_instance_info = instances })} + + complete_application symb form_arity args [] + = (symb, args, []) + complete_application symb=:{symb_arity} form_arity args extra_args + # arity_diff = min (form_arity - symb_arity) (length extra_args) + = ({ symb & symb_arity = symb_arity + arity_diff }, args ++ take arity_diff extra_args, drop arity_diff extra_args) + + build_application app [] + = App app + build_application app extra_args + = App app @ extra_args + +transformApplication :: !App ![Expression] !{# {# FunType} } !*TransformInfo -> *(!Expression,!*TransformInfo) +transformApplication app=:{app_symb=symb=:{symb_kind = SK_Function {glob_module, glob_object},symb_arity}, app_args} extra_args + imported_funs ti=:{ti_cons_args,ti_instances,ti_fun_defs} + | glob_module == cIclModIndex + | glob_object < size ti_cons_args + #! cons_class = ti_cons_args.[glob_object] + instances = ti_instances.[glob_object] + fun_def = ti_fun_defs.[glob_object] + = transformFunctionApplication fun_def instances cons_class app extra_args imported_funs ti +// It seems as if we have an array function + | isEmpty extra_args + = (App app, ti) + = (App { app & app_symb = { symb & symb_arity = symb_arity + length extra_args}, app_args = app_args ++ extra_args}, ti) +// This function is imported + | isEmpty extra_args + = (App app, ti) + # ar_diff = imported_funs.[glob_module].[glob_object].ft_arity - symb_arity + nr_of_extra_args = length extra_args + | nr_of_extra_args <= ar_diff + = (App {app & app_args = app_args ++ extra_args, app_symb = { symb & symb_arity = symb_arity + nr_of_extra_args }}, ti) + = (App {app & app_args = app_args ++ take ar_diff extra_args, app_symb = { symb & symb_arity = symb_arity + ar_diff }} @ + drop ar_diff extra_args, ti) + +transformApplication app=:{app_symb={symb_kind = SK_GeneratedFunction fun_def_ptr fun_index}} extra_args imported_funs ti=:{ti_fun_heap} + # (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap + = transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args imported_funs { ti & ti_fun_heap = ti_fun_heap } +transformApplication app [] imported_funs ti + = (App app, ti) +transformApplication app extra_args imported_funs ti + = (App app @ extra_args, ti) + +transformSelection opt_type [RecordSelection _ field_index : selectors] (App {app_symb={symb_kind= SK_Constructor _ }, app_args}) ti + = transform_selections selectors (app_args !! field_index) ti +where + transform_selections [] expr ti + = (expr, ti) + transform_selections [RecordSelection _ field_index : selectors] (App {app_symb={symb_kind= SK_Constructor _ }, app_args}) ti + = transform_selections selectors (app_args !! field_index) ti + transform_selections selectors expr ti + = (Selection No expr selectors, ti) +transformSelection opt_type selectors expr ti + = (Selection opt_type expr selectors, ti) + +determineProducers :: ![Int] ![Expression] !Index !*{! Producer} !*TransformInfo -> (!*{! Producer},![Expression],!*TransformInfo) +determineProducers cons_args [] prod_index producers ti + = (producers, [], ti) +determineProducers [ cons_arg : cons_args ] [ arg : args ] prod_index producers ti + | cons_arg == cActive + # (producers, new_args, ti) = determineProducers cons_args args (inc prod_index) producers ti + = determine_producer arg new_args prod_index producers ti + # (producers, new_args, ti) = determineProducers cons_args args prod_index producers ti + = (producers, [arg : new_args], ti) +where + determine_producer arg=:(App app=:{app_info_ptr}) new_args prod_index producers ti + | isNilPtr app_info_ptr + = (producers, [arg : new_args], ti) + # (app_info, ti_symbol_heap) = readPtr app_info_ptr ti.ti_symbol_heap + = determineProducer app app_info new_args prod_index producers { ti & ti_symbol_heap = ti_symbol_heap } + determine_producer arg new_args prod_index producers ti + = (producers, [arg : new_args], ti) + +determineProducer :: !App !ExprInfo ![Expression] !Index !*{! Producer} !*TransformInfo -> (!*{! Producer}, ![Expression], !*TransformInfo) +determineProducer app=:{app_symb = symb=:{symb_kind = SK_Constructor _}, app_args} (EI_ClassTypes types) new_args prod_index producers ti + # (app_args, (new_vars, ti_var_heap)) = renewVariables app_args ([], ti.ti_var_heap) + (new_args, ti_var_heap) = mapAppendSt retrieve_old_var new_vars new_args ti_var_heap + = ({ producers & [prod_index] = PR_Class { app & app_args = app_args } new_vars types}, new_args, { ti & ti_var_heap = ti_var_heap }) +where + retrieve_old_var {var_info_ptr} var_heap + #! var_info = sreadPtr var_info_ptr var_heap + # (VI_Forward var) = var_info + = (Var var, writePtr var_info_ptr VI_Empty (writePtr var.var_info_ptr VI_Empty var_heap)) +/* +determineProducer app=:{app_symb = symb=:{symb_kind = SK_Function { glob_module, glob_object }}, app_args} new_args prod_index producers ti + | glob_module == cIclModIndex + = ({ producers & [prod_index] = PR_Function symb glob_object}, app_args ++ new_args, ti) + = (producers, [App app : new_args ], ti) +determineProducer app=:{app_symb = symb=:{ symb_kind = SK_GeneratedFunction _ fun_index}, app_args} new_args prod_index producers ti=:{ti_fun_heap} + = ({ producers & [prod_index] = PR_GeneratedFunction symb fun_index }, app_args ++ new_args, ti) +determineProducer {app_symb = symb=:{symb_kind = SK_Constructor glob_index}, app_args} new_args prod_index producers ti + = ({ producers & [prod_index] = PR_Constructor symb app_args}, new_args, ti) +*/ +determineProducer app _ new_args _ producers ti + = (producers, [App app : new_args ], ti) + + +/* + verify_class_members [ App {app_symb, app_args} : mems] + = verify_class_members app_args && verify_class_members mems + verify_class_members [ _ : mems] + = False + verify_class_members [] + = True + + + verify_function fun_nr act_arity ti=:{ti_fun_defs,ti_new_functions} + | fun_nr < size ti_fun_defs + #! fd = ti_fun_defs.[fun_nr] + = (True, ti) + = (verify_new_function fun_nr act_arity ti_new_functions, ti) + where + verify_new_function fun_nr act_arity [{nf_fun_def={fun_index,fun_arity}}:new_functions] + | fun_nr == fun_index + = True + = verify_new_function fun_nr act_arity new_functions + verify_new_function fun_nr _ [] + = False +/* + verify_function fun_nr act_arity ti=:{ti_fun_defs,ti_new_functions} + | fun_nr < size ti_fun_defs + #! fd = ti_fun_defs.[fun_nr] + = (fd.fun_arity > act_arity, ti) + = (verify_new_function fun_nr act_arity ti_new_functions, ti) + where + verify_new_function fun_nr act_arity [{nf_fun_def={fun_index,fun_arity}}:new_functions] + | fun_nr == fun_index + = fun_arity > act_arity + = verify_new_function fun_nr act_arity new_functions + verify_new_function fun_nr _ [] + = False ---> fun_nr +*/ +*/ + +containsProducer prod_index producers + | prod_index == 0 + = False + #! prod_index = dec prod_index + = is_a_producer producers.[prod_index] || containsProducer prod_index producers +where + is_a_producer PR_Empty = False + is_a_producer _ = True + +class renewVariables a :: !a !(![BoundVar], !*VarHeap) -> (!a, !(![BoundVar], !*VarHeap)) + +instance renewVariables Expression +where + renewVariables (Var var=:{var_info_ptr}) (new_vars, var_heap) + #! var_info = sreadPtr var_info_ptr var_heap + = case var_info of + VI_Forward new_var + -> (Var { var & var_info_ptr = new_var.var_info_ptr }, (new_vars, var_heap)) + _ + # (new_info_ptr, var_heap) = newPtr (VI_Forward var) var_heap + new_var = { var & var_info_ptr = new_info_ptr } + var_heap = writePtr var_info_ptr (VI_Forward new_var) var_heap + -> (Var new_var, ([new_var : new_vars], var_heap)) + renewVariables (App app=:{app_args}) state + # (app_args, state) = renewVariables app_args state + = (App { app & app_args = app_args }, state) + renewVariables expr state + = (expr, state) + +instance renewVariables [a] | renewVariables a +where + renewVariables l state = mapSt renewVariables l state + +:: ImportedConstructors :== [Global Index] + +transformGroups :: !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*VarHeap !*TypeHeaps !*ExpressionHeap + -> (!*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) +transformGroups groups fun_defs cons_args common_defs imported_funs var_heap type_heaps symbol_heap + #! nr_of_funs = size fun_defs + # imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs } + (groups, imported_types, collected_imports, {ti_fun_defs,ti_new_functions,ti_var_heap,ti_symbol_heap,ti_fun_heap,ti_next_fun_nr,ti_type_heaps}) + = transform_groups 0 groups common_defs imported_funs imported_types [] + {ti_fun_defs = fun_defs, ti_instances = createArray nr_of_funs II_Empty, ti_cons_args = cons_args, + ti_new_functions = [], ti_fun_heap = newHeap, ti_var_heap = var_heap, ti_symbol_heap = symbol_heap, + ti_type_heaps = type_heaps, ti_next_fun_nr = nr_of_funs} + (groups, new_fun_defs, imported_types, collected_imports, ti_type_heaps, ti_var_heap) + = foldSt (add_new_function_to_group common_defs ti_fun_heap) ti_new_functions + (groups, [], imported_types, collected_imports, ti_type_heaps, ti_var_heap) + = ( groups, { fundef \\ fundef <- [ fundef \\ fundef <-: ti_fun_defs ] ++ new_fun_defs }, imported_types, collected_imports, + ti_var_heap, ti_type_heaps, ti_symbol_heap) + +where + transform_groups group_nr groups common_defs imported_funs imported_types collected_imports ti + | group_nr < size groups + #! group = groups.[group_nr] + # {group_members} = group + # (ti_fun_defs, imported_types, collected_imports, ti_type_heaps, ti_var_heap) = foldSt (convert_function_type common_defs) group_members + (ti.ti_fun_defs, imported_types, collected_imports, ti.ti_type_heaps, ti.ti_var_heap) + = transform_groups (inc group_nr) groups common_defs imported_funs imported_types collected_imports + (foldSt (transform_function imported_funs) group_members + { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap }) + = (groups, imported_types, collected_imports, ti) + + transform_function imported_funs fun ti=:{ti_fun_defs} + #! fun_def = ti_fun_defs.[fun] + # {fun_body = TransformedBody tb} = fun_def + (fun_rhs, ti) = transform tb.tb_rhs imported_funs ti + = { ti & ti_fun_defs = {ti.ti_fun_defs & [fun] = { fun_def & fun_body = TransformedBody { tb & tb_rhs = fun_rhs }}}} + + add_new_function_to_group :: !{# CommonDefs} !FunctionHeap !FunctionInfoPtr !(!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + add_new_function_to_group common_defs ti_fun_heap fun_ptr (groups, fun_defs, imported_types, collected_imports, type_heaps, var_heap) + # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr ti_fun_heap + group_index = gf_fun_def.fun_info.fi_group_index + (Yes ft=:{st_args,st_result}) = gf_fun_def.fun_type + ((st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes common_defs (st_result,st_args) + { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps = type_heaps, ets_var_heap = var_heap } + #! group = groups.[group_index] + = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, + [ { gf_fun_def & fun_type = Yes { ft & st_result = st_result, st_args = st_args }} : fun_defs], + ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + + convert_function_type common_defs fun_index (fun_defs, imported_types, collected_imports, type_heaps, var_heap) + # (fun_def=:{fun_type = Yes fun_type}, fun_defs) = fun_defs![fun_index] + (fun_type, imported_types, collected_imports, type_heaps, var_heap) + = convertSymbolType common_defs fun_type imported_types collected_imports type_heaps var_heap + = ({ fun_defs & [fun_index] = { fun_def & fun_type = Yes fun_type }}, imported_types, collected_imports, type_heaps, var_heap) + +convertSymbolType :: !{# CommonDefs} !SymbolType !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) +convertSymbolType common_defs st imported_types collected_imports type_heaps var_heap + # (st, {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes common_defs st + { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps= type_heaps, ets_var_heap = var_heap } + = (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + + +:: ExpandTypeState = + { ets_type_defs :: !.{#{#CheckedTypeDef}} + , ets_collected_conses :: !ImportedConstructors + , ets_type_heaps :: !.TypeHeaps + , ets_var_heap :: !.VarHeap + } + +class expandSynTypes a :: !{# CommonDefs} !a !*ExpandTypeState -> (!a, !*ExpandTypeState) + +/* +class expandSynTypes a :: !a (!*{#{#CheckedTypeDef}}, !*TypeHeaps) -> (!a, (!*{#{#CheckedTypeDef}}, !*TypeHeaps)) +*/ + +instance expandSynTypes SymbolType +where + expandSynTypes common_defs st=:{st_args,st_result,st_context} ets + # ((st_args,st_result), ets) = expandSynTypes common_defs (st_args,st_result) ets + # st_args = mapAppend (add_types_of_dictionary common_defs) st_context st_args + = ({st & st_args = st_args, st_result = st_result, st_arity = length st_args, st_context = [] }, ets) + where + add_types_of_dictionary common_defs {tc_class = {glob_module, glob_object={ds_index}}, tc_types} + # {class_arity, class_dictionary={ds_ident,ds_index}} = common_defs.[glob_module].com_class_defs.[ds_index] + dict_type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity + = { at_attribute = TA_Multi, at_annotation = AN_Strict, at_type = TA dict_type_symb ( + map (\type -> { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }) tc_types) } + +instance expandSynTypes Type +where + expandSynTypes common_defs (TA type_symb=:{type_index={glob_object,glob_module},type_name} types) ets=:{ets_type_defs} + # ({td_rhs,td_name,td_args},ets_type_defs) = ets_type_defs![glob_module].[glob_object] + ets = { ets & ets_type_defs = ets_type_defs } + = case td_rhs of + SynType rhs_type + # (type, ets_type_heaps) = substitute rhs_type.at_type (fold2St bind_var_and_attr td_args types ets.ets_type_heaps) + // ---> (td_name, td_args, rhs_type.at_type)) + -> expandSynTypes common_defs type { ets & ets_type_heaps = ets_type_heaps } + _ + # (types, ets) = expandSynTypes common_defs types ets + | glob_module == cIclModIndex + -> (TA type_symb types, ets) + -> (TA type_symb types, collect_imported_constructors common_defs glob_module td_rhs ets) + where + bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } + bind_var_and_attr { atv_variable = {tv_info_ptr}} {at_type} type_heaps=:{th_vars} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } + + collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap} + # (ets_collected_conses, ets_var_heap) + = collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs rt_constructor (ets_collected_conses, ets_var_heap) + = { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap } + collect_imported_constructors common_defs mod_index (AlgType constructors) ets=:{ets_collected_conses,ets_var_heap} + # (ets_collected_conses, ets_var_heap) + = foldSt (collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs) constructors (ets_collected_conses, ets_var_heap) + = { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap } + collect_imported_constructors common_defs mod_index _ ets + = ets + + collect_imported_constructor mod_index cons_defs {ds_index} (collected_conses, var_heap) + # {cons_type_ptr} = cons_defs.[ds_index] + (type_info, var_heap) = readPtr cons_type_ptr var_heap + | has_been_collected (sreadPtr cons_type_ptr var_heap) + = (collected_conses, var_heap) + = ([{ glob_module = mod_index, glob_object = ds_index } : collected_conses ], var_heap <:= (cons_type_ptr, VI_Used)) + + has_been_collected VI_Used = True + has_been_collected (VI_ExpandedType _) = True + has_been_collected _ = False + + + expandSynTypes common_defs (arg_type --> res_type) ets + # ((arg_type, res_type), ets) = expandSynTypes common_defs (arg_type, res_type) ets + = (arg_type --> res_type, ets) + expandSynTypes common_defs (cons_var :@: types) ets + # (types, ets) = expandSynTypes common_defs types ets + = (cons_var :@: types, ets) + expandSynTypes common_defs type ets + = (type, ets) + +instance expandSynTypes [a] | expandSynTypes a +where + expandSynTypes common_defs list ets + = mapSt (expandSynTypes common_defs) list ets + + +instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b +where + expandSynTypes common_defs tuple ets + = app2St (expandSynTypes common_defs, expandSynTypes common_defs) tuple ets + +instance expandSynTypes AType +where + expandSynTypes common_defs atype=:{at_type} ets + # (at_type, ets) = expandSynTypes common_defs at_type ets + = ({ atype & at_type = at_type }, ets) + + +/* +instance <<< InstanceInfo +where + (<<<) file (II_Node prods _ left right) = file <<< left <<< prods <<< right + (<<<) file II_Empty = file +*/ + + +instance <<< Producer +where + (<<<) file (PR_Function symbol index) + = file <<< "F" <<< symbol.symb_name + (<<<) file (PR_GeneratedFunction symbol index) + = file <<< "G" <<< symbol.symb_name <<< index + (<<<) file PR_Empty = file <<< 'E' + (<<<) file _ = file + +instance <<< FunCall +where + (<<<) file {fc_index} = file <<< fc_index + + diff --git a/frontend/transform.dcl b/frontend/transform.dcl new file mode 100644 index 0000000..79e47e8 --- /dev/null +++ b/frontend/transform.dcl @@ -0,0 +1,75 @@ +definition module transform + +import syntax, checksupport + +:: Group = + { group_members :: ![Int] + } + +partitionateAndLiftFunctions :: ![IndexRange] !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin + -> (!*{! Group}, !*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) + +partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin + -> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) + +:: UnfoldState = + { us_var_heap :: !.VarHeap + , us_symbol_heap :: !.ExpressionHeap + } + +class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) + +instance unfold Expression//, PatternExpression + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/frontend/transform.icl b/frontend/transform.icl new file mode 100644 index 0000000..2311449 --- /dev/null +++ b/frontend/transform.icl @@ -0,0 +1,1241 @@ +implementation module transform + +import syntax, check, StdCompare, utilities, RWSDebug + +:: LiftState = + { ls_var_heap :: !.VarHeap + , ls_fun_defs :: !.{#FunDef} + , ls_expr_heap :: !.ExpressionHeap + } + +class lift a :: !a !*LiftState -> (!a, !*LiftState) + +instance lift [a] | lift a +where + lift l ls = mapSt lift l ls + +instance lift (a,b) | lift a & lift b +where + lift t ls = app2St (lift,lift) t ls + +instance lift (Optional a) | lift a +where + lift (Yes x) ls + # (x, ls) = lift x ls + = (Yes x, ls) + lift no ls + = (no, ls) + +instance lift Expression +where + lift (FreeVar {fv_name,fv_info_ptr}) ls=:{ls_var_heap} + #! var_info = sreadPtr fv_info_ptr ls_var_heap + = case var_info of + VI_LiftedVariable var_info_ptr + # (var_expr_ptr, ls_expr_heap) = newPtr EI_Empty ls.ls_expr_heap + -> (Var { var_name = fv_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr }, { ls & ls_expr_heap = ls_expr_heap}) + _ + # (var_expr_ptr, ls_expr_heap) = newPtr EI_Empty ls.ls_expr_heap + -> (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, { ls & ls_expr_heap = ls_expr_heap}) + lift (App app) ls + # (app, ls) = lift app ls + = (App app, ls) + lift (expr @ exprs) ls + # ((expr,exprs), ls) = lift (expr,exprs) ls + = (expr @ exprs, ls) + lift (Let lad=:{let_binds, let_expr}) ls + # ((let_binds,let_expr), ls) = lift (let_binds,let_expr) ls + = (Let {lad & let_binds = let_binds, let_expr = let_expr}, ls) + lift (Case case_expr) ls + # (case_expr, ls) = lift case_expr ls + = (Case case_expr, ls) + lift (Selection is_unique expr selectors) ls + # (selectors, ls) = lift selectors ls + (expr, ls) = lift expr ls + = (Selection is_unique expr selectors, ls) + lift (Update expr1 selectors expr2) ls + # (selectors, ls) = lift selectors ls + (expr1, ls) = lift expr1 ls + (expr2, ls) = lift expr2 ls + = (Update expr1 selectors expr2, ls) + lift (RecordUpdate cons_symbol expression expressions) ls + # (expression, ls) = lift expression ls + (expressions, ls) = lift expressions ls + = (RecordUpdate cons_symbol expression expressions, ls) + lift (TupleSelect symbol argn_nr expr) ls + # (expr, ls) = lift expr ls + = (TupleSelect symbol argn_nr expr, ls) + lift (Lambda vars expr) ls + # (expr, ls) = lift expr ls + = (Lambda vars expr, ls) + lift (MatchExpr opt_tuple cons_symb expr) ls + # (expr, ls) = lift expr ls + = (MatchExpr opt_tuple cons_symb expr, ls) + lift expr ls + = (expr, ls) + +instance lift Selection +where + lift (ArraySelection array_select expr_ptr index_expr) ls + # (index_expr, ls) = lift index_expr ls + = (ArraySelection array_select expr_ptr index_expr, ls) + lift record_selection ls + = (record_selection, ls) + +instance lift App +where + lift app=:{app_symb = app_symbol=:{symb_arity,symb_kind = SK_Function {glob_object,glob_module}}, app_args} ls + # (app_args, ls) = lift app_args ls + | glob_module == cIclModIndex + #! fun_def = ls.ls_fun_defs.[glob_object] + # {fun_info={fi_free_vars}} = fun_def + fun_lifted = length fi_free_vars + | fun_lifted > 0 + # (app_args, ls_var_heap, ls_expr_heap) = add_free_variables fi_free_vars app_args ls.ls_var_heap ls.ls_expr_heap + = ({ app & app_args = app_args, app_symb = { app_symbol & symb_arity = symb_arity + fun_lifted }}, + { ls & ls_var_heap = ls_var_heap, ls_expr_heap = ls_expr_heap }) + = ({ app & app_args = app_args }, ls) + = ({ app & app_args = app_args }, ls) + where + add_free_variables :: ![FreeVar] ![Expression] !u:VarHeap !*ExpressionHeap -> (![Expression],!u:VarHeap,!*ExpressionHeap) + add_free_variables [] app_args var_heap expr_heap + = (app_args, var_heap, expr_heap) + add_free_variables [{fv_name, fv_info_ptr} : free_vars] app_args var_heap expr_heap + #! var_info = sreadPtr fv_info_ptr var_heap + = case var_info of + VI_LiftedVariable var_info_ptr + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] + var_heap expr_heap + _ + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] + var_heap expr_heap + + lift app=:{app_args} ls + # (app_args, ls) = lift app_args ls + = ({ app & app_args = app_args }, ls) + +instance lift (Bind a b) | lift a +where + lift bind=:{bind_src} ls + # (bind_src, ls) = lift bind_src ls + = ({ bind & bind_src = bind_src }, ls) + +instance lift Case +where + lift kees=:{ case_expr,case_guards,case_default } ls + # ((case_expr,(case_guards,case_default)), ls) = lift (case_expr,(case_guards,case_default)) ls + = ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default }, ls) + +instance lift CasePatterns +where + lift (AlgebraicPatterns type patterns) ls + # (patterns, ls) = lift patterns ls + = (AlgebraicPatterns type patterns, ls) + lift (BasicPatterns type patterns) ls + # (patterns, ls) = lift patterns ls + = (BasicPatterns type patterns, ls) + lift (DynamicPatterns patterns) ls + # (patterns, ls) = lift patterns ls + = (DynamicPatterns patterns, ls) + +instance lift AlgebraicPattern +where + lift pattern=:{ap_expr} ls + # (ap_expr, ls) = lift ap_expr ls + = ({ pattern & ap_expr = ap_expr }, ls) + +instance lift BasicPattern +where + lift pattern=:{bp_expr} ls + # (bp_expr, ls) = lift bp_expr ls + = ({ pattern & bp_expr = bp_expr }, ls) + +instance lift DynamicPattern +where + lift pattern=:{dp_rhs} ls + # (dp_rhs, ls) = lift dp_rhs ls + = ({ pattern & dp_rhs = dp_rhs }, ls) + +:: UnfoldState = + { us_var_heap :: !.VarHeap + , us_symbol_heap :: !.ExpressionHeap + } + +class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) + +instance unfold [a] | unfold a +where + unfold l us = mapSt unfold l us + +instance unfold (a,b) | unfold a & unfold b +where + unfold t us = app2St (unfold,unfold) t us + +instance unfold (Optional a) | unfold a +where + unfold (Yes x) us + # (x, us) = unfold x us + = (Yes x, us) + unfold no us + = (no, us) + +unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState) +unfoldVariable var=:{var_name,var_info_ptr} us=:{us_var_heap} + #! var_info = sreadPtr var_info_ptr us_var_heap + = case var_info of + VI_Expression expr + -> (expr, us) + VI_Variable var_name var_info_ptr + # (var_expr_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap + -> (Var {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr}, { us & us_symbol_heap = us_symbol_heap}) + _ + -> (Var var, us) + +instance unfold Expression +where + unfold (Var var) us + = unfoldVariable var us + unfold (App app) us + # (app, us) = unfold app us + = (App app, us) + unfold (expr @ exprs) us + # ((expr,exprs), us) = unfold (expr,exprs) us + = (expr @ exprs, us) + unfold (Let lad) us + # (lad, us) = unfold lad us + = (Let lad, us) + unfold (Case case_expr) us + # (case_expr, us) = unfold case_expr us + = (Case case_expr, us) + unfold (Selection is_unique expr selectors) us + # ((expr, selectors), us) = unfold (expr, selectors) us + = (Selection is_unique expr selectors, us) + unfold (Update expr1 selectors expr2) us + # (((expr1, expr2), selectors), us) = unfold ((expr1, expr2), selectors) us + = (Update expr1 selectors expr2, us) + unfold (RecordUpdate cons_symbol expression expressions) us + # ((expression, expressions), us) = unfold (expression, expressions) us + = (RecordUpdate cons_symbol expression expressions, us) + unfold (TupleSelect symbol argn_nr expr) us + # (expr, us) = unfold expr us + = (TupleSelect symbol argn_nr expr, us) + unfold (Lambda vars expr) us + # (expr, us) = unfold expr us + = (Lambda vars expr, us) + unfold (MatchExpr opt_tuple cons_symb expr) us + # (expr, us) = unfold expr us + = (MatchExpr opt_tuple cons_symb expr, us) + unfold expr us + = (expr, us) + +instance unfold Selection +where + unfold (ArraySelection array_select expr_ptr index_expr) us + # (index_expr, us) = unfold index_expr us + = (ArraySelection array_select expr_ptr index_expr, us) + unfold (DictionarySelection var selectors expr_ptr index_expr) us + # (index_expr, us) = unfold index_expr us + (var_expr, us) = unfoldVariable var us + = case var_expr of + App {app_symb={symb_kind= SK_Constructor _ }, app_args} + # [RecordSelection _ field_index:_] = selectors + (App { app_symb = {symb_name, symb_kind = SK_Function array_select}}) = app_args !! field_index + -> (ArraySelection { array_select & glob_object = { ds_ident = symb_name, ds_arity = 2, ds_index = array_select.glob_object}} + expr_ptr index_expr, us) + Var var + -> (DictionarySelection var selectors expr_ptr index_expr, us) + unfold record_selection ls + = (record_selection, ls) + +instance unfold FreeVar +where + unfold fv=:{fv_info_ptr,fv_name} us=:{us_var_heap} + # (new_info_ptr, us_var_heap) = newPtr VI_Empty us_var_heap + = ({ fv & fv_info_ptr = new_info_ptr }, { us & us_var_heap = writePtr fv_info_ptr (VI_Variable fv_name new_info_ptr) us_var_heap }) + +instance unfold App +where + unfold app=:{app_symb, app_args} us + # (app_args, us) = unfold app_args us + | is_function_or_macro app_symb.symb_kind + # (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap + = ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, { us & us_symbol_heap = us_symbol_heap }) + = ({ app & app_args = app_args, app_info_ptr = nilPtr }, us) + where + is_function_or_macro (SK_Function _) + = True + is_function_or_macro (SK_Macro _) + = True + is_function_or_macro (SK_OverloadedFunction _) + = True + is_function_or_macro symb_kind + = False + +instance unfold (Bind a b) | unfold a +where + unfold bind=:{bind_src} us + # (bind_src, us) = unfold bind_src us + = ({ bind & bind_src = bind_src }, us) + +instance unfold Case +where + unfold kees=:{ case_expr,case_guards,case_default,case_info_ptr} us + # ((case_expr,(case_guards,case_default)), us) = unfold (case_expr,(case_guards,case_default)) us + (old_case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap + (new_info_ptr, us_symbol_heap) = newPtr old_case_info us_symbol_heap + = ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default, case_info_ptr = new_info_ptr}, + { us & us_symbol_heap = us_symbol_heap }) + +instance unfold Let +where + unfold lad=:{let_binds, let_expr, let_info_ptr} us + # (let_binds, us) = copy_bound_vars let_binds us + # ((let_binds,let_expr), us) = unfold (let_binds,let_expr) us + (old_let_info, us_symbol_heap) = readPtr let_info_ptr us.us_symbol_heap + (new_info_ptr, us_symbol_heap) = newPtr old_let_info us_symbol_heap + = ({lad & let_binds = let_binds, let_expr = let_expr, let_info_ptr = new_info_ptr}, { us & us_symbol_heap = us_symbol_heap }) + where + copy_bound_vars [bind=:{bind_dst} : binds] us + # (bind_dst, us) = unfold bind_dst us + (binds, us) = copy_bound_vars binds us + = ([ {bind & bind_dst = bind_dst} : binds ], us) + copy_bound_vars [] us + = ([], us) + +instance unfold CasePatterns +where + unfold (AlgebraicPatterns type patterns) us + # (patterns, us) = unfold patterns us + = (AlgebraicPatterns type patterns, us) + unfold (BasicPatterns type patterns) us + # (patterns, us) = unfold patterns us + = (BasicPatterns type patterns, us) + unfold (DynamicPatterns patterns) us + # (patterns, us) = unfold patterns us + = (DynamicPatterns patterns, us) + +instance unfold BasicPattern +where + unfold guard=:{bp_expr} us + # (bp_expr, us) = unfold bp_expr us + = ({ guard & bp_expr = bp_expr }, us) + +instance unfold AlgebraicPattern +where + unfold guard=:{ap_vars,ap_expr} us + # (ap_vars, us) = unfold ap_vars us + (ap_expr, us) = unfold ap_expr us + = ({ guard & ap_vars = ap_vars, ap_expr = ap_expr }, us) + +instance unfold DynamicPattern +where + unfold guard=:{dp_var,dp_rhs} us + # (dp_var, us) = unfold dp_var us + (dp_rhs, us) = unfold dp_rhs us + = ({ guard & dp_var = dp_var, dp_rhs = dp_rhs }, us) + +updateFunctionCalls :: ![FunCall] ![FunCall] !*{# FunDef} !*SymbolTable + -> (![FunCall], !*{# FunDef}, !*SymbolTable) +updateFunctionCalls calls collected_calls fun_defs symbol_table + = foldSt add_function_call calls (collected_calls, fun_defs, symbol_table) +where + add_function_call fc (collected_calls, fun_defs, symbol_table) + # ({fun_symb}, fun_defs) = fun_defs![fc.fc_index] + (collected_calls, symbol_table) = examineFunctionCall fun_symb fc (collected_calls, symbol_table) + = (collected_calls, fun_defs, symbol_table) + +examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table) + #! entry = sreadPtr id_info symbol_table + = case entry.ste_kind of + STE_Called indexes + | isMember fc_index indexes + -> (calls, symbol_table) + -> ([ fc : calls ], symbol_table <:= (id_info, { entry & ste_kind = STE_Called [ fc_index : indexes ]})) + _ + -> ( [ fc : calls ], symbol_table <:= + (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) + +//unfoldMacro :: !FunDef ![Expression] !*ExpandInfo -> (!Expression, !*ExpandInfo) +unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}} args fun_defs (calls, es=:{es_var_heap,es_symbol_heap, es_symbol_table}) + # (let_binds, var_heap) = bind_expressions tb_args args [] es_var_heap + (result_expr, {us_symbol_heap,us_var_heap}) = unfold tb_rhs { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap } + (calls, fun_defs, es_symbol_table) = updateFunctionCalls fi_calls calls fun_defs es_symbol_table + | isEmpty let_binds + = (result_expr, fun_defs, (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table })) + # (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap + = (Let { let_strict = cIsNotStrict, let_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr}, fun_defs, + (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table })) +where + + bind_expressions [var : vars] [expr : exprs] binds var_heap + # (binds, var_heap) = bind_expressions vars exprs binds var_heap + = bind_expression var expr binds var_heap + bind_expressions _ _ binds var_heap + = (binds, var_heap) + + bind_expression {fv_count} expr binds var_heap + | fv_count == 0 + = (binds, var_heap) + bind_expression {fv_info_ptr} (Var {var_name,var_info_ptr}) binds var_heap + = (binds, writePtr fv_info_ptr (VI_Variable var_name var_info_ptr) var_heap) + bind_expression {fv_name,fv_info_ptr,fv_count} expr binds var_heap + | fv_count == 1 + = (binds, writePtr fv_info_ptr (VI_Expression expr) var_heap) + # (new_info, var_heap) = newPtr VI_Empty var_heap + new_var = { fv_name = fv_name, fv_def_level = NotALevel, fv_info_ptr = new_info, fv_count = 0 } + = ([{ bind_src = expr, bind_dst = new_var} : binds], writePtr fv_info_ptr (VI_Variable fv_name new_info) var_heap) + + +:: Group = + { group_members :: ![Int] +// , group_number :: !Int + } + +:: PartitioningInfo = + { pi_symbol_table :: !.SymbolTable +// , pi_marks :: !.{# Int} + , pi_var_heap :: !.VarHeap + , pi_symbol_heap :: !.ExpressionHeap + , pi_error :: !.ErrorAdmin + , pi_next_num :: !Int + , pi_next_group :: !Int + , pi_groups :: ![[Int]] + , pi_deps :: ![Int] + } + +NotChecked :== -1 + +partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin + -> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) +partitionateMacros {ir_from,ir_to} mod_index fun_defs modules var_heap symbol_heap symbol_table error + #! max_fun_nr = size fun_defs + # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, + pi_symbol_table = symbol_table, + pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } + (fun_defs, modules, {pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error, pi_next_group, pi_groups, pi_marks}) + = iFoldSt (pationate_macro mod_index max_fun_nr) ir_from ir_to (fun_defs, modules, partitioning_info) + = (iFoldSt reset_body_of_rhs_macro ir_from ir_to fun_defs, modules, pi_var_heap, pi_symbol_heap, pi_symbol_table, pi_error) +where + + reset_body_of_rhs_macro macro_index macro_defs + # (macro_def, macro_defs) = macro_defs![macro_index] + = case macro_def.fun_body of + RhsMacroBody body + -> { macro_defs & [macro_index] = { macro_def & fun_body = CheckedBody body }} + _ + -> macro_defs + + pationate_macro mod_index max_fun_nr macro_index (macro_defs, modules, pi) + # (macro_def, macro_defs) = macro_defs![macro_index] + | macro_def.fun_kind == FK_Macro + = case macro_def.fun_body of + CheckedBody body + # macros_modules_pi = foldSt (visit_macro mod_index max_fun_nr) macro_def.fun_info.fi_calls ( + { macro_defs & [macro_index] = { macro_def & fun_body = PartioningMacro }}, modules, pi) + -> expand_simple_macro mod_index macro_index macro_def macros_modules_pi + PartioningMacro + # identPos = newPosition macro_def.fun_symb macro_def.fun_pos + -> (macro_defs, modules, { pi & pi_error = checkError macro_def.fun_symb "recursive macro definition" (setErrorAdmin identPos pi.pi_error) }) + _ + -> (macro_defs, modules, pi) + = (macro_defs, modules, pi) + + visit_macro mod_index max_fun_nr {fc_index} macros_modules_pi + = pationate_macro mod_index max_fun_nr fc_index macros_modules_pi + + expand_simple_macro mod_index macro_index macro=:{fun_body = CheckedBody body, fun_info, fun_symb, fun_pos} + (macro_defs, modules, pi=:{pi_symbol_table,pi_symbol_heap,pi_var_heap,pi_error}) + | macros_are_simple fun_info.fi_calls macro_defs + # identPos = newPosition fun_symb fun_pos + es = { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, + es_symbol_heap = pi_symbol_heap, es_error = setErrorAdmin identPos pi_error } + (tb_args, tb_rhs, local_vars, fi_calls, macro_defs, modules, {es_symbol_table, es_var_heap, es_symbol_heap, es_error}) + = expandMacrosInBody [] body macro_defs mod_index modules es + macro = { macro & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, + fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = local_vars }} + = ({ macro_defs & [macro_index] = macro }, modules, + { pi & pi_symbol_table = es_symbol_table, pi_symbol_heap = es_symbol_heap, pi_var_heap = es_var_heap, pi_error = es_error }) + = ({ macro_defs & [macro_index] = { macro & fun_body = RhsMacroBody body }}, modules, pi) + + macros_are_simple [] macro_defs + = True + macros_are_simple [ {fc_index} : calls ] macro_defs + # {fun_kind,fun_body} = macro_defs.[fc_index] + = is_a_pattern_macro fun_kind fun_body && macros_are_simple calls macro_defs + where + is_a_pattern_macro FK_Macro (TransformedBody {tb_args}) + = True + is_a_pattern_macro _ _ + = False + +partitionateAndLiftFunctions :: ![IndexRange] !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin + -> (!*{! Group}, !*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) +partitionateAndLiftFunctions ranges mod_index fun_defs modules var_heap symbol_heap symbol_table error + #! max_fun_nr = size fun_defs + # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, + pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } + (fun_defs, modules, {pi_groups, pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error}) + = foldSt (partitionate_functions mod_index max_fun_nr) ranges (fun_defs, modules, partitioning_info) + groups = { {group_members = group} \\ group <- reverse pi_groups } + = (groups, fun_defs, modules, pi_var_heap, pi_symbol_heap, pi_symbol_table, pi_error) +where + + partitionate_functions mod_index max_fun_nr {ir_from,ir_to} funs_modules_pi + = iFoldSt (partitionate_global_function mod_index max_fun_nr) ir_from ir_to funs_modules_pi + + partitionate_global_function mod_index max_fun_nr fun_index funs_modules_pi + # (_, funs_modules_pi) = partitionate_function mod_index max_fun_nr fun_index funs_modules_pi + = funs_modules_pi + + partitionate_function mod_index max_fun_nr fun_index (fun_defs, modules, pi) + # (fun_def, fun_defs) = fun_defs![fun_index] + = case fun_def.fun_body of + CheckedBody body + # fun_number = pi.pi_next_num + # (min_dep, funs_modules_pi) = foldSt (visit_function mod_index max_fun_nr) fun_def.fun_info.fi_calls + (max_fun_nr, ({ fun_defs & [fun_index] = { fun_def & fun_body = PartioningFunction body fun_number }}, modules, + { pi & pi_next_num = inc fun_number, pi_deps = [fun_index : pi.pi_deps] })) + -> try_to_close_group mod_index max_fun_nr fun_index fun_number min_dep fun_def.fun_info.fi_def_level funs_modules_pi + PartioningFunction _ fun_number + -> (fun_number, (fun_defs, modules, pi)) + TransformedBody _ + | fun_def.fun_info.fi_group_index == NoIndex + -> (max_fun_nr, ({ fun_defs & [fun_index] = {fun_def & fun_info.fi_group_index = pi.pi_next_group }}, modules, + {pi & pi_next_group = inc pi.pi_next_group, pi_groups = [ [fun_index] : pi.pi_groups]})) + -> (max_fun_nr, (fun_defs, modules, pi)) + + visit_function mod_index max_fun_nr {fc_index} (min_dep, funs_modules_pi) + # (next_min, funs_modules_pi) = partitionate_function mod_index max_fun_nr fc_index funs_modules_pi + = (min next_min min_dep, funs_modules_pi) + + try_to_close_group mod_index max_fun_nr fun_index fun_number min_dep def_level (fun_defs, modules, + pi=:{pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_deps, pi_groups, pi_next_group, pi_error}) + | fun_number <= min_dep + # (pi_deps, group_without_macros, group_without_funs, fun_defs) + = close_group fun_index pi_deps [] [] max_fun_nr pi_next_group fun_defs + (fun_defs, pi_var_heap, pi_symbol_heap) + = liftFunctions def_level (group_without_macros ++ group_without_funs) pi_next_group fun_defs pi_var_heap pi_symbol_heap + (fun_defs, modules, es) + = expand_macros_in_group mod_index group_without_funs (fun_defs, modules, + { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, es_symbol_heap = pi_symbol_heap, + es_error = pi_error }) + (fun_defs, modules, {es_symbol_table, es_var_heap, es_symbol_heap, es_error}) + = expand_macros_in_group mod_index group_without_macros (fun_defs, modules, es) + = (max_fun_nr, (fun_defs, modules, { pi & pi_deps = pi_deps, pi_var_heap = es_var_heap, + pi_symbol_table = es_symbol_table, pi_error = es_error, pi_symbol_heap = es_symbol_heap, + pi_next_group = inc pi_next_group, pi_groups = [ group_without_macros ++ group_without_funs : pi_groups ] })) + = (min_dep, (fun_defs, modules, pi)) + where + close_group fun_index [d:ds] group_without_macros group_without_funs nr_of_fun_defs group_number fun_defs + # (fun_def, fun_defs) = fun_defs![d] + fun_defs = { fun_defs & [d] = { fun_def & fun_info.fi_group_index = group_number }} + | fun_def.fun_kind == FK_Macro + # group_without_funs = [d : group_without_funs] + | d == fun_index + = (ds, group_without_macros, group_without_funs, fun_defs) + = close_group fun_index ds group_without_macros group_without_funs nr_of_fun_defs group_number fun_defs + # group_without_macros = [d : group_without_macros] + | d == fun_index + = (ds, group_without_macros, group_without_funs, fun_defs) + = close_group fun_index ds group_without_macros group_without_funs nr_of_fun_defs group_number fun_defs + + expand_macros_in_group mod_index group funs_modules_es + = foldSt (expand_macros mod_index) group (funs_modules_es) + + expand_macros mod_index fun_index (fun_and_macro_defs, modules, es) + # (fun_def, fun_and_macro_defs) = fun_and_macro_defs![fun_index] + {fun_symb,fun_body = PartioningFunction body _, fun_info, fun_pos} = fun_def + identPos = newPosition fun_symb fun_pos + (tb_args, tb_rhs, fi_local_vars, fi_calls, fun_and_macro_defs, modules, es) + = expandMacrosInBody fun_info.fi_calls body fun_and_macro_defs mod_index modules { es & es_error = setErrorAdmin identPos es.es_error } + fun_def = { fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, + fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars }} + = ({ fun_and_macro_defs & [fun_index] = fun_def }, modules, es) + +addFunctionCallsToSymbolTable calls fun_defs symbol_table + = foldSt add_function_call_to_symbol_table calls ([], fun_defs, symbol_table) +where + add_function_call_to_symbol_table fc=:{fc_index} (collected_calls, fun_defs, symbol_table) + # ({fun_symb = { id_info }, fun_kind}, fun_defs) = fun_defs![fc_index] + | fun_kind == FK_Macro + = (collected_calls, fun_defs, symbol_table) + #! entry = sreadPtr id_info symbol_table + = ([fc : collected_calls], fun_defs, + symbol_table <:= (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) + +removeFunctionCallsFromSymbolTable calls fun_defs symbol_table + = foldSt remove_function_call_from_symbol_table calls (fun_defs, symbol_table) +where + remove_function_call_from_symbol_table {fc_index} (fun_defs, symbol_table) + # ({fun_symb = { id_info }}, fun_defs) = fun_defs![fc_index] + #! entry = sreadPtr id_info symbol_table + = (fun_defs, symbol_table <:= (id_info, entry.ste_previous)) + + +expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index modules es=:{es_symbol_table} + # (prev_calls, fun_defs, es_symbol_table) = addFunctionCallsToSymbolTable fi_calls fun_defs es_symbol_table + ([rhs:rhss], fun_defs, modules, (all_calls, es)) = expand cb_rhs fun_defs mod_index modules (prev_calls, { es & es_symbol_table = es_symbol_table }) + (fun_defs, es_symbol_table) = removeFunctionCallsFromSymbolTable all_calls fun_defs es.es_symbol_table + (merge_rhs, es_var_heap, es_symbol_heap, es_error) = mergeCases rhs rhss es.es_var_heap es.es_symbol_heap es.es_error + (merge_rhs, cb_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap}) = determineVariablesAndRefCounts cb_args merge_rhs // (merge_rhs ---> (cb_args, merge_rhs)) + { cos_error = es_error, cos_var_heap = es_var_heap, cos_symbol_heap = es_symbol_heap } + = (cb_args, merge_rhs, local_vars, all_calls, fun_defs, modules, + { es & es_error = cos_error, es_var_heap = cos_var_heap, es_symbol_heap = cos_symbol_heap, + es_symbol_table = es_symbol_table }) +// ---> (cb_args, local_vars, merge_rhs) + +cContainsFreeVars :== True +cContainsNoFreeVars :== False + +cMacroIsCalled :== True +cNoMacroIsCalled :== False + + +mergeCases :: !Expression ![Expression] !*VarHeap !*ExpressionHeap !*ErrorAdmin -> *(!Expression, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin); +mergeCases expr [] var_heap symbol_heap error + = (expr, var_heap, symbol_heap, error) +mergeCases (Let lad=:{let_expr}) exprs var_heap symbol_heap error + # (let_expr, var_heap, symbol_heap, error) = mergeCases let_expr exprs var_heap symbol_heap error + = (Let {lad & let_expr = let_expr}, var_heap,symbol_heap, error) +mergeCases case_expr=:(Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No}) [expr : exprs] var_heap symbol_heap error + = case (split_case var_info_ptr expr) of + Yes {case_guards,case_default} + # (case_guards, var_heap, symbol_heap, error) = merge_guards first_case.case_guards case_guards var_heap symbol_heap error + -> mergeCases (Case { first_case & case_guards = case_guards, case_default = case_default }) exprs var_heap symbol_heap error + No + # (case_default, var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error + -> (Case { first_case & case_default = Yes case_default}, var_heap, symbol_heap, error) + +where + split_case split_var_info_ptr (Case this_case=:{case_expr = Var {var_info_ptr}, case_guards, case_default}) + | split_var_info_ptr == var_info_ptr + = Yes this_case + | has_no_default case_default + = case case_guards of + AlgebraicPatterns type [alg_pattern] + -> case (split_case split_var_info_ptr alg_pattern.ap_expr) of + Yes split_case + -> Yes { split_case & case_guards = push_expression_into_guards ( + \guard_expr -> Case { this_case & case_guards = + AlgebraicPatterns type [ { alg_pattern & ap_expr = guard_expr }] }) + split_case.case_guards } + + No + -> No + BasicPatterns type [basic_pattern] + -> case (split_case split_var_info_ptr basic_pattern.bp_expr) of + Yes split_case + -> Yes { split_case & case_guards = push_expression_into_guards ( + \guard_expr -> Case { this_case & case_guards = + BasicPatterns type [ { basic_pattern & bp_expr = guard_expr }] }) + split_case.case_guards } + + No + -> No + DynamicPatterns [dynamic_pattern] + -> case (split_case split_var_info_ptr dynamic_pattern.dp_rhs) of + Yes split_case + -> Yes { split_case & case_guards = push_expression_into_guards ( + \guard_expr -> Case { this_case & case_guards = + DynamicPatterns [ { dynamic_pattern & dp_rhs = guard_expr }] }) + split_case.case_guards } + + No + -> No + _ + -> No + | otherwise + = No + split_case split_var_info_ptr (Let lad=:{let_expr}) + = case (split_case split_var_info_ptr let_expr) of + Yes split_case + -> Yes { split_case & case_guards = push_expression_into_guards ( + \let_expr -> Let { lad & let_expr = let_expr}) split_case.case_guards } + No + -> No + split_case split_var_info_ptr expr + = No + + has_no_default No = True + has_no_default (Yes _) = False + + push_expression_into_guards expr_fun (AlgebraicPatterns type patterns) + = AlgebraicPatterns type (map (\algpattern -> { algpattern & ap_expr = expr_fun algpattern.ap_expr }) patterns) + push_expression_into_guards expr_fun (BasicPatterns type patterns) + = BasicPatterns type (map (\baspattern -> { baspattern & bp_expr = expr_fun baspattern.bp_expr }) patterns) + push_expression_into_guards expr_fun (DynamicPatterns patterns) + = DynamicPatterns (map (\dynpattern -> { dynpattern & dp_rhs = expr_fun dynpattern.dp_rhs }) patterns) + +/* Happened already */ +/* + skip_aliases info_ptr [] + = info_ptr + skip_aliases info_ptr [{bind_src=Var {var_info_ptr},bind_dst} : binds ] + | info_ptr == var_info_ptr + = skip_aliases bind_dst.fv_info_ptr binds + = skip_aliases info_ptr binds +*/ + + + merge_guards guards=:(AlgebraicPatterns type1 patterns1) (AlgebraicPatterns type2 patterns2) var_heap symbol_heap error + | type1 == type2 + # (merged_patterns, var_heap, symbol_heap, error) = merge_algebraic_patterns patterns1 patterns2 var_heap symbol_heap error + = (AlgebraicPatterns type1 merged_patterns, var_heap, symbol_heap, error) + = (guards, var_heap, symbol_heap, checkError "" "incompatible patterns in case" error) + merge_guards guards=:(BasicPatterns basic_type1 patterns1) (BasicPatterns basic_type2 patterns2) var_heap symbol_heap error + | basic_type1 == basic_type2 + # (merged_patterns, var_heap, symbol_heap, error) = merge_basic_patterns patterns1 patterns2 var_heap symbol_heap error + = (BasicPatterns basic_type1 merged_patterns, var_heap, symbol_heap, error) + = (guards, var_heap, symbol_heap, checkError "" "incompatible patterns in case" error) + merge_guards guards=:(DynamicPatterns patterns1) (DynamicPatterns patterns2) var_heap symbol_heap error + # (merged_patterns, var_heap, symbol_heap, error) = merge_dynamic_patterns patterns1 patterns2 var_heap symbol_heap error + = (DynamicPatterns merged_patterns, var_heap, symbol_heap, error) + merge_guards patterns1 patterns2 var_heap symbol_heap error + = (patterns1, var_heap, symbol_heap, checkError "" "incompatible patterns in case" error) + + merge_algebraic_patterns patterns [alg_pattern : alg_patterns] var_heap symbol_heap error + # (patterns, var_heap, symbol_heap, error) = merge_algebraic_pattern_with_patterns alg_pattern patterns var_heap symbol_heap error + = merge_algebraic_patterns patterns alg_patterns var_heap symbol_heap error + merge_algebraic_patterns patterns [] var_heap symbol_heap error + = (patterns, var_heap, symbol_heap, error) + + merge_basic_patterns patterns [alg_pattern : alg_patterns] var_heap symbol_heap error + # (patterns, var_heap, symbol_heap, error) = merge_basic_pattern_with_patterns alg_pattern patterns var_heap symbol_heap error + = merge_basic_patterns patterns alg_patterns var_heap symbol_heap error + merge_basic_patterns patterns [] var_heap symbol_heap error + = (patterns, var_heap, symbol_heap, error) + + merge_dynamic_patterns patterns1 patterns2 var_heap symbol_heap error + = (patterns1 ++ patterns2, var_heap, symbol_heap, error) + + merge_algebraic_pattern_with_patterns new_pattern [pattern=:{ap_symbol,ap_vars,ap_expr} : patterns] var_heap symbol_heap error + | new_pattern.ap_symbol == ap_symbol + # (new_expr, var_heap, symbol_heap) = replace_variables new_pattern.ap_vars new_pattern.ap_expr ap_vars var_heap symbol_heap + (ap_expr, var_heap, symbol_heap, error) = mergeCases ap_expr [new_expr] var_heap symbol_heap error + = ([{ pattern & ap_expr = ap_expr} : patterns], var_heap, symbol_heap, error) + # (patterns, var_heap, symbol_heap, error) = merge_algebraic_pattern_with_patterns new_pattern patterns var_heap symbol_heap error + = ([ pattern : patterns ], var_heap, symbol_heap, error) + where + replace_variables [] expr ap_vars var_heap symbol_heap + = (expr, var_heap, symbol_heap) + replace_variables vars expr ap_vars var_heap symbol_heap + # (expr, us) = unfold expr { us_var_heap = build_aliases vars ap_vars var_heap, us_symbol_heap = symbol_heap } + = (expr, us.us_var_heap, us.us_symbol_heap) + + build_aliases [var1 : vars1] [ {fv_name,fv_info_ptr} : vars2 ] var_heap + = build_aliases vars1 vars2 (writePtr var1.fv_info_ptr (VI_Variable fv_name fv_info_ptr) var_heap) + build_aliases [] [] var_heap + = var_heap + + merge_algebraic_pattern_with_patterns new_pattern [] var_heap symbol_heap error + = ([new_pattern], var_heap, symbol_heap, error) + + merge_basic_pattern_with_patterns new_pattern [pattern=:{bp_value,bp_expr} : patterns] var_heap symbol_heap error + | new_pattern.bp_value == bp_value + # (bp_expr, var_heap, symbol_heap, error) = mergeCases bp_expr [new_pattern.bp_expr] var_heap symbol_heap error + = ([{ pattern & bp_expr = bp_expr} : patterns], var_heap, symbol_heap, error) + # (patterns, var_heap, symbol_heap, error) = merge_basic_pattern_with_patterns new_pattern patterns var_heap symbol_heap error + = ([ pattern : patterns ], var_heap, symbol_heap, error) + merge_basic_pattern_with_patterns new_pattern [] var_heap symbol_heap error + = ([new_pattern], var_heap, symbol_heap, error) + +mergeCases case_expr=:(Case first_case=:{case_default}) [expr : exprs] var_heap symbol_heap error + = case case_default of + Yes default_expr + # (default_expr, var_heap, symbol_heap, error) = mergeCases default_expr [expr : exprs] var_heap symbol_heap error + -> (Case { first_case & case_default = Yes default_expr }, var_heap, symbol_heap, error) + No + # (default_expr, var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error + -> (Case { first_case & case_default = Yes default_expr }, var_heap, symbol_heap, error) +mergeCases expr _ var_heap symbol_heap error + = (expr, var_heap, symbol_heap, checkWarning "" " alternative will never match" error) + + +liftFunctions min_level group group_index fun_defs var_heap expr_heap + # (contains_free_vars, lifted_function_called, fun_defs) + = foldSt (add_free_vars_of_non_recursive_calls_to_function group_index) group (False, False, fun_defs) + | contains_free_vars + # fun_defs = iterateSt (foldSt (add_free_vars_of_recursive_calls_to_function group_index) group) fun_defs + = lift_functions group fun_defs var_heap expr_heap + | lifted_function_called + = lift_functions group fun_defs var_heap expr_heap + = (fun_defs, var_heap, expr_heap) +where + + add_free_vars_of_non_recursive_calls_to_function group_index fun (contains_free_vars, lifted_function_called, fun_defs) + # (fun_def=:{fun_info}, fun_defs) = fun_defs![fun] + { fi_free_vars,fi_def_level,fi_calls } = fun_info + (lifted_function_called, fi_free_vars, fun_defs) + = foldSt (add_free_vars_of_non_recursive_call fi_def_level group_index) fi_calls (lifted_function_called, fi_free_vars, fun_defs) + = (contains_free_vars || not (isEmpty fi_free_vars), lifted_function_called, + { fun_defs & [fun] = { fun_def & fun_info = { fun_info & fi_free_vars = fi_free_vars }}}) + where + add_free_vars_of_non_recursive_call fun_def_level group_index {fc_index} (lifted_function_called, free_vars, fun_defs) + # ({fun_info = {fi_free_vars,fi_group_index}}, fun_defs) = fun_defs![fc_index] + | fi_group_index == group_index + = (lifted_function_called, free_vars, fun_defs) + | isEmpty fi_free_vars + = (lifted_function_called, free_vars, fun_defs) + # (free_vars_added, free_vars) = add_free_variables fun_def_level fi_free_vars (False, free_vars) + = (True, free_vars, fun_defs) + + add_free_vars_of_recursive_calls_to_function group_index fun (free_vars_added, fun_defs) + # (fun_def=:{fun_info}, fun_defs) = fun_defs![fun] + { fi_free_vars,fi_def_level,fi_calls } = fun_info + (free_vars_added, fi_free_vars, fun_defs) + = foldSt (add_free_vars_of_recursive_call fi_def_level group_index) fi_calls (free_vars_added, fi_free_vars, fun_defs) + = (free_vars_added, { fun_defs & [fun] = { fun_def & fun_info = { fun_info & fi_free_vars = fi_free_vars }}}) + where + add_free_vars_of_recursive_call fun_def_level group_index {fc_index} (free_vars_added, free_vars, fun_defs) + # ({fun_info = {fi_free_vars,fi_group_index}}, fun_defs) = fun_defs![fc_index] + | fi_group_index == group_index + # (free_vars_added, free_vars) = add_free_variables fun_def_level fi_free_vars (free_vars_added, free_vars) + = (free_vars_added, free_vars, fun_defs) + = (free_vars_added, free_vars, fun_defs) + + add_free_variables fun_level new_vars (free_vars_added, free_vars) + = add_free_global_variables (skip_local_variables fun_level new_vars) (free_vars_added, free_vars) + where + skip_local_variables level vars=:[{fv_def_level}:rest_vars] + | fv_def_level > level + = skip_local_variables level rest_vars + = vars + skip_local_variables _ [] + = [] + + add_free_global_variables [] (free_vars_added, free_vars) + = (free_vars_added, free_vars) + add_free_global_variables free_vars (free_vars_added, []) + = (True, free_vars) + add_free_global_variables [var:vars] (free_vars_added, free_vars) + # (free_var_added, free_vars) = newFreeVariable var free_vars + = add_free_global_variables vars (free_var_added || free_vars_added, free_vars) + + lift_functions group fun_defs var_heap expr_heap + = foldSt lift_function group (fun_defs, var_heap, expr_heap) + where + lift_function fun (fun_defs=:{[fun] = fun_def}, var_heap, expr_heap) + # {fi_free_vars} = fun_def.fun_info + fun_lifted = length fi_free_vars + (PartioningFunction {cb_args,cb_rhs} fun_number) = fun_def.fun_body + (cb_args, var_heap) = add_lifted_args fi_free_vars cb_args var_heap + (cb_rhs, {ls_fun_defs,ls_var_heap,ls_expr_heap}) = lift cb_rhs { ls_fun_defs = fun_defs, ls_var_heap = var_heap, ls_expr_heap = expr_heap } + ls_var_heap = remove_lifted_args fi_free_vars ls_var_heap + ls_fun_defs = { ls_fun_defs & [fun] = { fun_def & fun_lifted = fun_lifted, fun_body = PartioningFunction {cb_args = cb_args, cb_rhs = cb_rhs} fun_number}} + = (ls_fun_defs, ls_var_heap, ls_expr_heap) +// ---> ("lift_function", fun_def.fun_symb, fi_free_vars, cb_args, cb_rhs) + + remove_lifted_args vars var_heap + = foldl (\var_heap {fv_name,fv_info_ptr} -> writePtr fv_info_ptr VI_Empty var_heap) var_heap vars + + add_lifted_args [lifted_arg=:{fv_name,fv_info_ptr} : lifted_args] args var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + args = [{ lifted_arg & fv_info_ptr = new_info_ptr } : args ] + = add_lifted_args lifted_args args (writePtr fv_info_ptr (VI_LiftedVariable new_info_ptr) var_heap) + add_lifted_args [] args var_heap + = (args, var_heap) + +:: ExpandInfo :== (![FunCall], !.ExpandState) + +:: ExpandState = + { es_symbol_table :: !.SymbolTable + , es_var_heap :: !.VarHeap + , es_symbol_heap :: !.ExpressionHeap + , es_error :: !.ErrorAdmin + } + +class expand a :: !a !*{#FunDef} !Int !v:{# DclModule} !*ExpandInfo -> (!a, !*{#FunDef}, !v:{# DclModule}, !*ExpandInfo) + +instance expand [a] | expand a +where + expand [x:xs] fun_and_macro_defs mod_index modules es + # (x, fun_and_macro_defs, modules, es) = expand x fun_and_macro_defs mod_index modules es + (xs, fun_and_macro_defs, modules, es) = expand xs fun_and_macro_defs mod_index modules es + = ([x:xs], fun_and_macro_defs, modules, es) + expand [] fun_and_macro_defs mod_index modules es + = ([], fun_and_macro_defs, modules, es) + +instance expand (a,b) | expand a & expand b +where + expand (x,y) fun_and_macro_defs mod_index modules es + # (x, fun_and_macro_defs, modules, es) = expand x fun_and_macro_defs mod_index modules es + (y, fun_and_macro_defs, modules, es) = expand y fun_and_macro_defs mod_index modules es + = ((x,y), fun_and_macro_defs, modules, es) + +instance expand (Optional a) | expand a +where + expand (Yes x) fun_and_macro_defs mod_index modules es + # (x, fun_and_macro_defs, modules, es) = expand x fun_and_macro_defs mod_index modules es + = (Yes x, fun_and_macro_defs, modules, es) + expand no fun_and_macro_defs mod_index modules es + = (no, fun_and_macro_defs, modules, es) +/* +determineArity (SK_Function) +determineArity (SK_OverloadedFunction +determineArity (SK_Constructor +*/ +instance expand Expression +where + + expand (App app=:{app_symb = symb=:{symb_arity, symb_kind = SK_Macro {glob_object,glob_module}}, app_args}) fun_and_macro_defs mod_index modules es + # (app_args, fun_and_macro_defs, modules, (calls, state)) = expand app_args fun_and_macro_defs mod_index modules es + #! macro = fun_and_macro_defs.[glob_object] + | macro.fun_arity == symb_arity + # (expr, fun_and_macro_defs, es) = unfoldMacro macro app_args fun_and_macro_defs (calls, state) + = (expr, fun_and_macro_defs, modules, es) + # (calls, es_symbol_table) = examineFunctionCall macro.fun_symb {fc_index = glob_object, fc_level = NotALevel} (calls, state.es_symbol_table) + = (App { app & app_symb = { symb & symb_kind = SK_Function {glob_object = glob_object, glob_module = glob_module} }, app_args = app_args }, + fun_and_macro_defs, modules, (calls, { state & es_symbol_table = es_symbol_table })) + expand (App app=:{app_args}) fun_and_macro_defs mod_index modules es + # (app_args, fun_and_macro_defs, modules, es) = expand app_args fun_and_macro_defs mod_index modules es + = (App { app & app_args = app_args }, fun_and_macro_defs, modules, es) + expand (expr @ exprs) fun_and_macro_defs mod_index modules es + # ((expr,exprs), fun_and_macro_defs, modules, es) = expand (expr,exprs) fun_and_macro_defs mod_index modules es + = (expr @ exprs, fun_and_macro_defs, modules, es) + expand (Let lad=:{let_binds, let_expr}) fun_and_macro_defs mod_index modules es + # ((let_binds,let_expr), fun_and_macro_defs, modules, es) = expand (let_binds,let_expr) fun_and_macro_defs mod_index modules es + = (Let {lad & let_expr = let_expr, let_binds = let_binds}, fun_and_macro_defs, modules, es) + expand (Case case_expr) fun_and_macro_defs mod_index modules es + # (case_expr, fun_and_macro_defs, modules, es) = expand case_expr fun_and_macro_defs mod_index modules es + = (Case case_expr, fun_and_macro_defs, modules, es) + expand (Selection is_unique expr selectors) fun_and_macro_defs mod_index modules es + # ((expr, selectors), fun_and_macro_defs, modules, es) = expand (expr, selectors) fun_and_macro_defs mod_index modules es + = (Selection is_unique expr selectors, fun_and_macro_defs, modules, es) + expand (Update expr1 selectors expr2) fun_and_macro_defs mod_index modules es + # (((expr1, expr2), selectors), fun_and_macro_defs, modules, es) = expand ((expr1, expr2), selectors) fun_and_macro_defs mod_index modules es + = (Update expr1 selectors expr2, fun_and_macro_defs, modules, es) + expand (RecordUpdate cons_symbol expression expressions) fun_and_macro_defs mod_index modules es + # ((expression, expressions), fun_and_macro_defs, modules, es) = expand (expression, expressions) fun_and_macro_defs mod_index modules es + = (RecordUpdate cons_symbol expression expressions, fun_and_macro_defs, modules, es) + expand (TupleSelect symbol argn_nr expr) fun_and_macro_defs mod_index modules es + # (expr, fun_and_macro_defs, modules, es) = expand expr fun_and_macro_defs mod_index modules es + = (TupleSelect symbol argn_nr expr, fun_and_macro_defs, modules, es) + expand (Lambda vars expr) fun_and_macro_defs mod_index modules es + # (expr, fun_and_macro_defs, modules, es) = expand expr fun_and_macro_defs mod_index modules es + = (Lambda vars expr, fun_and_macro_defs, modules, es) + expand (MatchExpr opt_tuple cons_symb expr) fun_and_macro_defs mod_index modules es + # (expr, fun_and_macro_defs, modules, es) = expand expr fun_and_macro_defs mod_index modules es + = (MatchExpr opt_tuple cons_symb expr, fun_and_macro_defs, modules, es) + expand expr fun_and_macro_defs mod_index modules es + = (expr, fun_and_macro_defs, modules, es) + +instance expand Selection +where + expand (ArraySelection array_select expr_ptr index_expr) fun_and_macro_defs mod_index modules es + # (index_expr, fun_and_macro_defs, modules, es) = expand index_expr fun_and_macro_defs mod_index modules es + = (ArraySelection array_select expr_ptr index_expr, fun_and_macro_defs, modules, es) + expand record_selection fun_and_macro_defs mod_index modules es + = (record_selection, fun_and_macro_defs, modules, es) + + +instance expand (Bind a b) | expand a +where + expand bind=:{bind_src} fun_and_macro_defs mod_index modules es + # (bind_src, fun_and_macro_defs, modules, es) = expand bind_src fun_and_macro_defs mod_index modules es + = ({ bind & bind_src = bind_src }, fun_and_macro_defs, modules, es) + +instance expand Case +where + expand kees=:{ case_expr,case_guards,case_default } fun_and_macro_defs mod_index modules es + # ((case_expr,(case_guards,case_default)), fun_and_macro_defs, modules, es) = expand (case_expr,(case_guards,case_default)) fun_and_macro_defs mod_index modules es + = ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default }, fun_and_macro_defs, modules, es) + +instance expand CasePatterns +where + expand (AlgebraicPatterns type patterns) fun_and_macro_defs mod_index modules es + # (patterns, fun_and_macro_defs, modules, es) = expand patterns fun_and_macro_defs mod_index modules es + = (AlgebraicPatterns type patterns, fun_and_macro_defs, modules, es) + expand (BasicPatterns type patterns) fun_and_macro_defs mod_index modules es + # (patterns, fun_and_macro_defs, modules, es) = expand patterns fun_and_macro_defs mod_index modules es + = (BasicPatterns type patterns, fun_and_macro_defs, modules, es) + expand (DynamicPatterns patterns) fun_and_macro_defs mod_index modules es + # (patterns, fun_and_macro_defs, modules, es) = expand patterns fun_and_macro_defs mod_index modules es + = (DynamicPatterns patterns, fun_and_macro_defs, modules, es) + +instance expand AlgebraicPattern +where + expand alg_pattern=:{ap_expr} fun_and_macro_defs mod_index modules es + # (ap_expr, fun_and_macro_defs, modules, es) = expand ap_expr fun_and_macro_defs mod_index modules es + = ({ alg_pattern & ap_expr = ap_expr }, fun_and_macro_defs, modules, es) + +instance expand BasicPattern +where + expand bas_pattern=:{bp_expr} fun_and_macro_defs mod_index modules es + # (bp_expr, fun_and_macro_defs, modules, es) = expand bp_expr fun_and_macro_defs mod_index modules es + = ({ bas_pattern & bp_expr = bp_expr }, fun_and_macro_defs, modules, es) + +instance expand DynamicPattern +where + expand dyn_pattern=:{dp_rhs} fun_and_macro_defs mod_index modules es + # (dp_rhs, fun_and_macro_defs, modules, es) = expand dp_rhs fun_and_macro_defs mod_index modules es + = ({ dyn_pattern & dp_rhs = dp_rhs }, fun_and_macro_defs, modules, es) + + +:: CollectState = + { cos_var_heap :: !.VarHeap + , cos_symbol_heap :: !.ExpressionHeap + , cos_error :: !.ErrorAdmin + } + +determineVariablesAndRefCounts :: ![FreeVar] !Expression !*CollectState -> (!Expression , ![FreeVar], ![FreeVar], !*CollectState) +determineVariablesAndRefCounts free_vars expr cos=:{cos_var_heap} + # (expr, local_vars, cos) = collectVariables expr [] { cos & cos_var_heap = clearCount free_vars cIsAGlobalVar cos_var_heap } + (free_vars, cos_var_heap) = retrieveRefCounts free_vars cos.cos_var_heap + (local_vars, cos_var_heap) = retrieveRefCounts local_vars cos_var_heap + = (expr, free_vars, local_vars, { cos & cos_var_heap = cos_var_heap }) + +retrieveRefCounts free_vars var_heap + = mapSt retrieveRefCount free_vars var_heap + +retrieveRefCount fv=:{fv_info_ptr} var_heap + # (VI_Count count _, var_heap) = readPtr fv_info_ptr var_heap + = ({ fv & fv_count = count }, var_heap) + +/* + 'clearCount' initialises the 'fv_info_ptr' field of each 'FreeVar' +*/ + +class clearCount a :: !a !Bool !*VarHeap -> *VarHeap + +instance clearCount [a] | clearCount a +where + clearCount [x:xs] locality var_heap + = clearCount x locality (clearCount xs locality var_heap) + clearCount [] locality var_heap + = var_heap + +instance clearCount (Bind a b) | clearCount b +where + clearCount bind=:{bind_dst} locality var_heap + = clearCount bind_dst locality var_heap + +instance clearCount FreeVar +where + clearCount{fv_info_ptr} locality var_heap + = var_heap <:= (fv_info_ptr, VI_Count 0 locality) + +/* + In 'collectVariables' all local variables are collected. Moreover the reference counts + of the local as well as of the global variables are determined. Aliases and unreachable + bindings introduced in a 'let' are removed. +*/ + +class collectVariables a :: !a ![FreeVar] !*CollectState -> !(!a, ![FreeVar],!*CollectState) + +cContainsACycle :== True +cContainsNoCycle :== False + +instance collectVariables Expression +where + collectVariables (Var var) free_vars cos + # (var, free_vars, cos) = collectVariables var free_vars cos + = (Var var, free_vars, cos) + collectVariables (App app=:{app_args}) free_vars cos + # (app_args, free_vars, cos) = collectVariables app_args free_vars cos + = (App { app & app_args = app_args}, free_vars, cos) + collectVariables (expr @ exprs) free_vars cos + # ((expr, exprs), free_vars, cos) = collectVariables (expr, exprs) free_vars cos + = (expr @ exprs, free_vars, cos) + collectVariables (Let lad=:{let_binds, let_expr}) free_vars cos=:{cos_var_heap} + # cos_var_heap = determine_aliases let_binds cos_var_heap + (is_cyclic, let_binds, cos_var_heap) = detect_cycles_and_remove_alias_binds let_binds cos_var_heap + | is_cyclic + = (Let {lad & let_binds = let_binds }, free_vars, { cos & cos_var_heap = cos_var_heap, cos_error = checkError "" "cyclic let definition" cos.cos_error}) + | otherwise + # (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap } + (let_binds, free_vars, cos) = collect_variables_in_binds let_binds [] free_vars cos + | isEmpty let_binds + = (let_expr, free_vars, cos) + = (Let {lad & let_expr = let_expr, let_binds = let_binds}, free_vars, cos) + where + + /* Set the 'var_info_field' of each bound variable to either 'VI_Alias var' (if + this variable is an alias for 'var') or to 'VI_Count 0 cIsALocalVar' to initialise + the reference count info. + */ + + determine_aliases [{bind_dst={fv_info_ptr}, bind_src = Var var} : binds] var_heap + = determine_aliases binds (writePtr fv_info_ptr (VI_Alias var) var_heap) + determine_aliases [bind : binds] var_heap + = determine_aliases binds (clearCount bind cIsALocalVar var_heap) + determine_aliases [] var_heap + = var_heap + + + /* Remove all aliases from the list of 'let'-binds. Be carefull with cycles! */ + + detect_cycles_and_remove_alias_binds [] var_heap + = (cContainsNoCycle, [], var_heap) + detect_cycles_and_remove_alias_binds [bind=:{bind_dst={fv_info_ptr}} : binds] var_heap + #! var_info = sreadPtr fv_info_ptr var_heap + = case var_info of + VI_Alias {var_info_ptr} + | is_cyclic fv_info_ptr var_info_ptr var_heap + -> (cContainsACycle, binds, var_heap) + -> detect_cycles_and_remove_alias_binds binds var_heap + _ + # (is_cyclic, binds, var_heap) = detect_cycles_and_remove_alias_binds binds var_heap + -> (is_cyclic, [bind : binds], var_heap) + where + is_cyclic orig_info_ptr info_ptr var_heap + | orig_info_ptr == info_ptr + = True + #! var_info = sreadPtr info_ptr var_heap + = case var_info of + VI_Alias {var_info_ptr} + -> is_cyclic orig_info_ptr var_info_ptr var_heap + _ + -> False + + /* Apply 'collectVariables' to the bound expressions (the 'bind_src' field of 'let'-bind) if + the corresponding bound variable (the 'bind_dst' field) has been used. This can be determined + by examining the reference count. + */ + + collect_variables_in_binds binds collected_binds free_vars cos + # (continue, binds, collected_binds, free_vars, cos) = examine_reachable_binds False binds collected_binds free_vars cos + | continue + = collect_variables_in_binds binds collected_binds free_vars cos + = (collected_binds, free_vars, cos) + + examine_reachable_binds bind_found [bind=:{bind_dst={fv_info_ptr},bind_src} : binds] collected_binds free_vars cos + # (bind_found, binds, collected_binds, free_vars, cos) = examine_reachable_binds bind_found binds collected_binds free_vars cos + #! var_info = sreadPtr fv_info_ptr cos.cos_var_heap + # (VI_Count count is_global) = var_info + | count > 0 + # (bind_src, free_vars, cos) = collectVariables bind_src free_vars cos + = (True, binds, [ { bind & bind_src = bind_src } : collected_binds ], free_vars, cos) + = (bind_found, [bind : binds], collected_binds, free_vars, cos) + examine_reachable_binds bind_found [] collected_binds free_vars cos + = (bind_found, [], collected_binds, free_vars, cos) + + collectVariables (Case case_expr) free_vars cos + # (case_expr, free_vars, cos) = collectVariables case_expr free_vars cos + = (Case case_expr, free_vars, cos) + collectVariables (Selection is_unique expr selectors) free_vars cos + # ((expr, selectors), free_vars, cos) = collectVariables (expr, selectors) free_vars cos + = (Selection is_unique expr selectors, free_vars, cos) + collectVariables (Update expr1 selectors expr2) free_vars cos + # (((expr1, expr2), selectors), free_vars, cos) = collectVariables ((expr1, expr2), selectors) free_vars cos + = (Update expr1 selectors expr2, free_vars, cos) + collectVariables (RecordUpdate cons_symbol expression expressions) free_vars cos + # ((expression, expressions), free_vars, cos) = collectVariables (expression, expressions) free_vars cos + = (RecordUpdate cons_symbol expression expressions, free_vars, cos) + collectVariables (TupleSelect symbol argn_nr expr) free_vars cos + # (expr, free_vars, cos) = collectVariables expr free_vars cos + = (TupleSelect symbol argn_nr expr, free_vars, cos) + collectVariables (MatchExpr opt_tuple cons_symb expr) free_vars cos + # (expr, free_vars, cos) = collectVariables expr free_vars cos + = (MatchExpr opt_tuple cons_symb expr, free_vars, cos) + collectVariables expr free_vars cos + = (expr, free_vars, cos) + +instance collectVariables Selection +where + collectVariables (ArraySelection array_select expr_ptr index_expr) free_vars cos + # (index_expr, free_vars, cos) = collectVariables index_expr free_vars cos + = (ArraySelection array_select expr_ptr index_expr, free_vars, cos) + collectVariables record_selection free_vars cos + = (record_selection, free_vars, cos) + + +instance collectVariables [a] | collectVariables a +where + collectVariables [x:xs] free_vars cos + # (x, free_vars, cos) = collectVariables x free_vars cos + # (xs, free_vars, cos) = collectVariables xs free_vars cos + = ([x:xs], free_vars, cos) + collectVariables [] free_vars cos + = ([], free_vars, cos) + +instance collectVariables !(!a,!b) | collectVariables a & collectVariables b +where + collectVariables (x,y) free_vars cos + # (x, free_vars, cos) = collectVariables x free_vars cos + # (y, free_vars, cos) = collectVariables y free_vars cos + = ((x,y), free_vars, cos) + +instance collectVariables (Optional a) | collectVariables a +where + collectVariables (Yes x) free_vars cos + # (x, free_vars, cos) = collectVariables x free_vars cos + = (Yes x, free_vars, cos) + collectVariables no free_vars cos + = (no, free_vars, cos) + +instance collectVariables (Bind a b) | collectVariables a where + collectVariables bind=:{bind_src} free_vars cos + # (bind_src, free_vars, cos) = collectVariables bind_src free_vars cos + = ({bind & bind_src = bind_src}, free_vars, cos) + +instance collectVariables Case +where + collectVariables kees=:{ case_expr, case_guards, case_default } free_vars cos + # (case_expr, free_vars, cos) = collectVariables case_expr free_vars cos + # (case_guards, free_vars, cos) = collectVariables case_guards free_vars cos + # (case_default, free_vars, cos) = collectVariables case_default free_vars cos + = ({ kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, free_vars, cos) + + +instance collectVariables CasePatterns +where + collectVariables (AlgebraicPatterns type patterns) free_vars cos + # (patterns, free_vars, cos) = collectVariables patterns free_vars cos + = (AlgebraicPatterns type patterns, free_vars, cos) + collectVariables (BasicPatterns type patterns) free_vars cos + # (patterns, free_vars, cos) = collectVariables patterns free_vars cos + = (BasicPatterns type patterns, free_vars, cos) + collectVariables (DynamicPatterns patterns) free_vars cos + # (patterns, free_vars, cos) = collectVariables patterns free_vars cos + = (DynamicPatterns patterns, free_vars, cos) + + +instance collectVariables AlgebraicPattern +where + collectVariables pattern=:{ap_vars,ap_expr} free_vars cos + # (ap_expr, free_vars, cos) = collectVariables ap_expr free_vars { cos & cos_var_heap = clearCount ap_vars cIsALocalVar cos.cos_var_heap} + (ap_vars, cos_var_heap) = retrieveRefCounts ap_vars cos.cos_var_heap + = ({ pattern & ap_expr = ap_expr, ap_vars = ap_vars }, free_vars, { cos & cos_var_heap = cos_var_heap }) + +instance collectVariables BasicPattern +where + collectVariables pattern=:{bp_expr} free_vars cos + # (bp_expr, free_vars, cos) = collectVariables bp_expr free_vars cos + = ({ pattern & bp_expr = bp_expr }, free_vars, cos) + +instance collectVariables DynamicPattern +where + collectVariables pattern=:{dp_var,dp_rhs} free_vars cos + # (dp_rhs, free_vars, cos) = collectVariables dp_rhs free_vars { cos & cos_var_heap = clearCount dp_var cIsALocalVar cos.cos_var_heap} + (dp_var, cos_var_heap) = retrieveRefCount dp_var cos.cos_var_heap + = ({ pattern & dp_rhs = dp_rhs, dp_var = dp_var }, free_vars, { cos & cos_var_heap = cos_var_heap }) + +instance collectVariables BoundVar +where + collectVariables var=:{var_name,var_info_ptr} free_vars cos=:{cos_var_heap} + #! var_info = sreadPtr var_info_ptr cos_var_heap + = case var_info of + VI_Alias alias + -> collectVariables alias free_vars cos + VI_Count count is_global + | count > 0 || is_global + -> (var, free_vars, { cos & cos_var_heap = writePtr var_info_ptr (VI_Count (inc count) is_global) cos.cos_var_heap }) + -> (var, [{fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0} : free_vars ], + { cos & cos_var_heap = writePtr var_info_ptr (VI_Count 1 is_global) cos.cos_var_heap }) + _ + -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> var_name) + +instance <<< FreeVar +where + (<<<) file { fv_name } = file <<< fv_name + +instance <<< Ptr a +where + (<<<) file p = file <<< ptrToInt p + +instance <<< FunCall +where + (<<<) file {fc_index} = file <<< fc_index + diff --git a/frontend/type.dcl b/frontend/type.dcl new file mode 100644 index 0000000..259fb70 --- /dev/null +++ b/frontend/type.dcl @@ -0,0 +1,8 @@ +definition module type + +import StdArray +import syntax, check + +typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File + -> (!Bool, !*{# FunDef}, !{! (!Index, !SymbolType)}, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File) + diff --git a/frontend/type.icl b/frontend/type.icl new file mode 100644 index 0000000..370ef07 --- /dev/null +++ b/frontend/type.icl @@ -0,0 +1,1729 @@ +implementation module type + + +import StdEnv +import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor +import RWSDebug + +:: TypeInput = + { ti_common_defs :: {# CommonDefs } + , ti_functions :: {# {# FunType }} + } + +:: FunctionType = CheckedType !SymbolType | SpecifiedType !SymbolType ![AType] !TempSymbolType + | UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType + +:: TypeState = + { ts_fun_env :: !.{! FunctionType} + , ts_var_store :: !Int + , ts_attr_store :: !Int + , ts_var_heap :: !.VarHeap + , ts_type_heaps :: !.TypeHeaps + , ts_expr_heap :: !.ExpressionHeap + , ts_td_infos :: !.TypeDefInfos + , ts_error :: !.ErrorAdmin + } + +:: TypeCoercion = + { tc_demanded :: !AType + , tc_offered :: !AType + , tc_position :: !CoercionPosition + , tc_coercible :: !Bool + } + +:: SharedAttribute = + { sa_attr_nr :: !Int + , sa_position :: !Expression + } + +:: Requirements = + { req_overloaded_calls :: ![ExprInfoPtr] + , req_type_coercions :: ![TypeCoercion] + , req_attr_coercions :: ![AttrCoercion] + , req_cons_variables :: ![[TempVarId]] + , req_case_and_let_exprs :: ![ExprInfoPtr] + } + +instance toString BoundVar +where + toString varid = varid.var_name.id_name + +class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type}) + +instance arraySubst AType +where + arraySubst atype=:{at_type} subst + # (at_type, subst) = arraySubst at_type subst + = ({ atype & at_type = at_type }, subst) + +instance arraySubst Type +where + arraySubst tv=:(TempV tv_number) subst + #! type = subst.[tv_number] + = case type of + TE -> (tv, subst) + _ -> arraySubst type subst + arraySubst (arg_type --> res_type) subst + # (arg_type, subst) = arraySubst arg_type subst + (res_type, subst) = arraySubst res_type subst + = (arg_type --> res_type, subst) + arraySubst (TA cons_id cons_args) subst + # (cons_args, subst) = arraySubst cons_args subst + = (TA cons_id cons_args, subst) + arraySubst (TempCV tv_number :@: types) subst + #! type = subst.[tv_number] + = case type of + TE + # (types, subst) = arraySubst types subst + -> (TempCV tv_number :@: types, subst) + _ + # (type, subst) = arraySubst type subst + (types, subst) = arraySubst types subst + -> (simplify_type_appl type types, subst) + where + simplify_type_appl :: !Type ![AType] -> Type + simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args + = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) + simplify_type_appl (cons_var :@: types) type_args + = cons_var :@: (types ++ type_args) + simplify_type_appl (TempV tv_number) type_args + = TempCV tv_number :@: type_args + simplify_type_appl (TempQV tv_number) type_args + = TempQCV tv_number :@: type_args + arraySubst type subst + = (type, subst) + +instance arraySubst [a] | arraySubst a +where + arraySubst l subst + = mapSt arraySubst l subst + +instance arraySubst TempSymbolType +where + arraySubst tst=:{tst_args,tst_result,tst_context} subst + # (tst_args, subst) = arraySubst tst_args subst + (tst_result, subst) = arraySubst tst_result subst + (tst_context, subst) = arraySubst tst_context subst + = ({tst & tst_args = tst_args,tst_result = tst_result,tst_context = tst_context}, subst) + +instance arraySubst TypeContext +where + arraySubst tc=:{tc_types} subst + # (tc_types, subst) = arraySubst tc_types subst + = ({ tc & tc_types = tc_types}, subst) + +/* +instance arraySubst OverloadedCall +where + arraySubst oc=:{oc_context} subst + # (oc_context, subst) = arraySubst oc_context subst + = ({ oc & oc_context = oc_context }, subst) +*/ + +instance arraySubst CaseType +where + arraySubst ct=:{ct_pattern_type,ct_result_type,ct_cons_types} subst + # (ct_pattern_type, subst) = arraySubst ct_pattern_type subst + (ct_result_type, subst) = arraySubst ct_result_type subst + (ct_cons_types, subst) = arraySubst ct_cons_types subst + = ({ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) + +class contains_var a :: !Int !a -> Bool + +instance contains_var [a] | contains_var a +where + contains_var var_id [elem:list] + = contains_var var_id elem || contains_var var_id list + contains_var var_id [] + = False + +instance contains_var AType +where + contains_var var_id {at_type} = contains_var var_id at_type + +instance contains_var Type +where + contains_var var_id (TempV tv_number) + = var_id == tv_number + contains_var var_id (arg_type --> res_type) + = contains_var var_id arg_type || contains_var var_id res_type + contains_var var_id (TA cons_id cons_args) + = contains_var var_id cons_args + contains_var var_id (type :@: types) + = contains_var var_id type || contains_var var_id types + contains_var _ _ + = False + +instance contains_var ConsVariable +where + contains_var var_id (TempCV tv_number) + = var_id == tv_number + contains_var var_id _ + = False + +cannotUnify t1 t2 position err=:{ea_file,ea_loc} + # ea_file = ea_file <<< hd ea_loc <<< ": cannot unify " <<< t1 <<< " with " <<< t2 <<< " near " <<< position <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + +/* +simplifyType ta=:(type :@: type_args) + # type = simplify_type type + = case type of + TA type_cons cons_args + -> TA { type_cons & type_arity = type_cons.type_arity + length type_args } (cons_args ++ type_args) + _ -> ta +simplifyType type + = type +*/ + +class unify a :: !a !a !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, !*TypeHeaps) + +instance unify (a, b) | unify, arraySubst a & unify, arraySubst b +where + unify (t1x, t1y) (t2x, t2y) modules subst heaps + # (succ, subst, heaps) = unify t1y t2y modules subst heaps + | succ + # (t1x, subst) = arraySubst t1x subst + (t2x, subst) = arraySubst t2x subst + = unify t1x t2x modules subst heaps + = (False, subst, heaps) + +instance unify [a] | unify, arraySubst a +where + unify [t1 : ts1] [t2 : ts2] modules subst heaps + = unify (t1,ts1) (t2,ts2) modules subst heaps + unify [] [] modules subst heaps + = (True, subst, heaps) + unify _ _ modules subst heaps + = (False, subst, heaps) + +instance unify AType +where + unify t1 t2 modules subst heaps = unifyTypes t1.at_type t1.at_attribute t2.at_type t2.at_attribute modules subst heaps + + +unifyTypes :: !Type !TypeAttribute !Type !TypeAttribute !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, !*TypeHeaps) +unifyTypes (TempV tv_number1) attr1 tv=:(TempV tv_number2) attr2 modules subst heaps + = unifyTempVarIds tv_number1 tv_number2 subst heaps +unifyTypes tv=:(TempV tv_number) attr1 type attr2 modules subst heaps + | contains_var tv_number type + = (False, subst, heaps) + = (True, { subst & [tv_number] = type}, heaps) +unifyTypes type attr1 tv=:(TempV _) attr2 modules subst heaps + = unifyTypes tv attr2 type attr1 modules subst heaps +unifyTypes t1=:(TB tb1) attr1 t2=:(TB tb2) attr2 modules subst heaps + | tb1 == tb2 + = (True, subst, heaps) + = (False, subst, heaps) +unifyTypes (arg_type1 --> res_type1) attr1 (arg_type2 --> res_type2) attr2 modules subst heaps + = unify (arg_type1,res_type1) (arg_type2,res_type2) modules subst heaps +unifyTypes t1=:(TA cons_id1 cons_args1) attr1 t2=:(TA cons_id2 cons_args2) attr2 modules subst heaps + | cons_id1 == cons_id2 + = unify cons_args1 cons_args2 modules subst heaps + # (succ1, t1, heaps) = trytoExpand t1 attr1 modules heaps + (succ2, t2, heaps) = trytoExpand t2 attr2 modules heaps + | succ1 || succ2 + = unifyTypes t1 attr1 t2 attr2 modules subst heaps + = (False, subst, heaps) +unifyTypes (cons_var :@: types) attr1 type2 attr2 modules subst heaps + # (_, type2, heaps) = trytoExpand type2 attr2 modules heaps + = unifyTypeApplications cons_var types type2 modules subst heaps +unifyTypes type1 attr1 (cons_var :@: types) attr2 modules subst heaps + # (_, type1, heaps) = trytoExpand type1 attr1 modules heaps + = unifyTypeApplications cons_var types type1 modules subst heaps +unifyTypes t1=:(TempQV qv_number1) attr1 t2=:(TempQV qv_number2) attr2 modules subst heaps + = (qv_number1 == qv_number2, subst, heaps) +unifyTypes (TempQV qv_number) attr1 type attr2 modules subst heaps + = (False, subst, heaps) +unifyTypes type attr1 (TempQV qv_number1) attr2 modules subst heaps + = (False, subst, heaps) +unifyTypes type1 attr1 type2 attr2 modules subst heaps + # (succ1, type1, heaps) = trytoExpand type1 attr1 modules heaps + (succ2, type2, heaps) = trytoExpand type2 attr2 modules heaps + | succ1 || succ2 + = unifyTypes type1 attr1 type2 attr2 modules subst heaps + = (False, subst, heaps) + +trytoExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_attr {ti_common_defs} type_heaps + #! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object] + = case type_def.td_rhs of + SynType {at_type} + # (res_type, type_heaps) = expandTypeApplication type_def.td_args type_def.td_attribute at_type type_args type_attr type_heaps + -> (True, res_type, type_heaps) + _ + -> (False, type, type_heaps) +trytoExpand type type_attr modules type_heaps + = (False, type, type_heaps) + +unifyConsVariables (TempCV tv_number1) (TempCV tv_number2) subst heaps + = unifyTempVarIds tv_number1 tv_number2 subst heaps +unifyConsVariables (TempCV tv_number1) (TempQCV tv_number2) subst heaps + = (True, { subst & [tv_number1] = TempQV tv_number2}, heaps) +unifyConsVariables (TempQCV tv_number1) (TempCV tv_number2) subst heaps + = (True, { subst & [tv_number2] = TempQV tv_number1}, heaps) +unifyConsVariables (TempQCV tv_number1) (TempQCV tv_number2) subst heaps + = (tv_number1 == tv_number2, subst, heaps) + +unifyTempVarIds tv_number1 tv_number2 subst heaps + | tv_number1 == tv_number2 + = (True, subst, heaps) + = (True, { subst & [tv_number1] = TempV tv_number2}, heaps) + +constructorVariableToTypeVariable (TempCV temp_var_id) + = TempV temp_var_id +constructorVariableToTypeVariable (TempQCV temp_var_id) + = TempQV temp_var_id + +unifyTypeApplications cons_var type_args type=:(TA type_cons cons_args) modules subst heaps + # diff = type_cons.type_arity - length type_args + | diff >= 0 + # (succ, subst, heaps) = unify type_args (drop diff cons_args) modules subst heaps + | succ + # (rest_args, subst) = arraySubst (take diff cons_args) subst + = unifyTypes (constructorVariableToTypeVariable cons_var) TA_Multi (TA { type_cons & type_arity = diff } rest_args) TA_Multi modules subst heaps + = (False, subst, heaps) + = (False, subst, heaps) +unifyTypeApplications cons_var1 type_args type=:(cons_var2 :@: types) modules subst heaps + # arity1 = length type_args + arity2 = length types + diff = arity1 - arity2 + | diff == 0 + # (succ, subst, heaps) = unifyConsVariables cons_var1 cons_var2 subst heaps + | succ + # (type_args, subst) = arraySubst type_args subst + (types, subst) = arraySubst types subst + = unify type_args types modules subst heaps + = (False, subst, heaps) + | diff < 0 + # diff = 0 - diff + (succ, subst, heaps) = unifyTypes (constructorVariableToTypeVariable cons_var1) TA_Multi (cons_var2 :@: take diff types) TA_Multi modules subst heaps + | succ + # (type_args, subst) = arraySubst type_args subst + (types, subst) = arraySubst (drop diff types) subst + = unify type_args types modules subst heaps + = (False, subst, heaps) + | otherwise + # (succ, subst, heaps) = unifyTypes (cons_var1 :@: take diff type_args) TA_Multi (constructorVariableToTypeVariable cons_var2) TA_Multi modules subst heaps + | succ + # (type_args, subst) = arraySubst (drop diff type_args) subst + (types, subst) = arraySubst types subst + = unify type_args types modules subst heaps + = (False, subst, heaps) +unifyTypeApplications cons_var type_args type modules subst heaps + = (False, subst, heaps) + + +:: CopyState = + { copy_heaps :: !.TypeHeaps + } + +instance fromInt TypeAttribute +where + fromInt AttrUni = TA_Unique + fromInt AttrMulti = TA_Multi + fromInt av_number = TA_TempVar av_number + +class freshCopy a :: !a !*CopyState -> (!a, !*CopyState) + +instance freshCopy [a] | freshCopy a +where + freshCopy l ls = mapSt freshCopy l ls + +/* +cDoExtendAttrEnv :== True +cDontExtendAttrEnv :== False + +freshCopies :: !Bool ![a] !{# CommonDefs } !*CopyState -> (![a], !*CopyState) | freshCopy a +freshCopies extend_env [] modules cs + = ([], [], cs) +freshCopies extend_env [t:ts] modules cs + # (t, prop, cs) = freshCopy extend_env t modules cs + (ts, props, cs) = freshCopies extend_env ts modules cs + = ([t:ts], [prop:props], cs) +*/ + +freshCopyOfAttributeVar {av_name,av_info_ptr} attr_var_heap + # (av_info, attr_var_heap) = readPtr av_info_ptr attr_var_heap + = case av_info of + AVI_Attr attr + -> (attr, attr_var_heap) + _ + -> abort ("freshCopyOfAttributeVar (type,icl)" ---> av_name) + +freshCopyOfTypeAttribute (TA_Var avar) attr_var_heap + = freshCopyOfAttributeVar avar attr_var_heap +freshCopyOfTypeAttribute (TA_RootVar avar) attr_var_heap + = freshCopyOfAttributeVar avar attr_var_heap +freshCopyOfTypeAttribute TA_None attr_var_heap + = (TA_Multi, attr_var_heap) +freshCopyOfTypeAttribute TA_Unique attr_var_heap + = (TA_Unique, attr_var_heap) +freshCopyOfTypeAttribute attr attr_var_heap + = (attr, attr_var_heap) + +cIsExistential :== True +cIsNotExistential :== False + +freshCopyOfTypeVariable {tv_name,tv_info_ptr} cs=:{copy_heaps} + #! tv_info = sreadPtr tv_info_ptr copy_heaps.th_vars + = case tv_info of + TVI_Type fresh_var + -> (fresh_var, cs) + +freshConsVariable {tv_info_ptr} type_var_heap + #! tv_info = sreadPtr tv_info_ptr type_var_heap + = (to_constructor_variable tv_info, type_var_heap) + where + to_constructor_variable (TVI_Type (TempV temp_var_id)) + = TempCV temp_var_id + to_constructor_variable (TVI_Type (TempQV temp_var_id)) + = TempQCV temp_var_id + +instance freshCopy AType +where + freshCopy type=:{at_type = CV tv :@: types, at_attribute} cs=:{copy_heaps} + # (fresh_cons_var, th_vars) = freshConsVariable tv copy_heaps.th_vars + (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute copy_heaps.th_attrs + (types, cs) = freshCopy types { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars }} + = ({type & at_type = fresh_cons_var :@: types, at_attribute = fresh_attribute }, cs) + freshCopy type=:{at_type, at_attribute} cs=:{copy_heaps} + # (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute copy_heaps.th_attrs + (fresh_type, cs) = freshCopy at_type { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs }} + = ({ type & at_type = fresh_type, at_attribute = fresh_attribute }, cs) + +instance freshCopy Type +where + freshCopy (TV tv) cs=:{copy_heaps} + = freshCopyOfTypeVariable tv cs + freshCopy (TA cons_id=:{type_index={glob_object,glob_module}} cons_args) cs + # (cons_args, cs) = freshCopy cons_args cs + = (TA cons_id cons_args, cs) + freshCopy (arg_type --> res_type) cs + # (arg_type, cs) = freshCopy arg_type cs + (res_type, cs) = freshCopy res_type cs + = (arg_type --> res_type, cs) + freshCopy type cs + = (type, cs) + +freshExistentialVariables type_variables state + = foldSt fresh_existential_variable type_variables state +where + fresh_existential_variable {atv_variable={tv_info_ptr}} (var_heap, var_store) + = (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store) + +freshAlgebraicType :: !(Global Int) ![AlgebraicPattern] !{#CommonDefs} !*TypeState -> (![[AType]],!AType,![AttrCoercion],!*TypeState) +freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos} + # {td_rhs,td_args,td_attrs,td_name,td_attribute} = common_defs.[glob_module].com_type_defs.[glob_object] + # (th_vars, ts_var_store) = fresh_type_variables td_args (ts_type_heaps.th_vars, ts_var_store) + (th_attrs, ts_attr_store) = fresh_attributes td_attrs (ts_type_heaps.th_attrs, ts_attr_store) + cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }} + (cons_types, alg_type, ts_var_store, ts_attr_store, attr_env, cs) + = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store ts_attr_store cs + = (cons_types, alg_type, attr_env, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = cs.copy_heaps }) +// ---> ("freshAlgebraicType", alg_type, cons_types) +where + fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store attr_store cs=:{copy_heaps} + # {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars, cons_exi_attrs} = cons_defs.[glob_object.ds_index] + (th_vars, var_store) = freshExistentialVariables cons_exi_vars (copy_heaps.th_vars, var_store) +// (th_attrs, attr_store) = fresh_existential_attributes cons_exi_attrs (copy_heaps.th_attrs, attr_store) + (attr_env, th_attrs) = fresh_environment st_attr_env ([], copy_heaps.th_attrs) + (result_type, cs) = freshCopy st_result { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars } } + (fresh_args, cs) = freshCopy st_args cs + = ([fresh_args], result_type, var_store, attr_store, attr_env, cs) + fresh_symbol_types [{ap_symbol={glob_object}} : patterns] cons_defs var_store attr_store cs + # (cons_types, result_type, var_store, attr_store, attr_env, cs=:{copy_heaps}) + = fresh_symbol_types patterns cons_defs var_store attr_store cs +// {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars, cons_exi_attrs} = cons_defs.[glob_object.ds_index] + {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] + (th_vars, var_store) = freshExistentialVariables cons_exi_vars (copy_heaps.th_vars, var_store) +// (th_attrs, attr_store) = fresh_existential_attributes cons_exi_attrs (copy_heaps.th_attrs, attr_store) + (attr_env, th_attrs) = fresh_environment st_attr_env (attr_env, copy_heaps.th_attrs) + (fresh_args, cs) = freshCopy st_args { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars }} + = ([fresh_args : cons_types], result_type, var_store, attr_store, attr_env, cs) + + + fresh_type_variables type_variables state + = foldSt (\{atv_variable={tv_info_ptr}} (var_heap, var_store) -> (var_heap <:= (tv_info_ptr, TVI_Type (TempV var_store)), inc var_store)) + type_variables state + fresh_attributes attributes state + = foldSt (\{av_info_ptr} (attr_heap, attr_store) -> (attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store)), inc attr_store)) + attributes state +/* + fresh_existential_attributes attributes state + = foldSt (\{av_info_ptr} (attr_heap, attr_store) -> (attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempExVar attr_store)), inc attr_store)) + attributes state +*/ + fresh_environment inequalities (attr_env, attr_heap) + = foldSt fresh_inequality inequalities (attr_env, attr_heap) + + fresh_inequality {ai_demanded,ai_offered} (attr_env, attr_heap) + # (AVI_Attr dem_temp_attr, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap + (AVI_Attr off_temp_attr, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap + = case dem_temp_attr of + TA_TempVar dem_attr_var + -> case off_temp_attr of + TA_TempVar off_attr_var + | is_new_ineqality dem_attr_var off_attr_var attr_env + -> ([{ac_demanded = dem_attr_var, ac_offered = off_attr_var} : attr_env ], attr_heap) + -> (attr_env, attr_heap) + _ + -> (attr_env, attr_heap) + _ + -> (attr_env, attr_heap) + + is_new_ineqality dem_attr_var off_attr_var [{ac_demanded, ac_offered} : attr_env] + = (dem_attr_var <> ac_demanded || off_attr_var <> ac_offered) && is_new_ineqality dem_attr_var off_attr_var attr_env + is_new_ineqality dem_attr_var off_attr_var [] + = True + +freshSymbolType st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_env,st_arity} common_defs + ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos} + # (th_vars, var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store) + (th_attrs, attr_store) = fresh_attributes st_attr_vars (ts_type_heaps.th_attrs, ts_attr_store) + (attr_env, th_attrs) = freshEnvironment st_attr_env th_attrs + cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }} + (tst_args, cs) = freshCopy st_args cs + (tst_result, cs) = freshCopy st_result cs + (tst_context, {copy_heaps}) = freshTypeContexts st_context cs + cons_variables = foldSt (collect_cons_variables_in_tc common_defs) tst_context [] + = ({ tst_args = tst_args, tst_result = tst_result, tst_context = tst_context, tst_attr_env = attr_env, tst_arity = st_arity, tst_lifted = 0 }, cons_variables, + { ts & ts_var_store = var_store, ts_attr_store = attr_store, ts_type_heaps = copy_heaps}) +// ---> ("freshSymbolType", tst_args, tst_result) + where + fresh_type_variables type_variables state + = foldr (\{tv_info_ptr} (var_heap, var_store) -> (writePtr tv_info_ptr (TVI_Type (TempV var_store)) var_heap, inc var_store)) + state type_variables + fresh_attributes attributes state + = foldr (\{av_info_ptr} (attr_heap, attr_store) -> (writePtr av_info_ptr (AVI_Attr (TA_TempVar attr_store)) attr_heap, inc attr_store)) + state attributes + + collect_cons_variables_in_tc common_defs tc=:{tc_class={glob_module,glob_object={ds_index}}, tc_types} collected_cons_vars + # {class_cons_vars} = common_defs.[glob_module].com_class_defs.[ds_index] + = collect_cons_variables tc_types class_cons_vars collected_cons_vars + + collect_cons_variables [] class_cons_vars collected_cons_vars + = collected_cons_vars + collect_cons_variables [type : tc_types] class_cons_vars collected_cons_vars + | class_cons_vars bitand 1 == 0 + = collect_cons_variables tc_types (class_cons_vars >> 1) collected_cons_vars + = case type of + TempV temp_var_id + -> collect_cons_variables tc_types (class_cons_vars >> 1) (add_variable temp_var_id collected_cons_vars) +// ---> ("collect_cons_variables", temp_var_id) + _ + -> collect_cons_variables tc_types (class_cons_vars >> 1) collected_cons_vars + + add_variable new_var_id [] + = [new_var_id] + add_variable new_var_id vars=:[var_id : var_ids] + | new_var_id == var_id + = vars + = [var_id : add_variable new_var_id var_ids] + + +freshInequality {ai_demanded,ai_offered} attr_heap + # (av_dem_info, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap + (av_off_info, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap + (AVI_Attr (TA_TempVar dem_attr_var)) = av_dem_info + (AVI_Attr (TA_TempVar off_attr_var)) = av_off_info + = ({ac_demanded = dem_attr_var, ac_offered = off_attr_var}, attr_heap) // <<- (av_dem_info,av_off_info) + +freshEnvironment [ineq : ineqs] attr_heap + # (fresh_ineq, attr_heap) = freshInequality ineq attr_heap + (fresh_env, attr_heap) = freshEnvironment ineqs attr_heap + = ([fresh_ineq : fresh_env], attr_heap) +freshEnvironment [] attr_heap + = ([], attr_heap) + +freshTypeContexts tcs cs + = mapSt fresh_type_context tcs cs +where + fresh_type_context tc=:{tc_types} cs + # (tc_types, cs) = mapSt fresh_context_type tc_types cs + = ({ tc & tc_types = tc_types}, cs) + + fresh_context_type (CV tv :@: types) cs=:{copy_heaps} + # (fresh_cons_var, th_vars) = freshConsVariable tv copy_heaps.th_vars + (types, cs) = freshCopy types { cs & copy_heaps = { copy_heaps & th_vars = th_vars }} + = (fresh_cons_var :@: types, cs) + fresh_context_type type cs + = freshCopy type cs + +freshAttributedVariable :: !u:TypeState -> (!AType, !u:TypeState) +freshAttributedVariable ts=:{ts_var_store,ts_attr_store} + = ({ at_attribute = TA_TempVar ts_attr_store, at_annotation = AN_None, at_type = TempV ts_var_store }, + {ts & ts_var_store = inc ts_var_store, ts_attr_store = inc ts_attr_store}) + +freshNonUniqueVariable :: !u:TypeState -> (!AType, !u:TypeState) +freshNonUniqueVariable ts=:{ts_var_store} + = ({ at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts_var_store }, + {ts & ts_var_store = inc ts_var_store}) + +freshAttribute :: !u:TypeState -> (!TypeAttribute, !u:TypeState) +freshAttribute ts=:{ts_attr_store} + = (TA_TempVar ts_attr_store, {ts & ts_attr_store = inc ts_attr_store}) + + +:: PropState = + { prop_type_heaps :: !.TypeHeaps + , prop_td_infos :: !.TypeDefInfos + , prop_attr_vars :: ![AttributeVar] + , prop_attr_env :: ![AttrInequality] + , prop_error :: !.ErrorAdmin + } + + +attribute_error type_attr err + = TypeError "* attribute expected insted of" type_attr "" err + +addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index={glob_object,glob_module}} cons_args, at_attribute} ps + # (cons_args, props, ps=:{prop_td_infos,prop_type_heaps,prop_attr_vars,prop_attr_env,prop_error}) + = add_propagation_attributes_to_atypes modules cons_args ps + (prop_class, th_vars, prop_td_infos) = propClassification glob_object glob_module props modules prop_type_heaps.th_vars prop_td_infos + (at_attribute, prop_class, th_attrs, prop_attr_vars, prop_attr_env, prop_error) + = determine_attribute_of_cons modules at_attribute cons_args prop_class prop_type_heaps.th_attrs prop_attr_vars prop_attr_env prop_error + = ({ type & at_type = TA cons_id cons_args, at_attribute = at_attribute }, prop_class, { ps & prop_attr_vars = prop_attr_vars, + prop_td_infos = prop_td_infos, prop_attr_env = prop_attr_env, + prop_type_heaps = { prop_type_heaps & th_vars = th_vars, th_attrs = th_attrs}, prop_error = prop_error }) + where + add_propagation_attributes_to_atypes modules [] ps + = ([], [], ps) + add_propagation_attributes_to_atypes modules [atype : atypes] ps + # (atype, prop_class, ps) = addPropagationAttributesToAType modules atype ps + (atypes, prop_classes, ps) = add_propagation_attributes_to_atypes modules atypes ps + = ([atype : atypes], [prop_class : prop_classes], ps) + + determine_attribute_of_cons modules TA_Unique cons_args prop_class attr_var_heap attr_vars attr_env ps_error + = (TA_Unique, prop_class >> length cons_args, attr_var_heap, attr_vars, attr_env, ps_error) + determine_attribute_of_cons modules cons_attr cons_args prop_class attr_var_heap attr_vars attr_env ps_error + # (cumm_attr, prop_attrs, prop_class) = determine_cummulative_attribute cons_args TA_Multi [] prop_class + (comb_attr, attr_var_heap, attr_vars, attr_env, ps_error) + = combine_attributes cons_attr cumm_attr prop_attrs attr_var_heap attr_vars attr_env ps_error + = (comb_attr, prop_class, attr_var_heap, attr_vars, attr_env, ps_error) + + determine_cummulative_attribute [] cumm_attr attr_vars prop_class + = (cumm_attr, attr_vars, prop_class) + determine_cummulative_attribute [{at_attribute} : types ] cumm_attr attr_vars prop_class + | prop_class bitand 1 == 0 + = determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1) + = case at_attribute of + TA_Unique + -> (TA_Unique, [], prop_class >> length types) + TA_Multi + -> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1) + TA_Var attr_var + -> determine_cummulative_attribute types at_attribute [attr_var : attr_vars] (prop_class >> 1) + + + combine_attributes (TA_Var attr_var) cumm_attr prop_vars attr_var_heap attr_vars attr_env ps_error + = case cumm_attr of + TA_Unique + -> (TA_Unique, attr_var_heap, attr_vars, attr_env, attribute_error attr_var ps_error) + + TA_Multi + -> (TA_Var attr_var, attr_var_heap, attr_vars, attr_env, ps_error) + TA_Var _ + -> (TA_Var attr_var, attr_var_heap, attr_vars, foldSt (new_inequality attr_var) prop_vars attr_env, ps_error) + where + new_inequality off_attr_var dem_attr_var [] + = [{ ai_demanded = dem_attr_var, ai_offered = off_attr_var }] + new_inequality off_attr_var dem_attr_var ins=:[ inequal : iequals ] + | dem_attr_var.av_info_ptr == inequal.ai_demanded.av_info_ptr && off_attr_var.av_info_ptr == inequal.ai_offered.av_info_ptr + = ins + = [ inequal : new_inequality off_attr_var dem_attr_var iequals ] + + combine_attributes _ (TA_Var var) prop_vars attr_var_heap attr_vars attr_env ps_error + # (new_attr_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_attr_var = { var & av_info_ptr = new_attr_ptr } + = (TA_Var new_attr_var, attr_var_heap, [new_attr_var : attr_vars], + mapAppend (\ai_demanded -> { ai_demanded = ai_demanded, ai_offered = new_attr_var }) prop_vars attr_env, ps_error) + combine_attributes cons_attr TA_Unique _ attr_var_heap attr_vars attr_env ps_error + = (TA_Unique, attr_var_heap, attr_vars, attr_env, ps_error) + combine_attributes cons_attr _ _ attr_var_heap attr_vars attr_env ps_error + = (cons_attr, attr_var_heap, attr_vars, attr_env, ps_error) + +addPropagationAttributesToAType modules type=:{at_type} ps + # (at_type, ps) = addPropagationAttributesToType modules at_type ps + = ({ type & at_type = at_type }, NoPropClass, ps) + +addPropagationAttributesToType modules (arg_type --> res_type) ps + # (arg_type, prop_class, ps) = addPropagationAttributesToAType modules arg_type ps + (res_type, prop_class, ps) = addPropagationAttributesToAType modules res_type ps + = (arg_type --> res_type, ps) +addPropagationAttributesToType modules (type_var :@: types) ps + # (types, ps) = addPropagationAttributesToATypes modules types ps + = (type_var :@: types, ps) +addPropagationAttributesToType modules type ps + = (type, ps) + +addPropagationAttributesToATypes modules types ps + = mapSt (add_propagation_attributes_to_atype modules) types ps +where + add_propagation_attributes_to_atype modules type ps + # (type, prop_class, ps) = addPropagationAttributesToAType modules type ps + = (type, ps) + +:: Base :== {! AType} + +currySymbolType st=:{tst_args,tst_arity,tst_result,tst_attr_env} req_arity ts=:{ts_attr_store} + | tst_arity == req_arity + = (st, ts) + # (tst_args, rest_args, is_unique) = split_args req_arity tst_args + | is_unique + # (type, _, _) = buildCurriedType rest_args tst_result TA_Unique [] 0 + = ({ st & tst_args = tst_args, tst_arity = req_arity, tst_result = type }, ts) + # (type, tst_attr_env, ts_attr_store) = buildCurriedType rest_args tst_result (TA_TempVar ts_attr_store) + (build_attr_env ts_attr_store tst_args tst_attr_env) (inc ts_attr_store) + = ({ st & tst_args = tst_args, tst_arity = req_arity, tst_result = type, tst_attr_env = tst_attr_env }, { ts & ts_attr_store = ts_attr_store }) +where + split_args 0 args = ([], args, False) + split_args n [atype=:{at_attribute} : args] + # (left, right, is_unique) = split_args (dec n) args + = ([ atype : left ], right, is_unique || attr_is_unique at_attribute) + + attr_is_unique TA_Unique = True + attr_is_unique _ = False + + build_attr_env cum_attr_var [] attr_env + = attr_env + build_attr_env cum_attr_var [{at_attribute=(TA_TempVar attr_var)} : args] attr_env + = build_attr_env cum_attr_var args [{ ac_demanded = attr_var, ac_offered = cum_attr_var } : attr_env] + build_attr_env cum_attr_var [_ : args] attr_env + = build_attr_env cum_attr_var args attr_env + + +emptyIdent =: { id_name = "", id_info = nilPtr } + +buildCurriedType [] type cum_attr attr_env attr_store + = (type, attr_env, attr_store) +buildCurriedType [at=:{at_attribute}:ats] type cum_attr attr_env attr_store + # (next_cum_attr, attr_env, attr_store) = combine_attributes at_attribute cum_attr attr_env attr_store + (res_type, attr_env, attr_store) = buildCurriedType ats type next_cum_attr attr_env attr_store + = ({at_annotation = AN_None, at_attribute = cum_attr , at_type = at --> res_type }, attr_env, attr_store) +where + combine_attributes TA_Unique cum_attr attr_env attr_store + = (TA_Unique, attr_env, attr_store) + combine_attributes (TA_TempVar attr_var) (TA_TempVar cum_attr_var) attr_env attr_store + = (TA_TempVar attr_store, [{ ac_demanded = cum_attr_var,ac_offered = attr_store },{ ac_demanded = attr_var,ac_offered = attr_store }:attr_env], inc attr_store) + combine_attributes (TA_TempVar _) cum_attr attr_env attr_store + = (cum_attr, attr_env, attr_store) + combine_attributes _ (TA_TempVar cum_attr_var) attr_env attr_store + = (TA_TempVar attr_store, [{ ac_demanded = cum_attr_var,ac_offered = attr_store }:attr_env], inc attr_store) + combine_attributes _ cum_attr attr_env attr_store + = (cum_attr, attr_env, attr_store) + +determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_vars,st_attr_env} type_ptr common_defs ts=:{ts_var_heap} + # (type_info, ts_var_heap) = readPtr type_ptr ts_var_heap + ts = { ts & ts_var_heap = ts_var_heap } + = case type_info of + VI_PropagationType symb_type + # (copy_symb_type, cons_variables, ts) = freshSymbolType symb_type common_defs ts +// (ts ---> ("determineSymbolTypeOfFunction1", ident, symb_type)) + (curried_st, ts) = currySymbolType copy_symb_type act_arity ts + -> (curried_st, cons_variables, ts) +// ---> ("determineSymbolTypeOfFunction", ident, curried_st) + _ + # (st_args, ps) = addPropagationAttributesToATypes common_defs st_args + { prop_type_heaps = ts.ts_type_heaps, prop_td_infos = ts.ts_td_infos, + prop_attr_vars = st_attr_vars, prop_attr_env = st_attr_env, prop_error = ts.ts_error} + (st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env}) + = addPropagationAttributesToAType common_defs st_result ps + st = { st & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env } + # (copy_symb_type, cons_variables, ts) = freshSymbolType st common_defs { ts & + ts_type_heaps = prop_type_heaps, ts_td_infos = prop_td_infos, ts_error = prop_error, + ts_var_heap = ts.ts_var_heap <:= (type_ptr, VI_PropagationType st) } + (curried_st, ts) = currySymbolType copy_symb_type act_arity ts + -> (curried_st, cons_variables, ts) +// ---> ("determineSymbolTypeOfFunction", ident, st) + +standardFieldSelectorType {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} + #! {sd_type,sd_exi_vars,sd_exi_attrs} = ti_common_defs.[glob_module].com_selector_defs.[ds_index] + # (th_vars, ts_var_store) = freshExistentialVariables sd_exi_vars (ts_type_heaps.th_vars, ts_var_store) + (inst, cons_variables, ts) = freshSymbolType sd_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } + = (inst, ts) +// ---> ("standardFieldSelectorType", ds_ident, inst) + +standardTupleSelectorType {ds_index} arg_nr {ti_common_defs} ts + #! {cons_type} = ti_common_defs.[cPredefinedModuleIndex].com_cons_defs.[ds_index] + (fresh_type, cons_variables, ts) = freshSymbolType { cons_type & st_args = [cons_type.st_result], st_result = cons_type.st_args !! arg_nr } ti_common_defs ts + = (fresh_type, ts) + +standardRhsConstructorType index mod arity {ti_common_defs} ts + #! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] + # cons_type = { cons_type & st_vars = mapAppend (\{atv_variable} -> atv_variable) cons_exi_vars cons_type.st_vars } + (fresh_type, _, ts) = freshSymbolType cons_type ti_common_defs ts + = currySymbolType fresh_type arity ts +// ---> ("standardRhsConstructorType", cons_symb, fresh_type) + +standardLhsConstructorType index mod arity {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} + #! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] + # (th_vars, ts_var_store) = freshExistentialVariables cons_exi_vars (ts_type_heaps.th_vars, ts_var_store) + (fresh_type, _, ts) = freshSymbolType cons_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } + = (fresh_type, ts) +// ---> ("standardLhsConstructorType", cons_symb, fresh_type) + +:: ReferenceMarking :== Bool + +cIsRecursive :== True +cIsNotRecursive :== False + +storeAttribute (Yes expt_ptr) type_attribute symbol_heap + = writePtr expt_ptr (EI_Attribute (toInt type_attribute)) symbol_heap +storeAttribute No type_attribute symbol_heap + = symbol_heap + +requirementsOfApplication :: !App !TempSymbolType ![Special] !u:Requirements !TypeInput !*TypeState + -> (!u:Requirements, !AType, !Optional ExprInfoPtr, !*TypeState) +requirementsOfApplication {app_symb,app_args,app_info_ptr} + {tst_attr_env,tst_args,tst_result,tst_context} specials reqs=:{req_attr_coercions} ti ts + # reqs = { reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions } + (reqs, ts) = requirements_of_args app_args tst_args reqs ti ts + | isEmpty tst_context + = (reqs, tst_result, No, ts) + = ({ reqs & req_overloaded_calls = [app_info_ptr : reqs.req_overloaded_calls ]}, tst_result, No, + { ts & ts_expr_heap = ts.ts_expr_heap <:= (app_info_ptr, + EI_Overloaded { oc_symbol = app_symb, oc_context = tst_context, oc_specials = specials })}) +where + requirements_of_args :: ![Expression] ![AType] !u:Requirements !TypeInput !*TypeState + -> (!u:Requirements,!*TypeState) + requirements_of_args [] [] reqs ti ts + = (reqs, ts) + requirements_of_args [expr:exprs] [lt:lts] reqs ti ts + # (reqs, e_type, opt_expr_ptr, ts) = requirements expr reqs ti ts + req_type_coercions = [{ tc_demanded = lt, tc_offered = e_type, tc_position = { cp_expression = expr }, tc_coercible = True } : reqs.req_type_coercions ] + ts_expr_heap = storeAttribute opt_expr_ptr lt.at_attribute ts.ts_expr_heap + = requirements_of_args exprs lts { reqs & req_type_coercions = req_type_coercions} ti { ts & ts_expr_heap = ts_expr_heap } + +requirements :: !Expression !u:Requirements !TypeInput !*TypeState -> (!u:Requirements, !AType, !Optional ExprInfoPtr, !*TypeState) +requirements (Var var=:{var_info_ptr,var_expr_ptr}) reqs ti ts=:{ts_var_store,ts_attr_store,ts_var_heap,ts_expr_heap} + #! var_info = sreadPtr var_info_ptr ts_var_heap + # (VI_Type type) = var_info + = (reqs, type, Yes var_expr_ptr, ts) + +requirements expr=:(App app=:{app_symb={symb_name,symb_kind = SK_Function {glob_module,glob_object}, symb_arity}}) reqs + ti=:{ti_functions,ti_common_defs} ts=:{ts_fun_env,ts_var_heap} + | glob_module == cIclModIndex + #! fun_type = ts_fun_env.[glob_object] + = case fun_type of + UncheckedType fun_type + # (fun_type_copy,ts) = currySymbolType fun_type symb_arity ts + -> requirementsOfApplication app fun_type_copy [] reqs ti ts + SpecifiedType fun_type lifted_arg_types _ + # (fun_type_copy, cons_variables, ts) = freshSymbolType fun_type ti_common_defs ts +// ---> ("requirements (App SpecifiedType)", symb_name, fun_type)) + (fun_type_copy,ts) = currySymbolType { fun_type_copy & tst_args = lifted_arg_types ++ fun_type_copy.tst_args } symb_arity ts + -> requirementsOfApplication app fun_type_copy [] { reqs & req_cons_variables = [ cons_variables : reqs.req_cons_variables ] } ti ts + CheckedType fun_type + # (fun_type_copy, cons_variables, ts) = freshSymbolType fun_type ti_common_defs ts +// ---> ("requirements (App CheckedType)", symb_name, fun_type)) + (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts + -> requirementsOfApplication app fun_type_copy [] { reqs & req_cons_variables = [ cons_variables : reqs.req_cons_variables ] } ti ts + _ + -> abort "requirements (App)" ---> (symb_name, fun_type) + # {ft_type,ft_type_ptr,ft_specials} = ti_functions.[glob_module].[glob_object] + (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction symb_name symb_arity ft_type ft_type_ptr ti_common_defs ts + = requirementsOfApplication app fun_type_copy (get_specials ft_specials) { reqs & req_cons_variables = [ cons_variables : reqs.req_cons_variables ] } ti ts +where + get_specials (SP_ContextTypes specials) = specials + get_specials SP_None = [] + + +requirements expr=:(App app=:{app_symb={symb_kind, symb_arity}}) reqs ti ts=:{ts_fun_env} + # (fresh_type, cons_variables, ts) = standard_type symb_kind symb_arity ti ts + = requirementsOfApplication app fresh_type [] { reqs & req_cons_variables = [ cons_variables : reqs.req_cons_variables ] } ti ts +where + standard_type (SK_Constructor {glob_object,glob_module}) symb_arity ti ts + # (fresh_cons_type, ts) = standardRhsConstructorType glob_object glob_module symb_arity ti ts + = (fresh_cons_type, [], ts) + standard_type (SK_OverloadedFunction {glob_object,glob_module}) symb_arity {ti_common_defs} ts + #! {me_symb, me_type,me_type_ptr} = ti_common_defs.[glob_module].com_member_defs.[glob_object] + = determineSymbolTypeOfFunction me_symb symb_arity me_type me_type_ptr ti_common_defs ts +requirements (function @ args) reqs ti ts + # (reqs, off_fun_type, opt_fun_expr_ptr, ts) = requirements function reqs ti ts + (rev_off_arg_types, reqs, ts) = requirements_of_list args [] reqs ti ts + (alpha, ts) = freshAttributedVariable ts + (fun_type, req_type_coercions, ts) = apply_type rev_off_arg_types alpha reqs.req_type_coercions function ts + ts_expr_heap = storeAttribute opt_fun_expr_ptr fun_type.at_attribute ts.ts_expr_heap + = ({ reqs & req_type_coercions = [{ tc_demanded = fun_type, tc_offered = off_fun_type, tc_position = { cp_expression = function }, tc_coercible = True } : req_type_coercions ]}, + alpha, No, { ts & ts_expr_heap = ts_expr_heap }) +where + requirements_of_list [] rev_list_types reqs ti ts + = (rev_list_types, reqs, ts) + requirements_of_list [expr:exprs] rev_list_types reqs ti ts + # (reqs, e_type, opt_expr_ptr, ts) = requirements expr reqs ti ts + = requirements_of_list exprs [(opt_expr_ptr,e_type) : rev_list_types] reqs ti ts + + apply_type [] res_type type_coercions function ts + = (res_type, type_coercions, ts) + apply_type [(opt_expr_ptr,type) : types] res_type type_coercions function ts + # (type, type_coercions, ts) = determine_demanded_type type opt_expr_ptr type_coercions function ts + (u, ts) = freshAttribute ts + = apply_type types { at_annotation = AN_None, at_attribute = u, at_type = type --> res_type } type_coercions function ts + + determine_demanded_type :: !AType !(Optional ExprInfoPtr) ![TypeCoercion] !Expression !*TypeState + -> (!AType, ![TypeCoercion], !*TypeState) + determine_demanded_type type (Yes expr_ptr) type_coercions expr ts + # (dem_type, ts) = freshAttributedVariable ts + ts_expr_heap = writePtr expr_ptr (EI_Attribute (toInt dem_type.at_attribute)) ts.ts_expr_heap + = (dem_type, [ { tc_demanded = dem_type, tc_offered = type, tc_position = { cp_expression = expr }, tc_coercible = True } : type_coercions ], + { ts & ts_expr_heap = ts_expr_heap }) + determine_demanded_type type No type_coercions expr ts + = (type, type_coercions, ts) + +requirements bind_expr=:(Let {let_binds, let_expr, let_info_ptr}) reqs ti ts + # (rev_var_types, ts) = make_base let_binds [] ts + var_types = reverse rev_var_types + (reqs, res_type, opt_expr_ptr, ts) = requirements let_expr reqs ti ts + (reqs, ts) = requirements_of_binds let_binds var_types reqs ti ts + ts_expr_heap = writePtr let_info_ptr (EI_LetType var_types) ts.ts_expr_heap + = ({ reqs & req_case_and_let_exprs = [let_info_ptr : reqs.req_case_and_let_exprs]}, res_type, opt_expr_ptr, { ts & ts_expr_heap = ts_expr_heap }) + +where + + make_base [{bind_dst={fv_info_ptr}}:bs] var_types ts=:{ts_var_heap} + # (v, ts) = freshAttributedVariable ts + = make_base bs [v:var_types] { ts & ts_var_heap = writePtr fv_info_ptr (VI_Type v) ts.ts_var_heap } + make_base [] var_types ts + = (var_types, ts) + + requirements_of_binds [] _ reqs ti ts + = (reqs, ts) + requirements_of_binds [{bind_src}:bs] [b_type:bts] reqs ti ts + # (reqs, exp_type, opt_expr_ptr, ts) = requirements bind_src reqs ti ts + ts_expr_heap = storeAttribute opt_expr_ptr b_type.at_attribute ts.ts_expr_heap + req_type_coercions = [ { tc_demanded = b_type, tc_offered = exp_type, tc_position = { cp_expression = bind_src }, tc_coercible = True } + : reqs.req_type_coercions ] + = requirements_of_binds bs bts { reqs & req_type_coercions = req_type_coercions } ti { ts & ts_expr_heap = ts_expr_heap } + +requirements (Case {case_expr,case_guards,case_default,case_info_ptr}) reqs ti ts + # (reqs, expr_type, opt_expr_ptr, ts) = requirements case_expr reqs ti ts + (fresh_v, ts) = freshAttributedVariable ts + (reqs, cons_types, ts) = requirements_of_guarded_expressions case_guards case_expr expr_type opt_expr_ptr fresh_v reqs ti ts + (reqs, ts) = requirements_of_default case_default fresh_v reqs ti ts + ts_expr_heap = ts.ts_expr_heap <:= (case_info_ptr, EI_CaseType { ct_pattern_type = expr_type, ct_result_type = fresh_v, ct_cons_types = cons_types }) + = ({ reqs & req_case_and_let_exprs = [case_info_ptr : reqs.req_case_and_let_exprs]}, fresh_v, No, { ts & ts_expr_heap = ts_expr_heap }) +where + requirements_of_guarded_expressions (AlgebraicPatterns alg_type patterns) match_expr pattern_type opt_pattern_ptr + goal_type reqs ti=:{ti_common_defs} ts + # (cons_types, result_type, new_attr_env, ts) = freshAlgebraicType alg_type patterns ti_common_defs ts + (reqs, used_cons_types, ts) = requirements_of_algebraic_patterns patterns cons_types goal_type [] reqs ti ts + ts_expr_heap = storeAttribute opt_pattern_ptr result_type.at_attribute ts.ts_expr_heap + = ({ reqs & req_type_coercions = [{tc_demanded = result_type,tc_offered = pattern_type, tc_position = { cp_expression = match_expr }, + tc_coercible = True} : reqs.req_type_coercions], + req_attr_coercions = new_attr_env ++ reqs.req_attr_coercions }, reverse used_cons_types, + { ts & ts_expr_heap = ts_expr_heap }) + + requirements_of_guarded_expressions (BasicPatterns bas_type patterns) match_expr pattern_type opt_pattern_ptr goal_type reqs ti ts + # (attr_bas_type, ts) = attributedBasicType bas_type ts + (reqs, ts) = requirements_of_basic_patterns patterns goal_type reqs ti ts + ts_expr_heap = storeAttribute opt_pattern_ptr attr_bas_type.at_attribute ts.ts_expr_heap + = ({ reqs & req_type_coercions = [{tc_demanded = attr_bas_type,tc_offered = pattern_type, tc_position = { cp_expression = match_expr }, tc_coercible = True} : + reqs.req_type_coercions]}, [], { ts & ts_expr_heap = ts_expr_heap }) + requirements_of_guarded_expressions (DynamicPatterns dynamic_patterns) match_expr pattern_type opt_pattern_ptr goal_type reqs ti ts + # dyn_type = { at_type = TB BT_Dynamic, at_attribute = TA_Multi, at_annotation = AN_None } + (reqs, used_dyn_types, ts) = requirements_of_dynamic_patterns goal_type dynamic_patterns [] reqs ti ts + ts_expr_heap = storeAttribute opt_pattern_ptr TA_Multi ts.ts_expr_heap + = ({ reqs & req_type_coercions = [{tc_demanded = dyn_type, tc_offered = pattern_type, tc_position = { cp_expression = match_expr }, tc_coercible = True} : + reqs.req_type_coercions] }, reverse used_dyn_types, { ts & ts_expr_heap = ts_expr_heap }) + + requirements_of_algebraic_patterns [] cons_types goal_type used_cons_types reqs ti ts + = (reqs, used_cons_types, ts) + requirements_of_algebraic_patterns [{ap_vars, ap_expr }:gs] [ cons_arg_types : cons_types] goal_type used_cons_types reqs ti=:{ti_common_defs} ts + # (reqs, res_type, opt_expr_ptr, ts) = requirements ap_expr reqs ti { ts & ts_var_heap = makeBase ap_vars cons_arg_types ts.ts_var_heap} + ts_expr_heap = storeAttribute opt_expr_ptr res_type.at_attribute ts.ts_expr_heap + = requirements_of_algebraic_patterns gs cons_types goal_type [ cons_arg_types : used_cons_types ] + { reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = { cp_expression = ap_expr }, tc_coercible = True } : reqs.req_type_coercions] } + ti { ts & ts_expr_heap = ts_expr_heap } + + requirements_of_basic_patterns [] goal_type reqs ti ts + = (reqs, ts) + requirements_of_basic_patterns [{bp_expr }:gs] goal_type reqs ti=:{ti_common_defs} ts + # (reqs, res_type, opt_expr_ptr, ts) = requirements bp_expr reqs ti ts + ts_expr_heap = storeAttribute opt_expr_ptr res_type.at_attribute ts.ts_expr_heap + = requirements_of_basic_patterns gs goal_type + { reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = { cp_expression = bp_expr }, tc_coercible = True } : reqs.req_type_coercions] } + ti { ts & ts_expr_heap = ts_expr_heap } + + requirements_of_dynamic_patterns goal_type [{dp_var={fv_info_ptr},dp_type,dp_rhs} : dps] used_dyn_types reqs ti ts=:{ts_expr_heap, ts_var_heap} + # (EI_TempDynamicPattern _ _ _ _ dyn_type dyn_context dyn_expr_ptr type_code_symbol, ts_expr_heap) = readPtr dp_type ts_expr_heap + ts_var_heap = ts_var_heap <:= (fv_info_ptr, VI_Type dyn_type) + (reqs, dp_rhs_type, opt_expr_ptr, ts) = requirements dp_rhs reqs ti { ts & ts_expr_heap = ts_expr_heap, ts_var_heap = ts_var_heap } + ts_expr_heap = storeAttribute opt_expr_ptr dp_rhs_type.at_attribute ts.ts_expr_heap + type_coercion = { tc_demanded = goal_type, tc_offered = dp_rhs_type, tc_position = { cp_expression = dp_rhs }, tc_coercible = True } + | isEmpty dyn_context + # reqs = {reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions]} + = requirements_of_dynamic_patterns goal_type dps [ [dyn_type] : used_dyn_types ] reqs ti { ts & ts_expr_heap = ts_expr_heap } + # reqs = { reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions], req_overloaded_calls = [dyn_expr_ptr : reqs.req_overloaded_calls ]} + = requirements_of_dynamic_patterns goal_type dps [ [dyn_type] : used_dyn_types ] reqs ti { ts & ts_expr_heap = ts_expr_heap <:= + (dyn_expr_ptr, EI_Overloaded { oc_symbol = type_code_symbol, oc_context = dyn_context, oc_specials = [] }) } + requirements_of_dynamic_patterns goal_type [] used_dyn_types reqs ti ts + = (reqs, used_dyn_types, ts) + + + requirements_of_default (Yes expr) goal_type reqs ti ts + # (reqs, res_type, opt_expr_ptr, ts) = requirements expr reqs ti ts + ts_expr_heap = storeAttribute opt_expr_ptr res_type.at_attribute ts.ts_expr_heap + = ({ reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = { cp_expression = expr }, tc_coercible = True } : reqs.req_type_coercions] }, + { ts & ts_expr_heap = ts_expr_heap }) + requirements_of_default No goal_type reqs ti ts + = (reqs, ts) +requirements (DynamicExpr {dyn_expr,dyn_info_ptr}) reqs ti ts=:{ts_expr_heap} + # (EI_TempDynamicType _ dyn_type dyn_context dyn_expr_ptr type_code_symbol, ts_expr_heap) = readPtr dyn_info_ptr ts_expr_heap + (reqs, dyn_expr_type, opt_expr_ptr, ts) = requirements dyn_expr reqs ti { ts & ts_expr_heap = ts_expr_heap } + ts_expr_heap = storeAttribute opt_expr_ptr dyn_expr_type.at_attribute ts.ts_expr_heap + type_coercion = { tc_demanded = dyn_type, tc_offered = dyn_expr_type, tc_position = { cp_expression = dyn_expr }, tc_coercible = True } + | isEmpty dyn_context + = ({reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions]}, + { at_type = TB BT_Dynamic, at_attribute = TA_Multi, at_annotation = AN_None }, No, { ts & ts_expr_heap = ts_expr_heap }) + = ({ reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions], req_overloaded_calls = [dyn_expr_ptr : reqs.req_overloaded_calls ]}, + { at_type = TB BT_Dynamic, at_attribute = TA_Multi, at_annotation = AN_None }, No, + { ts & ts_expr_heap = ts_expr_heap <:= (dyn_expr_ptr, EI_Overloaded { + oc_symbol = type_code_symbol, oc_context = dyn_context, oc_specials = []}) }) + +requirements (Selection result_type_symb expr selectors) reqs ti ts + # (reqs, expr_type, opt_expr_ptr, ts) = requirements expr reqs ti ts + = case result_type_symb of + Yes {glob_object={ds_ident,ds_index,ds_arity}, glob_module} + # (var, ts) = freshAttributedVariable ts + (result_type, reqs, ts) = requirementsOfSelectors expr selectors False var expr opt_expr_ptr reqs ti ts + tuple_type = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity + non_unique_type_var = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts.ts_var_store } + req_type_coercions + = [ { tc_demanded = non_unique_type_var, tc_offered = result_type, tc_position = { cp_expression = expr }, tc_coercible = False }, + { tc_demanded = var, tc_offered = expr_type, tc_position = { cp_expression = expr }, tc_coercible = True } : + reqs.req_type_coercions] + result_type = { at_type = TA tuple_type [non_unique_type_var,var], at_attribute = TA_Unique, at_annotation = AN_None } + -> ({ reqs & req_type_coercions = req_type_coercions }, result_type, No, + {ts & ts_var_store = inc ts.ts_var_store, ts_expr_heap = storeAttribute opt_expr_ptr TA_Multi ts.ts_expr_heap}) + _ + # (result_type, reqs, ts) = requirementsOfSelectors expr selectors True expr_type expr opt_expr_ptr reqs ti ts + -> (reqs, result_type, No, { ts & ts_expr_heap = storeAttribute opt_expr_ptr result_type.at_attribute ts.ts_expr_heap }) + +requirements (Update expr1 selectors expr2) reqs ti ts + # (reqs, expr1_type, opt_expr1_ptr, ts) = requirements expr1 reqs ti ts + ts = { ts & ts_expr_heap = storeAttribute opt_expr1_ptr expr1_type.at_attribute ts.ts_expr_heap } + (reqs, expr2_type, opt_expr2_ptr, ts) = requirements expr2 reqs ti ts + ts = { ts & ts_expr_heap = storeAttribute opt_expr2_ptr expr2_type.at_attribute ts.ts_expr_heap } + (result_type, reqs, ts) = requirementsOfSelectors expr1 selectors True expr1_type expr1 opt_expr1_ptr reqs ti ts + reqs = { reqs & req_type_coercions = [ + { tc_demanded = expr2_type, tc_offered = result_type, tc_position = { cp_expression = expr2 }, tc_coercible = True /* RWS ??? */ } : reqs.req_type_coercions ]} + = (reqs, expr1_type, No, ts) + +requirements (RecordUpdate {glob_module,glob_object={ds_index,ds_arity}} expression expressions) reqs ti ts + # (lhs, ts) = standardLhsConstructorType ds_index glob_module ds_arity ti ts + (rhs, ts) = standardRhsConstructorType ds_index glob_module ds_arity ti ts + (reqs, expression_type, opt_expr_ptr, ts) = requirements expression reqs ti ts + (reqs, ts) = requirements_of_fields expression expressions rhs.tst_args lhs.tst_args reqs ti ts + ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr lhs.tst_result.at_attribute ts.ts_expr_heap } + coercion = { tc_demanded = lhs.tst_result, tc_offered = expression_type, tc_position = { cp_expression = expression }, tc_coercible = True } + = ({ reqs & req_attr_coercions = rhs.tst_attr_env ++ lhs.tst_attr_env ++ reqs.req_attr_coercions, req_type_coercions = [ coercion : reqs.req_type_coercions ]}, + rhs.tst_result, No, ts) +where + requirements_of_fields expression [] _ _ reqs ti ts + = (reqs, ts) + requirements_of_fields expression [field : fields] [dem_type : dem_types] [off_type : off_types] reqs ti ts + # (reqs, ts) = requirements_of_field expression field dem_type off_type reqs ti ts + = requirements_of_fields expression fields dem_types off_types reqs ti ts + + requirements_of_field expression {bind_src=EE} dem_field_type off_field_type reqs=:{req_type_coercions} ti ts + # coercion = { tc_demanded = dem_field_type, tc_offered = off_field_type, tc_position = { cp_expression = expression }, tc_coercible = True } + = ({ reqs & req_type_coercions = [ coercion : req_type_coercions ]}, ts) + requirements_of_field _ {bind_src} dem_field_type _ reqs=:{req_type_coercions} ti ts + # (reqs, expr_type, opt_expr_ptr, ts) = requirements bind_src reqs ti ts + ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr dem_field_type.at_attribute ts.ts_expr_heap } + coercion = { tc_demanded = dem_field_type, tc_offered = expr_type, tc_position = { cp_expression = bind_src }, tc_coercible = True } + = ({ reqs & req_type_coercions = [ coercion : reqs.req_type_coercions ]}, ts) + +requirements (TupleSelect tuple_symbol arg_nr expr) reqs=:{req_attr_coercions} ti ts + # ({tst_args = [argtype:_], tst_result, tst_attr_env}, ts) = standardTupleSelectorType tuple_symbol arg_nr ti ts + (reqs, e_type, opt_expr_ptr, ts) = requirements expr { reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions } ti ts + req_type_coercions = [{ tc_demanded = argtype, tc_offered = e_type, tc_position = { cp_expression = expr }, tc_coercible = True } : reqs.req_type_coercions ] + ts_expr_heap = storeAttribute opt_expr_ptr argtype.at_attribute ts.ts_expr_heap + = ( { reqs & req_type_coercions = req_type_coercions }, tst_result, No, { ts & ts_expr_heap = ts_expr_heap }) + + +requirements (BasicExpr basic_val basic_type) reqs ti ts + # (type, ts) = attributedBasicType basic_type ts + = (reqs, type, No, ts) + +requirements (MatchExpr opt_tuple_type {glob_object={ds_arity, ds_index},glob_module} expr) reqs ti ts + # ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType ds_index glob_module ds_arity ti ts + (reqs, e_type, opt_expr_ptr, ts) = requirements expr reqs ti ts + reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, + req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = { cp_expression = expr }, tc_coercible = True } : reqs.req_type_coercions ] } + ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap } + = case opt_tuple_type of + Yes {glob_object={ds_ident,ds_index,ds_arity}, glob_module} + # tuple_type = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity + -> (reqs, { at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, ts) + No + -> (reqs, hd tst_args, No, ts) + +requirements (AnyCodeExpr _ _ _) reqs ti ts + # (fresh_v, ts) = freshAttributedVariable ts + = (reqs, fresh_v, No, ts) +requirements (ABCCodeExpr _ _) reqs ti ts + # (fresh_v, ts) = freshAttributedVariable ts + = (reqs, fresh_v, No, ts) + +requirements expr reqs ti ts + = (reqs, abort ("Error in requirements\n" ---> expr), No, ts) + +requirementsOfSelectors expr [selector] tc_coercible sel_expr_type sel_expr opt_expr_ptr reqs ti ts + # ts_expr_heap = storeAttribute opt_expr_ptr sel_expr_type.at_attribute ts.ts_expr_heap + = requirementsOfSelector expr selector tc_coercible sel_expr_type sel_expr reqs ti { ts & ts_expr_heap = ts_expr_heap } +requirementsOfSelectors expr [selector : selectors] tc_coercible sel_expr_type sel_expr opt_expr_ptr reqs ti ts + # ts_expr_heap = storeAttribute opt_expr_ptr sel_expr_type.at_attribute ts.ts_expr_heap + (result_type, reqs, ts) = requirementsOfSelector expr selector tc_coercible sel_expr_type sel_expr reqs ti { ts & ts_expr_heap = ts_expr_heap } + = requirements_of_remaining_selectors expr selectors tc_coercible result_type expr reqs ti ts +where + requirements_of_remaining_selectors expr [selector] tc_coercible sel_expr_type sel_expr reqs ti ts + = requirementsOfSelector expr selector tc_coercible sel_expr_type sel_expr reqs ti ts + requirements_of_remaining_selectors expr [selector : selectors] tc_coercible sel_expr_type sel_expr reqs ti ts + # (result_type, reqs, ts) = requirementsOfSelector expr selector tc_coercible sel_expr_type sel_expr reqs ti ts + = requirements_of_remaining_selectors expr selectors tc_coercible result_type sel_expr reqs ti ts + +requirementsOfSelector expr (RecordSelection field filed_nr) tc_coercible sel_expr_type sel_expr reqs ti ts + # ({tst_args, tst_result, tst_attr_env}, ts) = standardFieldSelectorType field ti ts + req_type_coercions = [{ tc_demanded = sel_expr_type, tc_offered = hd tst_args, tc_position = { cp_expression = sel_expr }, tc_coercible = tc_coercible } : + reqs.req_type_coercions ] + = (tst_result, { reqs & req_type_coercions = req_type_coercions }, ts) +requirementsOfSelector expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr reqs ti ts + # {me_type} = ti.ti_common_defs.[glob_module].com_member_defs.[ds_index] + ({tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, ts) = freshSymbolType me_type ti.ti_common_defs ts + (dem_array_type, dem_index_type) = array_and_index_type tst_args + reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, req_cons_variables = [ cons_variables : reqs.req_cons_variables ]} + (reqs, index_type, opt_expr_ptr, ts) = requirements index_expr reqs ti ts + reqs = { reqs & req_type_coercions = [{ tc_demanded = dem_index_type, tc_offered = index_type, tc_position = { cp_expression = expr }, tc_coercible = True }, + { tc_demanded = dem_array_type, tc_offered = sel_expr_type, tc_position = { cp_expression = sel_expr }, tc_coercible = tc_coercible } : reqs.req_type_coercions ]} + ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr index_type.at_attribute ts.ts_expr_heap } + | isEmpty tst_context + = (tst_result, reqs, ts) + = (tst_result, { reqs & req_overloaded_calls = [expr_ptr : reqs.req_overloaded_calls ]}, { ts & ts_expr_heap = + ts.ts_expr_heap <:= (expr_ptr, EI_Overloaded { oc_symbol = + { symb_name = ds_ident, symb_kind = SK_OverloadedFunction {glob_module = glob_module, glob_object = ds_index}, symb_arity = ds_arity }, + oc_context = tst_context, oc_specials = [] })}) +where + array_and_index_type [array_type, index_type : _ ] + = (array_type, index_type) + +makeBase vars types ts_var_heap + = fold2St (\ {fv_info_ptr} type var_heap -> var_heap <:= (fv_info_ptr, VI_Type type)) vars types ts_var_heap + +attributedBasicType (BT_String string_type) ts=:{ts_attr_store} + = ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = string_type}, {ts & ts_attr_store = inc ts_attr_store}) +attributedBasicType bas_type ts=:{ts_attr_store} + = ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = TB bas_type}, {ts & ts_attr_store = inc ts_attr_store}) + +unify_coercions [{tc_demanded,tc_offered,tc_position}:coercions] modules subst heaps err + # (subst, heaps, err) = unify_coercions coercions modules subst heaps err + (subst_demanded, subst) = arraySubst tc_demanded subst + (subst_offered, subst) = arraySubst tc_offered subst + (succ, subst, heaps) = unify subst_demanded subst_offered modules subst heaps + | succ + = (subst, heaps, err) + = (subst, heaps, cannotUnify subst_demanded subst_offered tc_position err) + +unify_coercions [] modules subst heaps err + = (subst, heaps, err) + +InitFunEnv :: !Int -> *{! FunctionType} +InitFunEnv nr_of_fun_defs + = createArray nr_of_fun_defs EmptyFunctionType + +//CreateInitialSymbolTypes :: ![Int] !u:{# FunDef} !{# CommonDefs } !*TypeState -> (!u:{# FunDef}, !*TypeState) +CreateInitialSymbolTypes common_defs [] defs_and_state + = defs_and_state +CreateInitialSymbolTypes common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts) + #! fd = fun_defs.[fun] + # (pre_def_symbols, req_cons_variables, ts) = initial_symbol_type common_defs fd (pre_def_symbols, req_cons_variables, ts) + = CreateInitialSymbolTypes common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts) +where + initial_symbol_type common_defs {fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env}, fun_lifted, fun_info = {fi_dynamics} } + (pre_def_symbols, req_cons_variables, ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error}) + # (st_args, ps) = addPropagationAttributesToATypes common_defs st_args + { prop_type_heaps = ts_type_heaps, prop_td_infos = ts_td_infos, + prop_attr_vars = st_attr_vars, prop_attr_env = st_attr_env, prop_error = ts_error} + (st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env}) = addPropagationAttributesToAType common_defs st_result ps + ft = { ft & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env } + (th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap) + (fresh_fun_type, cons_variables, ts) = freshSymbolType ft common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap, + ts_td_infos = prop_td_infos, ts_error = prop_error } + (lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts + (ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols) + = fresh_dynamics fi_dynamics (ts.ts_var_store, ts.ts_type_heaps, ts.ts_var_heap, ts.ts_expr_heap, pre_def_symbols) + = (pre_def_symbols, [ cons_variables : req_cons_variables], + { ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft lifted_args + { fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted }}, + ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps }) + initial_symbol_type common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts) + # (st_gen, ts) = create_general_symboltype fun_arity fun_lifted ts + ts_type_heaps = ts.ts_type_heaps + (th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (ts_type_heaps.th_vars, ts.ts_expr_heap) + (ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols) + = fresh_dynamics fi_dynamics (ts.ts_var_store, { ts_type_heaps & th_vars = th_vars }, + ts.ts_var_heap, ts_expr_heap, pre_def_symbols) + = (pre_def_symbols, req_cons_variables, { ts & ts_fun_env = { ts.ts_fun_env & [fun] = UncheckedType st_gen }, ts_var_store = ts_var_store, + ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap}) + + + create_general_symboltype :: !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState) + create_general_symboltype nr_of_args nr_of_lifted_args ts + # (tst_args, ts) = fresh_attributed_type_variables nr_of_args [] ts + (tst_args, ts) = fresh_attributed_type_variables nr_of_lifted_args tst_args ts + (tst_result, ts) = freshAttributedVariable ts + = ({ tst_args = tst_args, tst_arity = nr_of_args + nr_of_lifted_args, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts) + + fresh_attributed_type_variables :: !Int ![AType] !*TypeState -> (![AType], !*TypeState) + fresh_attributed_type_variables n vars ts + | n == 0 + = (vars, ts) + # (var, ts) = freshAttributedVariable ts + = fresh_attributed_type_variables (dec n) [var : vars] ts + + fresh_non_unique_type_variables :: !Int ![AType] !*TypeState -> (![AType], !*TypeState) + fresh_non_unique_type_variables n vars ts + | n == 0 + = (vars, ts) + # (var, ts) = freshNonUniqueVariable ts + = fresh_non_unique_type_variables (dec n) [var : vars] ts + + fresh_dynamics dyn_ptrs state + = foldSt fresh_dynamic dyn_ptrs state + + fresh_dynamic dyn_ptr (var_store, type_heaps, var_heap, expr_heap, predef_symbols) + # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap + = case dyn_info of + EI_Dynamic opt_dyn_type=:(Yes {dt_uni_vars,dt_type,dt_global_vars}) + # (th_vars, var_store) = fresh_existential_attributed_variables dt_uni_vars (type_heaps.th_vars, var_store) + (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store) + (tdt_type, {copy_heaps}) = freshCopy dt_type { copy_heaps = { type_heaps & th_vars = th_vars }} + (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols)) + = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, copy_heaps.th_vars, predef_symbols) + -> (var_store, { copy_heaps & th_vars = type_var_heap }, var_heap, + expr_heap <:= (dyn_ptr, EI_TempDynamicType opt_dyn_type tdt_type contexts expr_ptr type_code_symbol), predef_symbols) + EI_Dynamic No + # fresh_var = TempV var_store + tdt_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = fresh_var } + + # ({pds_ident,pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeClass] + tc_class_symb = {glob_module = pds_module, glob_object = {ds_ident = pds_ident, ds_arity = 1, ds_index = pds_def }} + (pds, predef_symbols) = predef_symbols![PD_TypeCodeMember] + ({pds_ident,pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeMember] + tc_member_symb = { symb_name = pds_ident, symb_kind = SK_OverloadedFunction {glob_module = pds_module, glob_object = pds_def }, symb_arity = 0} + (new_var_ptr, var_heap) = newPtr VI_Empty var_heap + context = {tc_class = tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr} + (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> (inc var_store, type_heaps, var_heap, + expr_heap <:= (dyn_ptr, EI_TempDynamicType No tdt_type [context] expr_ptr tc_member_symb), predef_symbols) + EI_DynamicTypeWithVars loc_type_vars dt=:{dt_type,dt_global_vars} loc_dynamics + # (fresh_vars, (th_vars, var_store)) = fresh_existential_variables loc_type_vars (type_heaps.th_vars, var_store) + (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store) + (tdt_type, {copy_heaps}) = freshCopy dt_type { copy_heaps = { type_heaps & th_vars = th_vars }} + (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols)) + = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, copy_heaps.th_vars, predef_symbols) + -> fresh_local_dynamics loc_dynamics (var_store, { copy_heaps & th_vars = type_var_heap }, var_heap, + expr_heap <:= (dyn_ptr, EI_TempDynamicPattern loc_type_vars dt loc_dynamics fresh_vars tdt_type contexts expr_ptr type_code_symbol), predef_symbols) + + fresh_local_dynamics loc_dynamics state + = foldSt fresh_dynamic loc_dynamics state + + clear_dynamics dyn_ptrs heaps + = foldSt clear_dynamic dyn_ptrs heaps + + clear_dynamic dyn_ptr (var_heap, expr_heap) + # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap + = case dyn_info of + EI_Dynamic (Yes {dt_global_vars}) + -> (clear_type_vars dt_global_vars var_heap, expr_heap) + EI_Dynamic No + -> (var_heap, expr_heap) + EI_DynamicTypeWithVars loc_type_vars {dt_global_vars} loc_dynamics + -> clear_local_dynamics loc_dynamics (clear_type_vars dt_global_vars var_heap, expr_heap) + + clear_local_dynamics loc_dynamics state + = foldSt clear_dynamic loc_dynamics state + + clear_type_vars type_vars var_heap + = foldSt (\{tv_info_ptr} -> writePtr tv_info_ptr TVI_Empty) type_vars var_heap + + fresh_existential_attributed_variables type_variables state + = foldSt (\{atv_variable={tv_info_ptr}} (var_heap, var_store) -> (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store)) + type_variables state + fresh_existential_variables type_variables state + = mapSt (\{tv_info_ptr} (var_heap, var_store) -> (var_store, (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store))) + type_variables state + fresh_type_variables type_variables state + = foldSt fresh_type_variable type_variables state + + fresh_type_variable {tv_info_ptr} (var_heap, var_store) + # (var_info, var_heap) = readPtr tv_info_ptr var_heap + = case var_info of + TVI_Empty + -> (var_heap <:= (tv_info_ptr, TVI_Type (TempV var_store)), inc var_store) + _ + -> (var_heap, var_store) + + determine_context_and_expr_ptr global_vars (var_heap, expr_heap, type_var_heap, predef_symbols) + # ({pds_ident,pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeClass] + tc_class_symb = {glob_module = pds_module, glob_object = {ds_ident = pds_ident, ds_arity = 1, ds_index = pds_def }} + ({pds_ident,pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeMember] + tc_member_symb = { symb_name = pds_ident, symb_kind = SK_TypeCode, symb_arity = 0} + (contexts, (var_heap, type_var_heap)) = mapSt (build_type_context tc_class_symb) global_vars (var_heap, type_var_heap) + (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (contexts, expr_ptr, tc_member_symb, (var_heap, expr_heap, type_var_heap, predef_symbols)) + + build_type_context tc_class_symb {tv_info_ptr} (var_heap, type_var_heap) + # (TVI_Type fresh_var, type_var_heap) = readPtr tv_info_ptr type_var_heap + (new_var_ptr, var_heap) = newPtr VI_Empty var_heap + = ({tc_class = tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}, (var_heap, type_var_heap)) + + +specification_error type err + = TypeError "specified type conflicts with derived type" type "" err + +cleanUpAndCheckFunctionTypes [] defs type_contexts coercion_env attr_partition type_var_env attr_var_env fun_defs ts + = (fun_defs, ts) +cleanUpAndCheckFunctionTypes [fun : funs] defs type_contexts coercion_env attr_partition type_var_env attr_var_env fun_defs ts + #! fd = fun_defs.[fun] + # (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun defs type_contexts coercion_env attr_partition type_var_env attr_var_env ts + = cleanUpAndCheckFunctionTypes funs defs type_contexts coercion_env attr_partition type_var_env attr_var_env fun_defs ts +where + clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun defs type_contexts coercion_env attr_partition type_var_env attr_var_env ts + #! env_type = ts.ts_fun_env.[fun] + # ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error} + = case env_type of + ExpandedType fun_type tmp_fun_type exp_fun_type + # (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_error) + = cleanUpSymbolType exp_fun_type type_contexts coercion_env attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_error + | ts_error.ea_ok + # (ts_fun_env, attr_var_env, ts_type_heaps, ts_error) + = check_function_type fun_type tmp_fun_type clean_fun_type defs ts.ts_fun_env attr_var_env ts_type_heaps ts_error + -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_fun_env = ts_fun_env, ts_error = ts_error }) + -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_error = ts_error }) + UncheckedType exp_fun_type + # (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_error) + = cleanUpSymbolType exp_fun_type type_contexts coercion_env attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_error + ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type } + -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_fun_env = ts_fun_env, ts_error = ts_error }) + + check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars} defs fun_env attr_var_env type_heaps error + # (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type defs attr_var_env type_heaps + | equi + # type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars + = ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, error) +// ---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types) + = (fun_env, attr_var_env, type_heaps, specification_error clean_fun_type error) + where + add_lifted_arg_types arity_diff args1 args2 + | arity_diff > 0 + = take arity_diff args2 ++ args1 + = args1 + +addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of_lifted_arguments new_args new_vars new_attrs + = { st & st_args = take nr_of_lifted_arguments new_args ++ st_args, st_vars = st_vars ++ drop (length st_vars) new_vars, + st_attr_vars = st_attr_vars ++ take (length new_attrs - length st_attr_vars) new_attrs, st_arity = st_arity + nr_of_lifted_arguments } + + +:: FunctionRequirements = + { fe_requirements :: !Requirements + , fe_context :: !Optional [TypeContext] + , fe_location :: !IdentPos + } + +typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File + -> (!Bool, !*{# FunDef}, !{! (!Index, !SymbolType)}, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File) +typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file + #! fun_env_size = size fun_defs + # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } + + ti_common_defs = {{dcl_common \\ {dcl_common} <-: modules } & [cIclModIndex] = icl_defs } + ti_functions = {dcl_functions \\ {dcl_functions} <-: modules } + + type_def_sizes = [ size com_type_defs \\ {com_type_defs} <-: ti_common_defs ] + class_def_sizes = [ size com_class_defs \\ {com_class_defs} <-: ti_common_defs ] + class_instances = { { IT_Empty \\ i <- [0 .. dec size] } \\ size <- class_def_sizes } + + (td_infos, hp_type_heaps, ts_error) = analTypeDefs ti_common_defs hp_type_heaps ts_error + + state = collect_imported_instances imports ti_common_defs {} ts_error class_instances hp_type_heaps.th_vars td_infos + (_, ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state + + ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, + ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error } + ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions } + special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] } + # (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts) + (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs + (type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps}) + = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances, + { ts & ts_fun_env = ts_fun_env }) + {si_array_instances, si_next_TC_member_index, si_TC_instances}= special_instances + (array_inst_types, predef_symbols, ts_type_heaps) = convert_array_instances si_array_instances ti_common_defs predef_symbols ts_type_heaps + type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_type \\ {gtci_index, gtci_type} <- si_TC_instances} + = (not type_error, fun_defs, { array_inst_type \\ array_inst_type <- array_inst_types }, type_code_instances, ti_common_defs, ti_functions, + {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file) +where + + collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos + = foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos) + + collect_imported_instance common_defs {dcl_ident, dcl_kind = STE_Imported STE_Instance mod_index, dcl_index } state + = update_instances_of_class common_defs mod_index dcl_index state + collect_imported_instance common_defs _ state + = state + + collect_and_check_instances nr_of_instances common_defs state + = iFoldSt (update_instances_of_class common_defs cIclModIndex) 0 nr_of_instances state + + update_instances_of_class common_defs mod_index ins_index (dummy, error, class_instances, type_var_heap, td_infos) + # {ins_class={glob_object={ds_index},glob_module},ins_type={it_types}} = common_defs.[mod_index].com_instance_defs.[ins_index] + (mod_instances, class_instances) = replace class_instances glob_module dummy + (instances, mod_instances) = replace mod_instances ds_index IT_Empty + (error, instances) = insert it_types ins_index mod_index common_defs error instances + (_, mod_instances) = replace mod_instances ds_index instances + (dummy, class_instances) = replace class_instances glob_module mod_instances + (error, type_var_heap, td_infos) + = check_types_of_instances common_defs glob_module ds_index it_types (error, type_var_heap, td_infos) + = (dummy, error, class_instances, type_var_heap, td_infos) + + check_types_of_instances common_defs class_module class_index types state + # {class_arity,class_cons_vars} = common_defs.[class_module].com_class_defs.[class_index] + = check_instances_of_constructor_variables common_defs class_cons_vars (dec class_arity) types state + where + check_instances_of_constructor_variables common_defs cons_vars arg_nr [type : types] state + | cons_vars bitand (1 << arg_nr) <> 0 + # state = check_type_of_constructor_variable common_defs type state + = check_instances_of_constructor_variables common_defs cons_vars (dec arg_nr) types state + = check_instances_of_constructor_variables common_defs cons_vars (dec arg_nr) types state + check_instances_of_constructor_variables common_defs cons_vars arg_nr [] state + = state + + check_type_of_constructor_variable common_defs type=:(TA {type_index={glob_module,glob_object},type_arity} types) (error, type_var_heap, td_infos) + # {td_arity} = common_defs.[glob_module].com_type_defs.[glob_object] + ({tdi_properties,tdi_cons_vars}, td_infos) = td_infos![glob_module].[glob_object] + | tdi_properties bitand cIsNonCoercible == 0 + # ({sc_neg_vect}, type_var_heap, td_infos) + = signClassification glob_object glob_module [TopSignClass \\ cv <- tdi_cons_vars ] common_defs type_var_heap td_infos + = (check_sign type (sc_neg_vect >> type_arity) (td_arity - type_arity) error, type_var_heap, td_infos) + = (checkError type " instance type should be coercible" error, type_var_heap, td_infos) + where + check_sign type neg_signs arg_nr error + | arg_nr == 0 + = error + | neg_signs bitand 1 == 0 + = check_sign type (neg_signs >> 1) (dec arg_nr) error + = checkError type " all arguments of an instance type should have a non-negative sign" error + check_type_of_constructor_variable common_defs type=:(arg_type --> result_type) (error, type_var_heap, td_infos) + = (checkError type " instance type should be coercible" error, type_var_heap, td_infos) + check_type_of_constructor_variable common_defs type=:(cv :@: types) (error, type_var_heap, td_infos) + = (checkError type " instance type should be coercible" error, type_var_heap, td_infos) + check_type_of_constructor_variable common_defs type state + = state + + insert :: ![Type] !Index !Index !{# CommonDefs } !*ErrorAdmin !*InstanceTree -> (!*ErrorAdmin, !*InstanceTree) + insert ins_types new_ins_index new_ins_module modules error IT_Empty + = (error, IT_Node {glob_object = new_ins_index,glob_module = new_ins_module} IT_Empty IT_Empty) + insert ins_types new_ins_index new_ins_module modules error (IT_Node ins=:{glob_object,glob_module} it_less it_greater) + #! {ins_type={it_types}} = modules.[glob_module].com_instance_defs.[glob_object] + # cmp = ins_types =< it_types + | cmp == Smaller + # (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less + = (error, IT_Node ins it_less it_greater) + | cmp == Greater + # (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater + = (error, IT_Node ins it_less it_greater) + = (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater) + + type_instances ir_from ir_to class_instances ti funs_and_state + | ir_from == ir_to + = funs_and_state + # funs_and_state = type_component [ir_from] class_instances ti funs_and_state + = type_instances (inc ir_from) ir_to class_instances ti funs_and_state + + type_components group_index comps class_instances ti funs_and_state + | group_index == size comps + = funs_and_state + #! comp = comps.[group_index] + # funs_and_state = type_component comp.group_members class_instances ti funs_and_state + = type_components (inc group_index) comps class_instances ti funs_and_state + + type_component comp class_instances ti=:{ti_common_defs} (type_error, fun_defs, predef_symbols, special_instances, ts) + # (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes ti_common_defs comp (fun_defs, predef_symbols, [], ts) + (fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts + #! nr_of_type_variables = ts.ts_var_store + # (subst, ts_type_heaps, ts_error) + = unify_requirements_of_functions fun_reqs ti (createArray nr_of_type_variables TE) ts.ts_type_heaps ts.ts_error + | not ts_error.ea_ok + = (True, fun_defs, predef_symbols, special_instances, create_erroneous_function_types comp + { ts & ts_type_heaps = ts_type_heaps, ts_error = { ts_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar}) + # {ts_attr_store,ts_var_heap,ts_var_store,ts_expr_heap,ts_td_infos} = ts + (subst, nr_of_attr_vars, th_vars, ts_td_infos) = liftSubstitution subst ti_common_defs ts_attr_store ts_type_heaps.th_vars ts_td_infos + coer_demanded ={{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrUni] = CT_Unique } + coer_offered = {{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrMulti] = CT_NonUnique } + coercion_env = build_initial_coercion_env fun_reqs {coer_demanded = coer_demanded, coer_offered = coer_offered } + (over_info, (subst, ts_expr_heap)) = collect_and_expand_overloaded_calls fun_reqs [] (subst, ts_expr_heap) + (ts_expr_heap, subst) = expand_types_of_cases_and_lets fun_reqs (ts_expr_heap, subst) + (contexts, coercion_env, local_pattern_variables, + { os_type_heaps, os_var_heap, os_symbol_heap, os_predef_symbols, os_special_instances, os_error }) + = tryToSolveOverloading over_info ti_common_defs class_instances coercion_env + { os_type_heaps = {ts_type_heaps & th_vars = th_vars}, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap, + os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } + | not os_error.ea_ok + = (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp { ts & ts_type_heaps = os_type_heaps, + ts_error = { os_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar, + ts_td_infos = ts_td_infos, ts_expr_heap = os_symbol_heap, ts_var_heap = os_var_heap }) + # (fun_defs, coercion_env, subst, os_var_heap, os_symbol_heap, os_error) + = makeSharedReferencesNonUnique comp fun_defs coercion_env subst ti_common_defs os_var_heap os_symbol_heap os_error + (cons_var_vects, subst) = determine_cons_variables cons_variables (createArray (inc (BITINDEX nr_of_type_variables)) 0, subst) + (subst, {coer_offered,coer_demanded}, ts_td_infos, ts_type_heaps, ts_error) + = build_coercion_env fun_reqs subst coercion_env ti_common_defs cons_var_vects ts_td_infos os_type_heaps os_error + (attr_partition, coer_demanded) = partitionateAttributes coer_offered coer_demanded + (subst, ts_fun_env) = expand_function_types comp subst ts.ts_fun_env + attr_var_env = createArray nr_of_attr_vars TA_None + var_env = { subst & [i] = TE \\ i <- [0..dec ts_var_store]} + (fun_defs, ts) = cleanUpAndCheckFunctionTypes comp ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env fun_defs + { ts & ts_error = ts_error, ts_fun_env = ts_fun_env, ts_type_heaps = ts_type_heaps, + ts_td_infos = ts_td_infos, ts_var_heap = os_var_heap, ts_expr_heap = os_symbol_heap } + | not ts.ts_error.ea_ok + = (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_error = { ts.ts_error & ea_ok = True } }) + | isEmpty over_info + # ts_type_heaps = ts.ts_type_heaps + type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, + tci_type_var_heap = ts_type_heaps.th_vars } + (fun_defs, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error) + = updateDynamics comp contexts local_pattern_variables fun_defs ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error + = ( type_error || not ts_error.ea_ok, + fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, + ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }}) + # ts_type_heaps = ts.ts_type_heaps + type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, + tci_type_var_heap = ts_type_heaps.th_vars } + (fun_defs, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error) + = removeOverloadedFunctions comp (map (\(co,_,pos) -> (co,pos)) over_info) + contexts local_pattern_variables fun_defs ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error + = ( type_error || not ts_error.ea_ok, + fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, + ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }}) + + unify_requirements_of_functions :: ![FunctionRequirements] !TypeInput !*{!Type} !*TypeHeaps !*ErrorAdmin -> (!*{!Type},!*TypeHeaps,!*ErrorAdmin) + unify_requirements_of_functions [{fe_requirements={req_type_coercions},fe_location} : reqs_list] modules subst heaps ts_error + # ts_error = setErrorAdmin fe_location ts_error + (subst, heaps, ts_error) = unify_coercions req_type_coercions modules subst heaps ts_error + = unify_requirements_of_functions reqs_list modules subst heaps ts_error + unify_requirements_of_functions [] modules subst heaps ts_error + = (subst, heaps, ts_error) + + build_initial_coercion_env [{fe_requirements={req_attr_coercions},fe_location} : reqs_list] coercion_env + = build_initial_coercion_env reqs_list (add_to_initial_coercion_env req_attr_coercions coercion_env) + build_initial_coercion_env [] coercion_env + = coercion_env + + add_to_initial_coercion_env [{ac_offered,ac_demanded} : attr_coercions] coercion_env + = add_to_initial_coercion_env attr_coercions (newInequality ac_offered ac_demanded coercion_env) + add_to_initial_coercion_env [] coercion_env + = coercion_env + + determine_cons_variables variables vect_and_subst + = foldSt (foldSt determine_cons_variable) variables vect_and_subst + + determine_cons_variable tv_number (bitvects, subst) + # (type, subst) = subst![tv_number] + = case type of + TE + -> (set_bit tv_number bitvects, subst) // ---> ("determine_cons_variable1", tv_number) + TempV var_number + -> (set_bit var_number bitvects, subst) // ---> ("determine_cons_variable2", var_number) + _ + -> (bitvects, subst) + where + set_bit var_number bitvects + # bit_index = BITINDEX var_number + (prev_vect, bitvects) = bitvects![bit_index] + = { bitvects & [bit_index] = prev_vect bitor (1 << BITNUMBER var_number) } + + build_coercion_env [{fe_requirements={req_type_coercions},fe_location} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + # error = setErrorAdmin fe_location error + (subst, coercion_env, type_signs, type_var_heap, error) + = add_to_coercion_env req_type_coercions subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + = build_coercion_env reqs_list subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + build_coercion_env [] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + = (subst, coercion_env, type_signs, type_var_heap, error) + + add_to_coercion_env [{tc_offered,tc_demanded,tc_coercible,tc_position} : attr_coercions] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + # (subst, coercion_env, type_signs, type_var_heap, error) + = determineAttributeCoercions tc_offered tc_demanded tc_coercible tc_position subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + = add_to_coercion_env attr_coercions subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + add_to_coercion_env [] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + = (subst, coercion_env, type_signs, type_var_heap, error) + + collect_and_expand_overloaded_calls [] calls subst_and_heap + = (calls, subst_and_heap) + collect_and_expand_overloaded_calls [{ fe_context=Yes context, fe_requirements={req_overloaded_calls}, fe_location}:reqs] calls (subst, expr_heap) + # (context, subst) = arraySubst context subst + = collect_and_expand_overloaded_calls reqs [(Yes context, req_overloaded_calls, fe_location) : calls] + (foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap)) + collect_and_expand_overloaded_calls [{fe_context, fe_requirements={req_overloaded_calls}, fe_location}:reqs] calls (subst, expr_heap) + = collect_and_expand_overloaded_calls reqs [(fe_context, req_overloaded_calls, fe_location) : calls] + (foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap)) + + expand_type_contexts over_info_ptr (subst, expr_heap) + # (EI_Overloaded info, expr_heap) = readPtr over_info_ptr expr_heap + (oc_context, subst) = arraySubst info.oc_context subst + = (subst, expr_heap <:= (over_info_ptr, EI_Overloaded { info & oc_context = oc_context })) + + expand_types_of_cases_and_lets [] heap_and_subst + = heap_and_subst + expand_types_of_cases_and_lets [{fe_requirements={req_case_and_let_exprs}}:reqs] heap_and_subst + = expand_types_of_cases_and_lets reqs (foldl expand_case_or_let_type heap_and_subst req_case_and_let_exprs) + + expand_case_or_let_type (expr_heap, subst) info_ptr + #! info = sreadPtr info_ptr expr_heap + = case info of + EI_CaseType case_type + # (case_type, subst) = arraySubst case_type subst + -> (writePtr info_ptr (EI_CaseType case_type) expr_heap, subst) + EI_LetType let_type + # (let_type, subst) = arraySubst let_type subst + -> (writePtr info_ptr (EI_LetType let_type) expr_heap, subst) + + expand_function_types :: ![Int] !*{!Type} *{! FunctionType} -> (!*{!Type}, *{! FunctionType}) + expand_function_types [fun : funs] subst ts_fun_env + #! fun_type = ts_fun_env.[fun] + = case fun_type of + UncheckedType tst + # (exp_tst, subst) = arraySubst tst subst + -> expand_function_types funs subst { ts_fun_env & [fun] = UncheckedType exp_tst} + SpecifiedType ft _ tst + # (exp_tst, subst) = arraySubst tst subst + -> expand_function_types funs subst { ts_fun_env & [fun] = ExpandedType ft tst exp_tst} + expand_function_types [] subst ts_fun_env + = (subst, ts_fun_env) + + + update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) + update_function_types group_index comps fun_env fun_defs + | group_index == size comps + = (fun_defs, fun_env) + #! comp = comps.[group_index] + # (fun_defs, fun_env) = update_function_types_in_component comp.group_members fun_env fun_defs + = update_function_types (inc group_index) comps fun_env fun_defs + + where + update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) + update_function_types_in_component [ fun_index : funs ] fun_env fun_defs + # (CheckedType checked_fun_type, fun_env) = fun_env![fun_index] + #! fd = fun_defs.[fun_index] + = case fd.fun_type of + No + -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }} + Yes fun_type + # nr_of_lifted_arguments = checked_fun_type.st_arity - fun_type.st_arity + | nr_of_lifted_arguments > 0 + # fun_type = addLiftedArgumentsToSymbolType fun_type nr_of_lifted_arguments checked_fun_type.st_args checked_fun_type.st_vars checked_fun_type.st_attr_vars + -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }} + -> update_function_types_in_component funs fun_env fun_defs + update_function_types_in_component [] fun_env fun_defs + = (fun_defs, fun_env) + + type_functions group ti cons_variables fun_defs ts + = mapSt (type_function ti) group (cons_variables, fun_defs, ts) // ((cons_variables, fun_defs, ts) ---> "[(") ---> ")]" + + type_function ti fun_index (cons_variables, fun_defs, ts=:{ts_fun_env, ts_var_heap, ts_expr_heap, ts_error}) + #! fd = fun_defs.[fun_index] + type = ts_fun_env.[fun_index] + # {fun_symb,fun_arity,fun_body=TransformedBody {tb_args,tb_rhs},fun_pos, fun_info, fun_type} = fd + temp_fun_type = type_of type + ts_var_heap = makeBase tb_args temp_fun_type.tst_args ts_var_heap + fe_location = newPosition fun_symb fun_pos + ts_error = setErrorAdmin fe_location ts_error + reqs = { req_overloaded_calls = [], req_type_coercions = [], req_attr_coercions = [], req_case_and_let_exprs = [], req_cons_variables = cons_variables } + (rhs_reqs, rhs_type, rhs_expr_ptr, ts) = requirements tb_rhs reqs ti { ts & ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error } + req_type_coercions = [{tc_demanded = temp_fun_type.tst_result,tc_offered = rhs_type, tc_position = {cp_expression = tb_rhs }, tc_coercible = True} : + rhs_reqs.req_type_coercions ] + ts_expr_heap = storeAttribute rhs_expr_ptr temp_fun_type.tst_result.at_attribute ts.ts_expr_heap + = ({fe_location = fe_location, fe_context = if (has_option fun_type) (Yes temp_fun_type.tst_context) No, + fe_requirements = { rhs_reqs & req_type_coercions = req_type_coercions, req_cons_variables = [] }}, (rhs_reqs.req_cons_variables, fun_defs, + { ts & ts_expr_heap = ts_expr_heap })) + // ---> ("type_function", fun_symb) + where + has_option (Yes _) = True + has_option No = False + + type_of (UncheckedType tst) = tst + type_of (SpecifiedType _ _ tst) = tst + + convert_array_instances si_array_instances common_defs predef_symbols type_heaps + | isEmpty si_array_instances + = ([], predef_symbols, type_heaps) + # ({pds_ident,pds_module,pds_def},predef_symbols) = predef_symbols![PD_UnboxedArrayType] + unboxed_array_type = TA (MakeTypeSymbIdent { glob_object = pds_def, glob_module = pds_module } pds_ident 0) [] + ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_ArrayClass] + {class_members} = common_defs.[pds_module].com_class_defs.[pds_def] + array_members = common_defs.[pds_module].com_member_defs + (rev_instances, type_heaps) = foldSt (convert_array_instance class_members array_members unboxed_array_type) si_array_instances ([], type_heaps) + = (reverse rev_instances, predef_symbols, type_heaps) + where + convert_array_instance class_members array_members unboxed_array_type {ai_record} types_and_heaps + = iFoldSt (create_instance_type class_members array_members unboxed_array_type (TA ai_record [])) 0 (size class_members) types_and_heaps + + create_instance_type members array_members unboxed_array_type record_type member_index (inst_types, type_heaps) + # {me_type,me_class_vars} = array_members.[members.[member_index].ds_index] + # (instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [], + it_types = [unboxed_array_type, record_type]} SP_None type_heaps + = ([(member_index,instance_type) : inst_types], type_heaps) + + create_erroneous_function_types group ts + = foldSt create_erroneous_function_type group ts + + create_erroneous_function_type fun ts + #! env_type = ts.ts_fun_env.[fun] + = case env_type of + ExpandedType fun_type tmp_fun_type exp_fun_type + # (fun_type, ts_type_heaps) = extendSymbolType fun_type tmp_fun_type.tst_lifted ts.ts_type_heaps + -> { ts & ts_type_heaps = ts_type_heaps, ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType fun_type }} + UncheckedType tmp_fun_type + # (clean_fun_type, ts_type_heaps) = cleanSymbolType tmp_fun_type.tst_arity ts.ts_type_heaps + -> { ts & ts_type_heaps = ts_type_heaps, ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }} + SpecifiedType fun_type _ tmp_fun_type + # (fun_type, ts_type_heaps) = extendSymbolType fun_type tmp_fun_type.tst_lifted ts.ts_type_heaps + -> { ts & ts_type_heaps = ts_type_heaps, ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType fun_type }} + CheckedType _ + -> ts + +instance <<< AttrCoercion +where + (<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< '~' <<< ac_offered + +instance <<< FreeVar +where + (<<<) file {fv_name} = file <<< fv_name + +instance <<< TypeCoercion +where + (<<<) file {tc_demanded,tc_offered} = file <<< tc_demanded <<< '~' <<< tc_offered + +instance <<< TypeContext +where + (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types + +instance <<< DefinedSymbol +where + (<<<) file {ds_ident} + = file <<< ds_ident + +instance <<< FunctionType +where + (<<<) file (CheckedType _) + = file <<< "CheckedType" + (<<<) file (SpecifiedType _ _ _) + = file <<< "SpecifiedType" + (<<<) file (UncheckedType _) + = file <<< "UncheckedType" + (<<<) file (ExpandedType _ _ _) + = file <<< "ExpandedType" + (<<<) file EmptyFunctionType + = file <<< "EmptyFunctionType" diff --git a/frontend/typeanal.dcl b/frontend/typeanal.dcl new file mode 100644 index 0000000..d9d891b --- /dev/null +++ b/frontend/typeanal.dcl @@ -0,0 +1 @@ +definition module typeanal diff --git a/frontend/typeanal.icl b/frontend/typeanal.icl new file mode 100644 index 0000000..e602e72 --- /dev/null +++ b/frontend/typeanal.icl @@ -0,0 +1 @@ +implementation module typeanal
\ No newline at end of file diff --git a/frontend/typeproperties.dcl b/frontend/typeproperties.dcl new file mode 100644 index 0000000..fc7677a --- /dev/null +++ b/frontend/typeproperties.dcl @@ -0,0 +1,55 @@ +definition module typeproperties + +import StdInt, StdClass + +import general + +:: TypeClassification + +EmptyTypeClassification :: TypeClassification + +:: SignClassification = + { sc_pos_vect :: !BITVECT + , sc_neg_vect :: !BITVECT + } + +:: PropClassification :== BITVECT + +TopSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = bitnot 0 } +ArrowSignClass :== { sc_pos_vect = 2, sc_neg_vect = 1 } +PosSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } + +:: Sign = + { pos_sign :: !Bool + , neg_sign :: !Bool + } + + +TopSign :== { pos_sign = True, neg_sign = True } +BottomSign :== { pos_sign = False, neg_sign = False } +PositiveSign :== { pos_sign = True, neg_sign = False } +NegativeSign :== { pos_sign = False, neg_sign = True } + +signClassToSign :: !SignClassification !Int -> Sign + +/* +IsPositive sign_class index :== sign_class.sc_pos_vect bitand (1 << index) <> 0 +IsNegative sign_class index :== sign_class.sc_neg_vect bitand (1 << index) <> 0 +*/ +instance <<< Sign + +:: TypeSign key = + { ts_cons_var_signs :: !key + , ts_type_sign :: !SignClassification + } + +:: TypeProp key = + { ts_cons_var_props :: !key + , ts_type_prop :: !PropClassification + } + +retrieveSignClassification :: ![SignClassification] !TypeClassification -> Optional (TypeSign [SignClassification]) +retrievePropClassification :: ![PropClassification] !TypeClassification -> Optional (TypeProp [PropClassification]) + +addSignClassification :: ![SignClassification] !SignClassification !TypeClassification -> !TypeClassification +addPropClassification :: ![PropClassification] !PropClassification !TypeClassification -> !TypeClassification diff --git a/frontend/typeproperties.icl b/frontend/typeproperties.icl new file mode 100644 index 0000000..267dfd8 --- /dev/null +++ b/frontend/typeproperties.icl @@ -0,0 +1,139 @@ +implementation module typeproperties + +import StdEnv + +import general, StdCompare + +:: TypeClassification = + { tc_signs :: TypeSignTree + , tc_props :: TypePropTree + } + +:: SignClassification = + { sc_pos_vect :: !BITVECT + , sc_neg_vect :: !BITVECT + } +/* +IsPositive sign_class index :== sign_class.sc_pos_vect bitand (1 << index) <> 0 +IsNegative sign_class index :== sign_class.sc_neg_vect bitand (1 << index) <> 0 +*/ +:: PropClassification :== BITVECT + +TopSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = bitnot 0 } +ArrowSignClass :== { sc_pos_vect = 2, sc_neg_vect = 1 } +PosSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } + +:: Sign = + { pos_sign :: !Bool + , neg_sign :: !Bool + } + + +TopSign :== { pos_sign = True, neg_sign = True } +BottomSign :== { pos_sign = False, neg_sign = False } +PositiveSign :== { pos_sign = True, neg_sign = False } +NegativeSign :== { pos_sign = False, neg_sign = True } + +:: TypeSign key = + { ts_cons_var_signs :: !key + , ts_type_sign :: !SignClassification + } + +:: TypeProp key = + { ts_cons_var_props :: !key + , ts_type_prop :: !PropClassification + } + +:: VarBind a key = + { vb_number :: !key + , vb_value :: !a + } + +:: TypeSignTree :== BinTree (TypeSign [SignClassification]) +:: TypePropTree :== BinTree (TypeProp [PropClassification]) +:: EnvTree a :== BinTree (VarBind a Int) + +:: BinTree a = BT_Node !a !(BinTree a) !(BinTree a) | BT_Empty + +class key m :: (m a) -> a + +instance key TypeSign +where + key {ts_cons_var_signs} = ts_cons_var_signs + +instance key TypeProp +where + key {ts_cons_var_props} = ts_cons_var_props + +instance key (VarBind a) +where + key {vb_number} = vb_number + +EmptyTypeClassification :: TypeClassification +EmptyTypeClassification = { tc_signs = BT_Empty, tc_props = BT_Empty } + +treeInsert :: !k !(m k) !(BinTree (m k)) -> BinTree (m k) | =< k & key m +treeInsert new_key el BT_Empty + = BT_Node el BT_Empty BT_Empty +treeInsert new_key new_el tree=:(BT_Node el left right) + # cmp = new_key =< key el + | cmp == Smaller + = BT_Node el (treeInsert new_key new_el left) right + = BT_Node el left (treeInsert new_key new_el right) + +treeRetrieve :: !k !(BinTree (m k)) -> !Optional (m k) | =< k & key m +treeRetrieve search_key BT_Empty + = No +treeRetrieve search_key tree=:(BT_Node el left right) + # cmp = search_key =< key el + | cmp == Equal + = Yes el + | cmp == Smaller + = treeRetrieve search_key left + = treeRetrieve search_key right + +signClassToSign :: !SignClassification !Int -> Sign +signClassToSign {sc_pos_vect,sc_neg_vect} index + = { pos_sign = sc_pos_vect bitand (1 << index) <> 0, neg_sign = sc_neg_vect bitand (1 << index) <> 0} + +instance <<< Sign +where + (<<<) file {pos_sign,neg_sign} + | pos_sign + | neg_sign + = file <<< "T" + = file <<< "+" + | neg_sign + = file <<< "-" + = file <<< "L" + +instance =< SignClassification +where + =< sc1 sc2 + | sc1.sc_pos_vect == sc2.sc_pos_vect + | sc1.sc_neg_vect == sc2.sc_neg_vect + = Equal + | sc1.sc_neg_vect < sc2.sc_neg_vect + = Smaller + = Greater + | sc1.sc_pos_vect < sc2.sc_pos_vect + = Smaller + = Greater + +retrieveSignClassification :: ![SignClassification] !TypeClassification -> Optional (TypeSign [SignClassification]) +retrieveSignClassification cons_classes {tc_signs} + = treeRetrieve cons_classes tc_signs + +addSignClassification :: ![SignClassification] !SignClassification !TypeClassification -> !TypeClassification +addSignClassification hio_signs sign_class tc=:{tc_signs} + = { tc & tc_signs = treeInsert hio_signs { ts_cons_var_signs = hio_signs, ts_type_sign = sign_class } tc_signs } + +retrievePropClassification :: ![PropClassification] !TypeClassification -> Optional (TypeProp [PropClassification]) +retrievePropClassification cons_classes {tc_props} + = treeRetrieve cons_classes tc_props + +addPropClassification :: ![PropClassification] !PropClassification !TypeClassification -> !TypeClassification +addPropClassification hio_props prop_class tc=:{tc_props} + = { tc & tc_props = treeInsert hio_props { ts_cons_var_props = hio_props, ts_type_prop = prop_class } tc_props } + + diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl new file mode 100644 index 0000000..703fb41 --- /dev/null +++ b/frontend/typesupport.dcl @@ -0,0 +1,39 @@ +definition module typesupport + +import checksupport, StdCompare + +from unitype import Coercions, CoercionTree, AttributePartition + +TypeError :: !String !mess !String !*ErrorAdmin -> *ErrorAdmin | <<< mess + +:: AttributeEnv :== {! TypeAttribute } +:: VarEnv :== {! Type } + +cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) +extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) + +cleanUpSymbolType :: !TempSymbolType ![TypeContext] !{! CoercionTree} !AttributePartition !*VarEnv !*AttributeEnv !*TypeHeaps !*ErrorAdmin + -> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*ErrorAdmin) + +expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) + +equivalent :: !SymbolType !TempSymbolType !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps) + +:: AttrCoercion = + { ac_demanded :: !Int + , ac_offered :: !Int + } + +:: TempSymbolType = + { tst_args :: ![AType] + , tst_arity :: !Int + , tst_lifted :: !Int + , tst_result :: !AType + , tst_context :: ![TypeContext] + , tst_attr_env :: ![AttrCoercion] + } + +class substitute a :: !a !u:TypeHeaps -> (!a, !u:TypeHeaps) + +instance substitute AType, Type, TypeContext, AttrInequality, [a] | substitute a +instance <<< TempSymbolType diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl new file mode 100644 index 0000000..6c9379f --- /dev/null +++ b/frontend/typesupport.icl @@ -0,0 +1,755 @@ +implementation module typesupport + +import StdEnv, StdCompare +import syntax, parse, check, unitype, utilities, RWSDebug + +:: Store :== Int + +:: AttrCoercion = + { ac_demanded :: !Int + , ac_offered :: !Int + } + +:: TempSymbolType = + { tst_args :: ![AType] + , tst_arity :: !Int + , tst_lifted :: !Int + , tst_result :: !AType + , tst_context :: ![TypeContext] + , tst_attr_env :: ![AttrCoercion] + } + +class emptyValue a :: a + +instance emptyValue TypeAttribute +where + emptyValue = TA_None + +instance emptyValue Type +where + emptyValue = TE + + +lookUp :: !a !(Env a b) -> (!Bool, !b) | ==, toString a & emptyValue b +lookUp elem_id [] + = (False, emptyValue) +lookUp elem_id [b : bs] + | elem_id == b.bind_src + = (True, b.bind_dst) + = lookUp elem_id bs + +simplifyTypeApplication :: !Type ![AType] -> Type +simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args + = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) +simplifyTypeApplication (TV tv) type_args + = CV tv :@: type_args +simplifyTypeApplication (CV tv :@: type_args1) type_args2 + = CV tv :@: (type_args1 ++ type_args2) + +:: AttributeEnv :== {! TypeAttribute } +:: VarEnv :== {! Type } + +:: CleanUpState = + { cus_var_env :: !.VarEnv + , cus_attr_env :: !.AttributeEnv + , cus_heaps :: !.TypeHeaps + , cus_var_store :: !Int + , cus_attr_store :: !Int + , cus_error :: !.ErrorAdmin + } + + +class clean_up a :: !(!{! CoercionTree}, !AttributePartition) !a !*CleanUpState -> (!a, !*CleanUpState) + +instance clean_up AType +where + clean_up coercions atype=:{at_attribute,at_type} cus + # (at_attribute, cus) = clean_up coercions at_attribute cus + (at_type, cus) = clean_up coercions at_type cus + = ({atype & at_attribute = at_attribute, at_type = at_type}, cus) + +attrIsUndefined TA_None = True +attrIsUndefined _ = False + +varIsDefined TE = False +varIsDefined _ = True + +instance clean_up TypeAttribute +where + clean_up coercions TA_Unique cus + = (TA_Unique, cus) + clean_up coercions TA_Multi cus + = (TA_Multi, cus) + clean_up (coercions, attr_part) tv=:(TA_TempVar av_number) cus=:{cus_attr_env,cus_heaps,cus_attr_store,cus_error} + # av_group_nr = attr_part.[av_number] + coercion_tree = coercions.[av_group_nr] + | isNonUnique coercion_tree + = (TA_Multi, cus) + | isUnique coercion_tree + = (TA_Unique, cus) + #! attr = cus_attr_env.[av_group_nr] + | attrIsUndefined attr + # (av_info_ptr, th_attrs) = newPtr AVI_Empty cus_heaps.th_attrs + new_attr_var = TA_Var { av_name = NewAttrVarId cus_attr_store, av_info_ptr = av_info_ptr } + = (new_attr_var, { cus & cus_attr_env = { cus_attr_env & [av_group_nr] = new_attr_var}, + cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store}) + = (attr, cus) + +instance clean_up Type +where + clean_up coercions (TempV tv_number) cus=:{cus_var_env} + #! type = cus_var_env.[tv_number] + = cleanUpVariable type tv_number cus + clean_up coercions (TA tc types) cus + # (types, cus) = clean_up coercions types cus + = (TA tc types, cus) + clean_up coercions (argtype --> restype) cus + # (argtype, cus) = clean_up coercions argtype cus + (restype, cus) = clean_up coercions restype cus + = (argtype --> restype, cus) + clean_up coercions t=:(TB _) cus + = (t, cus) + clean_up coercions (TempCV tempvar :@: types) cus + #! type = cus.cus_var_env.[tempvar] + # (type, cus) = cleanUpVariable type tempvar cus + (types, cus) = clean_up coercions types cus + = (simplifyTypeApplication type types, cus) + clean_up coercions (TempQV qv_number) cus=:{cus_var_env,cus_error} + #! type = cus_var_env.[qv_number] + = cleanUpVariable type qv_number {cus & cus_error = existentialError cus_error} + clean_up coercions TE cus + = abort "unknown pattern in function clean_up" + +instance clean_up [a] | clean_up a +where + clean_up coercions l cus = mapSt (clean_up coercions) l cus + +cleanUpVariable TE tv_number cus=:{cus_heaps,cus_var_store,cus_var_env} + # (tv_info_ptr, th_vars) = newPtr TVI_Empty cus_heaps.th_vars + new_var = TV { tv_name = NewVarId cus_var_store, tv_info_ptr = tv_info_ptr } + = (new_var, { cus & cus_var_env = { cus_var_env & [tv_number] = new_var}, + cus_heaps = { cus_heaps & th_vars = th_vars }, cus_var_store = inc cus_var_store}) +cleanUpVariable (TLifted var) tv_number cus=:{cus_error} + = (TV var, { cus & cus_error = liftedError var cus_error}) +cleanUpVariable type tv_number cus + = (type, cus) + +class cleanUpClosed a :: !a !u:VarEnv -> (!Bool, !a, !u:VarEnv) + +instance cleanUpClosed AType +where + cleanUpClosed atype=:{at_type} env + # (ok, at_type, env) = cleanUpClosed at_type env + = (ok, { atype & at_type = at_type}, env) + +instance cleanUpClosed Type +where + cleanUpClosed (TempV tv_number) env + #! type = env.[tv_number] + = (varIsDefined type, type, env) + cleanUpClosed (TA tc types) env + # (ok, types, env) = cleanUpClosed types env + = (ok, TA tc types, env) + cleanUpClosed (argtype --> restype) env + # (ok, (argtype,res_type), env) = cleanUpClosed (argtype,restype) env + = (ok, argtype --> restype, env) + cleanUpClosed (TempCV tv_number :@: types) env + #! type = env.[tv_number] + | varIsDefined type + # (ok, types, env) = cleanUpClosed types env + = (ok, simplifyTypeApplication type types, env) + = (False, TempCV tv_number :@: types, env) + cleanUpClosed t env + = (True, t, env) + +instance cleanUpClosed (a,b) | cleanUpClosed a & cleanUpClosed b +where + cleanUpClosed (x,y) env + # (ok_x, x, env) = cleanUpClosed x env + | ok_x + # (ok_y, y, env) = cleanUpClosed y env + = (ok_y, (x,y), env) + = (False, (x,y), env) + +instance cleanUpClosed [a] | cleanUpClosed a +where + cleanUpClosed [] env + = (True, [], env) + cleanUpClosed [t:ts] env + # (ok, (t,ts), env) = cleanUpClosed (t,ts) env + = (ok, [t:ts], env) + +TypeError :: !String !mess !String !*ErrorAdmin -> *ErrorAdmin | <<< mess +TypeError err_pref err_msg err_post err=:{ea_file,ea_loc} + | isEmpty ea_loc + # ea_file = ea_file <<< "Type error: " <<< err_pref <<< ' ' <<< err_msg <<< ' ' <<< err_post <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + # ea_file = ea_file <<< "Type error " <<< hd ea_loc <<< ": " <<< err_pref <<< ' ' <<< err_msg <<< ' ' <<< err_post <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + + +overloadingError class_symb err + = TypeError "internal overloading of class" class_symb "is unsolvable" err + +existentialError err + = TypeError "existential" "type variable" "appears in the derived type specification" err + +liftedError var err + = TypeError "type variable of type of lifted argument" var "appears in the specified type" err + +clean_up_type_contexts [] env error + = ([], env, error) +clean_up_type_contexts [tc:tcs] env error + # (tcs, env, error) = clean_up_type_contexts tcs env error + (ok_tc_types, tc_types, env) = cleanUpClosed tc.tc_types env + | ok_tc_types + = ([{ tc & tc_types = tc_types } : tcs], env, error) + = (tcs, env, overloadingError tc.tc_class.glob_object.ds_ident error) + +extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) +extendSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of_extra_args type_heaps + | nr_of_extra_args > 0 + # (st_args, (st_vars, st_attr_vars, type_heaps)) + = newAttributedVariables nr_of_extra_args st_args (st_vars, st_attr_vars, type_heaps) + = ({ st & st_args = st_args, st_vars = st_vars, st_attr_vars = st_attr_vars, st_arity = st_arity + nr_of_extra_args }, type_heaps) + = (st, type_heaps) + +cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) +cleanSymbolType arity type_heaps + # (st_result, clean_state) = newAttributedVariable 0 ([], [], type_heaps) + (st_args, (st_vars, st_attr_vars, type_heaps)) = newAttributedVariables arity [] clean_state + = ({ st_arity = arity, st_vars = st_vars , st_args = st_args, st_result = st_result, st_context = [], + st_attr_env = [], st_attr_vars = st_attr_vars }, type_heaps) + +newAttributedVariables var_number attributed_variables clean_state=:(_,_,_) /* Temporary hack */ + | var_number == 0 + = (attributed_variables, clean_state) + # (attributed_variable, clean_state) = newAttributedVariable var_number clean_state + = newAttributedVariables (dec var_number) [ attributed_variable : attributed_variables ] clean_state + +newAttributedVariable var_number (variables, attributes, type_heaps=:{th_vars,th_attrs}) + # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars + new_var = { tv_name = NewVarId var_number, tv_info_ptr = tv_info_ptr } + (av_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs + new_attr_var = { av_name = NewAttrVarId var_number, av_info_ptr = av_info_ptr } + = ({ at_annotation = AN_None, at_attribute = TA_Var new_attr_var, at_type = TV new_var}, + ([ new_var : variables ], [ new_attr_var : attributes ], { type_heaps & th_vars = th_vars, th_attrs = th_attrs })) + +cleanUpSymbolType :: !TempSymbolType ![TypeContext] !{! CoercionTree} !AttributePartition !*VarEnv !*AttributeEnv !*TypeHeaps !*ErrorAdmin + -> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*ErrorAdmin) +cleanUpSymbolType tst=:{tst_arity,tst_args,tst_result,tst_context,tst_lifted} context coercions attr_part var_env attr_var_env heaps error + #! nr_of_temp_vars = size var_env + #! max_attr_nr = size attr_var_env + # cus = { cus_var_env = var_env, cus_attr_env = attr_var_env, cus_heaps = heaps, + cus_var_store = 0, cus_attr_store = 0, cus_error = error } + (lifted_args, cus=:{cus_var_env}) = clean_up (coercions,attr_part) (take tst_lifted tst_args) cus + (lifted_vars, cus_var_env) = determine_type_vars nr_of_temp_vars [] cus_var_env + (st_args, cus) = clean_up (coercions,attr_part) (drop tst_lifted tst_args) { cus & cus_var_env = cus_var_env } + (st_result, {cus_var_env,cus_attr_env,cus_heaps,cus_error}) = clean_up (coercions,attr_part) tst_result cus + (st_context, cus_var_env, error) = clean_up_type_contexts (tst_context ++ context) cus_var_env cus_error + (st_vars, var_env) = determine_type_vars nr_of_temp_vars lifted_vars cus_var_env + (attr_env, st_attr_vars, st_attr_env) = build_attribute_environment 0 max_attr_nr coercions cus_attr_env [] [] + st = { st_arity = tst_arity, st_vars = st_vars , st_args = lifted_args ++ st_args, st_result = st_result, st_context = st_context, + st_attr_env = st_attr_env, st_attr_vars = st_attr_vars } + = (st,{ var_env & [i] = TE \\ i <- [0..nr_of_temp_vars - 1]}, { attr_env & [i] = TA_None \\ i <- [0..max_attr_nr - 1]}, cus_heaps, error) +// ---> (tst, st) +where + determine_type_var var_index (all_vars, var_env) + #! type = var_env.[var_index] + = case type of + TV var + -> ([var : all_vars], { var_env & [var_index] = TLifted var}) + _ + -> (all_vars, var_env) + + determine_type_vars to_index all_vars var_env + = iFoldSt determine_type_var 0 to_index (all_vars, var_env) + + build_attribute_environment :: !Index !Index !{! CoercionTree} !*AttributeEnv ![AttributeVar] ![AttrInequality] + -> (!*AttributeEnv, ![AttributeVar], ![AttrInequality]) + build_attribute_environment attr_group_index max_attr_nr coercions attr_env attr_vars inequalities + | attr_group_index == max_attr_nr + = (attr_env, attr_vars, inequalities) + #! attr = attr_env.[attr_group_index] + = case attr of + TA_Var attr_var + # (attr_env, inequalities) = build_inequalities attr_var coercions.[attr_group_index] coercions attr_env inequalities + -> build_attribute_environment (inc attr_group_index) max_attr_nr coercions attr_env [attr_var : attr_vars] inequalities + TA_None + -> build_attribute_environment (inc attr_group_index) max_attr_nr coercions attr_env attr_vars inequalities + + build_inequalities off_var (CT_Node dem_attr left right) coercions attr_env inequalities + # (attr_env, inequalities) = build_inequalities off_var left coercions attr_env inequalities + (attr_env, inequalities) = build_inequalities off_var right coercions attr_env inequalities + #! attr = attr_env.[dem_attr] + = case attr of + TA_Var attr_var + | is_new_inequality attr_var off_var inequalities + -> (attr_env, [{ ai_demanded = attr_var, ai_offered = off_var } : inequalities]) + -> (attr_env, inequalities) + TA_None + -> build_inequalities off_var coercions.[dem_attr] coercions attr_env inequalities + build_inequalities off_var tree coercions attr_env inequalities + = (attr_env, inequalities) + + is_new_inequality dem_var off_var [] + = True + is_new_inequality dem_var off_var [{ ai_demanded, ai_offered } : inequalities] + = (dem_var <> ai_demanded || off_var <> ai_offered) && is_new_inequality dem_var off_var inequalities + + + +/* + build_inequalities :: !AttributeVar !(Env Int TypeAttribute) !Int !{# Bool} !Int !Int ![AttrInequality] -> [AttrInequality] + build_inequalities off_var attr_var_env next_var_number dem_vars skip size inequalities + | next_var_number == size + = inequalities + | dem_vars.[next_var_number] && next_var_number <> skip + # (found, TA_Var dem_var) = lookUp next_var_number attr_var_env + | found + # inequalities = [ { ai_demanded = dem_var, ai_offered = off_var } : inequalities] + = build_inequalities off_var attr_var_env (inc next_var_number) dem_vars skip size inequalities + = build_inequalities off_var attr_var_env (inc next_var_number) dem_vars skip size inequalities + = build_inequalities off_var attr_var_env (inc next_var_number) dem_vars skip size inequalities + +clean_up_symbol_type :: !SymbolType ![TypeContext] !*ErrorAdmin -> (!SymbolType, !*ErrorAdmin) +clean_up_symbol_type st=:{st_args,st_result,st_context} context error + # (st_args, var_env, attr_var_env, var_store, error) = clean_up_argument_types st_args [] [] 0 error + (st_result, var_env, attr_var_env, var_store, error) = clean_up_result_type st_result var_env attr_var_env var_store error + new_env = attr_var_env ++ var_env + (st_context, error) = clean_up_type_contexts (st_context ++ context) new_env error + = ({ st & st_vars = map (\bind=:{bind_dst = TV tv} -> tv) new_env, st_args = st_args, st_result = st_result, st_context = st_context }, error) + + +clean_up_type type var_binds uq_var_binds var_store error + # (type, var_binds, new_uq_var_binds, var_store) = clean_up type var_binds [] var_store + error = check_uq_vars new_uq_var_binds uq_var_binds error + | isEmpty new_uq_var_binds + = (type, var_binds, new_uq_var_binds ++ uq_var_binds, var_store, error) + = (TFA [ var \\ {bind_dst=TV var} <- new_uq_var_binds ] type, var_binds, new_uq_var_binds ++ uq_var_binds, var_store, error) + + +quantifiction_error err=:{ea_file} + # ea_file = ea_file <<< "Type error: Introduction of universal quantifier failed\n" + = { err & ea_file = ea_file} + +check_uq_vars [] uq_var_binds error = error +check_uq_vars [b:bs] uq_var_binds error + # (found, var) = lookUp b.bind_src uq_var_binds + | found + = quantifiction_error error + = check_uq_vars bs uq_var_binds error + +clean_up_argument_types [] var_binds uq_var_binds var_store error + = ([], var_binds, uq_var_binds, var_store, error) +clean_up_argument_types [t:ts] var_binds uq_var_binds var_store error + # (t, var_binds, uq_var_binds, var_store, error) = clean_up_type t var_binds uq_var_binds var_store error + (ts, var_binds, uq_var_binds, var_store, error) = clean_up_argument_types ts var_binds uq_var_binds var_store error + = ([t:ts], var_binds, uq_var_binds, var_store, error) + +clean_up_result_type (argtype --> restype) var_binds uq_var_binds var_store error + # (argtype, var_binds, uq_var_binds, var_store, error) = clean_up_type argtype var_binds uq_var_binds var_store error + (restype, var_binds, uq_var_binds, var_store, error) = clean_up_result_type restype var_binds uq_var_binds var_store error + = (argtype --> restype, var_binds, uq_var_binds, var_store, error) +clean_up_result_type type var_binds uq_var_binds var_store error + # (type, var_binds, new_uq_var_binds, var_store) = clean_up type var_binds [] var_store + error = check_uq_vars new_uq_var_binds uq_var_binds error + = (type, var_binds, new_uq_var_binds, var_store, error) + +*/ + + +class substitute a :: !a !u:TypeHeaps -> (!a, !u:TypeHeaps) + +instance substitute AType +where + substitute atype=:{at_attribute,at_type} heaps + # ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps + = ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps) + +instance substitute TypeAttribute +where + substitute (TA_Var {av_name, av_info_ptr}) heaps=:{th_attrs} + #! av_info = sreadPtr av_info_ptr th_attrs + # (AVI_Attr attr) = av_info + = (attr, heaps) + substitute TA_None heaps + = (TA_Multi, heaps) + substitute attr heaps + = (attr, heaps) + +instance substitute (a,b) | substitute a & substitute b +where + substitute (x,y) heaps + # (x, heaps) = substitute x heaps + (y, heaps) = substitute y heaps + = ((x,y), heaps) + +instance substitute [a] | substitute a +where + substitute [] heaps + = ([], heaps) + substitute [t:ts] heaps + # (t, heaps) = substitute t heaps + (ts, heaps) = substitute ts heaps + = ([t:ts], heaps) + + +instance substitute TypeContext +where + substitute tc=:{tc_types} heaps + # (tc_types, heaps) = substitute tc_types heaps + = ({ tc & tc_types = tc_types }, heaps) + +substituteTypeVariable {tv_name,tv_info_ptr} heaps=:{th_vars} + #! tv_info = sreadPtr tv_info_ptr th_vars + = case tv_info of + TVI_Type type + -> (type, heaps) + _ + -> abort ("Error in substitute (Type)" ---> (tv_info, tv_name)) + +instance substitute Type +where + substitute (TV tv) heaps + = substituteTypeVariable tv heaps + substitute (arg_type --> res_type) heaps + # ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps + = (arg_type --> res_type, heaps) + substitute (TA cons_id cons_args) heaps + # (cons_args, heaps) = substitute cons_args heaps + = (TA cons_id cons_args, heaps) + substitute (CV type_var :@: types) heaps + # (type, heaps) = substituteTypeVariable type_var heaps + (types, heaps) = substitute types heaps + = (simplifyTypeApplication type types, heaps) + substitute type heaps + = (type, heaps) + +instance substitute AttributeVar +where + substitute {av_info_ptr} heaps=:{th_attrs} + #! av_info = sreadPtr av_info_ptr th_attrs + # (AVI_Attr (TA_Var attr_var)) = av_info + = (attr_var, heaps) + +instance substitute AttrInequality +where + substitute {ai_demanded,ai_offered} heaps + # ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps + = ({ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps) + +expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) +expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs} + # th_attrs = bind_attr form_attr act_attr th_attrs + = substitute type_rhs (fold2St bind_type_and_attr type_args arg_types { type_heaps & th_attrs = th_attrs }) +where + bind_type_and_attr {atv_attribute = TA_Var {av_name,av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute,at_type} {th_vars,th_attrs} + = { th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } + bind_type_and_attr {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } + + bind_attr (TA_Var {av_name,av_info_ptr}) attr th_attrs + = th_attrs <:= (av_info_ptr, AVI_Attr attr) + bind_attr _ attr th_attrs + = th_attrs + + +VarIdTable :: {# String} +VarIdTable =: { "a", "b", "c", "d", "e", "f", "g", "h", "i", "j" } + +newIdent id_name + :== { id_name = id_name, id_info = nilPtr } + +NewVarId var_store + | var_store < size VarIdTable + = newIdent VarIdTable.[var_store] + = newIdent ("v" +++ toString var_store) + +AttrVarIdTable :: {# String} +AttrVarIdTable =: { "u", "v", "w", "x", "y", "z" } + +NewAttrVarId attr_var_store + | attr_var_store < size AttrVarIdTable + = newIdent AttrVarIdTable.[attr_var_store] + = newIdent ("u" +++ toString attr_var_store) + + + +instance == AttributeVar +where + (==) av1 av2 = av1.av_info_ptr == av2.av_info_ptr + + +/* +class equiv a :: !a !a !*VarEnv !*AttributeEnv -> (!Bool, !*VarEnv, !*AttributeEnv) + +instance equiv AType +where + equiv atype1 atype2 var_env attr_env + # (ok, attr_env) = equi_attrs atype1.at_attribute atype2.at_attribute attr_env + | ok + = equiv atype1.at_type atype2.at_type var_env attr_env + = (False, var_env, attr_env) + where + equi_attrs (TA_TempVar av_number) attr=:(TA_Var attr_var) attr_env + #! forw_attr = attr_env.[av_number] + = case forw_attr of + TA_None + -> (True, { attr_env & [av_number] = attr}) + TA_Var forw_var + -> (forw_var == attr_var, attr_env) + _ + -> abort "Error in equiv (AType)" + equi_attrs attr1 attr2 attr_env + = (attr1 == attr2, attr_env) + +instance equiv Type +where + equiv (TempV tv_number) type=:(TV var) var_env attr_env + #! forw_type = var_env.[tv_number] + = case forw_type of + TE + -> (True, { var_env & [tv_number] = type }, attr_env) + TV forw_var + -> (forw_var == var, var_env, attr_env) + _ + -> abort "Error in equiv (Type)" + equiv (arg_type1 --> restype1) (arg_type2 --> restype2) var_env attr_env + = equiv (arg_type1,restype1) (arg_type2,restype2) var_env attr_env + equiv (TA tc1 types1) (TA tc2 types2) var_env attr_env + | tc1 == tc2 + = equiv types1 types2 var_env attr_env + = (False, var_env, attr_env) + equiv (TB basic1) (TB basic2) var_env attr_env + = (basic1 == basic2, var_env, attr_env) + equiv (type1 :@: types1) (type2 :@: types2) var_env attr_env + = equiv (type1,types1) (type2,types2) var_env attr_env +/* equiv (TFA vars type1) type2 var_env attr_env + = equiv type1 type2 var_env attr_env + equiv type1 (TFA vars type2) var_env attr_env + = equiv type1 type2 var_env attr_env + equiv (TQV _) (TV _) var_env attr_env + = (True, var_env attr_env) +*/ + equiv type1 type2 var_env attr_env + = (False, var_env, attr_env) + +instance equiv (a,b) | equiv a & equiv b +where + equiv (x1,y1) (x2,y2) var_env attr_env + # (equi_x, var_env, attr_env) = equiv x1 x2 var_env attr_env + | equi_x + = equiv y1 y2 var_env attr_env + = (False, var_env, attr_env) + +instance equiv [a] | equiv a +where + equiv [x:xs] [y:ys] var_env attr_env + # (equi, var_env, attr_env) = equiv x y var_env attr_env + | equi + = equiv xs ys var_env attr_env + = (False, var_env, attr_env) + equiv [] [] var_env attr_env + = (True, var_env, attr_env) + equiv _ _ var_env attr_env + = (False, var_env, attr_env) +*/ + +class equiv a :: !a !a !*TypeHeaps -> (!Bool, !*TypeHeaps) + +instance equiv AType +where + equiv atype1 atype2 heaps=:{th_attrs} + # (ok, th_attrs) = equi_attrs atype1.at_attribute atype2.at_attribute th_attrs + | ok + = equiv atype1.at_type atype2.at_type { heaps & th_attrs = th_attrs } + = (False, { heaps & th_attrs = th_attrs }) + + where + equi_attrs attr=:(TA_Var {av_info_ptr}) (TA_TempVar av_number) attr_var_heap + #! av_info = sreadPtr av_info_ptr attr_var_heap + = case av_info of + AVI_Forward forw_var_number + -> (forw_var_number == av_number, attr_var_heap) + _ + -> (True, writePtr av_info_ptr (AVI_Forward av_number) attr_var_heap) + equi_attrs attr1 attr2 attr_env + = (attr1 == attr2, attr_env) + +equivTypeVars :: !TypeVar !TempVarId !*TypeHeaps -> (!Bool, !*TypeHeaps) +equivTypeVars {tv_info_ptr} var_number heaps=:{th_vars} + #! tv_info = sreadPtr tv_info_ptr th_vars + = case tv_info of + TVI_Forward forw_var_number + -> (forw_var_number == var_number, heaps) + _ + -> (True, { heaps & th_vars = writePtr tv_info_ptr (TVI_Forward var_number) heaps.th_vars }) + + +instance equiv Type +where + equiv (TV tv) (TempV var_number) heaps + = equivTypeVars tv var_number heaps + equiv (arg_type1 --> restype1) (arg_type2 --> restype2) heaps + = equiv (arg_type1,restype1) (arg_type2,restype2) heaps + equiv (TA tc1 types1) (TA tc2 types2) heaps + | tc1 == tc2 + = equiv types1 types2 heaps + = (False, heaps) + equiv (TB basic1) (TB basic2) heaps + = (basic1 == basic2, heaps) + equiv (CV tv :@: types1) (TempCV var_number :@: types2) heaps + # (equi_vars, heaps) = equivTypeVars tv var_number heaps + | equi_vars + = equiv types1 types2 heaps + = (False, heaps) +/* equiv (TFA vars type1) type2 heaps + = equiv type1 type2 heaps + equiv type1 (TFA vars type2) heaps + = equiv type1 type2 heaps + equiv (TQV _) (TV _) heaps + = (True, heaps) +*/ + equiv type1 type2 heaps + = (False, heaps) + +instance equiv (a,b) | equiv a & equiv b +where + equiv (x1,y1) (x2,y2) heaps + # (equi_x, heaps) = equiv x1 x2 heaps + | equi_x + = equiv y1 y2 heaps + = (False, heaps) + +instance equiv [a] | equiv a +where + equiv [x:xs] [y:ys] heaps + # (equi, heaps) = equiv x y heaps + | equi + = equiv xs ys heaps + = (False, heaps) + equiv [] [] heaps + = (True, heaps) + equiv _ _ heaps + = (False, heaps) + +equivalent :: !SymbolType !TempSymbolType !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps) +equivalent {st_args,st_result,st_context,st_attr_env} {tst_args,tst_result,tst_context,tst_attr_env,tst_lifted} defs attr_env heaps + #! nr_of_temp_attrs = size attr_env + # (ok, heaps) = equiv (drop tst_lifted st_args,st_result) (drop tst_lifted tst_args,tst_result) heaps + | ok + # (ok, heaps) = equivalent_list_of_contexts st_context tst_context defs heaps + | ok + # (ok, attr_env, attr_var_heap) = equivalent_environments st_attr_env (fill_environment tst_attr_env attr_env) heaps.th_attrs + = (ok, clear_environment tst_attr_env attr_env, { heaps & th_attrs = attr_var_heap }) + = (False, attr_env, heaps) + = (False, attr_env, heaps) +where + equivalent_list_of_contexts [] contexts defs heaps + = (True, heaps) + equivalent_list_of_contexts [tc : tcs] contexts defs heaps + # (ok, heaps) = contains_context tc contexts defs heaps + | ok + = equivalent_list_of_contexts tcs contexts defs heaps + = (False, heaps) + + contains_context tc1 [tc2 : tcs] defs heaps + # (ok, heaps) = equivalent_contexts tc1 tc2 defs heaps + | ok + = (True, heaps) + = contains_context tc1 tcs defs heaps + contains_context tc1 [] defs heaps + = (False, heaps) + + equivalent_contexts tc {tc_class,tc_types} defs heaps + | tc_class == tc.tc_class + = equiv tc.tc_types tc_types heaps + # {glob_object={ds_index},glob_module} = tc_class + #! class_def = defs.[glob_module].com_class_defs.[ds_index] + # {class_context,class_args} = class_def + | isEmpty class_context + = (False, heaps) + # th_vars = bind_class_args class_args tc_types heaps.th_vars + = equivalent_superclasses class_context tc defs { heaps & th_vars = th_vars } + where + bind_class_args [{tv_info_ptr} : vars] [type : types] type_var_heap + = bind_class_args vars types (writePtr tv_info_ptr (TVI_Type type) type_var_heap) + bind_class_args [] [] type_var_heap + = type_var_heap + + equivalent_superclasses [] tc defs heaps + = (False, heaps) + equivalent_superclasses [super_tc=:{tc_types} : tcs] tc defs heaps=:{th_vars} + # (tc_types, th_vars) = retrieve_types tc_types th_vars + (ok, heaps) = equivalent_contexts { super_tc & tc_types = tc_types } tc defs { heaps & th_vars = th_vars } + | ok + = (True, heaps) + = equivalent_superclasses tcs tc defs heaps + where + retrieve_types [TV {tv_info_ptr} : types] type_var_heap + #! (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + # (TVI_Type type) = tv_info + #! (types, type_var_heap) = retrieve_types types type_var_heap + = ([type : types], type_var_heap) + retrieve_types [type : types] type_var_heap + #! (types, type_var_heap) = retrieve_types types type_var_heap + = ([type : types], type_var_heap) + retrieve_types [] type_var_heap + = ([], type_var_heap) + + + fill_environment :: ![AttrCoercion] !*{! TypeAttribute} -> *{! TypeAttribute} + fill_environment [] attr_env + = attr_env + fill_environment [{ac_demanded,ac_offered} : coercions ] attr_env + #! offered = attr_env.[ac_demanded] + = fill_environment coercions { attr_env & [ac_demanded] = TA_List ac_offered offered } + + clear_environment :: ![AttrCoercion] !*{! TypeAttribute} -> *{! TypeAttribute} + clear_environment [] attr_env + = attr_env + clear_environment [{ac_demanded,ac_offered} : coercions ] attr_env + = clear_environment coercions { attr_env & [ac_demanded] = TA_None } + + equivalent_environments :: ![AttrInequality] !u:{!TypeAttribute} !v:AttrVarHeap -> (!Bool, !u:{!TypeAttribute}, !v:AttrVarHeap) + equivalent_environments [] attr_env attr_heap + = (True, attr_env, attr_heap) + equivalent_environments [{ai_demanded,ai_offered} : coercions ] attr_env attr_heap + #! av_info = sreadPtr ai_demanded.av_info_ptr attr_heap + # (AVI_Forward demanded_var_number) = av_info + #! av_info = sreadPtr ai_offered.av_info_ptr attr_heap + # (AVI_Forward offered_var_number) = av_info + #! offered_of_demanded = attr_env.[demanded_var_number] + # (succ, attr_env) = contains_coercion offered_var_number offered_of_demanded attr_env + | succ + = equivalent_environments coercions attr_env attr_heap + = (False, attr_env, attr_heap) + + contains_coercion :: !Int !TypeAttribute !u:{! TypeAttribute} -> (!Bool,!u:{!TypeAttribute}); + contains_coercion offered TA_None attr_env + = (False, attr_env) + contains_coercion offered (TA_List this_offered next_offered) attr_env + | offered == this_offered + = (True, attr_env) + #! offered_of_offered = attr_env.[this_offered] + # (succ, attr_env) = contains_coercion offered offered_of_offered attr_env + | succ + = (True, attr_env) + = contains_coercion offered next_offered attr_env + +instance <<< TypeContext +where + (<<<) file tc = file <<< tc.tc_class.glob_object.ds_ident <<< ' ' <<< tc.tc_types + +instance <<< AttrCoercion +where + (<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< " <= " <<< ac_offered + +instance <<< TempSymbolType +where + (<<<) file {tst_args, tst_result, tst_context, tst_attr_env } + | isEmpty tst_args + = file <<< tst_result <<< " | " <<< tst_context <<< " [" <<< tst_attr_env <<< ']' + = file <<< tst_args <<< " -> " <<< tst_result <<< " | " <<< tst_context <<< " [" <<< tst_attr_env <<< ']' + diff --git a/frontend/unitype.dcl b/frontend/unitype.dcl new file mode 100644 index 0000000..3769c19 --- /dev/null +++ b/frontend/unitype.dcl @@ -0,0 +1,48 @@ +definition module unitype + +import StdEnv +import syntax, analunitypes + +:: CoercionPosition = + { cp_expression :: !Expression + } + +AttrUni :== 0 +AttrMulti :== 1 +FirstAttrVar :== 2 + +instance toInt TypeAttribute + +:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique /* | CT_Existential !Int */ + +:: Coercions = { coer_demanded :: !.{! .CoercionTree}, coer_offered :: !.{! .CoercionTree }} + +isNonUnique :: !CoercionTree -> Bool +isUnique :: !CoercionTree -> Bool +// isExistential :: !CoercionTree -> Bool + +:: BOOLVECT :== Int + +BITINDEX temp_var_id :== temp_var_id >> 5 +BITNUMBER temp_var_id :== temp_var_id bitand 31 + +determineAttributeCoercions :: !AType !AType !Bool !CoercionPosition !u:{! Type} !*Coercions !{# CommonDefs } + !{# BOOLVECT } !*TypeDefInfos !*TypeHeaps !*ErrorAdmin + -> (!u:{! Type}, !*Coercions, !*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) + +:: AttributePartition :== {# Int} + +partitionateAttributes :: !{! CoercionTree} !{! *CoercionTree} -> (!AttributePartition, !{! CoercionTree}) + +newInequality :: !Int !Int !*Coercions -> *Coercions + +tryToMakeNonUnique :: !Int !*Coercions -> (!Bool, !*Coercions) + +tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions) + +uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin + +liftSubstitution :: !*{! Type} !{# CommonDefs } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos) + +instance <<< CoercionPosition + diff --git a/frontend/unitype.icl b/frontend/unitype.icl new file mode 100644 index 0000000..dce6a68 --- /dev/null +++ b/frontend/unitype.icl @@ -0,0 +1,795 @@ +implementation module unitype + +import StdEnv + +import syntax, analunitypes, type, utilities + +:: CoercionPosition = + { cp_expression :: !Expression + } + +AttrUni :== 0 +AttrMulti :== 1 +FirstAttrVar :== 2 + +:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique /* | CT_Existential !Int */ + +:: Coercions = { coer_demanded :: !.{! .CoercionTree}, coer_offered :: !.{! .CoercionTree }} + +:: AttributePartition :== {# Int} + +:: PartitioningInfo = + { pi_marks :: !.AttributePartition + , pi_next_num :: !Int + , pi_groups :: ![[Int]] + , pi_deps :: ![Int] + } + +uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin +uniquenessError position mess err=:{ea_file,ea_loc} + # ea_file = ea_file <<< "Uniqueness error " <<< hd ea_loc <<< ": \"" <<< position <<< '\"' <<< mess <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + +:: BOOLVECT :== Int + +BITINDEX temp_var_id :== temp_var_id >> 5 +BITNUMBER temp_var_id :== temp_var_id bitand 31 + +isPositive :: !TempVarId !{# BOOLVECT } -> Bool +isPositive var_id cons_vars + = cons_vars.[BITINDEX var_id] bitand (1 << BITNUMBER var_id) <> 0 + +determineAttributeCoercions :: !AType !AType !Bool !CoercionPosition !u:{! Type} !*Coercions !{# CommonDefs } + !{# BOOLVECT } !*TypeDefInfos !*TypeHeaps !*ErrorAdmin + -> (!u:{! Type}, !*Coercions, !*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) +determineAttributeCoercions off_type dem_type coercible position subst coercions defs cons_vars td_infos type_heaps error + # (exp_off_type, es) = expandType defs cons_vars off_type (subst, { es_type_heaps = type_heaps, es_td_infos = td_infos}) + (exp_dem_type, (subst, {es_td_infos,es_type_heaps})) = expandType defs cons_vars dem_type es + (ok, {crc_type_heaps, crc_coercions, crc_td_infos}) = coerce defs cons_vars exp_off_type exp_dem_type (if coercible PositiveSign TopSign) + { crc_type_heaps = es_type_heaps, crc_coercions = coercions, crc_td_infos = es_td_infos} + | ok + = (subst, crc_coercions, crc_td_infos, crc_type_heaps, error) +// ---> ("OK", off_type, exp_off_type, dem_type, exp_dem_type) + = (subst, crc_coercions, crc_td_infos, crc_type_heaps, uniquenessError position " invalid coercion" error) + ---> (off_type, exp_off_type, dem_type, exp_dem_type) + +NotChecked :== -1 +DummyAttrNumber :== -1 +:: AttributeGroups :== {! [Int]} + +partitionateAttributes :: !{! CoercionTree} !{! *CoercionTree} -> (!AttributePartition, !{! CoercionTree}) +partitionateAttributes coer_offered coer_demanded + #! max_attr_nr = size coer_offered + # partitioning_info = { pi_marks = createArray max_attr_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_groups = [] } + # {pi_marks,pi_groups} = partitionate_attributes FirstAttrVar max_attr_nr coer_offered partitioning_info + (nr_of_groups, groups) = reverse_and_length pi_groups 0 [] + partition = build_partition 0 groups pi_marks + # demanded = { CT_Empty \\ i <- [0 .. nr_of_groups - 1] } + = (partition, adjust_coercions 0 groups partition coer_offered coer_demanded demanded) +where + visit_attributes :: !CoercionTree !Int !Int !{! CoercionTree} !*PartitioningInfo -> *(!Int, !*PartitioningInfo) + visit_attributes (CT_Node attr left right) max_attr_nr min_dep coer_offered pi=:{pi_marks} + #! mark = pi_marks.[attr] + | mark == NotChecked + # (mark, pi) = partitionate_attribute attr max_attr_nr coer_offered pi + (min_dep, pi) = visit_attributes left max_attr_nr (min min_dep mark) coer_offered pi + = visit_attributes right max_attr_nr min_dep coer_offered pi + # (min_dep, pi) = visit_attributes left max_attr_nr (min min_dep mark) coer_offered pi + = visit_attributes right max_attr_nr min_dep coer_offered pi + visit_attributes tree max_attr_nr min_dep coer_offered pi + = (min_dep, pi) + + reverse_and_length :: ![a] !Int ![a] -> (!Int, ![a]) + reverse_and_length [] length list = (length, list) + reverse_and_length [ x : xs ] length list = reverse_and_length xs (inc length) [x : list] + + partitionate_attributes :: !Int !Int !{!CoercionTree} !*PartitioningInfo -> *PartitioningInfo + partitionate_attributes from_index max_attr_nr coer_offered pi=:{pi_marks} + | from_index == max_attr_nr + = pi + | pi_marks.[from_index] == NotChecked + # (_, pi) = partitionate_attribute from_index max_attr_nr coer_offered pi + = partitionate_attributes (inc from_index) max_attr_nr coer_offered pi + = partitionate_attributes (inc from_index) max_attr_nr coer_offered pi + + partitionate_attribute :: !Int !Int !{!CoercionTree} !*PartitioningInfo -> *(!Int, !*PartitioningInfo) + partitionate_attribute attr max_attr_nr coer_offered=:{ [attr] = off_attributes } pi=:{pi_next_num} + # (min_dep, pi) = visit_attributes off_attributes max_attr_nr max_attr_nr coer_offered (push_on_dep_stack attr pi) + = try_to_close_group attr pi_next_num min_dep max_attr_nr pi + where + push_on_dep_stack attr pi=:{pi_deps,pi_marks,pi_next_num} + = { pi & pi_deps = [attr : pi_deps], pi_marks = { pi_marks & [attr] = pi_next_num }, pi_next_num = inc pi_next_num} + + try_to_close_group attr attr_nr min_dep max_attr_nr pi=:{pi_marks, pi_deps, pi_groups} + | attr_nr <= min_dep + # (pi_deps, pi_marks, group) = close_group attr pi_deps pi_marks [] max_attr_nr + = (max_attr_nr, { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_groups = [group : pi_groups] }) + = (min_dep, pi) + where + close_group attr [d:ds] marks group max_attr_nr + # marks = { marks & [d] = max_attr_nr } + | d == attr + = (ds, marks, [d : group]) + = close_group attr ds marks [d : group] max_attr_nr + + build_partition group_nr [] partition + = partition + build_partition group_nr [group : groups] partition + = build_partition (inc group_nr) groups (build_partition_of_group group_nr group partition) + where + build_partition_of_group group_nr [attr : attrs] partition + = build_partition_of_group group_nr attrs { partition & [attr] = group_nr } + build_partition_of_group group_nr [] partition + = partition + + adjust_coercions group_index [group : groups] partition coer_offered coer_demanded demanded + # (combined_tree, coer_demanded) = combine_coercion_trees group_index group partition CT_Empty coer_offered coer_demanded + = adjust_coercions (inc group_index) groups partition coer_offered coer_demanded { demanded & [ group_index ] = combined_tree } + adjust_coercions group_index [] partition coer_offered coer_demanded demanded + = demanded + + combine_coercion_trees group_index [ attr : attrs ] partition merged_tree coer_offered coer_demanded + | isNonUnique coer_offered.[attr] + = (CT_NonUnique, coer_demanded) +/* | isExistential coer_offered.[attr] + = (CT_Existential DummyAttrNumber, coer_demanded) +*/ # (next_tree, coer_demanded) = replace coer_demanded attr CT_Empty + | isUnique next_tree + = (CT_Unique, coer_demanded) + # merged_tree = rebuild_tree group_index partition next_tree merged_tree + = combine_coercion_trees group_index attrs partition merged_tree coer_offered coer_demanded + combine_coercion_trees group_index [ ] partition merged_tree coer_offered coer_demanded + = (merged_tree, coer_demanded) + + + rebuild_tree :: !Index !AttributePartition !*CoercionTree !*CoercionTree -> *CoercionTree + rebuild_tree group_index partition (CT_Node attr left right) tree + # tree = rebuild_tree group_index partition left tree + tree = rebuild_tree group_index partition right tree + #! attr_nr = partition.[attr] + | attr_nr == group_index + = tree + # { tree } = insert partition.[attr] tree + = tree + where + insert :: !Int !*CoercionTree -> *CoercionTreeRecord + insert new_attr CT_Empty + = { tree = CT_Node new_attr CT_Empty CT_Empty } + insert new_attr (CT_Node this_attr ct_less ct_greater) + | new_attr < this_attr + # { tree } = insert new_attr ct_less + = { tree = CT_Node this_attr tree ct_greater } + | new_attr > this_attr + # { tree } = insert new_attr ct_greater + = { tree = CT_Node this_attr ct_less tree } + = { tree = CT_Node this_attr ct_less ct_greater } + rebuild_tree group_index partition empty_tree tree + = tree + +:: CoercionTreeRecord = { tree :: !.CoercionTree } + + +liftSubstitution :: !*{! Type} !{# CommonDefs } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos) +liftSubstitution subst modules attr_store type_var_heap td_infos + # ls = { ls_next_attr = attr_store, ls_td_infos = td_infos, ls_type_var_heap = type_var_heap} + = lift_substitution 0 modules subst ls +where + lift_substitution var_index modules subst ls + | var_index < size subst + #! type = subst.[var_index] + # (type, _, _, subst, ls) = lift modules type subst ls + = lift_substitution (inc var_index) modules { subst & [var_index] = type } ls + = (subst, ls.ls_next_attr, ls.ls_type_var_heap, ls.ls_td_infos) + +adjustSignClass :: !SignClassification !Int -> SignClassification +adjustSignClass {sc_pos_vect,sc_neg_vect} arity + = { sc_pos_vect = sc_pos_vect >> arity, sc_neg_vect = sc_neg_vect >> arity } + +// adjustPropClass :: !PropClassification !Int -> PropClassification +adjustPropClass prop_class arity :== prop_class >> arity + +:: LiftState = + { ls_next_attr :: !Int + , ls_type_var_heap :: !.TypeVarHeap + , ls_td_infos :: !.TypeDefInfos + } + + +liftTempTypeVariable :: !{# CommonDefs } !TempVarId !*{! Type} !*LiftState + -> (!Type, !SignClassification, !PropClassification, !*{! Type}, !*LiftState) +liftTempTypeVariable modules tv_number subst ls + #! type = subst.[tv_number] + = case type of + TE -> (TempV tv_number, TopSignClass, PropClass, subst, ls) + _ -> lift modules type subst ls + +class lift a :: !{# CommonDefs } !a !*{! Type} !*LiftState + -> (!a, !SignClassification, !PropClassification, !*{! Type}, !*LiftState) + + +instance lift Type +where + lift modules (TempV tv_number) subst ls + = liftTempTypeVariable modules tv_number subst ls + lift modules (arg_type --> res_type) subst ls + # (arg_type, _, _, subst, ls) = lift modules arg_type subst ls + (res_type, _, _, subst, ls) = lift modules res_type subst ls + = (arg_type --> res_type, BottomSignClass, NoPropClass, subst, ls) + lift modules (TA cons_id=:{type_index={glob_object,glob_module},type_arity} cons_args) subst ls + # (cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_args subst ls + (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos + = (TA { cons_id & type_prop = type_prop } cons_args, + adjustSignClass type_prop.tsp_sign type_arity, adjustPropClass type_prop.tsp_propagation type_arity, + subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + lift modules (TempCV temp_var :@: types) subst ls + # (type, sign_class, prop_class, subst, ls) = liftTempTypeVariable modules temp_var subst ls + (types, _, _, subst, ls) = lift_list modules types subst ls + = case type of + TA type_cons cons_args + # nr_of_new_args = length types + -> (TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types), + adjustSignClass sign_class nr_of_new_args, adjustPropClass prop_class nr_of_new_args, subst, ls) + TempV tv_number + -> (TempCV tv_number :@: types, TopSignClass, PropClass, subst, ls) + cons_var :@: cv_types + -> (cons_var :@: (cv_types ++ types), TopSignClass, PropClass, subst, ls) + lift modules type subst ls + = (type, BottomSignClass, NoPropClass, subst, ls) + +instance lift AType +where + lift modules attr_type=:{at_attribute,at_type} subst ls + # (at_type, sign_class, prop_class, subst, ls) = lift modules at_type subst ls + | type_is_non_coercible at_type + = ({attr_type & at_type = at_type}, sign_class, prop_class, subst, ls) + = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, + sign_class, prop_class, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + where + type_is_non_coercible (TempV _) + = True + type_is_non_coercible (TempQV _) + = True + type_is_non_coercible (_ --> _) + = True + type_is_non_coercible (_ :@: _) + = True + type_is_non_coercible _ + = False + + +lift_list :: !{#CommonDefs} ![a] !*{!Type} !*LiftState + -> (![a], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) | lift a +lift_list modules [] subst ls + = ([], [], [], subst, ls) +lift_list modules [t:ts] subst ls + # (t, sign_class, prop_class, subst, ls) = lift modules t subst ls + (ts, sign_classes, prop_classes, subst, ls) = lift_list modules ts subst ls + = ([t:ts], [sign_class : sign_classes], [prop_class : prop_classes], subst, ls) + +:: ExpansionState = + { es_type_heaps :: !.TypeHeaps + , es_td_infos :: !.TypeDefInfos + } + +class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState)) + +instance expandType AType +where + expandType modules cons_vars attr_type=:{at_type, at_attribute} (subst, es=:{es_type_heaps}) + # (at_attribute, th_attrs) = expand_attribute at_attribute es_type_heaps.th_attrs + (at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + = ({ attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) + where + expand_attribute (TA_Var {av_info_ptr}) attr_var_heap + # (AVI_Attr attr, attr_var_heap) = readPtr av_info_ptr attr_var_heap + = (attr, attr_var_heap) + expand_attribute attr attr_var_heap + = (attr, attr_var_heap) + +expandTempTypeVariable :: !TempVarId !*(!u:{! Type}, !*ExpansionState) -> (!Type, !*(!u:{! Type}, !*ExpansionState)) +expandTempTypeVariable tv_number (subst, es) + #! type = subst.[tv_number] + = case type of + TE -> (TempV tv_number, (subst, es)) + _ -> (type, (subst, es)) + +instance expandType Type +where + expandType modules cons_vars (TempV tv_number) es + = expandTempTypeVariable tv_number es + expandType modules cons_vars (TV {tv_info_ptr}) (subst, es=:{es_type_heaps}) + # (TVI_Type type, th_vars) = readPtr tv_info_ptr es_type_heaps.th_vars + = (type, (subst, {es & es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + expandType modules cons_vars (arg_type --> res_type) es + # (arg_type, es) = expandType modules cons_vars arg_type es + (res_type, es) = expandType modules cons_vars res_type es + = (arg_type --> res_type, es) + expandType modules cons_vars (TA cons_id=:{type_index={glob_object,glob_module}} cons_args) es + # (cons_args, sign_classes, prop_classes, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args es + (type_prop, th_vars, es_td_infos) + = typeProperties glob_object glob_module sign_classes prop_classes modules es_type_heaps.th_vars es_td_infos + = (TA { cons_id & type_prop = type_prop } cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + where + expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] !*(!u:{!Type}, !*ExpansionState) + -> (![AType], ![SignClassification], ![PropClassification], !*(!u:{!Type}, !*ExpansionState)) + expand_type_list modules cons_vars [] es + = ([], [], [], es) + expand_type_list modules cons_vars [t:ts] es + # (t, es) = expandType modules cons_vars t es + (ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts es + = case t.at_type of + TA {type_arity,type_prop} _ + -> ([t:ts], [adjustSignClass type_prop.tsp_sign type_arity : sign_classes], + [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes], es) + TempV tmp_var_id + | isPositive tmp_var_id cons_vars + -> ([t:ts], [PosSignClass : sign_classes], [PropClass : prop_classes], es) + -> ([t:ts], [TopSignClass : sign_classes], [NoPropClass : prop_classes], es) + _ + -> ([t:ts], [TopSignClass : sign_classes], [PropClass : prop_classes], es) + + expandType modules cons_vars (TempCV temp_var :@: types) es + # (type, es) = expandTempTypeVariable temp_var es + (types, es) = expandType modules cons_vars types es + = case type of + TA type_cons=:{type_arity} cons_args + # nr_of_new_args = length types + -> (TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) + TempV tv_number + -> (TempCV tv_number :@: types, es) + cons_var :@: cv_types + -> (cons_var :@: (cv_types ++ types), es) + expandType modules cons_vars type es + = (type, es) + +instance expandType [a] | expandType a +where + expandType modules cons_vars l es = mapSt (expandType modules cons_vars) l es + +instance toInt TypeAttribute +where + toInt TA_Unique = AttrUni + toInt (TA_TempVar av_number) = av_number +// toInt (TA_TempExVar av_number) = av_number + toInt TA_Multi = AttrMulti + toInt TA_None = AttrMulti + + +instance * Bool +where + (*) b1 b2 = b1 && b2 || not b1 && not b2 + +instance * Sign +where + (*) sign1 sign2 + = { pos_sign = sign1.pos_sign * sign2.pos_sign || sign1.neg_sign * sign2.neg_sign, + neg_sign = sign1.pos_sign * sign2.neg_sign || sign1.neg_sign * sign2.pos_sign } + +:: CoercionState = + { crc_type_heaps :: !.TypeHeaps + , crc_coercions :: !.Coercions + , crc_td_infos :: !.TypeDefInfos + } + + +class coerce a :: !{# CommonDefs} !{# BOOLVECT} !a !a !Sign !*CoercionState -> (!Bool, !*CoercionState) + +/* + +'coerceAttributes offered_attribute offered_attribute sign coercions' coerce offered_attribute to +offered_attribute according to sign. Failure is indicated by returning False as a result. + +*/ + +coerceAttributes TA_Unique dem_attr {neg_sign} coercions + | not neg_sign + = (True, coercions) +coerceAttributes off_attr TA_Unique {pos_sign} coercions + | not pos_sign + = (True, coercions) +coerceAttributes (TA_TempVar av_number) dem_attr {neg_sign} coercions=:{coer_demanded} + | not neg_sign && isUnique coer_demanded.[av_number] + = (True, coercions) +coerceAttributes off_attr (TA_TempVar av_number) {pos_sign} coercions=:{coer_demanded} + | not pos_sign && isUnique coer_demanded.[av_number] + = (True, coercions) +/* +coerceAttributes off_attr TA_Multi {neg_sign} coercions + | not neg_sign + = (True, coercions) +coerceAttributes TA_Multi dem_attr {pos_sign} coercions + | not pos_sign + = (True, coercions) +*/ +coerceAttributes (TA_TempVar av_number1) (TA_TempVar av_number2) {pos_sign,neg_sign} coercions + | av_number1 == av_number2 + = (True, coercions) + | pos_sign + | neg_sign + # (ok, coercions) = new_inequality av_number1 av_number2 coercions + | ok + = new_inequality av_number2 av_number1 coercions + = (False, coercions) + = new_inequality av_number1 av_number2 coercions + | neg_sign + = new_inequality av_number2 av_number1 coercions + = (True, coercions) +where + new_inequality :: !Int !Int !*Coercions -> (!Bool, !*Coercions) + new_inequality off_attr dem_attr coercions=:{coer_demanded, coer_offered} +/* | isExistential coer_offered.[off_attr] + #! off_attr_tree = coer_offered.[off_attr] + = coerce_to_existential_attribute off_attr_tree dem_attr coercions + | isExistential coer_demanded.[dem_attr] + #! dem_attr_tree = coer_demanded.[off_attr] + = coerce_to_existential_attribute dem_attr_tree off_attr coercions +*/ | isNonUnique coer_offered.[off_attr] + | isUnique coer_demanded.[dem_attr] + = (False, coercions) + = (True, makeNonUnique dem_attr coercions) + | isUnique coer_demanded.[dem_attr] + = (True, makeUnique off_attr coercions) + | isNonUnique coer_offered.[dem_attr] || isUnique coer_demanded.[off_attr] + = (True, coercions) + = (True, newInequality off_attr dem_attr coercions) +/* + coerce_to_existential_attribute (CT_Existential exi_number) attr_number coercions + = coerceToExistentialAttribute exi_number attr_number coercions +*/ + +coerceAttributes TA_Unique (TA_TempVar av_number) {neg_sign} coercions=:{coer_offered} + | isNonUnique coer_offered.[av_number] + = (False, coercions) + = (True, makeUnique av_number coercions)// ---> "*** 1 ***" +coerceAttributes (TA_TempVar av_number) TA_Unique {pos_sign} coercions=:{coer_offered} + | isNonUnique coer_offered.[av_number] + = (False, coercions) + = (True, makeUnique av_number coercions)// ---> "*** 2 ***" +coerceAttributes TA_Multi (TA_TempVar av_number) {pos_sign} coercions=:{coer_demanded} + | pos_sign + | isUnique coer_demanded.[av_number] + = (False, coercions) + = (True, makeNonUnique av_number coercions) + = (True, coercions) +coerceAttributes (TA_TempVar av_number) TA_Multi {neg_sign} coercions=:{coer_demanded} + | neg_sign + | isUnique coer_demanded.[av_number] + = (False, coercions) + = (True, makeNonUnique av_number coercions) + = (True, coercions) +coerceAttributes TA_Unique TA_Multi _ coercions + = (False, coercions) +coerceAttributes off_attr dem_attr {pos_sign,neg_sign} coercions +/* + | pos_sign || neg_sign // ---> ("coerceAttributes", off_attr, dem_attr) + = case off_attr of + TA_TempExVar eav_number + -> case dem_attr of + TA_TempVar av_number + -> coerceToExistentialAttribute eav_number av_number coercions + TA_TempExVar eav_number2 + -> (eav_number == eav_number2, coercions) + _ + -> (False, coercions) + + TA_TempVar av_number + -> case dem_attr of + TA_TempExVar eav_number + -> coerceToExistentialAttribute eav_number av_number coercions + _ + -> (True, coercions) + _ + -> case dem_attr of + TA_TempExVar eav_number + -> (False, coercions) + _ + -> (True, coercions) +*/ + = (True, coercions) + +/* +coerceToExistentialAttribute exi_attr_number attr_number coercions=:{coer_demanded, coer_offered} + #! dem_attr_tree = coer_demanded.[attr_number] + off_attr_tree = coer_offered.[attr_number] + = case dem_attr_tree ---> ("coerceToExistentialAttribute", exi_attr_number, attr_number, dem_attr_tree, off_attr_tree) of + CT_Unique + -> (False, coercions) + CT_Existential exi_attr_number2 + -> (exi_attr_number == exi_attr_number2, coercions) + _ + -> case off_attr_tree of + CT_NonUnique + -> (False, coercions) + _ + -> (True, make_attr_existential attr_number exi_attr_number coercions) + +where + make_attr_existential :: !Int !Int !*Coercions -> *Coercions + make_attr_existential attr exi_attr {coer_demanded, coer_offered} + # (dem_heaps_and_coercions, coer_demanded) = replace coer_demanded attr (CT_Existential exi_attr) + (off_heaps_and_coercions, coer_offered) = replace coer_offered attr (CT_Existential exi_attr) + = make_existential off_heaps_and_coercions exi_attr ( + make_existential dem_heaps_and_coercions exi_attr {coer_offered = coer_offered, coer_demanded = coer_demanded}) + + make_existential (CT_Node this_attr ct_less ct_greater) exi_attr coercions + # coercions = make_attr_existential this_attr exi_attr coercions + coercions = make_existential ct_less exi_attr coercions + coercions = make_existential ct_greater exi_attr coercions + = coercions + make_existential tree exi_attr coercions + = coercions +*/ +newInequality :: !Int !Int !*Coercions -> *Coercions +newInequality off_attr dem_attr coercions=:{coer_demanded, coer_offered} + # (dem_coercions, coer_demanded) = replace coer_demanded off_attr CT_Empty + (succ, dem_coercions) = insert dem_attr dem_coercions + coer_demanded = { coer_demanded & [off_attr] = dem_coercions } + | succ + # (off_coercions, coer_offered) = replace coer_offered dem_attr CT_Empty + (succ, off_coercions) = insert off_attr off_coercions + coer_offered = { coer_offered & [dem_attr] = off_coercions } + = {coer_demanded = coer_demanded, coer_offered = coer_offered} + = {coer_demanded = coer_demanded, coer_offered = coer_offered} +where + + insert :: !Int !*CoercionTree -> (!Bool, !*CoercionTree) + insert new_attr CT_Empty + = (True, CT_Node new_attr CT_Empty CT_Empty) + insert new_attr (CT_Node this_attr ct_less ct_greater) + | new_attr < this_attr + # (succ, ct_less) = insert new_attr ct_less + = (succ, CT_Node this_attr ct_less ct_greater) + | new_attr > this_attr + # (succ, ct_greater) = insert new_attr ct_greater + = (succ, CT_Node this_attr ct_less ct_greater) + = (False, CT_Node this_attr ct_less ct_greater) + +isNonUnique :: !CoercionTree -> Bool +isNonUnique CT_NonUnique = True +isNonUnique _ = False + +isUnique :: !CoercionTree -> Bool +isUnique CT_Unique = True +isUnique _ = False + +/* +isExistential :: !CoercionTree -> Bool +isExistential (CT_Existential exi_number) = True +isExistential attr_tree = False +*/ + +makeUnique :: !Int !*Coercions -> *Coercions +makeUnique attr {coer_demanded, coer_offered} + # (off_coercions, coer_offered) = replace coer_offered attr CT_Empty + coer_demanded = { coer_demanded & [attr] = CT_Unique } + = make_unique off_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded}// ---> ("makeUnique :", attr) +where + make_unique (CT_Node this_attr ct_less ct_greater) coercions + # coercions = makeUnique this_attr coercions + coercions = make_unique ct_less coercions + coercions = make_unique ct_greater coercions + = coercions + make_unique tree coercions + = coercions + +tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions) +tryToMakeUnique attr coercions=:{coer_offered} + | isNonUnique coer_offered.[attr] // || isExistential coer_offered.[attr] + = (False, coercions) + = (True, makeUnique attr coercions) + +makeNonUnique :: !Int !*Coercions -> *Coercions +makeNonUnique attr {coer_demanded, coer_offered} + # (dem_coercions, coer_demanded) = replace coer_demanded attr CT_Empty + coer_offered = { coer_offered & [attr] = CT_NonUnique } + = make_non_unique dem_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded} +where + make_non_unique (CT_Node this_attr ct_less ct_greater) coercions + # coercions = makeNonUnique this_attr coercions + coercions = make_non_unique ct_less coercions + coercions = make_non_unique ct_greater coercions + = coercions + make_non_unique tree coercions + = coercions + +tryToMakeNonUnique :: !Int !*Coercions -> (!Bool, !*Coercions) +tryToMakeNonUnique attr coercions=:{coer_demanded} + | isUnique coer_demanded.[attr] // || isExistential coer_demanded.[attr] + = (False, coercions) + = (True, makeNonUnique attr coercions) +// ---> ("tryToMakeNonUnique", attr) + +instance coerce AType +where + coerce defs cons_vars at1=:{at_attribute=attr1,at_type=type1} at2=:{at_attribute=attr2,at_type=type2} sign cs=:{crc_coercions} + # sign = adjust_sign sign type1 cons_vars + (succ, crc_coercions) = coerceAttributes attr1 attr2 sign crc_coercions + | succ + # (succ, cs) = coerce defs cons_vars type1 type2 sign { cs & crc_coercions = crc_coercions } + | succ + # (succ1, crc_coercions) = add_propagation_inequalities attr1 type1 cs.crc_coercions + (succ2, crc_coercions) = add_propagation_inequalities attr2 type2 crc_coercions + = (succ1 && succ2, { cs & crc_coercions = crc_coercions }) + = (False, cs) + = (False, { cs & crc_coercions = crc_coercions }) + // ---> ("coerceAttributes", attr1, attr2, sign) + + where + + adjust_sign :: !Sign !Type {# BOOLVECT} -> Sign + adjust_sign sign (TempV _) cons_vars + = TopSign + adjust_sign sign (TempQV _) cons_vars + = TopSign + adjust_sign sign (_ --> _) cons_vars + = TopSign + adjust_sign sign (TempCV tmp_var_id :@: _) cons_vars + | isPositive tmp_var_id cons_vars + = sign + = TopSign + adjust_sign sign (_ :@: _) cons_vars + = TopSign + adjust_sign sign (TA {type_name, type_prop={tsp_coercible}} _) cons_vars + | tsp_coercible + = sign + = TopSign +// ---> ("adjust_sign to top", type_name) + adjust_sign sign _ cons_vars + = sign + + add_propagation_inequalities attr (TA {type_prop={tsp_propagation}} cons_args) coercions + = add_inequalities tsp_propagation attr cons_args coercions + where + add_inequalities prop_class attr _ coercions + = (True, coercions) + + add_inequalities prop_class attr [] coercions + = (True, coercions) + add_inequalities prop_class attr [{at_attribute} : args] coercions + | (prop_class bitand 1) == 0 // || is_existential_attribute at_attribute coercions + = add_inequalities (prop_class >> 1) attr args coercions + # (succ, coercions) = coerceAttributes attr at_attribute PositiveSign coercions + | succ + = add_inequalities (prop_class >> 1) attr args coercions + = (False, coercions) + ---> ("add_propagation_inequalities", attr, at_attribute) +/* + is_existential_attribute (TA_TempExVar eav_number) coercions + = True + is_existential_attribute (TA_TempVar eav_number) {coer_offered} + = isExistential coer_offered.[eav_number] + is_existential_attribute _ {coer_offered} + = False +*/ + add_propagation_inequalities attr type coercions + = (True, coercions) + +coercionsOfTypeList defs cons_vars [t1 : ts1] [t2 : ts2] sign_class type_index sign cs + # arg_sign = sign * signClassToSign sign_class type_index + (ok, cs) = coerce defs cons_vars t1 t2 arg_sign cs + | ok + = coercionsOfTypeList defs cons_vars ts1 ts2 sign_class (inc type_index) sign cs + = (False, cs) +coercionsOfTypeList defs cons_vars [] [] _ _ _ cs + = (True, cs) + +isSynonymType (SynType _) + = True +isSynonymType type_rhs + = False + +tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module}} type_args type_heaps td_infos + # {td_rhs,td_args} = defs.[glob_module].com_type_defs.[glob_object] + | isSynonymType td_rhs + # (SynType {at_type}) = td_rhs + type_heaps = fold2St bind_type_and_attr td_args type_args type_heaps + (expanded_type, (_, {es_type_heaps, es_td_infos})) + = expandType defs cons_vars at_type ({}, { es_type_heaps = type_heaps, es_td_infos = td_infos }) + = (True, expanded_type, es_type_heaps, es_td_infos) + = (False, TA cons_id type_args, type_heaps, td_infos) +where + bind_type_and_attr {atv_attribute = TA_Var {av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute,at_type} {th_vars,th_attrs} + = { th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } + bind_type_and_attr {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } + + +instance coerce Type +where + coerce defs cons_vars (TA dem_cons dem_args) (TA off_cons off_args) sign cs=:{crc_type_heaps, crc_td_infos} + | dem_cons == off_cons + = coercionsOfTypeList defs cons_vars dem_args off_args dem_cons.type_prop.tsp_sign 0 sign cs + # (_, dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args crc_type_heaps crc_td_infos + (_, off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args crc_type_heaps crc_td_infos + = coerce defs cons_vars dem_type off_type sign { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } + coerce defs cons_vars (TA dem_cons dem_args) off_type sign cs=:{crc_type_heaps, crc_td_infos} + # (succ, dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args crc_type_heaps crc_td_infos + | succ + = coerce defs cons_vars dem_type off_type sign { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } + = (True, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) + coerce defs cons_vars dem_type (TA off_cons off_args) sign cs=:{crc_type_heaps, crc_td_infos} + # (succ, off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args crc_type_heaps crc_td_infos + | succ + = coerce defs cons_vars dem_type off_type sign { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } + = (True, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) + coerce defs cons_vars (arg_type1 --> res_type1) (arg_type2 --> res_type2) sign cs + # (ok, cs) = coerce defs cons_vars arg_type1 arg_type2 (NegativeSign * sign) cs + | ok + = coerce defs cons_vars res_type1 res_type2 sign cs + = (False, cs) + coerce defs cons_vars (cons_var :@: types1) (_ :@: types2) sign cs + = coercions_of_type_list defs cons_vars (determine_sign_of_arg_types cons_var cons_vars) types1 types2 cs + where + determine_sign_of_arg_types (TempCV tmp_var_id) cons_vars + | isPositive tmp_var_id cons_vars + = PositiveSign + = TopSign + determine_sign_of_arg_types _ cons_vars + = TopSign + + coercions_of_type_list :: !{# CommonDefs} !{# BOOLVECT} !Sign ![a] ![a] !*CoercionState -> (!Bool,!*CoercionState) | coerce a + coercions_of_type_list defs cons_vars sign [t1 : ts1] [t2 : ts2] cs + # (ok, cs) = coerce defs cons_vars t1 t2 sign cs + | ok + = coercions_of_type_list defs cons_vars sign ts1 ts2 cs + = (False, cs) + coercions_of_type_list defs cons_vars sign [] [] cs + = (True, cs) + coerce defs cons_vars _ _ sign cs + = (True, cs) + +AttrRestricted :== 0 + +instance <<< CoercionTree +where + (<<<) file (CT_Node attr left right) = file <<< left <<< ' ' <<< attr <<< ' ' <<< right + (<<<) file CT_Unique = file <<< "CT_Unique" + (<<<) file CT_NonUnique = file <<< "CT_NonUnique" +// (<<<) file (CT_Existential int) = file <<< "CT_Existential:" <<< int + (<<<) file CT_Empty = file <<< "##" + +instance <<< CoercionPosition +where + (<<<) file {cp_expression} = show_expression file cp_expression + + where + show_expression file (Var {var_name}) + = file <<< var_name + show_expression file (FreeVar {fv_name}) + = file <<< fv_name + show_expression file (App {app_symb={symb_name}}) + = file <<< symb_name + show_expression file (fun @ fun_args) + = show_expression file fun + show_expression file (Case {case_ident}) + = case case_ident of + Yes {id_name} + # (line, pos) = get_line_and_col "_c" id_name + -> file <<< "case [" <<< line <<< ',' <<< pos <<< ']' + No + -> file <<< "(case ... )" + show_expression file (Selection _ expr selectors) + = file <<< "selection" + show_expression file (Update expr1 selectors expr2) + = file <<< "update" + show_expression file (TupleSelect {ds_arity} elem_nr expr) + = file <<< "argument" <<< (elem_nr + 1) <<< " of " <<< ds_arity <<< "-tuple" + show_expression file (BasicExpr bv _) + = file <<< bv + show_expression file (MatchExpr _ _ expr) + = file <<< "match expression" + show_expression file _ + = file + + + get_line_and_col prefix ident + # ident = ident % (0, size prefix - 1) + del_pos = find_delimiter '_' 0 ident + = (toInt (ident % (0, del_pos - 1)), toInt (ident % (del_pos + 1, size ident - 1))) + where + find_delimiter del_char del_pos ident + | del_char == ident.[del_pos] + = del_pos + = find_delimiter del_char (inc del_pos) ident + diff --git a/frontend/utilities.dcl b/frontend/utilities.dcl new file mode 100644 index 0000000..434e7c7 --- /dev/null +++ b/frontend/utilities.dcl @@ -0,0 +1,92 @@ +definition module utilities + +from StdString import String +from StdEnv import Eq, not, Ord, IncDec +import StdMisc, general +/* + For Strings +*/ + +stringToCharList :: !String -> [Char] +charListToString :: ![Char] -> String +revCharListToString :: !Int ![Char] -> String + +isUpperCaseName :: ! String -> Bool +isLowerCaseName :: ! String -> Bool +isFunnyIdName :: ! String -> Bool +isSpecialChar :: ! Char -> Bool + +/* + For Lists +*/ + +mapSt :: !(.a -> (.st -> (.c,.st))) ![.a] !.st -> (![.c],!.st) + +app2St :: !(!.(.a -> .(.st -> (.c,.st))),!.(.e -> .(.st -> (.f,.st)))) !(.a,.e) !.st -> (!(.c,.f),!.st) + +mapAppendSt :: !(.a -> .(.b -> (.c,.b))) ![.a] !u:[.c] !.b -> !(!u:[.c],!.b) + +strictMap :: !(.a -> .b) ![.a] -> [.b] + +strictMapAppend :: !(.a -> .b) ![.a] !u:[.b] -> v:[.b], [u <= v] + +mapAppend :: !(.a -> .b) ![.a] !u:[.b] -> u:[.b] + +//zip2Append :: [.a] [.b] u:[w:(.a,.b)] -> v:[x:(.a,.b)], [w <= x, u <= v] + +eqMerge :: ![a] ![a] -> [a] | Eq a + +// foldl2 :: !(.c -> .(.a -> .(.b -> .c))) !.c ![.a] ![.b] -> .c +foldl2 op r l1 l2 + :== foldl2 r l1 l2 +where + foldl2 r [x : xs] [y : ys] + = foldl2 (op r x y) xs ys + foldl2 r [] [] + = r +//foldr2 :: !(.a -> .(.b -> .(.c -> .c))) !.c ![.a] ![.b] -> .c + +foldr2 op r l1 l2 + :== foldr2 r l1 l2 +where + foldr2 r [x : xs] [y : ys] + = op x y (foldr2 r xs ys) + foldr2 r [] [] + = r + +fold2St op l1 l2 st + :== fold_st2 l1 l2 st +where + fold_st2 [x : xs] [y : ys] st + = op x y (fold_st2 xs ys st) + fold_st2 [] [] st + = st + fold_st2 [] ys st + = abort ("fold_st2: second argument list contains more elements" ---> ys) + fold_st2 xs [] st + = abort ("fold_st2: first argument list contains more elements" ---> xs) + +// foldSt :: !(.a -> .(.st -> .st)) ![.a] !.st -> .st +foldSt op l st :== fold_st l st + where + fold_st [] st = st + fold_st [a:x] st = fold_st x (op a st) + +iFoldSt op fr to st :== i_fold_st fr to st + where + i_fold_st fr to st + | fr >= to + = st + = i_fold_st (inc fr) to (op fr st) + +iterateSt op st :== iterate_st op st + where + iterate_st op st + # (continue, st) = op (False, st) + | continue + = iterate_st op st + = st + +revAppend :: ![a] ![a] -> [a] // Reverse the list using the second argument as accumulator. +revMap :: !(.a -> .b) ![.a] !u:[.b] -> u:[.b] + diff --git a/frontend/utilities.icl b/frontend/utilities.icl new file mode 100644 index 0000000..51e11ce --- /dev/null +++ b/frontend/utilities.icl @@ -0,0 +1,200 @@ +implementation module utilities + +import StdEnv, general + + +/* + Utility routines. +*/ +StringToCharList` :: !String !Int !Int -> [Char] +StringToCharList` string 0 index + = [] +StringToCharList` string length index + = [string.[index] : StringToCharList` string (dec length) (inc index)] + +stringToCharList :: !String -> [Char] +stringToCharList string = StringToCharList` string (size string) 0 + +charListToString :: ![Char] -> String +charListToString [hd:tl] = toString hd +++ charListToString tl +charListToString [] = "" + +revCharListToString :: !Int ![Char] -> String +revCharListToString max_index l + # string = createArray (max_index + 1) '\0' + = fill_string max_index l string +where + fill_string :: !Int ![Char] !*String -> *String + fill_string n [ char : rest] string + = fill_string (n - 1) rest { string & [n] = char } + fill_string (-1) [] string + = string + +/* +revCharListToString [hd:tl] = revCharListToString tl +++ toString hd +revCharListToString [] = "" +*/ + +isUpperCaseName :: ! String -> Bool +isUpperCaseName id + = ('A' <= c && c <= 'Z') || c == '_' + where + c =: id.[0] + +isLowerCaseName :: ! String -> Bool +isLowerCaseName id + = 'a' <= c && c <= 'z' + where + c =: id.[0] + +isFunnyIdName :: ! String -> Bool +isFunnyIdName id + = isSpecialChar id.[0] + +isSpecialChar :: !Char -> Bool +isSpecialChar '~' = True +isSpecialChar '@' = True +isSpecialChar '#' = True +isSpecialChar '$' = True +isSpecialChar '%' = True +isSpecialChar '^' = True +isSpecialChar '?' = True +isSpecialChar '!' = True +isSpecialChar '+' = True +isSpecialChar '-' = True +isSpecialChar '*' = True +isSpecialChar '<' = True +isSpecialChar '>' = True +isSpecialChar '\\' = True +isSpecialChar '/' = True +isSpecialChar '|' = True +isSpecialChar '&' = True +isSpecialChar '=' = True +isSpecialChar ':' = True +isSpecialChar '.' = True +isSpecialChar c = False + +strictMap :: !(.a -> .b) ![.a] -> [.b] +strictMap f [x : xs] + #! head = f x + tail = strictMap f xs + = [head : tail] +strictMap f xs + = [] + +strictMapAppend :: !(.a -> .b) ![.a] !u:[.b] -> v:[.b], [u <= v] +strictMapAppend f [x : xs] tail + #! x = f x + xs = strictMapAppend f xs tail + = [x : xs] +strictMapAppend f [] tail + = tail + +mapAppend :: !(.a -> .b) ![.a] !u:[.b] -> u:[.b] +mapAppend f [x : xs] tail + # x = f x + xs = mapAppend f xs tail + = [x : xs] +mapAppend f [] tail + = tail + + +mapAppendSt :: !(.a -> .(.b -> (.c,.b))) ![.a] !u:[.c] !.b -> !(!u:[.c],!.b) +mapAppendSt f [x : xs] tail s + # (x, s) = f x s + (xs, s) = mapAppendSt f xs tail s + = ([x : xs], s) +mapAppendSt f [] tail s + = (tail, s) + +mapSt :: !(.a -> (.st -> (.c,.st))) ![.a] !.st -> (![.c],!.st) +mapSt f [x : xs] s + # (x, s) = f x s + (xs, s) = mapSt f xs s + = ([x : xs], s) +mapSt f [] s + = ([], s) + +app2St :: !(!.(.a -> .(.st -> (.c,.st))),!.(.e -> .(.st -> (.f,.st)))) !(.a,.e) !.st -> (!(.c,.f),!.st) +app2St (f,g) (x,y) s + # (x, s) = f x s + (y, s) = g y s + = ((x,y), s) + + +// foldl2 :: !(.c -> .(.a -> .(.b -> .c))) !.c ![.a] ![.b] -> .c +foldl2 op r l1 l2 + :== foldl2 r l1 l2 +where + foldl2 r [x : xs] [y : ys] + = foldl2 (op r x y) xs ys + foldl2 r [] [] + = r +//foldr2 :: !(.a -> .(.b -> .(.c -> .c))) !.c ![.a] ![.b] -> .c + +foldr2 op r l1 l2 + :== foldr2 r l1 l2 +where + foldr2 r [x : xs] [y : ys] + = op x y (foldr2 r xs ys) + foldr2 r [] [] + = r + +fold2St op l1 l2 st + :== fold_st2 l1 l2 st +where + fold_st2 [x : xs] [y : ys] st + = op x y (fold_st2 xs ys st) + fold_st2 [] [] st + = st + fold_st2 [] ys st + = abort ("fold_st2: second argument list contains more elements" ---> ys) + fold_st2 xs [] st + = abort ("fold_st2: first argument list contains more elements" ---> xs) + +// foldSt :: !(.a -> .(.st -> .st)) ![.a] !.st -> .st +foldSt op r l :== fold_st r l + where + fold_st [] st = st + fold_st [a:x] st = fold_st x (op a st) + +iFoldSt op fr to st :== i_fold_st fr to st + where + i_fold_st fr to st + | fr >= to + = st + = i_fold_st (inc fr) to (op fr st) + +iterateSt op st :== iterate_st op st + where + iterate_st op st + # (continue, st) = op (False, st) + | continue + = iterate_st op st + = st + +eqMerge :: ![a] ![a] -> [a] | Eq a +eqMerge [a : x] y + | isMember a y + = eqMerge x y + = [a : eqMerge x y] +eqMerge x y + = y + +revAppend :: ![a] ![a] -> [a] // Reverse the list using the second argument as accumulator. +revAppend [] acc = acc +revAppend [x : xs] acc = revAppend xs [x : acc] + +revMap :: !(.a -> .b) ![.a] !u:[.b] -> u:[.b] +revMap f [] acc = acc +revMap f [x : xs] acc = revMap f xs [f x : acc] + + + +/* +zip2Append :: [.a] [.b] u:[w:(.a,.b)] -> v:[x:(.a,.b)], [w <= x, u <= v] +zip2Append [] [] tail + = tail +zip2Append [x : xs] [y : ys] tail + = [(x,y) : zip2Append xs ys tail] +*/ |