\ hs 21.07.97 code squeezer
\ Forth level parts
\ Info: the decompiler is NOT supported yet
only forth also definitions

decimal
vocabulary optimizer  optimizer also definitions

: install-group	( n -- )	0 do 0 token, loop -1 token, ;	
15 constant #group1
25 constant #group2
create group1	#group1 install-group
create group2	#group2 install-group

create optimizer-array	 #group1 #group2 * cells allot
		#group1 #group2 * 0 do 0  optimizer-array i cells+ token! loop

[ifdef] arm-assembler
	code >group-index	( cfa group -- idx/-1 )
		r0	sp			pop
		r1	top			mov
		top	0 #			mov
	  begin	r2	r1 top 2 #asl ib        ldr
		r2	r0			cmp	eq next	
		r2	0 #			cmp
		top	-1 #			lt mov	lt next
	        top	1			incr
	  again	end-code
[else]	
	: >group-index		( cfa group -- idx/-1)
		dup >r
		begin	dup token@ 0>=
		while	2dup token@ = if nip r> - /cell / exit then
			cell+
		repeat	r> drop 2drop -1 ;
[then]

: >optimizer-adr	( #1 #2 -- adr )
	#group1 * + cells  optimizer-array + ;
: extend-group-list	( cfa group -- index )
	0 over >group-index dup 0< abort" instruction list exhausted"
	dup >r cells+ token! r> ;
: >true-idx	( cfa group -- idx/-1 )
	2dup >group-index dup 0< if drop extend-group-list else -rot 2drop then ;
: (def_squeeze	( cfa -- )	\ group1 group2
	' group1 >true-idx  ' group2 >true-idx  >optimizer-adr token! ;
: def_squeeze	( -- ) 	lastacf (def_squeeze ;

true constant opt_info

\ opt_compile, replaces compile, in compile-do-defined
: opt_compile,	( cfa -- )
	last-compiled cell+ @  group1 >group-index dup 0<	if  drop compile, exit then
	over group2 >group-index dup 0<				if 2drop compile, exit then
	>optimizer-adr token@ ?dup 0=				if compile, exit then
	opt_info
	if	cr ." In " lastacf .name  ." :" 32 to-column ." replacing " last-compiled cell+ @ .name over .name
		."    --> " dup .name
	then
	dup last-compiled cell+ !  nip last-compiled @ token! ;
patch opt_compile, compile, compile-do-defined
patch opt_compile, compile, do-postpone

only forth also definitions
