# New Ticket Created by Bob Rogers
# Please include the string: [perl #38264]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=38264 >
The attached code compiles to byte code OK in r11235, until you
comment out the push_eh indicated by the patch, which makes
compute_dominance_frontiers take forever. (Sorry; I wish I had time to
try to make it smaller.) TIA,
-- Bob Rogers
http://rgrjr.dyndns.org/
## 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
Index: toy-lisp.imc
===================================================================
RCS file: /shared/cvsroot/parrot-cl/toy-lisp.imc,v
retrieving revision 1.68
diff -u -r1.68 toy-lisp.imc
--- toy-lisp.imc 28 Dec 2005 15:56:15 -0000 1.68
+++ toy-lisp.imc 18 Jan 2006 02:54:08 -0000
@@ -1532,7 +1532,7 @@
.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
+ ## push_eh main_exception
main_read_loop:
print "* "
result = read(stdin, nil, eof_marker)
