--procedure old_printf(integer i, sequence fmt, sequence s)
--  printf(i,fmt,s)
--end procedure

--include dll.e
--include machine.e
--include misc.e
--constant libc = open_dll("")
--constant cputs = define_c_proc(libc, "puts", {C_POINTER})

--global procedure puts(integer i, sequence s)
--  atom a
--  a = allocate(length(s)+1)
--  poke(a, s)
--  poke(a+length(s),0)
--  free_console()
--  c_proc(cputs, {a})
--  free(a)
--end procedure

--global procedure printf(integer i, sequence fmt, object s)
--  puts(i, sprintf(fmt, s))
--end procedure

--global procedure print(integer i, object s)
--  puts(i, sprint(s))
--end procedure


--free_console()


include asm.e
--include graphics.e
--? text_rows(50)

--constant 
--    EAX=0, EBX=3, ECX=1, EDX=2, ESP=4, EBP=5, ESI=6, EDI=7,
--    AL=0, BL=3, CL=1, DL=2, 
--    AH=4, BH=7, CH=5, DH=6

function peek_object(atom address)
    sequence result
    atom a
    a = peek4s(address)
    if integer(a) then
        return a
    end if
    address = and_bits(a,#3FFFFFFF)*4
    if a > 0 then
        return float64_to_atom(peek({address,8}))
    else
        result = repeat(0, peek4u(address))
        for i = 1 to length(result) do
            result[i] = peek_object(address + 4*i)
        end for
        return result
    end if
end function

function decode_object(atom o)
    sequence result
    atom address
    if integer(o) then
        return o
    end if
    address = and_bits(o,#3FFFFFFF)*4
    if o > 0 and o < #80000000 then
        return float64_to_atom(peek({address,8}))
    else
        result = peek4u({address+4, peek4u(address)})
        for i = 1 to length(result) do
            result[i] = decode_object(result[i])
        end for
        return result
    end if
end function

function encode_object(object o)
    atom address, k
    if integer(o) then
        return o
    end if
    if atom(o) then
        address = allocate(8)
        poke(address, atom_to_float64(o))
        return or_bits(#40000000, floor(address / 4))
    end if
    address = allocate(4 + 4 * length(o))
    poke4(address, length(o))
    for i = 1 to length(o) do
        poke4(address+i*4,encode_object(o[i])) 
    end for
    return or_bits(#80000000, floor(address / 4))
end function

function allocate_object(object o)
    atom address
    address = allocate(4)
    poke4(address, encode_object(o))
    return address
end function

include smart.e

asm_output(1,1)    


sequence arguments, variables, globals, global_addys
arguments = {}
variables = {}
globals = {}
global_addys = {}

function Find(sequence name)
    if find(name, arguments) then
        return sprintf("dword ptr [ebp+%d]", 4*find(name, arguments))
    end if
    if find(name, variables) then
        return sprintf("dword ptr [ebp-%d]", 4*find(name, variables))
    end if
    if find(name, globals) then
        return sprintf("dword ptr [#%x]", global_addys[find(name, globals)])
    end if
end function
            
constant return_ = "\nmov esp,ebp\npop ebp"&
"\nret"
function func(sequence code)
    --puts(1, code)
    return get_asm("push ebp\nmov ebp,esp\n" & 
        code & return_)    
end function

function get(sequence name)
    return "mov eax, "&Find(name)&" ; get "&name&"\n"
end function
function set(sequence name)
    return "mov "&Find(name)&", eax ; set "&name&"\n"
end function
function gets(sequence name)
    return "push "&Find(name)&" ; get "&name&"\n"
end function
function sets(sequence name)
    return "pop "&Find(name)&" ; set "&name&"\n"
end function
function declare_global(sequence name, atom address)
    globals &= {name}
    global_addys &= {address}
    return address
end function
function const(atom i)
    return sprintf("mov eax, #%x ; const %d\n", {i,i})
end function
function consts(atom i)
    return sprintf("push dword #%x ; const %d\n", {i,i})
end function
function funcall(sequence name)
    return sprintf("jmp near #%x ; funcall %s\n", {
        global_addys[find(name, globals)], name})
end function

function subscript_assign(sequence name, sequence subscripts, object rval)
    sequence result
    integer esp
    result = ""
    esp = 0
    for i = 1 to length(subscripts) do
        if sequence(subscripts[i]) then
            result &= subscripts[i]
            esp += 4
        end if
    end for
    if sequence(rval) then 
        result &= rval&"\nmov ecx, eax\n"
        rval = "ecx"
    else
        rval = sprintf("%d", {rval})    
    end if
    result &= "mov eax, "&Find(name)&" ; get "&name&"\n"
    for i = 1 to length(subscripts)-1 do
        result &= "shl eax, 2\n"
        if sequence(subscripts[i]) then
            esp -= 4
            result &= sprintf("mov edx, [esp+%d]\nmov eax, [eax+edx*4]\n",{esp})
        else
            result &= sprintf("mov eax, [eax+#%x]\n", {subscripts[i]*4})
        end if
    end for
    result &= "shl eax, 2\n"
    if sequence(subscripts[length(subscripts)]) then
        esp -= 4
        result &= sprintf("mov edx, [esp+%d]\nmov dword ptr [eax+edx*4], %s\n", {esp,rval})
    else
        result &= sprintf("mov dword ptr [eax+#%x], %s\n", {subscripts[length(subscripts)]*4, rval})
    end if
    return result
end function



arguments = {"arg"}
variables = {"var"}
constant foo = declare_global("foo", allocate_object({{0,{0,0,0}}}))

constant f1 = declare_global("f1", func(
    const(1)&
    set("foo")))

constant f2 = func(funcall("f1"))

constant f3 = func(subscript_assign("foo", {consts(1),consts(2),consts(3)}, 1))
printf(1,"%x\n", f2 )

call(f3)
? peek_object(foo)



constant int_to_bytes_storage = allocate(4)
function int_to_bytes(atom i)
    poke4(int_to_bytes_storage, i)
    return peek({int_to_bytes_storage, 4})
end function

function autosize(object word, object byte, integer i)
    if i < -128 or i > 127 then
    	return word & int_to_bytes(i)
    else
    	return byte & i
    end if
end function

function push_dword(atom i) return #68 & int_to_bytes(i) end function
function add_esp(integer i) return autosize({#81,#C4},{#83,#C4},i) end function
function mov_eax(atom i) return #B8 & int_to_bytes(i) end function

function push_at_ebp(integer p) return #FF & autosize(#B5,#75,p) end function
function mov_at_ebp(integer p, atom i) 
    return #C7 & autosize(#85,#45,p) & int_to_bytes(i)
end function

    
constant
    pusha = #60,
    mov_ebp_esp = {#89,#E5},
    mov_esp_ebp = {#89,#EC},
    popa = #61,
    ret = #C3
    
function call_near(atom i) return #E8 & int_to_bytes(i) end function




constant 
  kind_jumps={"JO","JNO","JB","JNAE","JNB","JAE","JZ","JE","JNZ","JNE","JBE",
  "JNA","JNBE","JA","JS","JNS","JP","JPE","JNP","JPO","JL","JNGE","JNL","JGE",
  "JLE","JNG","JNLE","JG","JMP"},
  short_jumps={#70,#71,#72,#72,#73,#73,#74,#74,#75,#75,#76,#76,#77,#77,#78,#79,
  #7A,#7A,#7B,#7B,#7C,#7C,#7D,#7D,#7E,#7E,#7F,#7F,#EB},
  near_jumps={{#0F,#80},{#0F,#81},{#0F,#82},{#0F,#82},{#0F,#83},{#0F,#83},
  {#0F,#84},{#0F,#84},{#0F,#85},{#0F,#85},{#0F,#86},{#0F,#86},{#0F,#87},
  {#0F,#87},{#0F,#88},{#0F,#89},{#0F,#8A},{#0F,#8A},{#0F,#8B},{#0F,#8B},
  {#0F,#8C},{#0F,#8C},{#0F,#8D},{#0F,#8D},{#0F,#8E},{#0F,#8E},{#0F,#8F},
  {#0F,#8F},{#E9}}
  
function jump_blocks(sequence blocks) 
    -- blocks: {{{code},condition,target1[,target2]},...}
    sequence result
    sequence offsets, deltas
    integer ok
    deltas = repeat(0, length(blocks))
    offsets = repeat(0, length(blocks)+1)
    for i = 1 to length(blocks) do
        offsets[i+1] = offsets[i] + length(blocks[i][1]) + 2
    end for
    ok = 0
    while not ok do
        ok = 1
        ? {deltas,offsets}
        for i = 1 to length(blocks) do
            if deltas[i] < -128 or deltas[i] > 127 then
                deltas[i] = offsets[blocks[i][3]] - offsets[i+1]
            else
                deltas[i] = offsets[blocks[i][3]] - offsets[i+1]
                if deltas[i] < -128 or deltas[i] > 127 then
                    offsets[i+1..length(offsets)] += length(near_jumps[
		    find(blocks[i][2], kind_jumps)])+2
                    ok = 0
                    --exit  
                end if
            end if
        end for
    end while
    result = repeat(0,offsets[length(offsets)])
    for i = 1 to length(blocks) do
        if deltas[i] < -128 or deltas[i] > 127 then
            result[offsets[i]+1..offsets[i+1]] = blocks[i][1] & 
                near_jumps[find(blocks[i][2], kind_jumps)] & int_to_bytes(deltas[i])
        else
            result[offsets[i]+1..offsets[i+1]] = blocks[i][1] & 
                short_jumps[find(blocks[i][2], kind_jumps)] & deltas[i]
        end if           
    end for
    return result
end function



sequence local_vars
local_vars = {}

function compile_expression(sequence ex)
    if equal(ex[1] , "numeric") then 
    	return mov_eax(ex[2])
    end if
end function

function compile_expression_s(sequence ex)
    if equal(ex[1] , "numeric") then 
    	return push_dword(ex[2])
    elsif equal(ex[1] , "variable") then 
        return push_at_ebp(-4*(find(ex[2], local_vars)))
    end if
end function


function assign(sequence var, sequence ex)
    integer id
    id = find(var, local_vars)

    if equal(ex[1], "numeric") then
    	return mov_at_ebp(-id*4, ex[2])
    end if    

end function

function qprint(atom x)
    ? decode_object(x)
    --smart_print({peek_object(x)})
    return 0
end function
include dll.e
constant qprint_ptr = call_back(routine_id("qprint"))


sequence fixups
fixups = {}

function compile(sequence ops)
-- codes={expression, {operations}, {else-operations}
    sequence result, op, id
    result = {}
    
    for i = 1 to length(ops) do
        op = ops[i]
	id = op[1]
	if equal(id, "if") then
	
	elsif equal(id, "assign") then
    	    result &= assign(op[2], op[3])

	elsif equal(id, "declare") then
	    local_vars &= {op[2]}
	    result &=
	    	add_esp(-4)
	
	elsif equal(id, "main") then
    	    result &= 
	    	pusha &
    	    	mov_ebp_esp &
    	    	compile(op[2..length(op)]) &
    	    	mov_esp_ebp &
		popa &
    	    	ret
	
	elsif equal(id, "?") then
	    result &= compile_expression_s(op[2]) & 
	    	call_near(qprint_ptr) &
		add_esp(4)
	    fixups &= {call_near(qprint_ptr)}
	end if
    end for    
    return result
end function

function link(sequence code)
    atom result, addr
    sequence fix
    result = allocate(length(code))
    for i = 1 to length(fixups) do
    	fix = fixups[i]
	addr = match(fix, code) + length(fix) - 4
	code[addr..addr+3] = int_to_bytes(bytes_to_int(code[addr..addr+3]) -
	result - addr - 3)
    end for
    fixups = {}
    --printf(1, "#%x,\n#%x,#%02x,#%02x,#%02x,#%02x,\n#%x,#%02x,#%02x,#%02x,#%02x,\n#%x,#%02x,#%02x\n#%x,\n#%x,\n", and_bits(255,code))
    poke(result, code)
    return result
end function    


constant tst = link(compile({{"main",{"?", {"numeric", 1}}}}))
call(tst)

asm_output(1,1)
constant test= get_asm(sprintf(
"pusha mov ebp,esp mov dword ptr[ebp-4],4  push dword ptr [ebp-4] call near %d add esp, 4 mov esp,ebp popa ret ", 

{qprint_ptr}))
? test
call(test)
--? get_asm(
--"mov eax, 20 " &
--"mov eax, 2000 "&
--"add esp, 4000 "&
--"push dword ptr [esp + 4] "&
--"push dword ptr [esp + 400] "&
--"push dword ptr [ebp + 4] "&
--"push dword ptr [ebp + 400] "&
--"mov dword ptr [ebp-400], 1 "&
--"mov dword ptr [ebp-4], 1 "
--)

constant tst2 = link(compile({{"main",
{"declare", "x"},
{"declare", "y"},
{"assign", "x", {"numeric", encode_object({1,2,3})}},
{"assign", "y", {"numeric", 3}},
{"?", {"variable", "x"}},
{"?", {"variable", "y"}},
{"?", {"numeric", 1000}}
}}))


call(tst2)

constant tmp=jump_blocks({
{{#90,#90,#90},"JMP",3},
{repeat(#90,1220000),"JMP",4},
{{#90,#90,#90},"JMP",2}})
&#C3
constant tmp2=allocate(length(tmp))
poke(tmp2,tmp)
call(tmp2)