## Eval, apply, and all that.
##
## [created.  -- rgr, 10-Jan-05.]
##
## $Id: toy-lisp.imc,v 1.68 2005/12/28 15:56:15 rogers Exp $
##
## To do:
##
##   Support package-use-list, exported vs. internal symbols, use to
## print symbol package prefixes correctly.  [done.  -- rgr, 4-Feb-05.]
##
##   ** Escaping lowercase symbol and package names.
##
##   Define simple conditional special forms (if, cond, and, or).  [done.  --
## rgr, 6-Mar-05.]
##
##   ** Add more arithmetic and list functions.
##
##   ** Read #-macros.  [e.g. #';  can't read "(* (reduce #'foo bar) 3)"
## without #-macros; must do "(* (reduce (function foo) bar) 3)" instead.
## -- rgr, 30-Jan-05.]
##
##   * Read backquote.
##

### Higher-level stuff for symbols and packages.

.namespace ["ParrotCL::Common_Lisp"]

## Define the NIL symbol.  It will get stuffed into the COMMON-LISP package
## later (since we need NIL to create the package).
.sub _symbol_setup
	.local pmc nil
	nil = new Undef
	## Store something in these now so that symbol creation/interning work.
	store_global "ParrotCL::Common_Lisp", "NIL", nil
	store_global "ParrotCL::Common_Lisp", "keyword_package", nil
	$P30 = new PerlHash
	$P1 = new String
	$P1 = "NIL"
	$P30["NAME"] = $P1
	find_type $I0, "ParrotCL::Common_Lisp::Symbol"
	nil = new $I0, $P30
	nil."_set_symbol_value"(nil)
	## nil."_set_property_list"(nil)
	store_global "ParrotCL::Common_Lisp", "NIL", nil
.end

.namespace ["ParrotCL::Common_Lisp::Symbol"]

## This is mostly for debugging.
.sub __get_string method
	.local string result
	result = self."symbol_name"()
	.return (result)
.end

.namespace ["ParrotCL::Common_Lisp::Package"]

## [bug:  this must also search nicknames.  -- rgr, 19-Jan-05.]
.sub package_name_equalp method
	.param pmc package_name
	.local pmc name
	.local pmc tail
	.local int result

	name = self."package__name"()
	result = iseq name, package_name

	.return (result)
.end

.sub print_object method
	.local pmc package_name
	print "#<package "
	package_name = self."package__name"()
	print package_name
	print ">"
.end

.sub _make_symbol
	.param pmc pname
	.local pmc sym

	## create a new symbol.
	$P30 = new PerlHash
	$P30["NAME"] = pname
	find_type $I0, "ParrotCL::Common_Lisp::Symbol"
	sym = new $I0, $P30

	.return (sym)
.end

.sub _package_intern method
	.param pmc symbol_or_name

	.local pmc nil
	.local int base
	classoffset base, self, "ParrotCL::Common_Lisp::Package"
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc symbol_name
	.local pmc sym
	.local int symbolp

	symbolp = isa symbol_or_name, "ParrotCL::Common_Lisp::Symbol"
	if symbolp goto intern_symbol
	symbol_name = symbol_or_name
	goto intern_thing
intern_symbol:
	symbol_name = symbol_or_name."symbol_name"()

intern_thing:
	.local pmc hash
	hash = self."package_external_symbols"()
	sym = hash[symbol_name]
	defined $I0, sym
	if $I0 goto intern_ret
	hash = self."package_internal_symbols"()
	sym = hash[symbol_name]
	defined $I0, sym
	if $I0 goto intern_ret

	## add a new symbol.
	if symbolp goto intern_have_sym
	## make a new symbol.
	$P0 = new String
	set $P0, symbol_name
	sym = _make_symbol($P0)
	goto intern_stuff_sym
intern_have_sym:
	sym = symbol_or_name
intern_stuff_sym:
	## update symbol_package.
	sym."_set_symbol_package"(self)
	## see if we need to export and hack the value for keywords.
	.local pmc keyword_package
	keyword_package = find_global "ParrotCL::Common_Lisp", "keyword_package"
	ne_addr self, keyword_package, intern_not_kwd
	sym."_set_symbol_value"(sym)
	hash = self."package_external_symbols"()
intern_not_kwd:
	$I34 = isa sym, "ParrotCL::Common_Lisp::Symbol"
	if $I34 goto intern_normal
	print "[intern of non-symbol '"
	_print(sym)
	print "'.]\n"
	die 5, 1
intern_normal:
	hash[symbol_name] = sym
intern_ret:
	.return (sym)
.end

.sub _package_export method
	.param pmc symbol

	.local pmc ext_hash
	.local pmc int_hash
	.local pmc symbol_name
	symbol_name = symbol."symbol_name"()

	## see if it's already exported.
	.local pmc sym
	ext_hash = self."package_external_symbols"()
	sym = ext_hash[symbol_name]
	eq_addr sym, symbol, export_ret
	## take it out of the internal hash . . .
	int_hash = self."package_internal_symbols"()
	delete int_hash[symbol_name]
	## . . . and add it to the external one.
	ext_hash[symbol_name] = symbol
export_ret:
	## Does not return anything useful.
.end

.namespace ["ParrotCL::Common_Lisp"]

.sub _make_package_internal
	.param string package_name

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	$I0 = find_type "ParrotCL::Common_Lisp::Package"
	$P1 = new PerlHash
	$P1["%USE-LIST"] = nil
	$P1["%USED-BY-LIST"] = nil
	$P1["%SHADOWING-SYMBOLS"] = nil
	$P0 = new String
	$P0 = package_name
	$P1["%NAME"] = $P0
	$P0 = new PerlHash
	$P1["INTERNAL-SYMBOLS"] = $P0
	$P0 = new PerlHash
	$P1["EXTERNAL-SYMBOLS"] = $P0
	result = new $I0, $P1
	.return (result)
.end

.sub _package_setup
	## set up the initial packages.  [need to also give them their
	## nicknames.  -- rgr, 19-Jan-05.]
	.local pmc lisp_package
	.local pmc kernel_package
	.local pmc system_package
	.local pmc keyword_package
	.local pmc user_package
	.local pmc ext_package
	.local pmc conditions_package
	$S0 = "COMMON-LISP"
	lisp_package = _make_package_internal($S0)
	store_global "ParrotCL::Common_Lisp", "lisp_package", lisp_package
	$S0 = "KERNEL"
	kernel_package = _make_package_internal($S0)
	store_global "ParrotCL::Common_Lisp", "kernel_package", kernel_package
	$S0 = "SYSTEM"
	system_package = _make_package_internal($S0)
	store_global "ParrotCL::Common_Lisp", "system_package", system_package
	$S0 = "KEYWORD"
	keyword_package = _make_package_internal($S0)
	store_global "ParrotCL::Common_Lisp", "keyword_package", keyword_package
	$S0 = "COMMON-LISP-USER"
	user_package = _make_package_internal($S0)
	store_global "ParrotCL::Common_Lisp", "user_package", user_package
	store_global "ParrotCL::Common_Lisp", "*PACKAGE*", user_package
	$S0 = "EXTENSIONS"
	ext_package = _make_package_internal($S0)
	store_global "ParrotCL::Common_Lisp", "ext_package", ext_package
	$S0 = "CONDITIONS"
	conditions_package = _make_package_internal($S0)
	$P0 = _list(ext_package, conditions_package, system_package)
	$P0 = _list_star(keyword_package, user_package, $P0)
	$P0 = _list_star(lisp_package, kernel_package, $P0)
	store_global "ParrotCL::Common_Lisp", "all_packages", $P0

	## intern NIL as the first symbol.
	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	lisp_package."_package_intern"(nil)
	lisp_package."_package_export"(nil)
	## and T as the second.
	.local pmc const_t
	$P1 = new String
	$P1 = "T"
	const_t = lisp_package."_package_intern"($P1)
	lisp_package."_package_export"(const_t)
	store_global "ParrotCL::Common_Lisp", "T", const_t
	const_t."_set_symbol_value"(const_t)
	## const_t."_set_property_list"(nil)

	.local pmc const_quote
	$P33 = new String
	$P33 = "QUOTE"
	const_quote = lisp_package."_package_intern"($P33)
	lisp_package."_package_export"(const_quote)
	store_global "ParrotCL::Common_Lisp", "quote_symbol", const_quote

	.local pmc const_setq
	$P33 = new String
	$P33 = "SETQ"
	const_setq = lisp_package."_package_intern"($P33)
	lisp_package."_package_export"(const_setq)
	store_global "ParrotCL::Common_Lisp", "setq_symbol", const_setq

	## set up "package-use-list" for key packages (needed by intern).
	$P33 = _list(ext_package, system_package, lisp_package)
	kernel_package."_set_package__use_list"($P33)
	$P33 = _list(kernel_package, ext_package, lisp_package)
	system_package."_set_package__use_list"($P33)
	$P33 = _list(system_package, lisp_package)
	ext_package."_set_package__use_list"($P33)
	$P33 = _list(ext_package, lisp_package)
	user_package."_set_package__use_list"($P33)

	## define the lisp::*keyword-package* variable.
	$P34 = new String
	$P34 = "*KEYWORD-PACKAGE*"
	$P35 = lisp_package."_package_intern"($P34)
	$P35."_set_symbol_value"(keyword_package)

	## define the lisp:*package* variable.
	$P36 = new String
	$P36 = "*PACKAGE*"
	$P37 = lisp_package."_package_intern"($P36)
	lisp_package."_package_export"($P37)
	$P37."_set_symbol_value"(user_package)

	## set up some keywords needed by _find_symbol.
	.local pmc sym
	.local pmc pname
	pname = new String
	pname = "INHERITED"
	sym = keyword_package."_package_intern"(pname)
	store_global "ParrotCL::Common_Lisp", ":INHERITED", sym
	pname = new String
	pname = "EXTERNAL"
	sym = keyword_package."_package_intern"(pname)
	store_global "ParrotCL::Common_Lisp", ":EXTERNAL", sym
	pname = new String
	pname = "INTERNAL"
	sym = keyword_package."_package_intern"(pname)
	store_global "ParrotCL::Common_Lisp", ":INTERNAL", sym
.end

### Low-level stream support.

.namespace ["ParrotCL::Common_Lisp::Lisp_Stream"]

.sub print_object method
	print "#<stream "
	print ">"
.end

.sub stream_unread_char method
	.param pmc character

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	.local pmc char

	char = self."lisp_stream_unread_char"()
	eq_addr char, nil, unread_ok
	$P0 = new .Exception
	$P0["_message"] = "Double unread-char.\n"
	throw $P0
unread_ok_verbose:
	print "[unread "
	_print(character)
	print "]\n"
unread_ok:
	self."_set_lisp_stream_unread_char"(character)
.end

.sub stream_read_char method
	.param pmc eof_error_p
	.param pmc eof_value
	.param pmc recursive_p

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	.local pmc char

	char = self."lisp_stream_unread_char"()
	eq_addr char, nil, read_really
	self."_set_lisp_stream_unread_char"(nil)
	goto ret_char
read_really:
	.local pmc stream
	stream = self."lisp_stream_parrot_input_stream"()
	ne_addr stream, nil, got_stream
	$P0 = new .Exception
	$P0["_message"] = "Attempt to read from an output stream.\n"
	throw $P0
got_stream:
	.local string input_string
	.local int len
	input_string = read stream, 1
	len = length input_string
	if len > 0 goto got_char
	char = eof_value
	eq_addr eof_error_p, nil, ret_char
	$P0 = new .Exception
	$P0["_message"] = "EOF encountered in READ-CHAR.\n"
	throw $P0
got_char:
	.local int char_code
	char_code = ord input_string
	## [this breaks the reader.  -- rgr, 2-Jun-05.]
	## $P85 = new PerlInt
	## $P85 = char_code
	## $P86 = getclass "Character"
	## char = $P86."instantiate"($P85)
	char = new PerlInt
	char = char_code
	goto ret_char
ret_char_verbose:
	print "[read "
	_print(char)
	print "]\n"
ret_char:
	.return (char)
.end

.sub stream_write_char method
	.param pmc character

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc stream
	stream = self."lisp_stream_parrot_output_stream"()
	ne_addr stream, nil, got_stream
	$P0 = new .Exception
	$P0["_message"] = "Attempt to write to an input stream.\n"
	throw $P0
got_stream:
	$I52 = find_type "Character"
	$I41 = typeof character
	if $I52 != $I41 goto non_char
	$I0 = character[0]
	goto got_int
non_char:
	$I0 = character
	goto got_int
	## [not ready for this yet.  -- rgr, 3-Jun-05.]
	$P0 = new .Exception
	$P0["_message"] = "Non-character argument to STREAM-WRITE-CHAR.\n"
	throw $P0
got_int:
	$S0 = chr $I0
	print stream, $S0
	.return (character)
.end

.sub stream_write_string method
	.param pmc output_string
	.param pmc start
	.param pmc end

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc stream
	stream = self."lisp_stream_parrot_output_stream"()
	ne_addr stream, nil, got_stream
	$P0 = new .Exception
	$P0["_message"] = "Attempt to write to an input stream.\n"
	throw $P0
got_stream:
	.local string str
	.local int len
	.local int iend
	.local int istart
	str = output_string
	len = length str
	istart = start
	eq_addr end, nil, default_end
	iend = end
	goto got_end
default_end:
	iend = len
got_end:
	if istart != 0 goto substring
	if iend == len goto write_it
substring:
	.local string new_string
	## NB:  Common Lisp end indices are always exclusive.
	len = iend - istart
	new_string = substr output_string, istart, len
	print stream, new_string
	goto done
write_it:
	print stream, output_string
done:
	.return (output_string)
.end

### FDEFN objects.

## These are named holders for functions.

.namespace ["ParrotCL::Common_Lisp::Fdefn"]

## This is just for debugging.
.sub __get_string method
	.local string result
	result = "#<Fdefn object>"
	.return (result)
.end

.namespace ["ParrotCL::Common_Lisp"]

## For .INTERPINFO_CURRENT_CONT
.include "interpinfo.pasm"
## For .PerlNum, etc.
.include "pmctypes.pasm"

.sub _error_prin1
	.param pmc thing

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	push_eh oops
	$P38 = new String
	$P38 = "PRIN1"
	$P39 = _intern($P38)
	.local pmc fdefn
	fdefn = _fdefinition_object($P39, nil)
	## can't do much if no PRIN1.
	eq_addr fdefn, nil, oops
	.local pmc lisp_prin1
	lisp_prin1 = fdefn."fdefn_function"()
	$I33 = defined lisp_prin1
	unless $I33 goto oops
	lisp_prin1(thing)
oops:
.end

## Returns undef if it can't find it, for easy testing.
## This is used to fetch keyword args from disembodied plists.
.sub _get_keyword_arg
	.param pmc arglist
	.param pmc key

	.local pmc tail
	.local pmc arg
	.local pmc result
	.local pmc found_p
	tail = arglist
fka_loop:
	isa $I0, tail, "ParrotCL::Common_Lisp::Cons"
	unless $I0 goto fka_lose
	arg = tail."car"()
	tail = tail."cdr"()
	ne_addr arg, key, fka_next
	## found it.
	result = tail."car"()
	found_p = find_global "ParrotCL::Common_Lisp", "T"
	goto fka_ret
fka_next:
	tail = tail."cdr"()
	goto fka_loop
fka_lose:
	result = find_global "ParrotCL::Common_Lisp", "NIL"
	found_p = result
fka_ret:
	.return (result, found_p)
.end

### More FDEFN stuff.

## [based on src/code/fdefinition.lisp from CMUCL.  -- rgr, 7-Feb-05.]

.sub _fdefinition_object
	.param pmc name
	.param pmc create

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc fdefn
	$I33 = isa name, "ParrotCL::Common_Lisp::Symbol"
	unless $I33 goto fdo_not_symbol
	fdefn = name."symbol_function"()
	$I33 = defined fdefn
	if $I33 goto fdo_ret
	eq_addr create, nil, fdo_none
	## create a new fdefn object.
	$P34 = new PerlHash
	$P34["NAME"] = name
	find_type $I35, "ParrotCL::Common_Lisp::Fdefn"
	fdefn = new $I35, $P34
	name."_set_symbol_function"(fdefn)
	goto fdo_ret
fdo_none:
	fdefn = nil
	goto fdo_ret
fdo_not_symbol:
	$S0 = typeof name
	$I33 = isa name, "ParrotCL::Common_Lisp::Cons"
	unless $I33 goto unhandled
	.local pmc setf_name
	## [bug:  we assume the car is the symbol SETF.  -- rgr, 24-Dec-05.]
	setf_name = name."cdr"()
	$I33 = isa setf_name, "ParrotCL::Common_Lisp::Cons"
	unless $I33 goto unhandled
	setf_name = setf_name."car"()
	$I33 = isa setf_name, "ParrotCL::Common_Lisp::Symbol"
	unless $I33 goto unhandled
	## properly constructed setf function name.
	fdefn = setf_name."symbol_setf_function"()
	$I33 = defined fdefn
	if $I33 goto fdo_ret
	eq_addr create, nil, fdo_none
	## create a new fdefn object for the setf fn.
	$P34 = new PerlHash
	$P34["NAME"] = name
	find_type $I35, "ParrotCL::Common_Lisp::Fdefn"
	fdefn = new $I35, $P34
	setf_name."_set_symbol_setf_function"(fdefn)
	goto fdo_ret
unhandled:
	print "_fdefinition_object:  Can't handle this:  '"
	_error_prin1(name)
	print "'.\n"
	$P0 = new .Exception
	$P0["_message"] = "_fdefinition_object:  Unsupported.\n"
	throw $P0
fdo_ret:
	.return (fdefn)
.end

.sub _fdefn_or_lose
	.param pmc name

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc fn
	.local pmc fdefn
	$I0 = isa name, 'Sub'
	unless $I0 goto not_sub
	fn = name
	goto fol_ret
not_sub: 
	fdefn = _fdefinition_object(name, nil)
	eq_addr fdefn, nil, fol_lose
	fn = fdefn."fdefn_function"()
	$I33 = defined fn
	if $I33 goto fol_ret
fol_lose:
	print "_fdefn_or_lose:  '"
	_error_prin1(name)
	print "' is an undefined function.\n"
	$P0 = new .Exception
	$P0["_message"] = "Undefined function.\n"
	throw $P0
fol_ret:
	.return (fn)
.end

## [this may not be the best idea . . .  -- rgr, 13-Feb-05.]
.sub _fdefn_function_or_lose
	.param pmc fdefn

	.local pmc fn
	fn = fdefn."fdefn_function"()
	$I33 = defined fn
	unless $I33 goto fol_lose
	.return (fn)
fol_lose:
	.local pmc name
	name = fdefn."fdefn_name"()
	print "_fdefn_function_or_lose:  '"
	_error_prin1(name)
	print "' is an undefined function.\n"
	$P0 = new .Exception
	$P0["_message"] = "Undefined function.\n"
	throw $P0
.end

## based on the %set-fdefinition function, which is what (setf fdefinition)
## expands into.
.sub _set_fdefinition
	.param pmc function_name
	.param pmc new_value

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	.local pmc t
	t = find_global "ParrotCL::Common_Lisp", "T"

	.local pmc fdefn
	fdefn = _fdefinition_object(function_name, t)
	## the original definition loops over *setf-fdefinition-hook*, then
	## looks for fwrappers:last-fwrapper.
	fdefn."_set_fdefn_function"(new_value)
	.return (new_value)
.end

## This just sets the fdefinition to the null PMC.
.sub _fdefn_makunbound
	.param pmc fdefn

	.local pmc unbound
	null unbound
	fdefn."_set_fdefn_function"(unbound)
	.return (fdefn)
.end

### FIND-PACKAGE, FIND-SYMBOL, INTERN, and support.

## Similar to find-symbol, but only looks for an external symbol.
## This is used for fast name-conflict checking ... and symbol
## printing in the printer.
##
## we assume we have a print-name string and a package.
.sub _find_external_symbol
	.param pmc pname
	.param pmc package

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	.local pmc where

	.local pmc hash
	hash = package."package_external_symbols"()
	result = hash[pname]
	defined $I33, result
	unless $I33 goto fes_5
	where = find_global "ParrotCL::Common_Lisp", ":EXTERNAL"
	goto fes_ret
fes_5:
	where = nil
	result = nil
fes_ret:
	.return (result, where)
.end

## Take a package-or-string-or-symbol and return a package.
## [extended to return *PACKAGE* for NIL.  -- rgr, 12-Feb-05.]
.sub _package_or_lose
	.param pmc package_name

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc package
	ne_addr package_name, nil, pol_1
	package = find_global "ParrotCL::Common_Lisp", "*PACKAGE*"
	goto pol_ret
pol_1:
	.local int packagep
	packagep = isa package_name, "ParrotCL::Common_Lisp::Package"
	unless packagep goto pol_find
	package = package_name
	goto pol_ret
pol_find:
	## assume this is a package name.
	package = _find_package(package_name)
	ne_addr package, nil, pol_ret
	printerr "Can't find package named '"
	printerr package_name
	printerr "'.\n"
	die 5, 1
pol_ret:
	.return (package)
.end

## [this doesn't support stringables yet.  -- rgr, 2-Feb-05.]
.sub _find_symbol
	.param pmc symbol_name
	.param pmc package_name :optional
	.param int package_name_p :opt_flag

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	.local pmc where
	.local pmc package
	result = nil
	where = nil

	if package_name_p goto fs_find_pkg
	package = find_global "ParrotCL::Common_Lisp", "*PACKAGE*"
	goto fs_2
fs_find_pkg:
	package = _package_or_lose(package_name)
fs_2:
	.local string pname
	pname = symbol_name
	.local pmc hash
	hash = package."package_internal_symbols"()
	result = hash[pname]
	defined $I33, result
	unless $I33 goto fs_5
	where = find_global "ParrotCL::Common_Lisp", ":INTERNAL"
	goto fs_ret
fs_5:
	hash = package."package_external_symbols"()
	result = hash[pname]
	defined $I33, result
	unless $I33 goto fs_6
	where = find_global "ParrotCL::Common_Lisp", ":EXTERNAL"
	goto fs_ret
fs_6:
	## search package-use-list.
	.local pmc package_tail
	package_tail = package."package__use_list"()
	goto fs_test
fs_loop:
	package = package_tail."car"()
	hash = package."package_external_symbols"()
	result = hash[pname]
	defined $I33, result
	unless $I33 goto fs_next
	where = find_global "ParrotCL::Common_Lisp", ":INHERITED"
	goto fs_ret
fs_next:
	package_tail = package_tail."cdr"()
fs_test:
	ne_addr package_tail, nil, fs_loop
	result = nil
	goto fs_ret

fs_ret_verbose:
	print "[_find_symbol:  returning '"
	_print(result)
	print "' and '"
	_print(where)
	print "'.]\n"
fs_ret:
	.return (result, where)
.end

## Similar to find-symbol, but only looks for an external symbol.
.sub _find_external_symbol
	.param pmc symbol_name
	.param pmc package

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	.local pmc where
	result = nil
	where = nil

	## [how do we check this in the new calling scheme?  -- rgr, 23-Nov-05.]
	## if argcP == 2 goto fs_2
	goto fs_2
	$P0 = new .Exception
	$P0["_message"] = "Wrong number of args to LISP::FIND-EXTERNAL-SYMBOL.\n"
	throw $P0
fs_2:
	.local string pname
	pname = symbol_name
	.local pmc hash
	hash = package."package_external_symbols"()
	result = hash[pname]
	$I33 = defined result
	unless $I33 goto fs_ret
	where = find_global "ParrotCL::Common_Lisp", ":EXTERNAL"
fs_ret:
	.return (result, where)
.end

.sub _find_package
	.param pmc package_name
	.local pmc tail
	.local pmc result
	.local pmc nil

	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	result = nil
	tail = find_global "ParrotCL::Common_Lisp", "all_packages"
	$I33 = isa package_name, "ParrotCL::Common_Lisp::Symbol"
	unless $I33 goto fp_tail
	package_name = package_name."symbol_name"()
fp_tail:
	eq_addr tail, nil, fp_ret
	$P33 = tail."car"()
	$I34 = $P33."package_name_equalp"(package_name)
	unless $I34 goto _find_package_next
	result = $P33
	goto fp_ret
_find_package_next:
	tail = tail."cdr"()
	goto fp_tail

fp_ret:
	.return (result)
.end

.sub _intern
	.param pmc pname :optional
	.param int pname_p :opt_flag
	.param pmc package :optional
	.param int package_p :opt_flag
	.local PerlArray sym

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	if pname_p goto intern_args
intern_bad_arg:
	printerr "_intern:  Wrong number of args to _intern "
	printerr ", expected 1 or 2.\n"
	die 5, 1
intern_args:
	if package_p goto intern_find_pkg
	package = find_global "ParrotCL::Common_Lisp", "*PACKAGE*"
	goto intern_2
intern_find_pkg:
	.local int packagep
	packagep = isa package, "ParrotCL::Common_Lisp::Package"
	if packagep goto intern_2
	## assume this is a package name.
	.local pmc package_name
	package_name = package
	package = _find_package(package)
	ne_addr package, nil, intern_2
	printerr "_intern:  Can't find package named '"
	printerr package_name
	printerr "'.\n"
	die 5, 1
intern_2:
	## Have package, now look for a symbol.
	.local pmc where
	.local pmc pname_string
	pname_string = new String
	pname_string = pname
	(sym, where) = _find_symbol(pname_string, package)
	ne_addr where, nil, intern_ret
	## No symbol, must create a new one.
	sym = package."_package_intern"(pname_string)
	where = find_global "ParrotCL::Common_Lisp", ":INTERNAL"
intern_ret:
	.return (sym, where)
.end

.sub _export
	.param pmc symbols
	.param pmc package_name :optional
	.param int package_name_p :opt_flag

	.local pmc nil
	.local pmc t
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	t = find_global "ParrotCL::Common_Lisp", "T"

	.local pmc package
	if package_name_p goto find_pkg
	package = find_global "ParrotCL::Common_Lisp", "*PACKAGE*"
	goto doit
find_pkg:
	package = _package_or_lose(package_name)
doit:
	.local pmc tail
	.local pmc sym
	tail = symbols
export_next:
	eq_addr tail, nil, export_ret
	$I33 = isa tail, "ParrotCL::Common_Lisp::Cons"
	unless $I33 goto atom_yes
	sym = tail."car"()
	tail = tail."cdr"()
	goto export_this
atom_yes:
	sym = tail
	tail = nil
export_this:
	$I33 = isa sym, "ParrotCL::Common_Lisp::Symbol"
	if $I33 goto symbol_yes
	print "Export of non-symbol "
	_print(sym)
	print ".\n"
	printerr "Died.\n"
	die 5, 1
symbol_yes:
	package."_package_export"(sym)
	goto export_next
export_ret:
	.return (t)
.end

### Other Lisp primitives.

.sub _cons
	.param pmc car
	.param pmc cdr
	.local pmc cons
	.local pmc hash

	hash = new PerlHash
	hash["CAR"] = car
	hash["CDR"] = cdr
	find_type $I0, "ParrotCL::Common_Lisp::Cons"
	cons = new $I0, hash
	.return (cons)
.end

## This is not quite an accessor; it must return NIL if given NIL.  For this
## reason, we have to define it here, overriding the compiled slot accessors of
## the compiled structures.imc file.
.sub _car
	.param pmc thing

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	result = nil
	eq_addr thing, nil, car_ret
	$I33 = isa thing, "ParrotCL::Common_Lisp::Cons"
	if $I33 goto car_cons
	print "CAR of non-list '"
	_error_prin1(thing)
	print "'.\n"
	$P0 = new .Exception
	$P0["_message"] = "CAR of non-list\n"
	throw $P0
car_cons:
	result = thing."car"()
car_ret:
	.return (result)
.end

## This is not quite an accessor, either.
.sub _cdr
	.param pmc thing

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	result = nil
	eq_addr thing, nil, cdr_ret
	$I33 = isa thing, "ParrotCL::Common_Lisp::Cons"
	if $I33 goto cdr_cons
	print "CDR of non-list '"
	_error_prin1(thing)
	print "'.\n"
	$P0 = new .Exception
	$P0["_message"] = "CDR of non-list\n"
	throw $P0
cdr_cons:
	result = thing."cdr"()
cdr_ret:
	.return (result)
.end

.sub _list
	.param pmc argv :slurpy

	.local int argc
	.local pmc list

	argc = argv
	list = find_global "ParrotCL::Common_Lisp", "NIL"
list_tail:
	if argc == 0 goto _list_ret
	dec argc
	$P33 = argv[argc]
	list = _cons($P33, list)
	goto list_tail
_list_ret:
	.return (list)
.end

.sub _list_star
	.param pmc argv :slurpy

	.local int argc
	.local pmc list

	argc = argv
	if argc != 0 goto list_nontrivial
	list = find_global "ParrotCL::Common_Lisp", "NIL"
	goto _list_ret
list_nontrivial:
	dec argc
	list = argv[argc]
list_tail:
	if argc == 0 goto _list_ret
	dec argc
	$P33 = argv[argc]
	list = _cons($P33, list)
	goto list_tail
_list_ret:
	.return (list)
.end

## make sure that the float has a nonempty decimal fraction.
.sub _output_float
	.param pmc thing

	$S30 = thing
	$I31 = index $S30, "."
	if $I31 >= 0 goto float_decimal
	concat $S30, ".0"
float_decimal: 
	print $S30
.end

## [bug:  doesn't handle escaping.  -- rgr, 31-May-05.]
.sub _output_string
	.param pmc thing
	print '"'
	print thing
	print '"'
.end

.sub _output_integer
	.param pmc thing
	print thing
.end

### Defining symbols with function bindings.

## This is a helper function for load-time creation of funcallable symbols.
.sub _define_lisp_primitive
	.param string pname
	.param pmc function
	.param int export_p :optional
	.param int export_p_p :opt_flag

	.local pmc lisp_package
	lisp_package = find_global "ParrotCL::Common_Lisp", "lisp_package"

	if export_p_p goto got_export_p
	export_p = 1
got_export_p:
	.local pmc print_name
	print_name = new String
	print_name = pname
	.local pmc fn
	fn = lisp_package."_package_intern"(print_name)
	unless export_p goto set_fdefn
	_export(fn, lisp_package)
set_fdefn:
	_set_fdefinition(fn, function)
	.local pmc fn_check
	fn_check = fn."symbol_function"()
	$P33 = new Null
	eq_addr fn_check, $P33, dlp_oops
	goto dlp_ret
dlp_oops:
	print "[oops; didn't set "
	print pname
	print " function.]\n"
	die 5, 1
dlp_ret:
	.return (fn)
.end

## Set up primitives defined in this file.  Some of these must be defined here
## because they are needed at load time.  [indeed, some of them are needed at
## load time by structures.imc, which is the first file.  -- rgr, 24-Dec-05.]
.sub _define_primitives
	## things which should not be exported.
	.const .Sub f1 = "_fdefinition_object"
	_define_lisp_primitive("FDEFINITION-OBJECT", f1, 0)
	.const .Sub f2 = "_fdefn_makunbound"
	_define_lisp_primitive("FDEFN-MAKUNBOUND", f2, 0)
	.const .Sub fes = "_find_external_symbol"
	_define_lisp_primitive("FIND-EXTERNAL-SYMBOL", fes, 0)
	.const .Sub pol = "_package_or_lose"
	_define_lisp_primitive("PACKAGE-OR-LOSE", pol, 0)
	## normal Lisp primitives defined in this file.
	.const .Sub cons = "_cons"
	_define_lisp_primitive("CONS", cons)
	.const .Sub list = "_list"
	_define_lisp_primitive("LIST", list)
	.const .Sub list_star = "_list_star"
	_define_lisp_primitive("LIST*", list_star)
	.const .Sub fs = "_find_symbol"
	_define_lisp_primitive("FIND-SYMBOL", fs)
	.const .Sub fp = "_find_package"
	_define_lisp_primitive("FIND-PACKAGE", fp)
	.const .Sub intern = "_intern"
	_define_lisp_primitive("INTERN", intern)
	.const .Sub export = "_export"
	_define_lisp_primitive("EXPORT", export)
.end

## this needs to be separate so that it can be used to override the accessors
## defined in structures.lisp, which don't handle NIL.  -- rgr, 24-Dec-05.
.sub _define_more_primitives
	.const .Sub car = "_car"
	_define_lisp_primitive("CAR", car)
	.const .Sub cdr = "_cdr"
	_define_lisp_primitive("CDR", cdr)
	.const .Sub values = "_values"
	_define_lisp_primitive("VALUES", values)
	.const .Sub values_list = "_values_list"
	_define_lisp_primitive("VALUES-LIST", values_list)
	.const .Sub funcall = "_funcall"
	_define_lisp_primitive("FUNCALL", funcall)
	.const .Sub apply = "_apply"
	_define_lisp_primitive("APPLY", apply)
	.const .Sub eval = "_eval"
	_define_lisp_primitive("EVAL", eval)
	.const .Sub lisp_load = "_lisp_load"
	_define_lisp_primitive("LOAD", lisp_load)
	## these are kludges for printing; none should be exported.
	.const .Sub os = "_output_string"
	_define_lisp_primitive("OUTPUT-STRING", os, 0)
	.const .Sub of = "_output_float"
	_define_lisp_primitive("OUTPUT-FLOAT", of, 0)
	.const .Sub oi = "_output_integer"
	_define_lisp_primitive("OUTPUT-INTEGER", oi, 0)
.end

## This may look pointless, but it allows "(apply #'values 1 2 (list 3 4))", for
## example.
.sub _values
	.param pmc args :slurpy
	.return (args :flat)
.end

## 
.sub _values_list
	.param pmc list
	$P34 = new PerlArray

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	result = new ResizablePMCArray
	result = 0
next_value:
	eq_addr list, nil, done
	$I33 = isa list, "ParrotCL::Common_Lisp::Cons"
	unless $I33 goto not_proper_list
	$P35 = list."car"()
	push result, $P35
	list = list."cdr"()
	goto next_value
not_proper_list: 
	$P0 = new .Exception
	$S0 = "VALUES-LIST:  Not a proper list.\n"
	$P0["_message"] = $S0
	throw $P0
done:
	.return (result :flat)
.end

## If it hasn't got a FUNCALL, it isn't a Lisp.
.sub _funcall
	.param pmc function
	.param pmc argv :slurpy

	.local pmc fn_binding
	fn_binding = _fdefn_or_lose(function)
	.return fn_binding(argv :flat)
.end

## If it hasn't got an APPLY, it isn't a Lisp.
.sub _apply
	.param pmc function
	.param pmc argv :slurpy

	.local int argc
	argc = argv

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc fn_binding
	fn_binding = _fdefn_or_lose(function)
	## the last array element will be a list of other args.
	## [it didn't work to try to push them onto argv; i think that's because
	## parrot creates a fixed-length array.  -- rgr, 8-Feb-05.]
	.local pmc list_args
	.local pmc more_args
	list_args = pop argv
	more_args = new PerlArray
	eq_addr list_args, nil, apply_doit
apply_next:
	$P33 = list_args."car"()
	push more_args, $P33
	list_args = list_args."cdr"()
	ne_addr list_args, nil, apply_next
apply_doit:
	.return fn_binding(argv :flat, more_args :flat)
.end

### Primitive evaluator.

.sub _eval
	.param pmc expression

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc result
	$I33 = isa expression, "ParrotCL::Common_Lisp::Symbol"
	unless $I33 goto eval_not_sym
	## print "[eval symbol]\n"
	result = expression."symbol_value"()
	$I42 = defined result
	if $I42 goto eval_ret
	$P0 = new .Exception
	$S0 = "Unbound variable '"
	$S1 = expression
	concat $S0, $S1
	concat $S0, "' in EVAL.\n"
	$P0["_message"] = $S0
	throw $P0
eval_not_sym:
	$I33 = isa expression, "ParrotCL::Common_Lisp::Cons"
	unless $I33 goto eval_not_cons
	## print "[eval cons]\n"
	.local pmc function
	.local pmc args
	function = expression."car"()
	args = expression."cdr"()
	$I33 = isa function, "ParrotCL::Common_Lisp::Symbol"
	if $I33 goto eval_func_sym
	print "_eval:  expression \""
	_print(expression)
	print "\" has an invalid function.\n"
	printerr "Died.\n"
	die 5, 1
eval_func_sym:
	.local pmc quote
	quote = find_global "ParrotCL::Common_Lisp", "quote_symbol"
	ne_addr function, quote, eval_func_not_quote

	## Quoted expression.
	result = args."car"()
	goto eval_ret
eval_func_not_quote:
	.local pmc setq
	setq = find_global "ParrotCL::Common_Lisp", "setq_symbol"
	ne_addr function, setq, eval_func_not_setq

	## Setq special form.
	.local pmc symbol
	.local pmc value
	symbol = args."car"()
	$I33 = isa symbol, "ParrotCL::Common_Lisp::Symbol"
	unless $I33 goto eval_setq_not_sym
	args = args."cdr"()
	value = args."car"()
	result = _eval(value)
	symbol."_set_symbol_value"(result)
	goto eval_ret
eval_setq_not_sym:
	print "_eval:  Non-symbol '"
	_print(symbol)
	print "' as first arg to 'setq'.\n"
	printerr "Died.\n"
	die 5, 1

eval_func_not_setq:
eval_funcall:
	.local pmc fn_binding
	fn_binding = _fdefn_or_lose(function)
	## we now evaluate the arguments, converting the list into a PerlArray
	## as we go so that we can apply it . . .
	$P34 = new PerlArray
eval_args_next:
	eq_addr args, nil, eval_args_done
	$P35 = args."car"()
	$P36 = _eval($P35)
	push $P34, $P36
	args = args."cdr"()
	goto eval_args_next
eval_not_cons:
	result = expression
eval_ret:
	.return (result)
eval_args_done:
	.return fn_binding($P34 :flat)
.end

## Given an array as our sole parameter, turn it into a list.
.sub _listify_array
	.param pmc array

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	## set up the iteration, counting i from the length down to 0.
	.local pmc result
	.local int i
	result = nil
	i = array

	## test for empty array.  at this point, i is past the last elt.
	if i == 0 goto listify_ret
listify_args_next:
	i = i - 1
	## i now points to the last elt
	$P36 = array[i]
	result = _cons($P36, result)
	## if we just consed elt 0, we're done.
	if i > 0 goto listify_args_next
listify_ret:
	.return (result)
.end

### Other stub functionality.

.sub _lisp_load
	.param pmc file_name

	.local pmc t
	t = find_global "ParrotCL::Common_Lisp", "T"
	.local pmc current_package_sym
	$P40 = new String
	$P40 = "*PACKAGE*"
	current_package_sym = _intern($P40)

	## need to "bind" *PACKAGE* here.  this isn't complete, as it leaves the
	## new value in effect on nonlocal exit.  loading.
	.local pmc old_package
	old_package = current_package_sym."symbol_value"()
	## do the load.
	$S0 = file_name
	load_bytecode $S0
	## restore the package.
	current_package_sym."_set_symbol_value"(old_package)
	.return (t)
.end

### Top-level read/eval/print loop.

## Builds the standard streams.
.sub _init_streams
	.local pmc stream
	.local pmc hash

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	.local pmc lisp_package
	lisp_package = find_global "ParrotCL::Common_Lisp", "lisp_package"
	.local pmc stream_name

	find_type $I0, "ParrotCL::Common_Lisp::Lisp_Stream"
	hash = new PerlHash
	hash["UNREAD-CHAR"] = nil
	hash["PARROT-OUTPUT-STREAM"] = nil
	stream = getstdin
	hash["PARROT-INPUT-STREAM"] = stream
	stream = new $I0, hash
	$P1 = new String
	$P1 = "*STANDARD-INPUT*"
	stream_name = lisp_package."_package_intern"($P1)
	lisp_package."_package_export"(stream_name)
	stream_name."_set_symbol_value"(stream)
	## store_global "ParrotCL::Common_Lisp", "*STANDARD-INPUT*", stream_name
	stream = getstdout
	pioctl $I2, stream, 3, 0
	unless $I2 goto pioctl_done
	print "[pioctl for stdout returned "
	print $I2
	print "]\n"
pioctl_done:
	hash["PARROT-OUTPUT-STREAM"] = stream
	hash["PARROT-INPUT-STREAM"] = nil
	stream = new $I0, hash
	$P1 = new String
	$P1 = "*STANDARD-OUTPUT*"
	stream_name = lisp_package."_package_intern"($P1)
	lisp_package."_package_export"(stream_name)
	stream_name."_set_symbol_value"(stream)
	## store_global "ParrotCL::Common_Lisp", "*STANDARD-OUTPUT*", stream_name
.end

## We have to split this out and stuff it in a global so that structures.pbc
## can call it before attempting to define functions.
.sub _fdefn_init_kludge
	_symbol_setup()
	_package_setup()
	_define_primitives()
.end

.sub _main @MAIN
	loadlib $P1, "dynclasses/character"
	$P0 = getclass "Character"
	$I0 = defined $P0
	if $I0 goto load2
	printerr "Bug:  Couldn't find 'Character' class after loading "
	print $P1
	printerr ".\n"
	die 5, 1
load2:
	## NB:  We can't use _lisp_load on structures.pbc, because it's too
	## early in the load process for it to work.
	load_bytecode "structures.pbc"
	_define_more_primitives()
	## load_bytecode "dump-methods.imc"
	$P1 = new String
	$P1 = "fdefinition.pbc"
	_lisp_load($P1)
	$P2 = new String
	$P2 = "symbol.pbc"
	_lisp_load($P2)
	$P3 = new String
	$P3 = "list.pbc"
	_lisp_load($P3)
	$P4 = new String
	$P4 = "stream.pbc"
	_lisp_load($P4)
	$P5 = new String
	$P5 = "pred.pbc"
	_lisp_load($P5)
	$P6 = new String
	$P6 = "arith.pbc"
	_lisp_load($P6)
	$P7 = new String
	$P7 = "numbers.pbc"
	_lisp_load($P7)
	$P8 = new String
	$P8 = "char.pbc"
	_lisp_load($P8)
	$P9 = new String
	$P9 = "hash-internals.pbc"
	_lisp_load($P9)
	$P10 = new String
	$P10 = "hash-new.pbc"
	_lisp_load($P10)
	$P11 = new String
	$P11 = "reader.pbc"
	_lisp_load($P11)
	_init_streams()

	.local pmc nil
	nil = find_global "ParrotCL::Common_Lisp", "NIL"

	.local pmc kwd
	kwd = new String
	kwd = "KEYWORD"
	$P33 = new String
	$P33 = "EOF marker"
	$P32 = _intern($P33, kwd)
	.local pmc eof_marker
	eof_marker = _cons($P32, nil)
	.local pmc result
	.local pmc stdin
	$P36 = new String
	$P36 = "*STANDARD-INPUT*"
	$P37 = _intern($P36)
	stdin = $P37."symbol_value"()
	.local pmc read
	$P34 = new String
	$P34 = "READ"
	$P35 = _intern($P34)
	read = _fdefn_or_lose($P35)
	.local pmc lisp_print
	$P38 = new String
	$P38 = "PRIN1"
	$P39 = _intern($P38)
	lisp_print = _fdefn_or_lose($P39)
	store_global "ParrotCL::Common_Lisp", "PRIN1", lisp_print
	## need to reset *PACKAGE* here, because we don't bind it properly
	## around loading "structures.pbc".
	.local pmc current_package_sym
	$P40 = new String
	$P40 = "*PACKAGE*"
	current_package_sym = _intern($P40)
	.local pmc user_package
	user_package = find_global "ParrotCL::Common_Lisp", "user_package"
	current_package_sym."_set_symbol_value"(user_package)
	push_eh main_exception
main_read_loop:
	print "* "
	result = read(stdin, nil, eof_marker)
	eq_addr result, eof_marker, main_end
	print "Read: "
	lisp_print(result)
	print "\n"
	.local pmc values
	.local int n_values
	(values :slurpy) = _eval(result)
	n_values = values
	if n_values == 0 goto main_no_values
	if n_values == 1 goto main_one_value
	## print 2 or more values
	.local int i
	i = 0
main_next_value:
	if i >= n_values goto main_read_loop
	result = values[i]
	print "Eval "
	print i
	print ": "
	lisp_print(result)
	print "\n"
	i = i + 1
	goto main_next_value
main_no_values:
	print "Eval: [no values]\n"
	goto main_read_loop
main_one_value:	
	print "Eval: "
	result = values[0]
	lisp_print(result)
	print "\n"
	goto main_read_loop
main_exception:
	.local pmc exception
	.get_results (exception)
	print "Error: "
	print exception
	## must now re-establish the exception handler.
	push_eh main_exception
	nil = find_global "ParrotCL::Common_Lisp", "NIL"
	goto main_read_loop
main_end:
	print "\n"
	end
.end