leak-check.red

Red [
  Title: "Leak checks" 
  Description: {
  	Checks the system/words context for words leaking
	* You can use inline in your code or
	* Check a block
	* Check a file (it must have an #assert [code] test inside and
	  run at least once
  }
  Usage: {
	Start with /INIT to fill the initial check buffer, before the code to check
	Start a second time with no arguments and it will return the new "leaked" words 
	The INITial check buffer will remain filled until "CLEAR" or a new /INIT

	/STOP will halt the processing when found a difference and print it
	/REPORT will open the consolle and print the difference without halting
	
	Use /ID to add an unique identifier in the output
	
	You can start it  multiple times after /INIT to check
	for progressive difference against the first one
	
	USE /DO test a block of code or to LOAD a Red file, run and test it
	  Inside you should have ASSERT #[code]
	  After the function will end its test it will report leaked words
	  You can use this mode together with /REPORT to print on screen the results
	  or you the function result in your own way 
	  
	 USE /TEST <code> <test-code> to run a test after loading a code
	 
  }
  Version: 1.6
  Author: "Giuseppe Chillemi"
  Copyright: {
  	1 Billion Dollar to use it in you software or
	BSD-3 Licence if you don't have this amount 
  }
  LOG: {
  	Implemented attempt
	better ouput
  }
]


leak-check: func [	
	"Check the system/words context for leaks"
	/init "Initialize the reference buffer of system/words."
	/skip
	nm [word! block!]
	/do "Test the code for leaks"
	code [block! file!] "The code to test"
	/test "Load a code and run a test"
	code2  [block! file!]  "The code to load"
	test-code [block! file!] "The test to run" 
	/attempt "Attempt the loaded %file but do not stop if error"
	/clear "Clear the buffers"
	/buffer "Returns the accumulated buffers"
	/stop "Stops on difference and prints the result"
	/Report "Report differences but does not halt"
	/ID
	ID*  [String! WORD!] "The ID string for on screen logging"	
	/local
	bl
	bf
	af
	w
	pos
	bu
	fl
	test-code-fl
	out-data
	code-error?
] [
	
	;TBD: add more tests
	;TBD: Log to file
	;TBD: Try to use a faster method than removing using parse
	;TBD: Optimize code referencing to the unique buffer at every
	;  operation

	either any [do test] [
		
			;------ Code TEST here
		
			;--- FL and CODE are are executed by the function
			; /TEST writes the first argument Filename and code block there 
		
			;--- Code for /do refinement: /Test wins over /DO
			if all [not test do file? code] [
				
				;--- If code is FILE, it is loaded. CODE is always a block.
				fl: code code: system/words/attempt [load code]
				unless code [do make error! rejoin ["Can't load code: " fl]]
			]
			
			;--- Code for /test refinement
			if test [
				either file? code2 [

					;--- If code is FILE, it is loaded. CODE is always a block.
					; CODE2 is TEST code argument. It is written in CODE
					; so it will be executed
					fl: code2 code: system/words/attempt [load code2]
					unless code2 [do make error! rejoin ["Can't load code: " fl]]
				] [
					;--- If block, code gets CODE2
					code: code2
				]
				;--- Same as bedore, here we try to load test-code if file
				if file? test-code [
					test-code-fl: test-code test-code: system/words/attempt [load test-code]
					unless test-code [do make error! rejoin ["Can't load code: " test-code-fl]]
				]
			]

			;--- Execution and test phase
			;
			
			;--- Init of the system/words buffer
			;
			leak-check/init
			
			code-error?: false
			;--- We try to run the code
			if error? try [system/words/do code] [
				code-error?: true
		
				print [
					either ID [rejoin ["#ID: " ID*]][""] 
					either test ["TEST TARGET Caused error! "] ["CODE caused error! "] 
					either file? fl [rejoin ["CODE FILE:" file rejoin [" " MOLD/PART code 50 ] ]] [rejoin ["" MOLD/PART code 50 ]]
				]
	
				if not attempt [
					system/words/Do make error! "CODE caused error! "
				] 
				
			]
			
			;--- If it not a test, we check after the execution and stop if requested
			either not test [
				out-data: leak-check/:buffer/:stop/:report/:skip/:id nm id*
			] [
				;--- If it is a /test, we Won't STOP at CODE but here on test code 
				;(Look, there is no /:STOP refinement here!)
				; 
				out-data: leak-check/:buffer/:report/:skip/:id nm id*					
			]
			
			;--- Here we run the test
			if test [
				either not code-error? [

					if error? try [system/words/do test-code] [

						print [
							either ID [rejoin ["#ID: " ID*]][""] 
							"TEST CODE caused error! " 
							either file? fl [rejoin ["TEST CODE FILE:" file rejoin [" " MOLD/PART test-code 50 ]]] [rejoin ["" MOLD/PART test-code 50 ]]
						]
						
						if not attempt [
							system/words/Do make error! "test-Code caused error!"
						] 
					
					]
					out-data: leak-check/:buffer/:stop/:report/:skip/:id nm id*
					
				] [
					print [either ID [rejoin ["#ID: " ID*]][""] "TEST SKIPPED"]
				]
			]
			
			
	] [
		
		bf: [] ;<--- Static _before_ INIT buffer between calls
		af: [] ;<--- Lastest _after_ system/words content, refreshed at each call
		
		bu: reduce [quote before: bf quote after: af] ;<--- Buffer to return if requestes
		
		either not buffer [
		;--- If you pass just a word to remove if found leaking, it is converted to block 
		;
			if all [skip word? nm] [nm: to-block nm]
			
			;--- Get system word in temporary BL block unless BUFFER or CLEAR are used
			;
			if  any [init all [not buffer not clear true]] [;<< True is needed to execute when INIT is not present
				bl: words-of system/words
				
				;--- Parsing the system/words context
				;- Removing any word which is UNSET
				parse bl [
					any [pos: set w any-word! if (unset? get/any w) :pos remove any-word! | skip] end
				]
			]
			
			;--- If INIT buffer is empty, fire error!
			;
			if all [not init empty? head bf] [Do make error! "/INIT not used to initialize!"]
			
			case/all [
				
				init [
					;--- Delete both buffers
					system/words/clear head bf
					system/words/clear head af
					append bf bl
				]
				
				;--- Initalize the AFTER block if no other refinements
				all [not init not buffer not clear] [
					system/words/clear head af 
					append af bl
					if skip [append bf nm] 
					out-data: exclude af bf 
				]
				
				;--- Delete both buffers... TBD: remove in favor of INIT?
				clear [
					system/words/clear head bf 
					system/words/clear head af 
				]
			]
			
			;--- Returns the difference on AFTER or
			;  if no command or 
			;  after /stop and difference is present
			
			if all [not init not buffer any [report stop]] [

				if all [any [report stop] not empty? out-data] [
					case [
						stop [
							Prin [
								either id [rejoin ["#ID: " id* " | "]] [""] 
								either skip [rejoin ["Skipped: " mold nm " | "]] [""] 
								"Leaks: "
							]
							probe out-data halt
						]
						report [
							Prin [
								either id [rejoin ["#ID: " id* " | "]] [""] 
								either skip [rejoin ["Skipped: " mold nm " |"]] [""] 
								" leaks: "
							] 
							probe out-data
						]
					]
				]
			]
		] [
			;Returns the buffer if requested
			if buffer [out-data: bu]
		]
	]

	out-data
]



comment [

;  Test this:

  ;--- Start collecting the system context
  ;
  leak-check/init

  f: func [a] [b: 33 aa: 44]

  f 99

  ;-- Checks skipping word <F>
  ;--   and stopping after a an error is found
  ;
  leak-check/stop/skip [f] 

;--- Result:
;--- Skipped: [f] |  Leaks: [b aa]

]