Initial import

frontend/Debug.dcl

+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"
+

frontend/Debug.icl

+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

frontend/Heap.dcl

+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

frontend/Heap.icl

+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

frontend/RWSDebug.dcl

+definition module RWSDebug
+
+(->>) :: !.a !.b -> .a
+(<<-) :: .a !.b -> .a
+<<->> :: !.a -> .a
\ No newline at end of file

frontend/RWSDebug.icl

+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

frontend/ShowWrapped.dcl

+definition module ShowWrapped
+
+from Wrap import WrappedNode
+
+ShowWrapped :: WrappedNode -> [{#Char}]
\ No newline at end of file

frontend/ShowWrapped.icl

+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"

frontend/StdCompare.dcl

+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
+

frontend/StdCompare.icl

+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)