World's worst Scheme interpreter (for porting to 3DS SmileBASIC)

scheme.py

# https://gist.github.com/excelangue/f57822e37a9aa20f3168

# types
nil = 0
tnum = 1
tcons = 2
tsym = 3
tproc = 4
tfastcall = 5

# system calls
RESERVED = 2
fastcalls = ["" for x in range(0,RESERVED+1)]

splus = 1
fastcalls[splus] = "_plus"
sdefine = 2
fastcalls[sdefine] = "_define"

# memory allocation

HEAPSIZE = 2048
tospace = RESERVED
fromspace = int((HEAPSIZE + RESERVED) / 2)
heap = [[0 for x in range(4)] for x in range(HEAPSIZE)] # type, value, next, gc
hptr = RESERVED + 1

ATOMSIZE = 128
atoms = ["" for x in range(ATOMSIZE)]
aptr = 1

# memory management

def alloc():
	global hptr

	if (hptr + 1 > tospace + HEAPSIZE / 2):
		cheneygc(envptr, nil)
	if (hptr + 1 > tospace + HEAPSIZE / 2):
		error("out of memory")

	hptr += 1
	return hptr - 1

def cheneycopy(cell):
	if (heap[cell][3] == nil):
		heap[cell][3] = alloc()
		heap[heap[cell][3]][0] = heap[cell][0]
		heap[heap[cell][3]][1] = cheneycopy(heap[cell][1])
		heap[heap[cell][3]][3] = nil

		if (heap[cell][0] == tcons):
			if (heap[cell][2] != nil):
					heap[heap[cell][3]][2] = cheneycopy(heap[cell][2])

	return heap[cell][3]

def cheneygc(envptr, ccc):
	global fromspace, tospace, hptr
	freed = 0

	swap = fromspace
	fromspace = tospace
	tospace = swap

	hptr = tospace

	e = envptr
	newenv = cons(nil, nil)
	newenvptr = newenv

	while e:
		heap[newenvptr][1] = cheneycopy(heap[e][1])
		newenvptr = heap[cons(newenvptr, nil)][2]
		e = heap[e][2]

	return newenv

# cell manipulation

def strtoanum(ss):
	global atoms, aptr
	for i in range(0,aptr):
		if atoms[i] == ss.upper():
			return i
	atoms[aptr] = ss.upper()
	aptr += 1
	return aptr - 1

def strtocell(ss):
	global heap, hptr, atoms, aptr, tnum, tcons, tsym, tproc

	l = len(ss)
	cs = ss[0:1]
	if (cs == "-" and l >= 2) or (cs >= "0" and cs <= "9"):
		v = int(cs)
		p = alloc()
		heap[p][0] = tnum
		heap[p][1] = v
		return p
	if ss.upper() == "NIL":
		return nil
	i = strtoanum(ss)
	p = alloc()
	heap[p][0] = tsym
	heap[p][1] = i
	return p

def cons(car, cdr):
	global heap, hptr, atoms, aptr, tnum, tcons, tsym, tproc

	p = alloc()
	heap[p][0] = tcons
	heap[p][1] = car
	heap[p][2] = cdr
	return p

# car, cdr, and friends (convenience functions)

def car(x):
	return heap[x][1]

def cdr(x):
	return heap[x][2]

def cadr(x):
	return heap[heap[x][2]][1]

def caddr(x):
	return heap[heap[heap[x][2]][2]][1]

def cadar(x):
	return heap[heap[heap[x][1]][2]][1]

def caddar(x):
	return heap[heap[heap[heap[x][1]][2]][2]][1]

def cadddr(x):
	return heap[heap[heap[heap[x][2]][2]][2]][1]

def push(stack, item):
	return cons(item, stack)

def pop(stack):
	popped = data(stack)
	newstack = nex(stack)
	return (popped, newstack)

def peek(stack):
	return heap[stack][1]

def typ(cell):
	return heap[cell][0]

def data(cell):
	return heap[cell][1]

def nex(cell):
	return heap[cell][2]

def isnull(cell):
	return not heap[cell][1] and not heap[cell][2]

# list manipulation

def makelist(*items): # will be hard to implement, avoid
	global heap, hptr, atoms, aptr, tnum, tcons, tsym, tproc

	cell = cons(items[0], nil)
	res = cell
	for item in items[1:]:
		heap[cell][2] = cons(item, nil)
		cell = nex(cell)
	return res

def listappend(l1, l2):
	if not l1 or isnull(l1):
		return l2
	temp = l1
	while heap[temp][2] and not isnull(nex(temp)):
		temp = nex(temp)
	heap[temp][2] = l2
	return l1

def inlist(lst, i):
	while lst:
		if (data(lst) == i):
			return True
		lst = nex(lst)
	return False

def reverse(lst):
	print ("called reverse")
	revd = nil
	while lst and not isnull(lst):
		temp = lst
		lst = cdr(lst)
		heap[temp][2] = revd
		revd = temp
	return revd

# system interface

def error(message):
	print (message)
	import sys
	sys.exit()

def fastcall(fname, arglist, envptr):
	return globals()[fname](arglist, envptr)

def makefastcall(cellid):
	p = alloc()
	heap[p][0] = tfastcall
	heap[p][1] = cellid
	return p

def _plus(arglist, envptr):
	res = 0
	while arglist:
		cell = data(arglist)
		if (heap[cell][0] != tnum):
			error("expected a number in sum")
		res += data(cell)
		arglist = nex(arglist)
	return res

def _define(arglist, envptr):
	if (typ(car(arglist)) != tsym):
		error("expected a symbol name to define")
		return nil

	defvar(car(arglist), cadr(arglist), envptr)
	return nil

# REPL

def evaluate(cell, env):
	if (typ(cell) == tnil or typ(cell) == tnum):
		return cell
	elif (typ(cell) == tsym):
		return lookup(data(cell), env)

def write(cell):
	if (typ(cell) == tnum):
		print(data(cell))
	else:
		error("unknown type for " + str(cell))

# registers
envptr = cons(cons(nil, nil), nil)

# environment manipulation

def defvar(cell, value, env):
	anum = data(cell)
	frame = car(env)
	varlist = heap[frame][1]
	vallist = heap[frame][2]

	while varlist:
		if varlist == anum:
			heap[vallist][1] = value
			return
		varlist = nex(varlist)
		vallist = nex(vallist)
	heap[frame][1] = cons(cell, heap[frame][1])
	heap[frame][2] = cons(value, heap[frame][2])

def lookup(anum, env):
	e = env
	while e:
		frame = car(env)
		varlist = heap[frame][1]
		vallist = heap[frame][2]
		while varlist:
			if data(car(varlist)) == anum:
				return car(vallist)
			varlist = heap[varlist][2]
			vallist = heap[vallist][2]
		e = nex(e)
	error("unbound variable: " + atoms[anum])

def parse(sexp):
	atomend = "()\"'"
	whitespace = " \n"
	stack = cons(nil, nil)

	while sexp:
		c = sexp[:1]
		if (c not in atomend and c not in whitespace):
			res = c
			sexp = sexp[1:]
			while (sexp[:1] not in atomend and sexp[:1] not in whitespace):
				res += sexp[:1]
				sexp = sexp[1:]
			(popped, stack) = pop(stack)
			popped = listappend(popped, cons(strtocell(res), nil))
			stack = push(stack, popped)

		elif (c in atomend):
			if (c == '('):
				stack = push(stack, cons(nil, nil))
				sexp = sexp[1:]

			elif (c == ')'):
				(end, stack) = pop(stack)
				(start, stack) = pop(stack)

				if (typ(peek(end)) == tsym) and (atoms[data(peek(end))] == "QUOTE"):
					(quote, end) = pop(end)
					end = cons(quote, end)

				start = listappend(start, cons(end, nil))

				stack = push(stack, start)
				sexp = sexp[1:]

			elif (c == '\"'):
				pass
			elif (c == '\''):
				stack = push(stack, cons(strtocell("QUOTE"), nil))
				sexp = sexp[1:]

		elif (c in whitespace):
			sexp = sexp[1:]

	return pop(stack)[0]

def t(cell):
	th(cell, 0)

def th(cell, level):
	if (typ(cell) == nil):
		print ("{0}nil".format("  "*level))
		return
	elif (typ(cell) == tnum):
		print ("{0}{1} -> #{2}".format("  "*level, cell, data(cell)))
	elif (typ(cell) == tcons):
		print ("{0}{1} cons".format("  "*level, cell))
		th(data(cell), level + 1)
		th(nex(cell), level)
	elif (typ(cell) == tsym):
		print ("{0}{1} -> \"{2}\"".format("  "*level, cell, atoms[data(cell)]))
	elif (typ(cell) == tfastcall):
		print ("{0}{1} -> fastcall: {2}".format("  "*level, cell, fastcalls[data(cell)]))

defvar(strtocell("+"), makefastcall(splus), envptr)
defvar(strtocell("DEFINE"), makefastcall(sdefine), envptr)
print (fastcall(fastcalls[heap[lookup(strtoanum("+"), envptr)][1]], makelist(strtocell("1"), strtocell("2"), strtocell("3")), envptr))
print (fastcall(fastcalls[heap[lookup(strtoanum("define"), envptr)][1]], makelist(strtocell("meme"), strtocell("5")), envptr))

sexp = "(map (lam (n) (+ n 1)) '(1 2 3))"
print ("parse \"{0}\"".format(sexp))
t(parse(sexp))