Permalink
Browse files

import following languages : bf, chitchat, forth, jako, lisp, ook, sc…

…heme & urm
  • Loading branch information...
0 parents commit 78527da277cd871a0d344da8339d400dc9128c67 @fperrad fperrad committed Mar 15, 2009
Showing with 6,686 additions and 0 deletions.
  1. +28 −0 CHANGES
  2. +8 −0 KNOWN_BUGS
  3. +201 −0 LICENSE
  4. +3 −0 MAINTAINER
  5. +11 −0 README
  6. +1,334 −0 cl.pir
  7. +53 −0 config/makefiles/root.in
  8. +191 −0 eval.pir
  9. +19 −0 include/macros.pir
  10. +118 −0 include/macros/assert.pir
  11. +44 −0 include/macros/error.pir
  12. +180 −0 include/macros/list.pir
  13. +114 −0 include/macros/standard.pir
  14. +150 −0 include/macros/types.pir
  15. +555 −0 internals.pir
  16. +84 −0 lib/Parrot/Test/Lisp.pm
  17. +155 −0 lisp.pir
  18. +109 −0 lisp/bootstrap.l
  19. +18 −0 lisp/core.l
  20. +68 −0 lisp/list.l
  21. +5 −0 lisp/logic.l
  22. +7 −0 lisp/math.l
  23. +90 −0 lisp/objects.l
  24. +51 −0 lisp/pred.l
  25. +550 −0 read.pir
  26. +696 −0 system.pir
  27. +60 −0 t/arithmetics.t
  28. +159 −0 t/atoms.t
  29. +206 −0 t/cl.t
  30. +100 −0 t/function.t
  31. +10 −0 t/harness
  32. +30 −0 t/hello.t
  33. +59 −0 t/lexicals.t
  34. +76 −0 t/read.t
  35. +127 −0 t/system.t
  36. +771 −0 types.pir
  37. +246 −0 validate.pir
28 CHANGES
@@ -0,0 +1,28 @@
+Changes for version 0.4.13
+--------------------------
+ * Change LICENSE to Artistic License 2.0
+ * Start with a test suite
+
+Changes for version 0.4.12
+--------------------------
+ * Make languages/lisp compile again, as it was broken due to changes in Parrot
+
+Changes for version 0.1.2
+-------------------------
+ * Added basic macro support
+ * Added a basic DEFUN macro
+ * Added support for loading a file off the command line (based on a patch
+ from Leo)
+ * Speed ups in checking list lengths (courtesy Leo)
+ * Rewrote Lisp functions to use DEFUN
+
+Changes for version 0.1.1
+-------------------------
+ * Added BOUNDP function
+ * Added COPY-TREE function
+ * Added IDENTITY function
+ * Added ACONS function
+ * Added ZEROP function
+ * Added an EXPORT function stub
+ * Added an IN-PACKAGE function stub
+ * Split related functions out into separate files in lisp/
8 KNOWN_BUGS
@@ -0,0 +1,8 @@
+# $Id$
+
+Known deficencies in Parrot Common Lisp:
+
+Some broken features.
+
+( print "asdf" ) print asdf and not "asdf"
+
201 LICENSE
@@ -0,0 +1,201 @@
+ The Artistic License 2.0
+
+ Copyright (c) 2000-2006, The Perl Foundation.
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+Preamble
+
+This license establishes the terms under which a given free software
+Package may be copied, modified, distributed, and/or redistributed.
+The intent is that the Copyright Holder maintains some artistic
+control over the development of that Package while still keeping the
+Package available as open source and free software.
+
+You are always permitted to make arrangements wholly outside of this
+license directly with the Copyright Holder of a given Package. If the
+terms of this license do not permit the full use that you propose to
+make of the Package, you should contact the Copyright Holder and seek
+a different licensing arrangement.
+
+Definitions
+
+ "Copyright Holder" means the individual(s) or organization(s)
+ named in the copyright notice for the entire Package.
+
+ "Contributor" means any party that has contributed code or other
+ material to the Package, in accordance with the Copyright Holder's
+ procedures.
+
+ "You" and "your" means any person who would like to copy,
+ distribute, or modify the Package.
+
+ "Package" means the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection and/or of
+ those files. A given Package may consist of either the Standard
+ Version, or a Modified Version.
+
+ "Distribute" means providing a copy of the Package or making it
+ accessible to anyone else, or in the case of a company or
+ organization, to others outside of your company or organization.
+
+ "Distributor Fee" means any fee that you charge for Distributing
+ this Package or providing support for this Package to another
+ party. It does not mean licensing fees.
+
+ "Standard Version" refers to the Package if it has not been
+ modified, or has been modified only in ways explicitly requested
+ by the Copyright Holder.
+
+ "Modified Version" means the Package, if it has been changed, and
+ such changes were not explicitly requested by the Copyright
+ Holder.
+
+ "Original License" means this Artistic License as Distributed with
+ the Standard Version of the Package, in its current version or as
+ it may be modified by The Perl Foundation in the future.
+
+ "Source" form means the source code, documentation source, and
+ configuration files for the Package.
+
+ "Compiled" form means the compiled bytecode, object code, binary,
+ or any other form resulting from mechanical transformation or
+ translation of the Source form.
+
+
+Permission for Use and Modification Without Distribution
+
+(1) You are permitted to use the Standard Version and create and use
+Modified Versions for any purpose without restriction, provided that
+you do not Distribute the Modified Version.
+
+
+Permissions for Redistribution of the Standard Version
+
+(2) You may Distribute verbatim copies of the Source form of the
+Standard Version of this Package in any medium without restriction,
+either gratis or for a Distributor Fee, provided that you duplicate
+all of the original copyright notices and associated disclaimers. At
+your discretion, such verbatim copies may or may not include a
+Compiled form of the Package.
+
+(3) You may apply any bug fixes, portability changes, and other
+modifications made available from the Copyright Holder. The resulting
+Package will still be considered the Standard Version, and as such
+will be subject to the Original License.
+
+
+Distribution of Modified Versions of the Package as Source
+
+(4) You may Distribute your Modified Version as Source (either gratis
+or for a Distributor Fee, and with or without a Compiled form of the
+Modified Version) provided that you clearly document how it differs
+from the Standard Version, including, but not limited to, documenting
+any non-standard features, executables, or modules, and provided that
+you do at least ONE of the following:
+
+ (a) make the Modified Version available to the Copyright Holder
+ of the Standard Version, under the Original License, so that the
+ Copyright Holder may include your modifications in the Standard
+ Version.
+
+ (b) ensure that installation of your Modified Version does not
+ prevent the user installing or running the Standard Version. In
+ addition, the Modified Version must bear a name that is different
+ from the name of the Standard Version.
+
+ (c) allow anyone who receives a copy of the Modified Version to
+ make the Source form of the Modified Version available to others
+ under
+
+ (i) the Original License or
+
+ (ii) a license that permits the licensee to freely copy,
+ modify and redistribute the Modified Version using the same
+ licensing terms that apply to the copy that the licensee
+ received, and requires that the Source form of the Modified
+ Version, and of any works derived from it, be made freely
+ available in that license fees are prohibited but Distributor
+ Fees are allowed.
+
+
+Distribution of Compiled Forms of the Standard Version
+or Modified Versions without the Source
+
+(5) You may Distribute Compiled forms of the Standard Version without
+the Source, provided that you include complete instructions on how to
+get the Source of the Standard Version. Such instructions must be
+valid at the time of your distribution. If these instructions, at any
+time while you are carrying out such distribution, become invalid, you
+must provide new instructions on demand or cease further distribution.
+If you provide valid instructions or cease distribution within thirty
+days after you become aware that the instructions are invalid, then
+you do not forfeit any of your rights under this license.
+
+(6) You may Distribute a Modified Version in Compiled form without
+the Source, provided that you comply with Section 4 with respect to
+the Source of the Modified Version.
+
+
+Aggregating or Linking the Package
+
+(7) You may aggregate the Package (either the Standard Version or
+Modified Version) with other packages and Distribute the resulting
+aggregation provided that you do not charge a licensing fee for the
+Package. Distributor Fees are permitted, and licensing fees for other
+components in the aggregation are permitted. The terms of this license
+apply to the use and Distribution of the Standard or Modified Versions
+as included in the aggregation.
+
+(8) You are permitted to link Modified and Standard Versions with
+other works, to embed the Package in a larger work of your own, or to
+build stand-alone binary or bytecode versions of applications that
+include the Package, and Distribute the result without restriction,
+provided the result does not expose a direct interface to the Package.
+
+
+Items That are Not Considered Part of a Modified Version
+
+(9) Works (including, but not limited to, modules and scripts) that
+merely extend or make use of the Package, do not, by themselves, cause
+the Package to be a Modified Version. In addition, such works are not
+considered parts of the Package itself, and are not subject to the
+terms of this license.
+
+
+General Provisions
+
+(10) Any use, modification, and distribution of the Standard or
+Modified Versions is governed by this Artistic License. By using,
+modifying or distributing the Package, you accept this license. Do not
+use, modify, or distribute the Package, if you do not accept this
+license.
+
+(11) If your Modified Version has been derived from a Modified
+Version made by someone other than you, you are nevertheless required
+to ensure that your Modified Version complies with the requirements of
+this license.
+
+(12) This license does not grant you the right to use any trademark,
+service mark, tradename, or logo of the Copyright Holder.
+
+(13) This license includes the non-exclusive, worldwide,
+free-of-charge patent license to make, have made, use, offer to sell,
+sell, import and otherwise transfer the Package with respect to any
+patent claims licensable by the Copyright Holder that are necessarily
+infringed by the Package. If you institute patent litigation
+(including a cross-claim or counterclaim) against any party alleging
+that the Package constitutes direct or contributory patent
+infringement, then this Artistic License to you shall terminate on the
+date that such litigation is filed.
+
+(14) Disclaimer of Warranty:
+THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
+IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
+NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
+LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3 MAINTAINER
@@ -0,0 +1,3 @@
+# $Id$
+
+N: Cory Spencer
11 README
@@ -0,0 +1,11 @@
+This is Parrot Common Lisp
+--------------------------
+
+Parrot Common Lisp is Copyright (C) 2004 - 2005 Cory Spencer. All
+Rights Reserved.
+
+LICENSE INFORMATION
+-------------------
+
+This code is distributed under the "Artistic License 2.0".
+The "Artistic License 2.0" can be found in the file "LICENSE".
1,334 cl.pir
@@ -0,0 +1,1334 @@
+# $Id$
+
+=head1 NAME
+
+cl.pir - Set up the package 'COMMON-LISP'
+
+=cut
+
+.sub _init_cl :init
+
+ .local pmc symbol
+ .local pmc value
+
+ .local pmc package
+ .PACKAGE(package, "COMMON-LISP")
+ set_global ["PACKAGES"], "COMMON-LISP", package
+ set_global ["PACKAGES"], "CL", package
+
+ .local pmc t
+ t = package.'_intern_symbol'("T") # Create the T symbol, T meaning true
+ t.'_set_value'(t)
+ t.'_set_package'(package)
+ t.'_set_special'(t)
+ set_global ["SYMBOLS"], "T", t # Quick alias to T
+
+ .local pmc nil
+ nil = package.'_intern_symbol'("NIL") # Create the NIL symbol
+ nil.'_set_value'(nil)
+ nil.'_set_package'(package)
+ nil.'_set_special'(t)
+ set_global ["SYMBOLS"], "NIL", nil # Quick alias to NIL
+
+ .INTEGER(value,1)
+ .DEFVAR(symbol, package, "*GENSYM-COUNTER*", value)
+
+ .DEFVAR(symbol, package, "*PACKAGE*", package)
+
+ .READTABLE(value)
+ .DEFVAR(symbol, package, "*READTABLE*", value)
+
+ .local pmc stream
+ getstdin stream
+ .STREAM(value,stream)
+ .DEFVAR(symbol, package, "*STANDARD-INPUT*", value)
+
+ getstdout stream
+ stream.'buffer_type'('unbuffered')
+ .STREAM(value,stream)
+ .DEFVAR(symbol, package, "*STANDARD-OUTPUT*", value)
+
+ .local pmc function # this is needed in r20641
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "APPLY", _apply)
+ .DEFUN(symbol, package, "APPLY", "_apply")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "ATOM", _atom)
+ .DEFUN(symbol, package, "ATOM", "_atom")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "BOUNDP", _boundp)
+ .DEFUN(symbol, package, "BOUNDP", "_boundp")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CAR", _car)
+ .DEFUN(symbol, package, "CAR", "_car")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CDR", _cdr)
+ .DEFUN(symbol, package, "CDR", "_cdr")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CHAR", _char)
+ .DEFUN(symbol, package, "CHAR", "_char")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CONS", _cons)
+ .DEFUN(symbol, package, "CONS", "_cons")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "EQ", _eq)
+ .DEFUN(symbol, package, "EQ", "_eq")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "EVAL", _eval)
+ .DEFUN(symbol, package, "EVAL", "_eval")
+
+ .SPECIAL_FORM(symbol, package, "FUNCTION", '_function')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "GENSYM", _gensym)
+ .DEFUN(symbol, package, "GENSYM", "_gensym")
+
+ .SPECIAL_FORM(symbol, package, "IF", '_if')
+
+ .SPECIAL_FORM(symbol, package, "LET", '_let')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "LIST", _list)
+ .DEFUN(symbol, package, "LIST", "_list")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "MOD", _modulus)
+ .DEFUN(symbol, package, "MOD", "_modulus")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "NULL", _null)
+ .DEFUN(symbol, package, "NULL", "_null")
+
+ .DEFUN(symbol, package, "PRINT", "_print")
+
+ .SPECIAL_FORM(symbol, package, "PROGN", '_progn')
+
+ .SPECIAL_FORM(symbol, package, "QUOTE", '_quote')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "READ", _read)
+ .DEFUN(symbol, package, "READ", "_read")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "READ-DELIMITED-LIST",_read_delimited_list)
+ .DEFUN(symbol, package, "READ-DELIMITED-LIST","_read_delimited_list")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "RPLACA", _rplaca)
+ .DEFUN(symbol, package, "RPLACA", "_rplaca")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "RPLACD", _rplacd)
+ .DEFUN(symbol, package, "RPLACD", "_rplacd")
+
+ .SPECIAL_FORM(symbol, package, "SETQ", '_setq')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "TYPE-OF", _type_of)
+ .DEFUN(symbol, package, "TYPE-OF", "_type_of")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "VALUES", _values)
+ .DEFUN(symbol, package, "VALUES", "_values")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "QUIT", _quit)
+ .DEFUN(symbol, package, "QUIT", "_quit")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "/", _divide)
+ .DEFUN(symbol, package, "/", "_divide")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "-", _subtract)
+ .DEFUN(symbol, package, "-", "_subtract")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "*", _multiply)
+ .DEFUN(symbol, package, "*", "_multiply")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "+", _add)
+ .DEFUN(symbol, package, "+", "_add")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "=", _equal)
+ .DEFUN(symbol, package, "=", "_equal")
+
+ .return(1)
+.end
+
+.sub _apply
+ .param pmc args
+ .ASSERT_MINIMUM_LENGTH(args, 2, ERROR_NARGS)
+
+ .local pmc car
+ .CAR(car, args)
+
+ .local pmc args_of_func
+ .SECOND(args_of_func, args)
+ .ASSERT_TYPE(args_of_func, "list")
+
+ .local string type
+ type = typeof car
+ if type == "LispFunction" goto CAR_IS_FUNCTION
+ if type == "LispSymbol" goto CAR_IS_SYMBOL
+ goto INVALID_FUNCTION_NAME
+
+CAR_IS_FUNCTION:
+ .tailcall _FUNCTION_CALL(car, args_of_func)
+
+CAR_IS_SYMBOL:
+ .local pmc func
+ func = car.'_get_function'() # Get the function from symbol
+ if_null func, INVALID_FUNCTION_NAME # Throw an error if undefined
+ type = typeof func
+ # print type
+ # print ' for CAR_IS_SYMBOL'
+ .tailcall _FUNCTION_CALL(func,args_of_func)
+
+INVALID_FUNCTION_NAME:
+ .ERROR_1("undefined-function", "%s is not a function name", car)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to APPLY")
+ goto DONE
+
+ERROR_NONLIST:
+ .ERROR_0("type-error", "second argument to APPLY must be a proper list")
+ goto DONE
+
+DONE:
+ .return() # Call the return continuation
+.end
+
+.sub _atom
+ .param pmc args
+ .local string type
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+
+ type = typeof a # An atom is anything that is
+ if type != "LispCons" goto ATOM # not a cons.
+ goto CONS
+
+ATOM:
+ .TRUE(retv)
+ goto DONE
+
+CONS:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to ATOM")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _boundp
+ .param pmc args
+ .local pmc symbol
+ .local pmc retv
+ .local pmc val
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(symbol, args)
+ .ASSERT_TYPE(symbol, "symbol")
+
+ val = symbol.'_get_value'()
+ if_null val, UNBOUND
+
+ .TRUE(retv)
+ goto DONE
+
+UNBOUND:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to BOUNDP")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _car
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+ .ASSERT_TYPE(a, "list")
+
+ .CAR(retv, a)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CAR")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _cdr
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+ .ASSERT_TYPE(a, "list")
+
+ .CDR(retv, a)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CDR")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _char
+ .param pmc args
+
+ .local pmc retval
+ .local pmc ke
+ .local string str
+ .local string sstr
+ .local int k
+ .local int leng
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ str = args[0]
+ ke = args[1]
+ k = ke[0]
+
+ length leng, str
+
+ if k > leng goto BOUNDS
+ if k < 0 goto BOUNDS
+
+ sstr = substr str, k, 1
+ retval = new 'LispString'
+ retval = sstr
+ goto DONE
+
+BOUNDS:
+ .NIL(retval)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CHAR")
+ goto DONE
+
+DONE:
+ .return(retval)
+.end
+
+.sub _cons
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+ .local pmc b
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(a, args)
+ .SECOND(b, args)
+
+ .CONS(retv, a, b)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CONS")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _eq
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+ .local pmc b
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(a, args)
+ .SECOND(b, args)
+
+ eq_addr a, b, EQUAL
+ goto NOT_EQUAL
+
+EQUAL:
+ .TRUE(retv)
+ goto DONE
+
+NOT_EQUAL:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to EQ")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _function
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local pmc form
+ .CAR(form, args)
+
+ .local pmc retv
+
+ .local string type
+ type = typeof form
+ if type == "LispSymbol" goto SYMBOL # Retrieve function from symbol
+
+ .local int is_lambda_list
+ is_lambda_list = _IS_ORDINARY_LAMBDA_LIST(form) # Check if it's a lambda form
+ if is_lambda_list goto LAMBDA_FORM # and build a closure if so
+
+ goto INVALID_FUNCTION_NAME
+
+SYMBOL:
+ .local string symname
+ symname = form.'_get_name_as_string'() # Retrieve the symbols name
+
+ .local pmc package
+ package = form.'_get_package'() # Retrieve the symbols package name
+ .local string pkgname
+ pkgname = package.'_get_name_as_string'()
+
+ .local pmc symbol
+ symbol = _LOOKUP_GLOBAL(pkgname, symname) # Lookup the symbol
+
+ .local int found
+ found = defined symbol # Ensure the symbol was found in
+ unless found goto FUNCTION_NOT_FOUND # the global namespace
+
+ retv = symbol.'_get_function'() # Ensure the symbol had a function
+ defined found, symbol # defined
+ unless found goto FUNCTION_NOT_FOUND
+
+ goto DONE
+
+LAMBDA_FORM:
+ retv = _MAKE_LAMBDA(form) # Create a closure PMC
+ goto DONE
+
+INVALID_FUNCTION_NAME:
+ .ERROR_1("undefined-function", "%s is not a function name", form)
+ goto DONE
+
+FUNCTION_NOT_FOUND:
+ .ERROR_1("undefined-function", "the function %s is undefined", symname)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to FUNCTION")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _gensym
+ .param pmc args
+ .local string prefix
+ .local string gname
+ .local pmc suffix
+ .local pmc symbol
+ .local pmc garg
+ .local pmc gcnt
+ .local pmc retv
+ .local pmc car
+
+ .ASSERT_LENGTH_BETWEEN(args, 0, 1, ERROR_NARGS)
+
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*GENSYM-COUNTER*")
+ gcnt = symbol.'_get_value'()
+
+ suffix = gcnt
+ prefix = "G"
+
+ .NULL(args, MAKE_SYMBOL)
+
+ .CAR(car, args)
+ goto CHECK_PREFIX
+
+CHECK_PREFIX:
+ .ASSERT_TYPE_AND_BRANCH(car, "string", CHECK_SUFFIX)
+ prefix = car
+ goto MAKE_SYMBOL
+
+CHECK_SUFFIX:
+ .ASSERT_TYPE(car, "integer")
+ if car < 0 goto ERROR_NEGINT
+ suffix = car
+ goto MAKE_SYMBOL
+
+MAKE_SYMBOL:
+ garg = new 'Array'
+ garg = 2
+ garg[0] = prefix
+ garg[1] = suffix
+
+ sprintf gname, "%s%0.6d", garg
+ retv = _SYMBOL(gname)
+
+ inc gcnt
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to GENSYM")
+ goto DONE
+
+ERROR_NEGINT:
+ .ERROR_1("program-error", "%d is negative", car)
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _if
+ .param pmc args
+ .local pmc retv
+ .local pmc form
+ .local pmc earg
+
+ .ASSERT_LENGTH_BETWEEN(args, 2, 3, ERROR_NARGS)
+
+ .CAR(form, args) # Get the test form
+
+ .LIST_1(earg,form)
+ retv = _eval(earg) # Evaluate the test form.
+
+ .NULL(retv, ELSE_CLAUSE) # If test was false, goto else clause
+ goto THEN_CLAUSE #else goto then clause
+
+THEN_CLAUSE:
+ .SECOND(form, args)
+
+ .LIST_1(earg, form)
+ retv = _eval(earg)
+ goto DONE
+
+ELSE_CLAUSE:
+ .THIRD(form, args)
+
+ .LIST_1(earg, form)
+ retv = _eval(earg)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to IF")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _list
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+ .local pmc retp
+ .local pmc cons
+ .local pmc nil
+
+ .NIL(retv)
+ .NIL(nil)
+
+ lptr = args
+LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(targ, lptr)
+
+ .NULL(retv, EMPTY_LIST)
+
+ .CONS(cons, targ, nil)
+ retp[1] = cons
+ retp = cons
+
+EMPTY_LIST_RETURN:
+ .CDR(lptr, lptr)
+ goto LOOP
+
+EMPTY_LIST:
+ .CONS(retv, targ, nil)
+ retp = retv
+ goto EMPTY_LIST_RETURN
+
+DONE:
+ .return(retv)
+.end
+
+.sub _null
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+
+ .NULL(a, IS_NULL)
+
+ .NIL(retv)
+ goto DONE
+
+IS_NULL:
+ .TRUE(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to NULL")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _let
+ .param pmc args
+ .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS)
+
+ .local string name
+ .local string type
+ .local pmc package
+ .local pmc symbol
+ .local pmc value
+ .local pmc fargs
+ .local pmc init
+ .local pmc body
+ .local pmc lptr
+ .local pmc form
+ .local int test
+ .local int i
+
+ # VALID_IN_PARROT_0_2_0 new_pad -1 # Create new lexical scope
+
+ .CAR(init, args) # The variable bindings
+ .CDR(body, args) # The form to evaluate
+
+ .local pmc keyvals
+ keyvals = new 'ResizablePMCArray' # List for holding init values
+ .local pmc dynvars
+ dynvars = new 'ResizablePMCArray' # List for holding dynamic vars
+
+ # for exception handling, currently broken
+ .local pmc error
+ null error
+ push_eh CLEANUP_HANDLER # Set a handler for cleanup
+
+ .local pmc retv
+ .NIL(retv) # Initialize return value
+
+INIT_FORM: # Process the init form
+ type = typeof init
+ if type == "LispSymbol" goto INIT_SYMBOL
+ if type == "LispCons" goto INIT_LIST
+ goto EVAL_BODY
+
+INIT_SYMBOL:
+ push keyvals, init # Init form was just a symbol -
+ null value # no value is assigned to it
+ push keyvals, value
+
+ goto INIT_DONE
+
+INIT_LIST:
+ lptr = init
+ goto INIT_LIST_LOOP
+
+INIT_LIST_LOOP:
+ .NULL(lptr, INIT_DONE)
+
+ .CAR(form, lptr) # Get the next init form
+
+ .ASSERT_TYPE_AND_BRANCH(form, "list", ERROR_BAD_SPEC)
+ # VALID_IN_PARROT_0_2_0 .ASSERT_LENGTH(form, 2, ERROR_BADSPEC) # Ensure a valid init form
+ .ASSERT_LENGTH(form, 2, ERROR_BAD_SPEC) # Ensure a valid init form
+
+ .CAR(symbol, form) # The symbol we're assigning to
+ .SECOND(value, form) # The value being assigned
+
+ .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", ERROR_BAD_SPEC)
+
+ .LIST_1(fargs, value) # Put value into an arg list
+ value = _eval(fargs) # Evaluate it
+
+ push keyvals, symbol # Push symbol onto key/val list
+ push keyvals, value # Push value onto key/val list
+
+ .CDR(lptr, lptr)
+ goto INIT_LIST_LOOP
+
+INIT_DONE:
+
+ # bind the variables in init
+ .local int nvar
+ nvar = keyvals
+ i = 0
+BIND_LOOP:
+ if i >= nvar goto BIND_DONE
+
+ symbol = keyvals[i] # Pop symbol of key/val list
+ inc i
+ value = keyvals[i] # Pop value of key/val list
+
+ name = symbol.'_get_name_as_string'()
+
+ test = _IS_SPECIAL(symbol)
+ if test == 0 goto BIND_LEXICAL
+ goto BIND_DYNAMIC
+
+BIND_LEXICAL:
+ # TODO: replace push_pad, pop_pad, do not worry about closures yet
+ symbol = _LEXICAL_SYMBOL(name, value) # Create a new lexical symbol
+ inc i
+ goto BIND_LOOP
+
+BIND_DYNAMIC:
+ package = symbol.'_get_package'() # Get dynamic symbols package
+
+ symbol = package.'_shadow_symbol'(name) # Shadow the symbol
+ symbol.'_set_value'(value) # Set the new value
+
+ push dynvars, symbol # Keep around for tracking
+
+ inc i
+ goto BIND_LOOP
+
+BIND_DONE:
+ goto EVAL_BODY
+
+
+EVAL_BODY:
+ lptr = body # Set pointer to the body form
+
+EVAL_LOOP: # Evaluate each form in order
+ .NULL(lptr, EVAL_DONE)
+
+ .CAR(form, lptr) # Get the next form in the body
+ .LIST_1(fargs, form) # Put it into an arg list
+ retv = _eval(fargs) # Evaluate it
+
+ .CDR(lptr, lptr) # Get a pointer to next form
+ goto EVAL_LOOP
+
+EVAL_DONE:
+ goto CLEANUP
+
+
+CLEANUP_HANDLER:
+ .get_results (error) # Caught an exception - save it
+ goto CLEANUP # and clean up before rethrow
+
+CLEANUP:
+ # VALID_IN_PARROT_0_2_0 pop_pad # Pop off the lexical scope
+
+ nvar = dynvars
+ i = 0
+
+CLEANUP_LOOP:
+ if i >= nvar goto CLEANUP_DONE
+
+ symbol = dynvars[i] # Symbol to be unshadowed
+ name = symbol.'_get_name_as_string'()
+ package = symbol.'_get_package'()
+
+ package.'_unshadow_symbol'(name) # Unshadow the symbol
+
+ inc i
+ goto CLEANUP_LOOP
+
+CLEANUP_DONE:
+ if_null error, DONE # Rethrow an exception if we
+ rethrow error # need to
+ goto DONE
+
+CLEANUP_RETHROW:
+ rethrow error
+ goto DONE
+
+# VALID_IN_PARROT_0_2_0 ERROR_BADSPEC:
+ERROR_BAD_SPEC:
+ .ERROR_1("program-error", "illegal variable specification %s", form)
+ goto CLEANUP
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to LET")
+ goto CLEANUP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _print # This is just a temporary stand-in - it
+ .param pmc args # doesn't have near enough the amount of
+ # functionality required.
+ .local string strval
+ .local pmc retv
+ .local pmc obj
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(obj, args)
+
+ strval = obj
+ .STRING(retv, obj)
+ print retv
+ print "\n"
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to PRINT")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _progn
+ .param pmc args
+ .local pmc eform
+ .local pmc eargs
+ .local pmc lptr
+ .local pmc retv
+
+ .NIL(retv)
+ lptr = args
+
+FORM_LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(eform, lptr) # Create the arg list for eval
+ .LIST_1(eargs, eform)
+
+ retv = _eval(eargs) # Evaluate form in list
+
+ .CDR(lptr, lptr) # Point to next form
+ goto FORM_LOOP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _quit
+ .param pmc args
+
+ .ASSERT_LENGTH(args, 0, ERROR_NARGS)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to QUIT")
+ goto DONE
+
+DONE:
+ end
+.end
+
+.sub _quote
+ .param pmc args
+ .local pmc retv
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(retv,args)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to QUOTE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _rplaca
+ .param pmc args
+ .local pmc cons
+ .local pmc val
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(cons, args)
+ .SECOND(val, args)
+
+ .ASSERT_TYPE(cons, "cons")
+
+ cons[0] = val # Replace the car with val
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to RPLACA")
+ goto DONE
+
+DONE:
+ .return(cons)
+.end
+
+.sub _rplacd
+ .param pmc args
+ .local pmc cons
+ .local pmc val
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(cons, args)
+ .SECOND(val, args)
+
+ .ASSERT_TYPE(cons, "cons") # Ensure first arg is a cons
+
+ cons[1] = val # Replace the cdr with val
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to RPLACD")
+ goto DONE
+
+DONE:
+ .return(cons)
+.end
+
+.sub _setq
+ .param pmc args
+
+ .local string name
+ .local pmc lexical
+ .local pmc symbol
+ .local pmc value
+ .local pmc retv
+ .local pmc lptr
+ .local pmc earg
+
+ .ASSERT_EVEN_LENGTH(args, ERROR_NARGS)
+
+ lptr = args # Pointer to the arguments
+ .NIL(retv) # Initialize return value
+
+LOOP:
+ .NULL(lptr, DONE) # If we're at the EOL goto DONE
+
+ .CAR(symbol, lptr) # Get the variable to assign to
+ .SECOND(value, lptr) # Get the value being assigned
+
+ .ASSERT_TYPE(symbol, "symbol") # Ensure variable is a symbol
+
+ name = symbol.'_get_name_as_string'() # Get the symbols name
+ lexical = _LOOKUP_LEXICAL(name) # Look for it in lexical env
+ if_null lexical, SET_SYMBOL_VALUE
+
+ symbol = lexical # Lexical variable was found
+
+SET_SYMBOL_VALUE:
+ .LIST_1(earg, value) # Evaluate the value form
+ retv = _eval(earg)
+
+ symbol.'_set_value'(retv)
+
+ .CDR(lptr, lptr)
+ .CDR(lptr, lptr)
+
+ goto LOOP
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "odd number of arguments to SETQ")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _type_of
+ .param pmc args
+ .local string type
+ .local string name
+ .local pmc form
+ .local pmc retv
+ .local pmc nil
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(form, args)
+
+ null nil
+
+ type = typeof form
+
+ if type == "LispCons" goto CONS
+ if type == "LispFloat" goto FLOAT
+ if type == "LispFunction" goto FUNCTION
+ if type == "LispHash" goto HASH
+ if type == "LispInteger" goto INTEGER
+ if type == "LispMacro" goto MACRO
+ if type == "LispPackage" goto PACKAGE
+ if type == "LispStream" goto STREAM
+ if type == "LispString" goto STRING
+ if type == "LispSymbol" goto SYMBOL
+
+ goto UNKNOWN_TYPE
+
+CONS:
+ name = "CONS"
+ goto LOOKUP_SYMBOL
+
+FLOAT:
+ name = "FLOAT"
+ goto LOOKUP_SYMBOL
+
+FUNCTION:
+ name = "FUNCTON"
+ goto LOOKUP_SYMBOL
+
+HASH:
+ name = "HASH-TABLE"
+ goto LOOKUP_SYMBOL
+
+INTEGER:
+ name = "INTEGER"
+ goto LOOKUP_SYMBOL
+
+MACRO:
+ name = "MACRO"
+ goto LOOKUP_SYMBOL
+
+PACKAGE:
+ name = "PACKAGE"
+ goto LOOKUP_SYMBOL
+
+STREAM:
+ name = "STREAM"
+ goto LOOKUP_SYMBOL
+
+STRING:
+ name = "STRING"
+ goto LOOKUP_SYMBOL
+
+SYMBOL:
+ name = "SYMBOL"
+ goto LOOKUP_SYMBOL
+
+UNKNOWN_TYPE:
+ name = "UNKNOWN"
+ goto LOOKUP_SYMBOL
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "odd number of arguments to TYPE-OF")
+ goto DONE
+
+LOOKUP_SYMBOL:
+ retv = _GLOBAL_SYMBOL("COMMON-LISP", name, nil, nil)
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _values
+ .param pmc args
+ .local int size
+ .local int llen
+
+ llen = _LIST_LENGTH(args) # Get # values we're returning
+
+ $P16 = args # Pointer to argument list
+
+ if llen == 0 goto DONE
+
+ $P5 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 1 goto DONE
+
+ $P6 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 2 goto DONE
+
+ $P7 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 3 goto DONE
+
+ $P8 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 4 goto DONE
+
+ $P9 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 5 goto DONE
+
+ $P10 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 6 goto DONE
+
+ $P11 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 7 goto DONE
+
+ $P12 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 8 goto DONE
+
+ $P13 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 9 goto DONE
+
+ $P14 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 10 goto DONE
+
+ $P15 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 11 goto DONE
+
+ size = llen - 11 # Size of the overflow array
+
+ $P3 = new 'Array' # Allocate overflow array
+ $P3 = size
+
+ .local pmc elem
+ .local int indx
+
+ indx = 0 # Initial index into overflow
+OVERFLOW_LOOP:
+ if indx == size goto DONE_OVERFLOW
+
+ elem = $P16[0]
+
+ $P3[indx] = elem # Set next overflow element
+ inc indx
+
+ $P16 = $P16[1] # Set next element in list
+ goto OVERFLOW_LOOP
+
+DONE_OVERFLOW:
+ llen = 11 # Only report # retv's in regs
+ goto DONE
+
+DONE:
+ # VALID_IN_PARROT_0_2_0 is_prototyped = 0 # Set up return registers
+
+ # VALID_IN_PARROT_0_2_0 argcI = 0
+ # VALID_IN_PARROT_0_2_0 argcN = 0
+ # VALID_IN_PARROT_0_2_0 argcP = llen
+ # VALID_IN_PARROT_0_2_0 argcS = 0
+
+ # VALID_IN_PARROT_0_2_0 returncc
+ .return()
+.end
+
+.sub _add
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+
+ .INTEGER(retv, "0") # + with no args should give 0
+
+ lptr = args
+
+LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(targ,lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv + targ # Add to the running total.
+
+ .CDR(lptr,lptr)
+ goto LOOP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _subtract
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+ .local int narg
+
+ .ASSERT_MINIMUM_LENGTH(args,1,ERROR_NARGS)
+
+ .CAR(retv,args) # Get the first argument and
+ .ASSERT_TYPE(retv, "number") # ensure it is numeric.
+
+ .CDR(lptr,args) # Get a pointer to rest of args
+ narg = 1 # Number of args encountered
+
+LOOP:
+ .NULL(lptr,DONE_LOOP)
+
+ .CAR(targ, lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv - targ # Subtract from running total.
+
+ .CDR(lptr,lptr)
+ inc narg # Increment # args processed
+ goto LOOP
+
+DONE_LOOP:
+ if narg > 1 goto DONE # If we only had one arg return
+ neg retv # its negative value
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to -")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _multiply
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+
+ .INTEGER(retv, "1") # + with no args should give 0
+
+ lptr = args
+
+LOOP:
+ .NULL(lptr,DONE)
+
+ .CAR(targ,lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv * targ # Multiply the running product.
+
+ .CDR(lptr,lptr)
+ goto LOOP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _divide
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+ .local int narg
+
+ .ASSERT_MINIMUM_LENGTH(args,1,ERROR_NARGS)
+
+ .CAR(retv,args) # Get the first argument and
+ .ASSERT_TYPE(retv, "number") # ensure it is numeric.
+
+ .CDR(lptr,args) # Get a pointer to rest of args
+ narg = 1 # Number of args encountered
+
+LOOP:
+ .NULL(lptr,DONE_LOOP)
+
+ .CAR(targ,lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv / targ # Divide the running total.
+
+ .CDR(lptr,lptr)
+ inc narg # Increment # args processed
+ goto LOOP
+
+DONE_LOOP:
+ if narg > 1 goto DONE # If we only had one arg, return
+ .INTEGER(targ, 1) # its inverse
+ retv = targ / retv
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to /")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _modulus
+ .param pmc args
+ .local pmc retv
+ .local pmc numb
+ .local pmc div
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(numb,args)
+ .SECOND(div,args)
+
+ .ASSERT_TYPE(numb, "number") # Ensure both of the args are
+ .ASSERT_TYPE(div, "number") # numeric.
+
+ .INTEGER(retv,0)
+
+ mod retv, numb, div # Compute the modulus
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to MOD")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _equal
+ .param pmc args
+ .local pmc lptr
+ .local pmc arg1
+ .local pmc arg2
+ .local pmc retv
+
+ .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(arg1, args) # Get the first argument and
+ .ASSERT_TYPE(arg1, "number") # ensure it is numeric.
+
+ .CDR(lptr,args) # Get a pointer to rest of args
+
+ .TRUE(retv)
+
+LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(arg2, lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(arg2, "number") # it is numeric.
+
+ if arg1 != arg2 goto NOT_EQUAL
+
+ .CDR(lptr, lptr)
+ goto LOOP
+
+NOT_EQUAL:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to =")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
53 config/makefiles/root.in
@@ -0,0 +1,53 @@
+# Copyright (C) 2005-2009, Parrot Foundation.
+# $Id$
+
+# Setup some commands
+RM_F = @rm_f@
+PERL = @perl@
+PARROT = ../../parrot@exe@
+BUILD_DIR = @build_dir@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+all: build
+
+# This is a listing of all targets, that are meant to be called by users
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " all: 'lisp.pbc'"
+ @echo " This is the default."
+ @echo ""
+ @echo " help: Print this help message."
+ @echo ""
+ @echo " test: Run the test suite."
+ @echo ""
+ @echo " clean: Cleaning up."
+ @echo ""
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=lisp
+
+test: build
+ $(PERL) -Ilib -I../../lib t/harness
+
+build: lisp.pir
+ $(PARROT) -o lisp.pbc lisp.pir
+
+clean: testclean
+ $(RM_F) core "*.pbc" "*~"
+
+testclean:
+ $(RM_F) t/*.out t/*.l
+
+realclean: clean
+ $(RM_F) Makefile
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
191 eval.pir
@@ -0,0 +1,191 @@
+# $Id$
+
+=head1 NAME
+
+eval.pir - evaluate forms
+
+=cut
+
+.sub _eval
+ .param pmc args
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local string symname
+ .local string type
+ .local pmc symbol
+ .local int found
+ .local pmc body
+ .local pmc retv
+
+ # switch based on the type of the first arg
+ .local pmc form
+ .CAR(form, args)
+ type = typeof form
+ if type == "LispSymbol" goto SYMBOL
+ if type == "LispCons" goto FUNCTION_FORM
+ if type == "LispInteger" goto SELF_EVALUATING_OBJECT
+ if type == "LispString" goto SELF_EVALUATING_OBJECT
+ if type == "LispFloat" goto SELF_EVALUATING_OBJECT
+
+ .ERROR_1("internal", "Unknown object type in eval: %s", type)
+
+
+FUNCTION_FORM:
+ .local pmc function
+ .local pmc funcargs
+ .local pmc funcptr
+ .local pmc funcarg
+ .local pmc test
+
+ .CAR(symbol, form)
+ .CDR(body, form)
+
+ .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", FUNCTION_NOT_FOUND)
+
+ # Retrieve the function from the symbol.
+ function = symbol.'_get_function'()
+
+ # If the function wasn't set for the symbol, throw an error.
+ defined found, function
+ unless found goto FUNCTION_NOT_FOUND
+
+ # Check to see if the function is a special form (which aren't subject to
+ # normal function evaluation rules).
+ type = typeof function
+ if type == "LispSpecialForm" goto SPECIAL_FORMS
+ if type == "LispMacro" goto MACRO_FORM
+
+ # Normal function - evaluate all arguments being passed into the function.
+ .NIL(funcargs)
+
+ funcptr = body
+
+FUNCTION_LOOP:
+ .NULL(funcptr, FUNCTION_CALL) # Call the function if no args left.
+
+ .CAR(funcarg, funcptr) # Pop the next arg off the list.
+
+ .local pmc evalarg # Evaluate the argument.
+ .LIST_1(evalarg, funcarg)
+ funcarg = _eval(evalarg)
+
+ .APPEND(funcargs,funcargs,funcarg) # Add the result to the args list.
+
+ .CDR(funcptr,funcptr) # Move to the next arg in the list.
+
+ goto FUNCTION_LOOP
+
+FUNCTION_CALL:
+ .tailcall _FUNCTION_CALL(function,funcargs)
+ # VALID_IN_PARROT_0_2_0 goto DONE
+
+FUNCTION_NOT_FOUND:
+ .ERROR_1("undefined-function", "%s is not a function name", symbol)
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to EVAL")
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SPECIAL_FORMS:
+ # Special forms aren't subject to normal evaluation rules - keep the
+ # arguments as is and call the function.
+ funcargs = body
+ goto FUNCTION_CALL
+
+MACRO_FORM:
+ .local pmc macroexp
+ .local pmc macrosym
+ .local pmc macroenv
+ .local pmc macroarg
+
+ macrosym = _LOOKUP_SYMBOL("*MACROEXPAND-HOOK*")
+ if_null macrosym, MACRO_NOT_INITIALIZED
+
+ macroexp = macrosym.'_get_value'() # Get the expander function
+ .ASSERT_TYPE_AND_BRANCH(macroexp, "function", MACRO_NOT_INITIALIZED)
+
+ # VALID_IN_PARROT_0_2_0 peek_pad macroenv # Get current lexical scope
+
+ .LIST_3(funcargs, symbol, body, macroenv)
+ retv = _FUNCTION_CALL(macroexp, funcargs) # Call the macroexpand hook
+
+ .LIST_1(macroarg, retv)
+ _eval(macroarg)
+
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SYMBOL:
+ symbol = form
+ symname = symbol.'_get_name_as_string'()
+
+ .local int is_special
+ is_special = _IS_SPECIAL(symbol) # Check if we're a dynamic
+ unless is_special goto LEXICAL_SYMBOL # variable
+ goto DYNAMIC_SYMBOL
+
+DYNAMIC_SYMBOL:
+ .local pmc package
+ .local string pkgname
+ package = symbol.'_get_package'()
+ pkgname = package.'_get_name_as_string'()
+
+ symbol = _LOOKUP_GLOBAL(pkgname, symname)
+ goto CHECK_VALUE
+
+LEXICAL_SYMBOL:
+ retv = _LOOKUP_LEXICAL(symname) # Check for a lexical shadow
+ if_null retv, CHECK_VALUE # If not found, assume global
+ symbol = retv # Use the lexical value
+ goto CHECK_VALUE
+
+CHECK_VALUE:
+ retv = symbol.'_get_value'() # Check for symbol's value
+
+ defined found, retv
+ unless found goto SYMBOL_NOT_FOUND
+
+DONE_SYMBOL:
+ # VALID_IN_PARROT_0_2_0 argcP = 1 # One value returned
+ # VALID_IN_PARROT_0_2_0 P5 = retv # Return value
+ # VALID_IN_PARROT_0_2_0
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SYMBOL_NOT_FOUND:
+ .ERROR_1("unbound-variable", "variable %s has no value", form)
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SELF_EVALUATING_OBJECT:
+ # Object is a primitive type (ie. a string, integer or float).
+ # VALID_IN_PARROT_0_2_0 argcP = 1 # One value returned
+ # VALID_IN_PARROT_0_2_0 P5 = retv # Return value
+
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(form)
+
+MACRO_NOT_INITIALIZED:
+ .ERROR_0("internal","the macro system has not been initialized")
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DONE:
+# VALID_IN_PARROT_0_2_0 is_prototyped = 0 # Nonprototyped return
+# VALID_IN_PARROT_0_2_0 argcI = 0 # No integer values returned
+# VALID_IN_PARROT_0_2_0 argcN = 0 # No float values returned
+# VALID_IN_PARROT_0_2_0 argcS = 0 # No string values returned
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 returncc # Call the return continuation
+
+ .return()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
19 include/macros.pir
@@ -0,0 +1,19 @@
+# $Id$
+
+=head1 NAME
+
+include/macros.pir - include PIR file in F<include/macros>.
+
+=cut
+
+.include "include/macros/assert.pir"
+.include "include/macros/error.pir"
+.include "include/macros/list.pir"
+.include "include/macros/standard.pir"
+.include "include/macros/types.pir"
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
118 include/macros/assert.pir
@@ -0,0 +1,118 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/assert.pir - macros for checking assumptions
+
+=head1 Macros
+
+=head2 ASSERT_TYPE(A,T)
+
+Asserts that A is of type T, throwing a error of type "type-error" on failure
+
+=cut
+
+.macro ASSERT_TYPE(A,T)
+ .local string _atypes
+ .local int _testi
+
+ _testi = _IS_TYPE(.A, .T)
+ if _testi == 1 goto .$DONE
+ goto .$WRONG_TYPE
+
+.label $WRONG_TYPE:
+ .ERROR_2("type-error", "%s is not of type %s", .A, .T)
+ goto .$DONE
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_TYPE_AND_BRANCH(A,T,B)
+
+Asserts that A is of type T, branching to B on failure.
+
+=cut
+
+.macro ASSERT_TYPE_AND_BRANCH(A,T,B)
+ .local string _atypes
+ .local int _testi
+
+ _testi = _IS_TYPE(.A, .T)
+ if _testi == 1 goto .$DONE
+ goto .B
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_LENGTH(A,L,B)
+
+Asserts that list A is of length L, branching to B on failure.
+
+=cut
+
+.macro ASSERT_LENGTH(A,L,B)
+ .local int _leni
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ if _leni == .L goto .$DONE # Branch on success
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_MINIMUM_LENGTH(A,L,B)
+
+Asserts that list A is at least of length L, branching to B on failure.
+
+=cut
+
+.macro ASSERT_MINIMUM_LENGTH(A,L,B)
+ .local int _leni
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ if _leni >= .L goto .$DONE # Branch on success
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_LENGTH_BETWEEN(A,L,M,B)
+
+Asserts that list A is at least of length L and at most of length M, branching to B on failure.
+
+=cut
+
+.macro ASSERT_LENGTH_BETWEEN(A,L,M,B)
+ .local int _leni
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ if _leni >= .L goto .$DONE # Branch on success (min bound)
+ if _leni <= .M goto .$DONE # Branch on success (max bound)
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_EVEN_LENGTH(A,B)
+
+Asserts that list A is composed of an even number of elements, branching to B on failure.
+
+=cut
+
+.macro ASSERT_EVEN_LENGTH(A,B)
+ .local int _leni
+ .local int _modi
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ mod _modi, _leni, 2
+ if _modi == 0 goto .$DONE # Branch on success
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
44 include/macros/error.pir
@@ -0,0 +1,44 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/error.pir - macros for reporting errors
+
+=head1 Macros
+
+=cut
+
+.macro ERROR_0(T,M)
+ _error(.T, .M)
+.endm
+
+.macro ERROR_1(T,M,A)
+ .local string _errmsgs
+ .local pmc _errargp
+
+ _errargp = new 'Array'
+ _errargp = 1
+ _errargp[0] = .A
+
+ sprintf _errmsgs, .M, _errargp
+ _error(.T, _errmsgs)
+.endm
+
+.macro ERROR_2(T,M,A,B)
+ .local string _errmsgs
+ .local pmc _errargp
+
+ _errargp = new 'Array'
+ _errargp = 2
+ _errargp[0] = .A
+ _errargp[1] = .B
+
+ sprintf _errmsgs, .M, _errargp
+ _error(.T, _errmsgs)
+.endm
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
180 include/macros/list.pir
@@ -0,0 +1,180 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/list.pir - list processing macros
+
+This file contains various list processing macros.
+All macro arguments are assumed to be PMC types unless otherwise noted.
+
+=head1 Macros
+
+=head2 .NULL(L,B)
+
+Branch to B if L is an empty list.
+
+=cut
+
+.macro NULL (L,B)
+ .local pmc _nilp
+
+ .NIL(_nilp)
+ eq_addr .L, _nilp, .B
+.endm
+
+=head2 .CAR(R,A)
+
+Puts the car of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro CAR (R,A)
+ .NULL(.A, .$IS_NULL)
+
+ .R = .A[0]
+
+ goto .$DONE
+
+.label $IS_NULL:
+ .NIL(.R)
+ goto .$DONE
+
+.label $DONE:
+.endm
+
+=head2 .APPEND(R,A,B)
+
+Appends B to list A, placing the result into R. A is assumed to be a valid list.
+
+=cut
+
+.macro APPEND (R,A,B)
+ .local pmc _listptr1p
+ .local pmc _listptr2p
+ .local pmc _listtmpp
+
+ .NULL(.A, .$EMPTY_LIST) # Special case if A is an empty list.
+
+ _listptr1p = .A
+
+.label $APPEND_LOOP: # Loop until we reach the end of the list.
+ .NULL(_listptr1p,.$DONE_LOOP)
+
+ _listptr2p = _listptr1p
+
+ .CDR(_listptr1p,_listptr1p)
+ goto .$APPEND_LOOP
+
+.label $DONE_LOOP: # At the EOL, replace the list end (NIL)
+ .LIST_1(_listtmpp, .B) # with a new cons containing the new element.
+ _listptr2p[1] = _listtmpp
+ goto .$DONE
+
+.label $EMPTY_LIST:
+ .LIST_1(.R,.B)
+
+.label $DONE:
+.endm
+
+=head2 .CDR(R,A)
+
+Puts the cdr of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro CDR (R,A)
+
+ .NULL(.A, .$IS_NULL)
+ .R = .A[1]
+ goto .$DONE
+
+.label $IS_NULL:
+ .NIL(.R)
+ goto .$DONE
+
+.label $DONE:
+.endm
+
+=head2 .SECOND(R,A)
+
+Puts the second element of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro SECOND (R,A)
+ .local pmc _cdrp
+
+ .CDR(_cdrp, .A)
+ .CAR(.R, _cdrp)
+.endm
+
+=head2 .THIRD(R,A)
+
+Puts the third element of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro THIRD (R,A)
+ .local pmc _cdrp
+
+ .CDR(_cdrp, .A)
+ .CDR(_cdrp, _cdrp)
+ .CAR(.R, _cdrp)
+.endm
+
+=head2 .FOURTH(R,A)
+
+Puts the fourth element of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro FOURTH (R,A)
+ .local pmc _cdrp
+
+ .CDR(_cdrp, .A)
+ .CDR(_cdrp, _cdrp)
+ .CDR(_cdrp, _cdrp)
+ .CAR(.R, _cdrp)
+.endm
+
+=head2 .LIST_1(R,A)
+
+Creates a one element list containing A, placing the result in R.
+
+=cut
+
+.macro LIST_1 (R,A)
+ .local pmc _bp
+
+ .NIL(_bp)
+ .CONS(.R, .A, _bp)
+.endm
+
+
+=head2 .LIST_2(R,A,B)
+
+Creates a two element list containing A and B, placing the result in R.
+
+=cut
+
+.macro LIST_2 (R,A,B)
+ .local pmc _cp
+
+ .LIST_1(_cp, .B)
+ .CONS(.R, .A, _cp)
+.endm
+
+.macro LIST_3 (R,A,B,C)
+ .local pmc _cp
+
+ .LIST_2(_cp, .B, .C)
+ .CONS(.R, .A, _cp)
+.endm
+
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
114 include/macros/standard.pir
@@ -0,0 +1,114 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/standard.pir - miscellaneous macros
+
+=head1 DESCRITPTION
+
+This file contains miscellaneous macros.
+
+=head1 Macros
+
+=head2 .NIL(R)
+
+Sets R to the empty list (the NIL symbol).
+
+=cut
+
+.macro NIL (R)
+ get_global .R, ["SYMBOLS"], "NIL"
+.endm
+
+=head2 .TRUE(R)
+
+Sets R to true (the TRUE symbol).
+
+=cut
+
+.macro TRUE (R)
+ get_global .R, ["SYMBOLS"], "T"
+.endm
+
+.macro CONSTANT (P)
+ .local Boolean _const
+
+ _const = new 'Boolean'
+ _const = 1
+
+ setprop .P, "constant", _const
+.endm
+
+.macro CONSTANTP (R,P)
+ .local pmc _const
+
+ getprop .R, "constant", .P
+.endm
+
+.macro SPECIAL_FORM (S,P,N,L)
+ .local pmc _specialformp
+ # VALID_IN_PARROT_0_2_0 .local pmc _funcp
+ .local pmc _namep
+
+ # VALID_IN_PARROT_0_2_0 newsub _funcp, .Sub, .L
+
+ _specialformp = new "LispSpecialForm"
+ # VALID_IN_PARROT_0_2_0 _specialformp._set_body(.L)
+ .const 'Sub' _special_func = .L
+ _specialformp.'_set_body'(_special_func)
+
+ _namep = new "LispString"
+ _namep = .N
+ _specialformp.'_set_name'(_namep)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_function'(_specialformp)
+ .S.'_set_package'(.P)
+.endm
+
+.macro DEFUN (S,P,N,L)
+ .local pmc _functionp
+ .local pmc _namep
+
+ .FUNCTION(_functionp, .L)
+
+ _namep = new "LispString"
+ _namep = .N
+ _functionp.'_set_name'(_namep)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_function'(_functionp)
+ .S.'_set_package'(.P)
+.endm
+
+.macro DEFMACRO (S,P,N,L)
+ .local pmc _macrop
+ .local pmc _namep
+
+ .MACRO(_macrop, .L)
+
+ _namep = new "LispString"
+ _namep = .N
+ _macrop.'_set_name'(_namep)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_function'(_macrop)
+ .S.'_set_package'(.P)
+.endm
+
+.macro DEFVAR (S,P,N,V)
+ .local pmc _specialp
+
+ .TRUE(_specialp)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_value'(.V)
+ .S.'_set_package'(.P)
+ .S.'_set_special'(_specialp)
+.endm
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
150 include/macros/types.pir
@@ -0,0 +1,150 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/types.pir
+
+=head1 Macros
+
+=head2 .CONS(R,A,B)
+
+Creates a new cons with car A and cdr B, placing the result in R.
+
+=cut
+
+.macro CONS (R,A,B)
+ .local pmc _consp
+
+
+ _consp = new "LispCons"
+
+ _consp[0] = .A
+ _consp[1] = .B
+
+ .R = _consp
+.endm
+
+=head2 .STRING(R,S)
+
+Creates a new string with value S, placing the result in R.
+
+=cut
+
+.macro STRING (R,S)
+ .R = new "LispString"
+ .R = .S
+.endm
+
+=head2 .STREAM(R,S)
+