Commit 50df7e8d authored by cvs2snv's avatar cvs2snv

This commit was manufactured by cvs2svn to create tag 'Initial'.

parent c29daa15
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"
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 (wrapNode 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 (wrapNode 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
:== wrapNode ...
MaxDepthIndicator
:== wrapNode .+.
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 {wrapNode e \\ e <-: a & i <- [0 .. maxBreadth]})
// otherwise
= WrappedArray {wrapNode 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
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
implementation module Heap;
import StdOverloaded,StdMisc;
:: 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
| isNilPtr p
= abort "writePtr: Nil pointer encountered\n";
= writePtr2 p v h;
writePtr2 :: !(Ptr v) !v !*(Heap v) -> .Heap v;
writePtr2 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
| isNilPtr p
= 0;
= ptrToInt2 p;
ptrToInt2 :: !(Ptr v) -> Int;
ptrToInt2 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
definition module RWSDebug
(->>) :: !.a !.b -> .a
(<<-) :: .a !.b -> .a
<<->> :: !.a -> .a
\ No newline at end of file
implementation module RWSDebug
import Debug
show x
= debugShowWithOptions [DebugMaxChars 80, DebugMaxDepth 5] x
(->>) :: !.a !.b -> .a
(->>) value debugValue
= debugAfter debugValue show value
(<<-) :: .a !.b -> .a
(<<-) value debugValue
= debugBefore debugValue show value
<<->> :: !.a -> .a
<<->> value
= debugValue show value
definition module ShowWrapped
from Wrap import WrappedNode
showWrapped :: WrappedNode -> [{#Char}]
\ No newline at end of file
implementation module ShowWrapped
import StdEnv
import Wrap
ShowParentheses
:== True
Don`tShowParentheses
:== False
showWrapped :: WrappedNode -> [{#Char}]
showWrapped node
= show Don`tShowParentheses node
show :: Bool WrappedNode -> [{#Char}]
show _ (WrappedInt i)
= [toString i]
show _ (WrappedChar c)
= ["\'" +++ toString c +++ "\'"]
show _ (WrappedBool b)
= [toString b]
show _ (WrappedReal r)
= [toString r]
show _ (WrappedFile _)
= ["File"]
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 Don`tShowParentheses el \\ el <-: a])] ++ ["}"]
show _ (WrappedRecord descriptor args)
= ["{" : flatten (separate [" "] [[showDescriptor descriptor] : [show ShowParentheses arg \\ arg <-: args]])] ++ ["}"]
show _ (WrappedOther WrappedDescriptorCons args)
| size args == 2
= ["[" : flatten [show Don`tShowParentheses args.[0] : showTail args.[1]]] ++ ["]"]
where
showTail :: WrappedNode -> [[{#Char}]]
showTail (WrappedOther WrappedDescriptorCons args)
| size args == 2
= [[", "], show Don`tShowParentheses args.[0] : showTail args.[1]]
showTail (WrappedOther WrappedDescriptorNil args)
| size args == 0
= []
showTail node // abnormal list
= [[" : " : show Don`tShowParentheses node]]
show _ (WrappedOther WrappedDescriptorTuple args)
= ["(" : flatten (separate [", "] [show Don`tShowParentheses arg \\ arg <-: args])] ++ [")"]
show parentheses (WrappedOther descriptor args)
| parentheses && size args > 0
= ["(" : application] ++ [")"]
// otherwise
= application
where
application
= flatten (separate [" "] [[showDescriptor descriptor] : [show ShowParentheses arg \\ arg <-: args]])
showDescriptor :: WrappedDescriptor -> {#Char}
showDescriptor (WrappedDescriptorOther id)
= toString id
showDescriptor WrappedDescriptorNil
= "[]"
showDescriptor WrappedDescriptorCons
= "[:]"
showDescriptor WrappedDescriptorTuple
= "(..)"
showBasicArray :: {#a} -> [{#Char}] | toString, ArrayElem a
showBasicArray a
= ["{" : separate ", " [toString el \\ el <-: a]] ++ ["}"]
showWrappedArray :: {WrappedNode} -> [{#Char}]
showWrappedArray a
= ["{" : flatten (separate [", "] [show Don`tShowParentheses 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 -> {#Char}
toString _
= "File"
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, Priority, Assoc
export == Int
instance < MemberDef
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 (type1 :@: types1) (type2 :@: types2)
= type1 == type2 && types1 == types2
equal_constructor_args (TQV varid1) (TQV varid2)
= varid1 == varid2
equal_constructor_args type1 type2
= True
instance == Priority
where
(==) NoPrio NoPrio = True
(==) (Prio assoc1 prio1) (Prio assoc2 prio2) = assoc1==assoc2 && prio1==prio2
instance == Assoc
where
(==) a1 a2 = equal_constructor a1 a2
:: 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)
(=<) [] [] =