Universal Lambda Machine: Difference between revisions

=={{header|Phix}}==

Translation of "how it works" and hence bitmode-only, except for leading ' '..'/' trick, and I managed to get Quine8 to work with only a minor kludge.<br>

If you think you can get blc8 to work, just be grateful that I decided at the eleventh hour and by the skin of my teeth against obfuscating this..

<syntaxhighlight lang="phix">

with javascript_semantics

constant IOP = 0, // code for gro, wr0, wr1, put

VAR = 1, // code for variable lookup

APP = 2, // code for applications

ABS = 3, // code for abstractions

ROOT = 1 // sentinel kept at stack[1]

sequence nexts, envps, refs, terms, // stack

mem // memory

integer ip, // instruction pointer

ep, // end of code pointer

frep, // freelist

contp, // continuation stack

envp // environment pointer

--constant M = 512 -- grow automatically

constant M = 50000 -- fixed limit (~safer)

-- (Programs that are left to run out of memory will tend to

-- gradually slow the machine, and sometimes even hang it.)

procedure grow_memory()

if M!=512 then crash("out of memory") end if

-- else 512->1024->2048->4096->8192, etc.

mem &= repeat(0,length(mem))

end procedure

procedure Gc(integer p)

// garbage collection (stack only, but not mem)

while p>ROOT do

refs[p] -= 1

if refs[p] then exit end if

Gc(nexts[p])

nexts[p] = frep

frep = p

p = envps[p]

end while

end procedure

procedure Var()

integer e = envp, t = envp,

x = mem[ip+1], i = 1

while i<=x and e!=ROOT do

e = nexts[e]

i += 1

end while

assert(e!=ROOT,"UNDEFINED VARIABLE %d", {x})

ip = terms[e]

envp = envps[e]

refs[envp] += 1

Gc(t)

end procedure

bool bitmode

string src, tgt

integer sdx = 0, b = 0, c

function nextbit()

if b=0 then

if sdx>=length(src) then return -1 end if

sdx += 1

c = src[sdx]

b = iff(bitmode?1:8)

end if

b -= 1

return shift_bits(c,b)&&1

end function

procedure Gro()

integer c = nextbit(), sc = ep+1

sequence g = iff(c!=-1?{ABS,APP,8,APP,2,VAR,0,ABS,ABS,VAR,even(c)}

:{ABS,ABS,VAR,0})

ep += length(g)

if ep>=length(mem) then grow_memory() end if

mem[sc..ep] = g

end procedure

string outlog = ""

integer o = 0, ob = 0

bool quine8 -- mini-kludge...

procedure Put()

integer ch = '1'-odd(ip)

ip = 3;

if not bitmode then

o = o*2+odd(ch)

ob += 1

if ob<8 then return end if

ch = o

o = 0

ob = 0

end if

if quine8 then

printf(1,"%02x",ch)

else

puts(1,ch)

end if

outlog &= ch

end procedure

procedure Abs()

// pops continuation and pushes it to environment

integer t = contp

contp = nexts[t]

nexts[t] = envp

envp = t

ip += 1

end procedure

procedure App()

// pushes continuation for argument

int x = mem[ip+1]

integer t = frep, e, term = ip+2+x

if t=0 then

nexts = append(nexts,0)

envps = append(envps,0)

refs = append(refs,0)

terms = append(terms,0)

t = length(terms)

end if

frep = nexts[t]

refs[t] = 1

terms[t] = term

if term>22 and term!=ep then

e = envp

refs[e] += 1

else

e = ROOT

end if

envps[t] = e

nexts[t] = contp

contp = t

ip += 2

end procedure

procedure Iop()

if ip>=ep then

Gro()

else

Put() // ip is an element of {6,13,20,21}

end if

Gc(envp)

envp = ROOT

end procedure

function NeedBit()

integer b = nextbit()

assert(b!=-1,"UNEXPECTED EOF")

return b

end function

function Parse()

integer t, start = ep, p, bit

bool need = false

while true do

if ep+2>=length(mem) then grow_memory() end if

bit = nextbit()

if bit==-1 then

if not need then exit end if

crash("UNFINISHED EXPRESSION");

elsif bit then

t = 0

while NeedBit() do t+=1 end while

ep += 2

mem[ep-1..ep] = {VAR,t}

exit

elsif NeedBit() then

t = ep+1

ep += 2;

mem[t..t+1] = {APP,Parse()}

need = true

else

ep += 1

mem[ep] = ABS

end if

end while

return ep-start

end function

procedure Krivine(bool soe)

ep = 25

mem[1..24] = {APP, 21, ABS, APP, 9, VAR, 0, ABS, APP, ABS, APP, 2,

VAR, IOP, ABS, APP, 4, APP, 1, VAR, IOP, IOP, 0, APP}

mem[25] = Parse()

{nexts,envps,refs,terms} = {{0},{0},{1},{0}}

{b,frep,contp,envp,ip} = {0,0,0,ROOT,1}

while true do

integer mip = mem[ip]

-- (aside: there is simply no way to exit loop from within

-- switch in JavaScript, since break is overloaded,

-- hence also banned on desktop/Phix under with js.)

if (mip=ABS and not contp)

or length(outlog)>length(tgt) then -- (soe all done)

exit

end if

switch mip do

case VAR: Var();

case APP: App();

case ABS: Abs();

case IOP: Iop();

default: crash("CORRUPT TERM");

end switch

end while

if not soe then -- (which has a forced early exit)

int rc = mem[ip+2]

assert(rc=0,"CONTINUATIONS EXHAUSTED")

end if

printf(1,"\n\n")

end procedure

constant tests = {{"Quine","000101100100011010000000000001011011110010111100111111011111011010"&

"000101100100011010000000000001011011110010111100111111011111011010",1},

{"Quine8",x"16468005bcbcfdf68016468005bcbcfdf680",1},

{"Sieve of Eratosthenes",

"00010001100110010100011010000000010110000010010001010111110111101001000110100001110"&

"011010000000000101101110011100111111101111000000001111100110111000000101100000110110",

"0011010100010100010100010000010100000100010100010000010000010100000100010100000100010000010"&

"0000001000101000101000100000000000001000100000101000000000101000001000001000100000100000101"&

"0000000001010001010000000000010000000000010001010001000001010000000001000001000001000001010"&

"000010001010000000001000000000000010001010001000000000000010000010000000001010001000001000."},

{"100 doors",

"00010001000101010001101000000101100000110011101100101000110100000000001011111110000001"&

"01111101011001011001000110100001111100110100101111101111000000001011111111110110011001"&

"11111101110000000010111111000000101111101011001101110010101100000010111101100101111001"&

"1110011110110100000000001011011100111011110000000001000000111001110100000000101101110110",

"10010000100000010000000010000000000100000000000010000000000000010000000000000000100000"&

"00000000000001"},

{"342",

"0101000110100000000110000101100111100000100101111101111000010101100000000110000111110"&

"0000010111111011001011111101100101111010011101011110001000000101110010101000110100000"&

"0000010110000101011111101111100000010101111011111011111100001011000000101111111010110"&

"111000000111111000010110111101110011110100000010110000011011000100000101111000111001110",

"11010"},

{"0^0",

"0001010110100000010110111011010",

"1"},

{"Hello, World!",

" Hello, world!\n",2},

}

for ti,t in tests do

printf(1,"%s:\n",{t[1]})

src = t[2]

bitmode = (src[1]&&#FE)='0'

quine8 = ti==2

if ti<=2 then

if quine8 then

for c in src do

printf(1,"%02x",c)

end for

else

printf(1,src)

end if

printf(1," (src)\n")

end if

object t3 = t[3]

if integer(t3) then t3 = src[t3..$] end if

bool soe = t3[$]='.' -- (force an early quit)

-- (no point leaving it running if you(/I) can't

-- be bothered to verify the output properly...)

if soe then t3 = t3[1..$-1] end if

tgt = t3

{sdx,b,outlog,o,ob} = {0,0,"",0,0}

mem = repeat(0,M) -- if M=512, extended as needed (and it will be)

Krivine(soe)

integer ld = length(outlog)-length(tgt)

if ld then

assert(soe and ld==1)

outlog = outlog[1..$-1]

end if

assert(outlog==tgt)

end for

</syntaxhighlight>

{{out}}

<pre>

Quine:

000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010 (src)

000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010

Quine8:

16468005BCBCFDF68016468005BCBCFDF680 (src)

16468005BCBCFDF68016468005BCBCFDF680

Sieve of Eratosthenes:

0011010100010100010100010000010100000100010100010000010000010100000100010100000100010000010000000100010100010100010000000000000100010000010100000000010100000100000100010000010000010100000000010100010100000000000100000000000100010100010000010100000000010000010000010000010100000100010100000000010000000000000100010100010000000000000100000100000000010100010000010000

100 doors:

1001000010000001000000001000000000010000000000001000000000000001000000000000000010000000000000000001

342:

11010

0^0:

1

Hello, World!:

Hello, world!

</pre>