-- Local Constants ----

-- stack

constant TOP = 1

-- nfor

constant START = 1, FINISH = 2, STEP = 3

-- Local Static Stacks ----

sequence nfor_stack, nfor_istack

nfor_stack  = {}
nfor_istack = {}

procedure pop_stacks()
    integer len
    len = length(nfor_istack)
    nfor_stack  = nfor_stack[2..len]
    nfor_istack = nfor_istack[2..len]
end procedure

procedure reassign_stack_tops(sequence top, sequence itop)
    nfor_stack[TOP]  = top
    nfor_istack[TOP] = itop
end procedure

-- Checking Flag (set to 0 speeds up at expense of error corrections)

integer
  nfor_check
  nfor_check = 1

global procedure with_nfor_check()
    nfor_check = 1
end procedure

global procedure without_nfor_check()
    nfor_check = 0
end procedure

-- Internal routines --

with trace -- ***** --

function n_sfs_tidy(sequence n_sfs) -- tidy up nfor() parameter sequence
    object sfs, sfsj
    for i = 1 to length(n_sfs) do
	sfs = n_sfs[i]
	if atom(sfs) then
	    sfs = {sfs,sfs,1}
	elsif length(sfs) = START then
	    sfs &= sfs & 1
	elsif length(sfs) = FINISH then
	    sfs &= 1
	elsif length(sfs) > STEP then
	    sfs = sfs[START..STEP]
	end if
	for j = START to STEP do
	    sfsj = sfs[j]
	    if sequence(sfsj) then
		if length(sfsj) then
		    sfs[j] = sfsj[1]
		else
		    sfs[j] = 1
		end if
	    end if
	end for
	if not sfs[STEP] then
	    sfs[STEP] = 1
	end if
	n_sfs[i] = sfs
    end for
    return n_sfs
end function

function reverse(sequence s) -- stolen from misc.e
-- reverse the top-level elements of a sequence.
-- Thanks to Hawke' for helping to make this run faster.
    integer lower, n, n2
    sequence t

    n = length(s)
    n2 = floor(n/2)+1
    t = repeat(0, n)
    lower = 1
    for upper = n to n2 by -1 do
	t[upper] = s[lower]
	t[lower] = s[upper]
	lower += 1
    end for
    return t
end function

-- Main Euphoria-like nfor code routines --

global procedure nfor(sequence n_sfs) -- n * start, finish, step
    sequence indices
    integer len

    len = length(n_sfs)

    if not len then return end if

    if nfor_check then
	n_sfs = n_sfs_tidy(n_sfs)
    end if
    if len > 1 then
	n_sfs = reverse(n_sfs)
    end if

    indices = repeat(0, len)
    for i = 1 to len do
	indices[i] = n_sfs[i][START]
    end for

    nfor_stack  = prepend(nfor_stack,  n_sfs)
    nfor_istack = prepend(nfor_istack, indices)
end procedure

global function end_nfor()
    sequence top, itop
    atom curr_finish, curr_step, itopi
    integer len

    if not length(nfor_istack) then
	-- exit outside of nfor!
	return {}
    end if

    itop = nfor_istack[TOP]
    len  = length(itop)
    top  = nfor_stack[TOP]

    for i = 1 to len do
	curr_finish = top[i][FINISH]
	curr_step   = top[i][STEP]
	itopi = itop[i] + curr_step
	if ( curr_step < 0 and itopi < curr_finish ) or
	   ( curr_step > 0 and itopi > curr_finish ) then
	    itop[i] = top[i][START] -- start an inner loop again
	    reassign_stack_tops(top, itop)
	    -- keep going to next nfor level
	else
	    itop[i] = itopi
	    reassign_stack_tops(top, itop)
	    return 0 -- keep going with current nfor level
	end if
    end for

    -- if we're here, we've finished all loops
    pop_stacks()
    return 1
end function

global function exit_nfor(integer levels)
    sequence top, itop
    integer len

    if not length(nfor_istack) then
	-- exit_nfor outside of nfor!
	return {}
    end if

    itop = nfor_istack[TOP]

    len = length(itop)

    -- check for bad number of levels
    if levels <= 0 then
	levels = 1
    elsif levels >= len then
	-- discard whole current nfor (total exit!)
	pop_stacks()
	return 0
    end if

    top  = nfor_stack[TOP]

    for i = 1 to levels do
	itop[i] = top[i][START]
    end for

    reassign_stack_tops(top, itop)
    return 1
end function

global function nfor_indices()
    if not length(nfor_istack) then
	-- no current nfor!
	return {}
    end if
    return reverse(nfor_istack[TOP])
end function

global function nfor_index(integer i)
    integer len
    len = length(nfor_istack)
    if not len then
	-- no current nfor!
	return 0
    end if
    if i < 1 or i > len then
	return 0
    end if
    return nfor_istack[TOP][len-i+1]
end function

-- Test Code --

trace(1)

nfor(repeat({0,1},2)) while 1 do

    puts(1,"outer: " & 48+nfor_indices() & "\n")

    nfor(repeat({0,1,1},3)) while 1 do

	puts(1,"inner: " & 48+nfor_indices() & "\n")

    if end_nfor() then exit end if end while

if end_nfor() then exit end if end while