// Modifications
//	Sep-19-1984	FH	Added call to HEAPINIT



Main Module heaptest
%set use_routine_names = true

	Use	TEXTIO
	import	HEAPINIT from HEAPINIT
	Declare
		one_word_str is
			Structure
				one	: integer
			EndStructure
		two_word_str is
			Structure
				one	: integer
				two	: integer
			EndStructure
		three_word_str is
			Structure
				one	: integer
				two	: integer
				three	: integer
			EndStructure
		four_word_str is
			Structure
				one	: integer
				two	: integer
				three	: integer
				four	: integer
			EndStructure
		five_word_str is
			Structure
				one	: integer
				two	: integer
				three	: integer
				four	: integer
				five	: integer
			EndStructure
		seventeen_word_array is array [ 1..17 ] of integer
		one_word_ptr is pointer one_word_str
		two_word_ptr is pointer two_word_str
		three_word_ptr is pointer three_word_str
		four_word_ptr is pointer four_word_str
		five_word_ptr is pointer five_word_str
		seventeen_word_ptr is pointer seventeen_word_array
		ptr_1A	: static one_word_ptr
		ptr_1B	: static one_word_ptr
		ptr_2A	: static two_word_ptr
		ptr_2B	: static two_word_ptr
		ptr_3A	: static three_word_ptr
		ptr_3B	: static three_word_ptr
		ptr_4A	: static four_word_ptr
		ptr_4B	: static four_word_ptr
		ptr_5A	: static five_word_ptr
		ptr_5B	: static five_word_ptr
		ptr_17	: static seventeen_word_ptr
		I is integer
		P is pointer I
		P1	: static P
		flex_array is packed array [ 1..?N ] of char
		flex_ptr is pointer flex_array
		message	: static flex_ptr
	EndDeclare

	Exception error

	Out_record ( TTY )
	TTY_line ( "Praxis Allocation, Initialization and Free test program" )

	TTY_Line ( "Initialize the heap")
	HEAPINIT ()



	TTY_line ( "Sequential allocation test" )
	Guard
		ptr_1A := allocate one_word_ptr ()
		ptr_2A := allocate two_word_ptr ()
		If force integer ( ptr_2A ) <> force integer ( ptr_1A ) + 10 do
			Raise error
		EndIf
		ptr_3A := allocate three_word_ptr ()
		If force integer ( ptr_3A ) <> force integer ( ptr_2A ) + 12 do
			Raise error
		EndIf
		ptr_4A := allocate four_word_ptr ()
		If force integer ( ptr_4A ) <> force integer ( ptr_3A ) + 14 do
			Raise error
		EndIf
		ptr_5A := allocate five_word_ptr ()
		If force integer ( ptr_5A ) <> force integer ( ptr_4A ) + 16 do
			Raise error
		EndIf
		TTY_line ( "Pass" )
	Catch
		Default:
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "Free/Reallocate valid pointer test" )
	Guard
		Declare ( temp : three_word_ptr initially ptr_3A )
		Free ( temp )
		temp := nil
		temp := allocate three_word_ptr ()
		If temp <> ptr_3A do
			Raise error
		EndIf
		temp := nil
		temp := allocate three_word_ptr ()
		If force integer ( temp ) <> force integer ( ptr_5A ) + 18 do
			Raise error
		EndIf
		TTY_line ( "Pass" )
	Catch
		Default:
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "Free invalid pointer test" )
	Guard
		Declare ( temp : three_word_ptr initially force three_word_ptr ( 6 ) )
		Free ( temp )
		Raise error
	Catch
		Case x_failed_free:
			TTY_line ( "Pass" )
		Default:
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "Merge sequential freed space test" )
	Guard
		Free ( ptr_2A )
		Free ( ptr_4A )
		Free ( ptr_3A )
		ptr_17 := allocate seventeen_word_ptr ()
		If force integer ( ptr_17 ) <> force integer ( ptr_2A ) do
			Raise error
		EndIf
		TTY_line ( "Pass" )
	Catch
		Default:
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "Freed space fit test" )
	Guard
		Free ( ptr_17 )
		ptr_2A := allocate two_word_ptr ()
		If force integer ( ptr_2A ) <> force integer ( ptr_1A ) + 10 do
			Raise error
		EndIf
		ptr_3A := allocate three_word_ptr ()
		If force integer ( ptr_3A ) <> force integer ( ptr_2A ) + 12 do
			Raise error
		EndIf
		ptr_5B := allocate five_word_ptr ()
		If force integer ( ptr_5B ) = force integer ( ptr_3A ) + 14 do
			TTY_line ( "overfit" )
			Raise error
		EndIf
		ptr_4A := allocate four_word_ptr ()
		If force integer ( ptr_4A ) <> force integer ( ptr_3A ) + 14 do
			Raise error
		EndIf
		TTY_line ( "Pass" )
	Catch
		Default:
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "Initialization test" )
	Guard
		free ( ptr_3A )
		ptr_3A := allocate three_word_ptr ( one: 1, two: 2, three: 3 )
		If ptr_3A@.one <> 1 do
			Raise error
		OrIf ptr_3A@.two <> 2 do
			Raise error
		OrIf ptr_3A@.three <> 3 do
			Raise error
		EndIf
		TTY_line ( "Pass" )
	Catch
		Default:
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "Heap empty test" )
	Guard
		Repeat
			ptr_17 := allocate seventeen_word_ptr ()
		Until false
		Raise error
	Catch
		Case x_heap_empty:
			TTY_line ( "Pass" )
		Default :
			TTY_line ( "Fail" )
	EndGuard
	TTY_line ( "x_heap_empty test 2" )
	Guard
		For i := 1 to 2000 do
			P1 := allocate P ()
		EndFor
		Raise error
	Catch
		Case x_heap_empty:
			TTY_line ( "Pass" )
		Default:
			TTY_line ( "Fail" )
	EndGuard
///%if false
	TTY_line ( "x_heap_empty test3" )
	Guard
		For i := 1 to 2000 do
			P1 := allocate P ( 5 )
// Note compiler bug:
//	Does not remove argument ( 5 ) from stack after allocate
		EndFor
		Raise error
	Catch
		Case x_heap_empty:
			TTY_line ( "Pass" )
		Default:
			TTY_line ( "Fail" )
	EndGuard
///%endif
	TTY_line ( "Test complete" )

//	message := allocate flex_ptr ( "This is a test" )
// Note compiler bug:


EndModule