Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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

…heme & urm
  • Loading branch information...
commit 78527da277cd871a0d344da8339d400dc9128c67 0 parents
François Perrad fperrad authored

Showing 37 changed files with 6,686 additions and 0 deletions. Show diff stats Hide diff stats

  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 @@
  1 +Changes for version 0.4.13
  2 +--------------------------
  3 + * Change LICENSE to Artistic License 2.0
  4 + * Start with a test suite
  5 +
  6 +Changes for version 0.4.12
  7 +--------------------------
  8 + * Make languages/lisp compile again, as it was broken due to changes in Parrot
  9 +
  10 +Changes for version 0.1.2
  11 +-------------------------
  12 + * Added basic macro support
  13 + * Added a basic DEFUN macro
  14 + * Added support for loading a file off the command line (based on a patch
  15 + from Leo)
  16 + * Speed ups in checking list lengths (courtesy Leo)
  17 + * Rewrote Lisp functions to use DEFUN
  18 +
  19 +Changes for version 0.1.1
  20 +-------------------------
  21 + * Added BOUNDP function
  22 + * Added COPY-TREE function
  23 + * Added IDENTITY function
  24 + * Added ACONS function
  25 + * Added ZEROP function
  26 + * Added an EXPORT function stub
  27 + * Added an IN-PACKAGE function stub
  28 + * Split related functions out into separate files in lisp/
8 KNOWN_BUGS
... ... @@ -0,0 +1,8 @@
  1 +# $Id$
  2 +
  3 +Known deficencies in Parrot Common Lisp:
  4 +
  5 +Some broken features.
  6 +
  7 +( print "asdf" ) print asdf and not "asdf"
  8 +
201 LICENSE
... ... @@ -0,0 +1,201 @@
  1 + The Artistic License 2.0
  2 +
  3 + Copyright (c) 2000-2006, The Perl Foundation.
  4 +
  5 + Everyone is permitted to copy and distribute verbatim copies
  6 + of this license document, but changing it is not allowed.
  7 +
  8 +Preamble
  9 +
  10 +This license establishes the terms under which a given free software
  11 +Package may be copied, modified, distributed, and/or redistributed.
  12 +The intent is that the Copyright Holder maintains some artistic
  13 +control over the development of that Package while still keeping the
  14 +Package available as open source and free software.
  15 +
  16 +You are always permitted to make arrangements wholly outside of this
  17 +license directly with the Copyright Holder of a given Package. If the
  18 +terms of this license do not permit the full use that you propose to
  19 +make of the Package, you should contact the Copyright Holder and seek
  20 +a different licensing arrangement.
  21 +
  22 +Definitions
  23 +
  24 + "Copyright Holder" means the individual(s) or organization(s)
  25 + named in the copyright notice for the entire Package.
  26 +
  27 + "Contributor" means any party that has contributed code or other
  28 + material to the Package, in accordance with the Copyright Holder's
  29 + procedures.
  30 +
  31 + "You" and "your" means any person who would like to copy,
  32 + distribute, or modify the Package.
  33 +
  34 + "Package" means the collection of files distributed by the
  35 + Copyright Holder, and derivatives of that collection and/or of
  36 + those files. A given Package may consist of either the Standard
  37 + Version, or a Modified Version.
  38 +
  39 + "Distribute" means providing a copy of the Package or making it
  40 + accessible to anyone else, or in the case of a company or
  41 + organization, to others outside of your company or organization.
  42 +
  43 + "Distributor Fee" means any fee that you charge for Distributing
  44 + this Package or providing support for this Package to another
  45 + party. It does not mean licensing fees.
  46 +
  47 + "Standard Version" refers to the Package if it has not been
  48 + modified, or has been modified only in ways explicitly requested
  49 + by the Copyright Holder.
  50 +
  51 + "Modified Version" means the Package, if it has been changed, and
  52 + such changes were not explicitly requested by the Copyright
  53 + Holder.
  54 +
  55 + "Original License" means this Artistic License as Distributed with
  56 + the Standard Version of the Package, in its current version or as
  57 + it may be modified by The Perl Foundation in the future.
  58 +
  59 + "Source" form means the source code, documentation source, and
  60 + configuration files for the Package.
  61 +
  62 + "Compiled" form means the compiled bytecode, object code, binary,
  63 + or any other form resulting from mechanical transformation or
  64 + translation of the Source form.
  65 +
  66 +
  67 +Permission for Use and Modification Without Distribution
  68 +
  69 +(1) You are permitted to use the Standard Version and create and use
  70 +Modified Versions for any purpose without restriction, provided that
  71 +you do not Distribute the Modified Version.
  72 +
  73 +
  74 +Permissions for Redistribution of the Standard Version
  75 +
  76 +(2) You may Distribute verbatim copies of the Source form of the
  77 +Standard Version of this Package in any medium without restriction,
  78 +either gratis or for a Distributor Fee, provided that you duplicate
  79 +all of the original copyright notices and associated disclaimers. At
  80 +your discretion, such verbatim copies may or may not include a
  81 +Compiled form of the Package.
  82 +
  83 +(3) You may apply any bug fixes, portability changes, and other
  84 +modifications made available from the Copyright Holder. The resulting
  85 +Package will still be considered the Standard Version, and as such
  86 +will be subject to the Original License.
  87 +
  88 +
  89 +Distribution of Modified Versions of the Package as Source
  90 +
  91 +(4) You may Distribute your Modified Version as Source (either gratis
  92 +or for a Distributor Fee, and with or without a Compiled form of the
  93 +Modified Version) provided that you clearly document how it differs
  94 +from the Standard Version, including, but not limited to, documenting
  95 +any non-standard features, executables, or modules, and provided that
  96 +you do at least ONE of the following:
  97 +
  98 + (a) make the Modified Version available to the Copyright Holder
  99 + of the Standard Version, under the Original License, so that the
  100 + Copyright Holder may include your modifications in the Standard
  101 + Version.
  102 +
  103 + (b) ensure that installation of your Modified Version does not
  104 + prevent the user installing or running the Standard Version. In
  105 + addition, the Modified Version must bear a name that is different
  106 + from the name of the Standard Version.
  107 +
  108 + (c) allow anyone who receives a copy of the Modified Version to
  109 + make the Source form of the Modified Version available to others
  110 + under
  111 +
  112 + (i) the Original License or
  113 +
  114 + (ii) a license that permits the licensee to freely copy,
  115 + modify and redistribute the Modified Version using the same
  116 + licensing terms that apply to the copy that the licensee
  117 + received, and requires that the Source form of the Modified
  118 + Version, and of any works derived from it, be made freely
  119 + available in that license fees are prohibited but Distributor
  120 + Fees are allowed.
  121 +
  122 +
  123 +Distribution of Compiled Forms of the Standard Version
  124 +or Modified Versions without the Source
  125 +
  126 +(5) You may Distribute Compiled forms of the Standard Version without
  127 +the Source, provided that you include complete instructions on how to
  128 +get the Source of the Standard Version. Such instructions must be
  129 +valid at the time of your distribution. If these instructions, at any
  130 +time while you are carrying out such distribution, become invalid, you
  131 +must provide new instructions on demand or cease further distribution.
  132 +If you provide valid instructions or cease distribution within thirty
  133 +days after you become aware that the instructions are invalid, then
  134 +you do not forfeit any of your rights under this license.
  135 +
  136 +(6) You may Distribute a Modified Version in Compiled form without
  137 +the Source, provided that you comply with Section 4 with respect to
  138 +the Source of the Modified Version.
  139 +
  140 +
  141 +Aggregating or Linking the Package
  142 +
  143 +(7) You may aggregate the Package (either the Standard Version or
  144 +Modified Version) with other packages and Distribute the resulting
  145 +aggregation provided that you do not charge a licensing fee for the
  146 +Package. Distributor Fees are permitted, and licensing fees for other
  147 +components in the aggregation are permitted. The terms of this license
  148 +apply to the use and Distribution of the Standard or Modified Versions
  149 +as included in the aggregation.
  150 +
  151 +(8) You are permitted to link Modified and Standard Versions with
  152 +other works, to embed the Package in a larger work of your own, or to
  153 +build stand-alone binary or bytecode versions of applications that
  154 +include the Package, and Distribute the result without restriction,
  155 +provided the result does not expose a direct interface to the Package.
  156 +
  157 +
  158 +Items That are Not Considered Part of a Modified Version
  159 +
  160 +(9) Works (including, but not limited to, modules and scripts) that
  161 +merely extend or make use of the Package, do not, by themselves, cause
  162 +the Package to be a Modified Version. In addition, such works are not
  163 +considered parts of the Package itself, and are not subject to the
  164 +terms of this license.
  165 +
  166 +
  167 +General Provisions
  168 +
  169 +(10) Any use, modification, and distribution of the Standard or
  170 +Modified Versions is governed by this Artistic License. By using,
  171 +modifying or distributing the Package, you accept this license. Do not
  172 +use, modify, or distribute the Package, if you do not accept this
  173 +license.
  174 +
  175 +(11) If your Modified Version has been derived from a Modified
  176 +Version made by someone other than you, you are nevertheless required
  177 +to ensure that your Modified Version complies with the requirements of
  178 +this license.
  179 +
  180 +(12) This license does not grant you the right to use any trademark,
  181 +service mark, tradename, or logo of the Copyright Holder.
  182 +
  183 +(13) This license includes the non-exclusive, worldwide,
  184 +free-of-charge patent license to make, have made, use, offer to sell,
  185 +sell, import and otherwise transfer the Package with respect to any
  186 +patent claims licensable by the Copyright Holder that are necessarily
  187 +infringed by the Package. If you institute patent litigation
  188 +(including a cross-claim or counterclaim) against any party alleging
  189 +that the Package constitutes direct or contributory patent
  190 +infringement, then this Artistic License to you shall terminate on the
  191 +date that such litigation is filed.
  192 +
  193 +(14) Disclaimer of Warranty:
  194 +THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
  195 +IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
  196 +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
  197 +NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
  198 +LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
  199 +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
  200 +DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
  201 +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3  MAINTAINER
... ... @@ -0,0 +1,3 @@
  1 +# $Id$
  2 +
  3 +N: Cory Spencer
11 README
... ... @@ -0,0 +1,11 @@
  1 +This is Parrot Common Lisp
  2 +--------------------------
  3 +
  4 +Parrot Common Lisp is Copyright (C) 2004 - 2005 Cory Spencer. All
  5 +Rights Reserved.
  6 +
  7 +LICENSE INFORMATION
  8 +-------------------
  9 +
  10 +This code is distributed under the "Artistic License 2.0".
  11 +The "Artistic License 2.0" can be found in the file "LICENSE".
1,334 cl.pir
... ... @@ -0,0 +1,1334 @@
  1 +# $Id$
  2 +
  3 +=head1 NAME
  4 +
  5 +cl.pir - Set up the package 'COMMON-LISP'
  6 +
  7 +=cut
  8 +
  9 +.sub _init_cl :init
  10 +
  11 + .local pmc symbol
  12 + .local pmc value
  13 +
  14 + .local pmc package
  15 + .PACKAGE(package, "COMMON-LISP")
  16 + set_global ["PACKAGES"], "COMMON-LISP", package
  17 + set_global ["PACKAGES"], "CL", package
  18 +
  19 + .local pmc t
  20 + t = package.'_intern_symbol'("T") # Create the T symbol, T meaning true
  21 + t.'_set_value'(t)
  22 + t.'_set_package'(package)
  23 + t.'_set_special'(t)
  24 + set_global ["SYMBOLS"], "T", t # Quick alias to T
  25 +
  26 + .local pmc nil
  27 + nil = package.'_intern_symbol'("NIL") # Create the NIL symbol
  28 + nil.'_set_value'(nil)
  29 + nil.'_set_package'(package)
  30 + nil.'_set_special'(t)
  31 + set_global ["SYMBOLS"], "NIL", nil # Quick alias to NIL
  32 +
  33 + .INTEGER(value,1)
  34 + .DEFVAR(symbol, package, "*GENSYM-COUNTER*", value)
  35 +
  36 + .DEFVAR(symbol, package, "*PACKAGE*", package)
  37 +
  38 + .READTABLE(value)
  39 + .DEFVAR(symbol, package, "*READTABLE*", value)
  40 +
  41 + .local pmc stream
  42 + getstdin stream
  43 + .STREAM(value,stream)
  44 + .DEFVAR(symbol, package, "*STANDARD-INPUT*", value)
  45 +
  46 + getstdout stream
  47 + stream.'buffer_type'('unbuffered')
  48 + .STREAM(value,stream)
  49 + .DEFVAR(symbol, package, "*STANDARD-OUTPUT*", value)
  50 +
  51 + .local pmc function # this is needed in r20641
  52 +
  53 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "APPLY", _apply)
  54 + .DEFUN(symbol, package, "APPLY", "_apply")
  55 +
  56 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "ATOM", _atom)
  57 + .DEFUN(symbol, package, "ATOM", "_atom")
  58 +
  59 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "BOUNDP", _boundp)
  60 + .DEFUN(symbol, package, "BOUNDP", "_boundp")
  61 +
  62 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CAR", _car)
  63 + .DEFUN(symbol, package, "CAR", "_car")
  64 +
  65 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CDR", _cdr)
  66 + .DEFUN(symbol, package, "CDR", "_cdr")
  67 +
  68 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CHAR", _char)
  69 + .DEFUN(symbol, package, "CHAR", "_char")
  70 +
  71 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CONS", _cons)
  72 + .DEFUN(symbol, package, "CONS", "_cons")
  73 +
  74 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "EQ", _eq)
  75 + .DEFUN(symbol, package, "EQ", "_eq")
  76 +
  77 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "EVAL", _eval)
  78 + .DEFUN(symbol, package, "EVAL", "_eval")
  79 +
  80 + .SPECIAL_FORM(symbol, package, "FUNCTION", '_function')
  81 +
  82 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "GENSYM", _gensym)
  83 + .DEFUN(symbol, package, "GENSYM", "_gensym")
  84 +
  85 + .SPECIAL_FORM(symbol, package, "IF", '_if')
  86 +
  87 + .SPECIAL_FORM(symbol, package, "LET", '_let')
  88 +
  89 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "LIST", _list)
  90 + .DEFUN(symbol, package, "LIST", "_list")
  91 +
  92 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "MOD", _modulus)
  93 + .DEFUN(symbol, package, "MOD", "_modulus")
  94 +
  95 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "NULL", _null)
  96 + .DEFUN(symbol, package, "NULL", "_null")
  97 +
  98 + .DEFUN(symbol, package, "PRINT", "_print")
  99 +
  100 + .SPECIAL_FORM(symbol, package, "PROGN", '_progn')
  101 +
  102 + .SPECIAL_FORM(symbol, package, "QUOTE", '_quote')
  103 +
  104 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "READ", _read)
  105 + .DEFUN(symbol, package, "READ", "_read")
  106 +
  107 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "READ-DELIMITED-LIST",_read_delimited_list)
  108 + .DEFUN(symbol, package, "READ-DELIMITED-LIST","_read_delimited_list")
  109 +
  110 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "RPLACA", _rplaca)
  111 + .DEFUN(symbol, package, "RPLACA", "_rplaca")
  112 +
  113 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "RPLACD", _rplacd)
  114 + .DEFUN(symbol, package, "RPLACD", "_rplacd")
  115 +
  116 + .SPECIAL_FORM(symbol, package, "SETQ", '_setq')
  117 +
  118 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "TYPE-OF", _type_of)
  119 + .DEFUN(symbol, package, "TYPE-OF", "_type_of")
  120 +
  121 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "VALUES", _values)
  122 + .DEFUN(symbol, package, "VALUES", "_values")
  123 +
  124 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "QUIT", _quit)
  125 + .DEFUN(symbol, package, "QUIT", "_quit")
  126 +
  127 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "/", _divide)
  128 + .DEFUN(symbol, package, "/", "_divide")
  129 +
  130 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "-", _subtract)
  131 + .DEFUN(symbol, package, "-", "_subtract")
  132 +
  133 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "*", _multiply)
  134 + .DEFUN(symbol, package, "*", "_multiply")
  135 +
  136 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "+", _add)
  137 + .DEFUN(symbol, package, "+", "_add")
  138 +
  139 + # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "=", _equal)
  140 + .DEFUN(symbol, package, "=", "_equal")
  141 +
  142 + .return(1)
  143 +.end
  144 +
  145 +.sub _apply
  146 + .param pmc args
  147 + .ASSERT_MINIMUM_LENGTH(args, 2, ERROR_NARGS)
  148 +
  149 + .local pmc car
  150 + .CAR(car, args)
  151 +
  152 + .local pmc args_of_func
  153 + .SECOND(args_of_func, args)
  154 + .ASSERT_TYPE(args_of_func, "list")
  155 +
  156 + .local string type
  157 + type = typeof car
  158 + if type == "LispFunction" goto CAR_IS_FUNCTION
  159 + if type == "LispSymbol" goto CAR_IS_SYMBOL
  160 + goto INVALID_FUNCTION_NAME
  161 +
  162 +CAR_IS_FUNCTION:
  163 + .tailcall _FUNCTION_CALL(car, args_of_func)
  164 +
  165 +CAR_IS_SYMBOL:
  166 + .local pmc func
  167 + func = car.'_get_function'() # Get the function from symbol
  168 + if_null func, INVALID_FUNCTION_NAME # Throw an error if undefined
  169 + type = typeof func
  170 + # print type
  171 + # print ' for CAR_IS_SYMBOL'
  172 + .tailcall _FUNCTION_CALL(func,args_of_func)
  173 +
  174 +INVALID_FUNCTION_NAME:
  175 + .ERROR_1("undefined-function", "%s is not a function name", car)
  176 + goto DONE
  177 +
  178 +ERROR_NARGS:
  179 + .ERROR_0("program-error", "wrong number of arguments to APPLY")
  180 + goto DONE
  181 +
  182 +ERROR_NONLIST:
  183 + .ERROR_0("type-error", "second argument to APPLY must be a proper list")
  184 + goto DONE
  185 +
  186 +DONE:
  187 + .return() # Call the return continuation
  188 +.end
  189 +
  190 +.sub _atom
  191 + .param pmc args
  192 + .local string type
  193 + .local pmc retv
  194 + .local pmc a
  195 +
  196 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  197 +
  198 + .CAR(a, args)
  199 +
  200 + type = typeof a # An atom is anything that is
  201 + if type != "LispCons" goto ATOM # not a cons.
  202 + goto CONS
  203 +
  204 +ATOM:
  205 + .TRUE(retv)
  206 + goto DONE
  207 +
  208 +CONS:
  209 + .NIL(retv)
  210 + goto DONE
  211 +
  212 +ERROR_NARGS:
  213 + .ERROR_0("program-error", "wrong number of arguments to ATOM")
  214 + goto DONE
  215 +
  216 +DONE:
  217 + .return(retv)
  218 +.end
  219 +
  220 +.sub _boundp
  221 + .param pmc args
  222 + .local pmc symbol
  223 + .local pmc retv
  224 + .local pmc val
  225 +
  226 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  227 +
  228 + .CAR(symbol, args)
  229 + .ASSERT_TYPE(symbol, "symbol")
  230 +
  231 + val = symbol.'_get_value'()
  232 + if_null val, UNBOUND
  233 +
  234 + .TRUE(retv)
  235 + goto DONE
  236 +
  237 +UNBOUND:
  238 + .NIL(retv)
  239 + goto DONE
  240 +
  241 +ERROR_NARGS:
  242 + .ERROR_0("program-error", "wrong number of arguments to BOUNDP")
  243 + goto DONE
  244 +
  245 +DONE:
  246 + .return(retv)
  247 +.end
  248 +
  249 +.sub _car
  250 + .param pmc args
  251 + .local pmc retv
  252 + .local pmc a
  253 +
  254 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  255 +
  256 + .CAR(a, args)
  257 + .ASSERT_TYPE(a, "list")
  258 +
  259 + .CAR(retv, a)
  260 +
  261 + goto DONE
  262 +
  263 +ERROR_NARGS:
  264 + .ERROR_0("program-error", "wrong number of arguments to CAR")
  265 + goto DONE
  266 +
  267 +DONE:
  268 + .return(retv)
  269 +.end
  270 +
  271 +.sub _cdr
  272 + .param pmc args
  273 + .local pmc retv
  274 + .local pmc a
  275 +
  276 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  277 +
  278 + .CAR(a, args)
  279 + .ASSERT_TYPE(a, "list")
  280 +
  281 + .CDR(retv, a)
  282 +
  283 + goto DONE
  284 +
  285 +ERROR_NARGS:
  286 + .ERROR_0("program-error", "wrong number of arguments to CDR")
  287 + goto DONE
  288 +
  289 +DONE:
  290 + .return(retv)
  291 +.end
  292 +
  293 +.sub _char
  294 + .param pmc args
  295 +
  296 + .local pmc retval
  297 + .local pmc ke
  298 + .local string str
  299 + .local string sstr
  300 + .local int k
  301 + .local int leng
  302 +
  303 + .ASSERT_LENGTH(args, 2, ERROR_NARGS)
  304 +
  305 + str = args[0]
  306 + ke = args[1]
  307 + k = ke[0]
  308 +
  309 + length leng, str
  310 +
  311 + if k > leng goto BOUNDS
  312 + if k < 0 goto BOUNDS
  313 +
  314 + sstr = substr str, k, 1
  315 + retval = new 'LispString'
  316 + retval = sstr
  317 + goto DONE
  318 +
  319 +BOUNDS:
  320 + .NIL(retval)
  321 + goto DONE
  322 +
  323 +ERROR_NARGS:
  324 + .ERROR_0("program-error", "wrong number of arguments to CHAR")
  325 + goto DONE
  326 +
  327 +DONE:
  328 + .return(retval)
  329 +.end
  330 +
  331 +.sub _cons
  332 + .param pmc args
  333 + .local pmc retv
  334 + .local pmc a
  335 + .local pmc b
  336 +
  337 + .ASSERT_LENGTH(args, 2, ERROR_NARGS)
  338 +
  339 + .CAR(a, args)
  340 + .SECOND(b, args)
  341 +
  342 + .CONS(retv, a, b)
  343 + goto DONE
  344 +
  345 +ERROR_NARGS:
  346 + .ERROR_0("program-error", "wrong number of arguments to CONS")
  347 + goto DONE
  348 +
  349 +DONE:
  350 + .return(retv)
  351 +.end
  352 +
  353 +.sub _eq
  354 + .param pmc args
  355 + .local pmc retv
  356 + .local pmc a
  357 + .local pmc b
  358 +
  359 + .ASSERT_LENGTH(args, 2, ERROR_NARGS)
  360 +
  361 + .CAR(a, args)
  362 + .SECOND(b, args)
  363 +
  364 + eq_addr a, b, EQUAL
  365 + goto NOT_EQUAL
  366 +
  367 +EQUAL:
  368 + .TRUE(retv)
  369 + goto DONE
  370 +
  371 +NOT_EQUAL:
  372 + .NIL(retv)
  373 + goto DONE
  374 +
  375 +ERROR_NARGS:
  376 + .ERROR_0("program-error", "wrong number of arguments to EQ")
  377 + goto DONE
  378 +
  379 +DONE:
  380 + .return(retv)
  381 +.end
  382 +
  383 +.sub _function
  384 + .param pmc args
  385 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  386 +
  387 + .local pmc form
  388 + .CAR(form, args)
  389 +
  390 + .local pmc retv
  391 +
  392 + .local string type
  393 + type = typeof form
  394 + if type == "LispSymbol" goto SYMBOL # Retrieve function from symbol
  395 +
  396 + .local int is_lambda_list
  397 + is_lambda_list = _IS_ORDINARY_LAMBDA_LIST(form) # Check if it's a lambda form
  398 + if is_lambda_list goto LAMBDA_FORM # and build a closure if so
  399 +
  400 + goto INVALID_FUNCTION_NAME
  401 +
  402 +SYMBOL:
  403 + .local string symname
  404 + symname = form.'_get_name_as_string'() # Retrieve the symbols name
  405 +
  406 + .local pmc package
  407 + package = form.'_get_package'() # Retrieve the symbols package name
  408 + .local string pkgname
  409 + pkgname = package.'_get_name_as_string'()
  410 +
  411 + .local pmc symbol
  412 + symbol = _LOOKUP_GLOBAL(pkgname, symname) # Lookup the symbol
  413 +
  414 + .local int found
  415 + found = defined symbol # Ensure the symbol was found in
  416 + unless found goto FUNCTION_NOT_FOUND # the global namespace
  417 +
  418 + retv = symbol.'_get_function'() # Ensure the symbol had a function
  419 + defined found, symbol # defined
  420 + unless found goto FUNCTION_NOT_FOUND
  421 +
  422 + goto DONE
  423 +
  424 +LAMBDA_FORM:
  425 + retv = _MAKE_LAMBDA(form) # Create a closure PMC
  426 + goto DONE
  427 +
  428 +INVALID_FUNCTION_NAME:
  429 + .ERROR_1("undefined-function", "%s is not a function name", form)
  430 + goto DONE
  431 +
  432 +FUNCTION_NOT_FOUND:
  433 + .ERROR_1("undefined-function", "the function %s is undefined", symname)
  434 + goto DONE
  435 +
  436 +ERROR_NARGS:
  437 + .ERROR_0("program-error", "wrong number of arguments to FUNCTION")
  438 + goto DONE
  439 +
  440 +DONE:
  441 + .return(retv)
  442 +.end
  443 +
  444 +.sub _gensym
  445 + .param pmc args
  446 + .local string prefix
  447 + .local string gname
  448 + .local pmc suffix
  449 + .local pmc symbol
  450 + .local pmc garg
  451 + .local pmc gcnt
  452 + .local pmc retv
  453 + .local pmc car
  454 +
  455 + .ASSERT_LENGTH_BETWEEN(args, 0, 1, ERROR_NARGS)
  456 +
  457 + symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*GENSYM-COUNTER*")
  458 + gcnt = symbol.'_get_value'()
  459 +
  460 + suffix = gcnt
  461 + prefix = "G"
  462 +
  463 + .NULL(args, MAKE_SYMBOL)
  464 +
  465 + .CAR(car, args)
  466 + goto CHECK_PREFIX
  467 +
  468 +CHECK_PREFIX:
  469 + .ASSERT_TYPE_AND_BRANCH(car, "string", CHECK_SUFFIX)
  470 + prefix = car
  471 + goto MAKE_SYMBOL
  472 +
  473 +CHECK_SUFFIX:
  474 + .ASSERT_TYPE(car, "integer")
  475 + if car < 0 goto ERROR_NEGINT
  476 + suffix = car
  477 + goto MAKE_SYMBOL
  478 +
  479 +MAKE_SYMBOL:
  480 + garg = new 'Array'
  481 + garg = 2
  482 + garg[0] = prefix
  483 + garg[1] = suffix
  484 +
  485 + sprintf gname, "%s%0.6d", garg
  486 + retv = _SYMBOL(gname)
  487 +
  488 + inc gcnt
  489 + goto DONE
  490 +
  491 +ERROR_NARGS:
  492 + .ERROR_0("program-error", "wrong number of arguments to GENSYM")
  493 + goto DONE
  494 +
  495 +ERROR_NEGINT:
  496 + .ERROR_1("program-error", "%d is negative", car)
  497 + goto DONE
  498 +
  499 +DONE:
  500 + .return(retv)
  501 +.end
  502 +
  503 +.sub _if
  504 + .param pmc args
  505 + .local pmc retv
  506 + .local pmc form
  507 + .local pmc earg
  508 +
  509 + .ASSERT_LENGTH_BETWEEN(args, 2, 3, ERROR_NARGS)
  510 +
  511 + .CAR(form, args) # Get the test form
  512 +
  513 + .LIST_1(earg,form)
  514 + retv = _eval(earg) # Evaluate the test form.
  515 +
  516 + .NULL(retv, ELSE_CLAUSE) # If test was false, goto else clause
  517 + goto THEN_CLAUSE #else goto then clause
  518 +
  519 +THEN_CLAUSE:
  520 + .SECOND(form, args)
  521 +
  522 + .LIST_1(earg, form)
  523 + retv = _eval(earg)
  524 + goto DONE
  525 +
  526 +ELSE_CLAUSE:
  527 + .THIRD(form, args)
  528 +
  529 + .LIST_1(earg, form)
  530 + retv = _eval(earg)
  531 + goto DONE
  532 +
  533 +ERROR_NARGS:
  534 + .ERROR_0("program-error", "wrong number of arguments to IF")
  535 + goto DONE
  536 +
  537 +DONE:
  538 + .return(retv)
  539 +.end
  540 +
  541 +.sub _list
  542 + .param pmc args
  543 + .local pmc lptr
  544 + .local pmc targ
  545 + .local pmc retv
  546 + .local pmc retp
  547 + .local pmc cons
  548 + .local pmc nil
  549 +
  550 + .NIL(retv)
  551 + .NIL(nil)
  552 +
  553 + lptr = args
  554 +LOOP:
  555 + .NULL(lptr, DONE)
  556 +
  557 + .CAR(targ, lptr)
  558 +
  559 + .NULL(retv, EMPTY_LIST)
  560 +
  561 + .CONS(cons, targ, nil)
  562 + retp[1] = cons
  563 + retp = cons
  564 +
  565 +EMPTY_LIST_RETURN:
  566 + .CDR(lptr, lptr)
  567 + goto LOOP
  568 +
  569 +EMPTY_LIST:
  570 + .CONS(retv, targ, nil)
  571 + retp = retv
  572 + goto EMPTY_LIST_RETURN
  573 +
  574 +DONE:
  575 + .return(retv)
  576 +.end
  577 +
  578 +.sub _null
  579 + .param pmc args
  580 + .local pmc retv
  581 + .local pmc a
  582 +
  583 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  584 +
  585 + .CAR(a, args)
  586 +
  587 + .NULL(a, IS_NULL)
  588 +
  589 + .NIL(retv)
  590 + goto DONE
  591 +
  592 +IS_NULL:
  593 + .TRUE(retv)
  594 + goto DONE
  595 +
  596 +ERROR_NARGS:
  597 + .ERROR_0("program-error", "wrong number of arguments to NULL")
  598 + goto DONE
  599 +
  600 +DONE:
  601 + .return(retv)
  602 +.end
  603 +
  604 +.sub _let
  605 + .param pmc args
  606 + .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS)
  607 +
  608 + .local string name
  609 + .local string type
  610 + .local pmc package
  611 + .local pmc symbol
  612 + .local pmc value
  613 + .local pmc fargs
  614 + .local pmc init
  615 + .local pmc body
  616 + .local pmc lptr
  617 + .local pmc form
  618 + .local int test
  619 + .local int i
  620 +
  621 + # VALID_IN_PARROT_0_2_0 new_pad -1 # Create new lexical scope
  622 +
  623 + .CAR(init, args) # The variable bindings
  624 + .CDR(body, args) # The form to evaluate
  625 +
  626 + .local pmc keyvals
  627 + keyvals = new 'ResizablePMCArray' # List for holding init values
  628 + .local pmc dynvars
  629 + dynvars = new 'ResizablePMCArray' # List for holding dynamic vars
  630 +
  631 + # for exception handling, currently broken
  632 + .local pmc error
  633 + null error
  634 + push_eh CLEANUP_HANDLER # Set a handler for cleanup
  635 +
  636 + .local pmc retv
  637 + .NIL(retv) # Initialize return value
  638 +
  639 +INIT_FORM: # Process the init form
  640 + type = typeof init
  641 + if type == "LispSymbol" goto INIT_SYMBOL
  642 + if type == "LispCons" goto INIT_LIST
  643 + goto EVAL_BODY
  644 +
  645 +INIT_SYMBOL:
  646 + push keyvals, init # Init form was just a symbol -
  647 + null value # no value is assigned to it
  648 + push keyvals, value
  649 +
  650 + goto INIT_DONE
  651 +
  652 +INIT_LIST:
  653 + lptr = init
  654 + goto INIT_LIST_LOOP
  655 +
  656 +INIT_LIST_LOOP:
  657 + .NULL(lptr, INIT_DONE)
  658 +
  659 + .CAR(form, lptr) # Get the next init form
  660 +
  661 + .ASSERT_TYPE_AND_BRANCH(form, "list", ERROR_BAD_SPEC)
  662 + # VALID_IN_PARROT_0_2_0 .ASSERT_LENGTH(form, 2, ERROR_BADSPEC) # Ensure a valid init form
  663 + .ASSERT_LENGTH(form, 2, ERROR_BAD_SPEC) # Ensure a valid init form
  664 +
  665 + .CAR(symbol, form) # The symbol we're assigning to
  666 + .SECOND(value, form) # The value being assigned
  667 +
  668 + .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", ERROR_BAD_SPEC)
  669 +
  670 + .LIST_1(fargs, value) # Put value into an arg list
  671 + value = _eval(fargs) # Evaluate it
  672 +
  673 + push keyvals, symbol # Push symbol onto key/val list
  674 + push keyvals, value # Push value onto key/val list
  675 +
  676 + .CDR(lptr, lptr)
  677 + goto INIT_LIST_LOOP
  678 +
  679 +INIT_DONE:
  680 +
  681 + # bind the variables in init
  682 + .local int nvar
  683 + nvar = keyvals
  684 + i = 0
  685 +BIND_LOOP:
  686 + if i >= nvar goto BIND_DONE
  687 +
  688 + symbol = keyvals[i] # Pop symbol of key/val list
  689 + inc i
  690 + value = keyvals[i] # Pop value of key/val list
  691 +
  692 + name = symbol.'_get_name_as_string'()
  693 +
  694 + test = _IS_SPECIAL(symbol)
  695 + if test == 0 goto BIND_LEXICAL
  696 + goto BIND_DYNAMIC
  697 +
  698 +BIND_LEXICAL:
  699 + # TODO: replace push_pad, pop_pad, do not worry about closures yet
  700 + symbol = _LEXICAL_SYMBOL(name, value) # Create a new lexical symbol
  701 + inc i
  702 + goto BIND_LOOP
  703 +
  704 +BIND_DYNAMIC:
  705 + package = symbol.'_get_package'() # Get dynamic symbols package
  706 +
  707 + symbol = package.'_shadow_symbol'(name) # Shadow the symbol
  708 + symbol.'_set_value'(value) # Set the new value
  709 +
  710 + push dynvars, symbol # Keep around for tracking
  711 +
  712 + inc i
  713 + goto BIND_LOOP
  714 +
  715 +BIND_DONE:
  716 + goto EVAL_BODY
  717 +
  718 +
  719 +EVAL_BODY:
  720 + lptr = body # Set pointer to the body form
  721 +
  722 +EVAL_LOOP: # Evaluate each form in order
  723 + .NULL(lptr, EVAL_DONE)
  724 +
  725 + .CAR(form, lptr) # Get the next form in the body
  726 + .LIST_1(fargs, form) # Put it into an arg list
  727 + retv = _eval(fargs) # Evaluate it
  728 +
  729 + .CDR(lptr, lptr) # Get a pointer to next form
  730 + goto EVAL_LOOP
  731 +
  732 +EVAL_DONE:
  733 + goto CLEANUP
  734 +
  735 +
  736 +CLEANUP_HANDLER:
  737 + .get_results (error) # Caught an exception - save it
  738 + goto CLEANUP # and clean up before rethrow
  739 +
  740 +CLEANUP:
  741 + # VALID_IN_PARROT_0_2_0 pop_pad # Pop off the lexical scope
  742 +
  743 + nvar = dynvars
  744 + i = 0
  745 +
  746 +CLEANUP_LOOP:
  747 + if i >= nvar goto CLEANUP_DONE
  748 +
  749 + symbol = dynvars[i] # Symbol to be unshadowed
  750 + name = symbol.'_get_name_as_string'()
  751 + package = symbol.'_get_package'()
  752 +
  753 + package.'_unshadow_symbol'(name) # Unshadow the symbol
  754 +
  755 + inc i
  756 + goto CLEANUP_LOOP
  757 +
  758 +CLEANUP_DONE:
  759 + if_null error, DONE # Rethrow an exception if we
  760 + rethrow error # need to
  761 + goto DONE
  762 +
  763 +CLEANUP_RETHROW:
  764 + rethrow error
  765 + goto DONE
  766 +
  767 +# VALID_IN_PARROT_0_2_0 ERROR_BADSPEC:
  768 +ERROR_BAD_SPEC:
  769 + .ERROR_1("program-error", "illegal variable specification %s", form)
  770 + goto CLEANUP
  771 +
  772 +ERROR_NARGS:
  773 + .ERROR_0("program-error", "wrong number of arguments to LET")
  774 + goto CLEANUP
  775 +
  776 +DONE:
  777 + .return(retv)
  778 +.end
  779 +
  780 +.sub _print # This is just a temporary stand-in - it
  781 + .param pmc args # doesn't have near enough the amount of
  782 + # functionality required.
  783 + .local string strval
  784 + .local pmc retv
  785 + .local pmc obj
  786 +
  787 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  788 +
  789 + .CAR(obj, args)
  790 +
  791 + strval = obj
  792 + .STRING(retv, obj)
  793 + print retv
  794 + print "\n"
  795 +
  796 + goto DONE
  797 +
  798 +ERROR_NARGS:
  799 + .ERROR_0("program-error", "wrong number of arguments to PRINT")
  800 + goto DONE
  801 +
  802 +DONE:
  803 + .return(retv)
  804 +.end
  805 +
  806 +.sub _progn
  807 + .param pmc args
  808 + .local pmc eform
  809 + .local pmc eargs
  810 + .local pmc lptr
  811 + .local pmc retv
  812 +
  813 + .NIL(retv)
  814 + lptr = args
  815 +
  816 +FORM_LOOP:
  817 + .NULL(lptr, DONE)
  818 +
  819 + .CAR(eform, lptr) # Create the arg list for eval
  820 + .LIST_1(eargs, eform)
  821 +
  822 + retv = _eval(eargs) # Evaluate form in list
  823 +
  824 + .CDR(lptr, lptr) # Point to next form
  825 + goto FORM_LOOP
  826 +
  827 +DONE:
  828 + .return(retv)
  829 +.end
  830 +
  831 +.sub _quit
  832 + .param pmc args
  833 +
  834 + .ASSERT_LENGTH(args, 0, ERROR_NARGS)
  835 + goto DONE
  836 +
  837 +ERROR_NARGS:
  838 + .ERROR_0("program-error", "wrong number of arguments to QUIT")
  839 + goto DONE
  840 +
  841 +DONE:
  842 + end
  843 +.end
  844 +
  845 +.sub _quote
  846 + .param pmc args
  847 + .local pmc retv
  848 +
  849 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  850 +
  851 + .CAR(retv,args)
  852 + goto DONE
  853 +
  854 +ERROR_NARGS:
  855 + .ERROR_0("program-error", "wrong number of arguments to QUOTE")
  856 + goto DONE
  857 +
  858 +DONE:
  859 + .return(retv)
  860 +.end
  861 +
  862 +.sub _rplaca
  863 + .param pmc args
  864 + .local pmc cons
  865 + .local pmc val
  866 +
  867 + .ASSERT_LENGTH(args, 2, ERROR_NARGS)
  868 +
  869 + .CAR(cons, args)
  870 + .SECOND(val, args)
  871 +
  872 + .ASSERT_TYPE(cons, "cons")
  873 +
  874 + cons[0] = val # Replace the car with val
  875 + goto DONE
  876 +
  877 +ERROR_NARGS:
  878 + .ERROR_0("program-error", "wrong number of arguments to RPLACA")
  879 + goto DONE
  880 +
  881 +DONE:
  882 + .return(cons)
  883 +.end
  884 +
  885 +.sub _rplacd
  886 + .param pmc args
  887 + .local pmc cons
  888 + .local pmc val
  889 +
  890 + .ASSERT_LENGTH(args, 2, ERROR_NARGS)
  891 +
  892 + .CAR(cons, args)
  893 + .SECOND(val, args)
  894 +
  895 + .ASSERT_TYPE(cons, "cons") # Ensure first arg is a cons
  896 +
  897 + cons[1] = val # Replace the cdr with val
  898 + goto DONE
  899 +
  900 +ERROR_NARGS:
  901 + .ERROR_0("program-error", "wrong number of arguments to RPLACD")
  902 + goto DONE
  903 +
  904 +DONE:
  905 + .return(cons)
  906 +.end
  907 +
  908 +.sub _setq
  909 + .param pmc args
  910 +
  911 + .local string name
  912 + .local pmc lexical
  913 + .local pmc symbol
  914 + .local pmc value
  915 + .local pmc retv
  916 + .local pmc lptr
  917 + .local pmc earg
  918 +
  919 + .ASSERT_EVEN_LENGTH(args, ERROR_NARGS)
  920 +
  921 + lptr = args # Pointer to the arguments
  922 + .NIL(retv) # Initialize return value
  923 +
  924 +LOOP:
  925 + .NULL(lptr, DONE) # If we're at the EOL goto DONE
  926 +
  927 + .CAR(symbol, lptr) # Get the variable to assign to
  928 + .SECOND(value, lptr) # Get the value being assigned
  929 +
  930 + .ASSERT_TYPE(symbol, "symbol") # Ensure variable is a symbol
  931 +
  932 + name = symbol.'_get_name_as_string'() # Get the symbols name
  933 + lexical = _LOOKUP_LEXICAL(name) # Look for it in lexical env
  934 + if_null lexical, SET_SYMBOL_VALUE
  935 +
  936 + symbol = lexical # Lexical variable was found
  937 +
  938 +SET_SYMBOL_VALUE:
  939 + .LIST_1(earg, value) # Evaluate the value form
  940 + retv = _eval(earg)
  941 +
  942 + symbol.'_set_value'(retv)
  943 +
  944 + .CDR(lptr, lptr)
  945 + .CDR(lptr, lptr)
  946 +
  947 + goto LOOP
  948 +
  949 +ERROR_NARGS:
  950 + .ERROR_0("program-error", "odd number of arguments to SETQ")
  951 + goto DONE
  952 +
  953 +DONE:
  954 + .return(retv)
  955 +.end
  956 +
  957 +.sub _type_of
  958 + .param pmc args
  959 + .local string type
  960 + .local string name
  961 + .local pmc form
  962 + .local pmc retv
  963 + .local pmc nil
  964 +
  965 + .ASSERT_LENGTH(args, 1, ERROR_NARGS)
  966 +
  967 + .CAR(form, args)
  968 +
  969 + null nil
  970 +
  971 + type = typeof form
  972 +
  973 + if type == "LispCons" goto CONS
  974 + if type == "LispFloat" goto FLOAT
  975 + if type == "LispFunction" goto FUNCTION
  976 + if type == "LispHash" goto HASH
  977 + if type == "LispInteger" goto INTEGER
  978 + if type == "LispMacro" goto MACRO
  979 + if type == "LispPackage" goto PACKAGE
  980 + if type == "LispStream" goto STREAM
  981 + if type == "LispString" goto STRING
  982 + if type == "LispSymbol" goto SYMBOL
  983 +
  984 + goto UNKNOWN_TYPE
  985 +
  986 +CONS:
  987 + name = "CONS"
  988 + goto LOOKUP_SYMBOL
  989 +
  990 +FLOAT:
  991 + name = "FLOAT"
  992 + goto LOOKUP_SYMBOL
  993 +
  994 +FUNCTION:
  995 + name = "FUNCTON"
  996 + goto LOOKUP_SYMBOL
  997 +
  998 +HASH:
  999 + name = "HASH-TABLE"
  1000 + goto LOOKUP_SYMBOL
  1001 +
  1002 +INTEGER:
  1003 + name = "INTEGER"
  1004 + goto LOOKUP_SYMBOL
  1005 +
  1006 +MACRO:
  1007 + name = "MACRO"
  1008 + goto LOOKUP_SYMBOL
  1009 +
  1010 +PACKAGE:
  1011 + name = "PACKAGE"
  1012 + goto LOOKUP_SYMBOL
  1013 +
  1014 +STREAM:
  1015 + name = "STREAM"
  1016 + goto LOOKUP_SYMBOL
  1017 +
  1018 +STRING:
  1019 + name = "STRING"