├── CHANGES ├── Configure.pl ├── KNOWN_BUGS ├── LICENSE ├── MAINTAINER ├── README ├── cl.pir ├── config └── makefiles │ └── root.in ├── eval.pir ├── include ├── macros.pir └── macros │ ├── assert.pir │ ├── error.pir │ ├── list.pir │ ├── standard.pir │ └── types.pir ├── internals.pir ├── lib └── Parrot │ └── Test │ └── Lisp.pm ├── lisp.pir ├── lisp ├── bootstrap.l ├── core.l ├── list.l ├── logic.l ├── math.l ├── objects.l └── pred.l ├── read.pir ├── system.pir ├── t ├── arithmetics.t ├── atoms.t ├── cl.t ├── function.t ├── harness ├── hello.t ├── lexicals.t ├── read.t └── system.t ├── types.pir └── validate.pir /CHANGES: -------------------------------------------------------------------------------- 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/ 29 | -------------------------------------------------------------------------------- /Configure.pl: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2009, Parrot Foundation. 2 | # $Id$ 3 | 4 | use strict; 5 | use warnings; 6 | use 5.008; 7 | 8 | # Get a list of parrot-configs to invoke. 9 | my @parrot_config_exe = ( 10 | 'parrot/parrot_config', 11 | '../../parrot_config', 12 | 'parrot_config', 13 | ); 14 | 15 | # Get configuration information from parrot_config 16 | my %config = read_parrot_config(@parrot_config_exe); 17 | unless (%config) { 18 | die "Unable to locate parrot_config."; 19 | } 20 | 21 | # Create the Makefile using the information we just got 22 | create_makefiles(%config); 23 | 24 | sub read_parrot_config { 25 | my @parrot_config_exe = @_; 26 | my %config = (); 27 | for my $exe (@parrot_config_exe) { 28 | no warnings; 29 | if (open my $PARROT_CONFIG, '-|', "$exe --dump") { 30 | print "Reading configuration information from $exe\n"; 31 | while (<$PARROT_CONFIG>) { 32 | $config{$1} = $2 if (/(\w+) => '(.*)'/); 33 | } 34 | close $PARROT_CONFIG; 35 | last if %config; 36 | } 37 | } 38 | %config; 39 | } 40 | 41 | 42 | # Generate Makefiles from a configuration 43 | sub create_makefiles { 44 | my %config = @_; 45 | my %makefiles = ( 46 | 'config/makefiles/root.in' => 'Makefile', 47 | # 'config/makefiles/pmc.in' => 'src/pmc/Makefile', 48 | # 'config/makefiles/ops.in' => 'src/ops/Makefile', 49 | ); 50 | my $build_tool = $config{libdir} . $config{versiondir} 51 | . '/tools/dev/gen_makefile.pl'; 52 | 53 | foreach my $template (keys %makefiles) { 54 | my $makefile = $makefiles{$template}; 55 | print "Creating $makefile\n"; 56 | system($config{perl}, $build_tool, $template, $makefile); 57 | } 58 | } 59 | 60 | # Local Variables: 61 | # mode: cperl 62 | # cperl-indent-level: 4 63 | # fill-column: 100 64 | # End: 65 | # vim: expandtab shiftwidth=4: 66 | 67 | -------------------------------------------------------------------------------- /KNOWN_BUGS: -------------------------------------------------------------------------------- 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 | 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 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. 202 | -------------------------------------------------------------------------------- /MAINTAINER: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | N: Cory Spencer 4 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 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". 12 | -------------------------------------------------------------------------------- /cl.pir: -------------------------------------------------------------------------------- 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" 1020 | goto LOOKUP_SYMBOL 1021 | 1022 | SYMBOL: 1023 | name = "SYMBOL" 1024 | goto LOOKUP_SYMBOL 1025 | 1026 | UNKNOWN_TYPE: 1027 | name = "UNKNOWN" 1028 | goto LOOKUP_SYMBOL 1029 | 1030 | ERROR_NARGS: 1031 | .ERROR_0("program-error", "odd number of arguments to TYPE-OF") 1032 | goto DONE 1033 | 1034 | LOOKUP_SYMBOL: 1035 | retv = _GLOBAL_SYMBOL("COMMON-LISP", name, nil, nil) 1036 | goto DONE 1037 | 1038 | DONE: 1039 | .return(retv) 1040 | .end 1041 | 1042 | .sub _values 1043 | .param pmc args 1044 | .local int size 1045 | .local int llen 1046 | 1047 | llen = _LIST_LENGTH(args) # Get # values we're returning 1048 | 1049 | $P16 = args # Pointer to argument list 1050 | 1051 | if llen == 0 goto DONE 1052 | 1053 | $P5 = $P16[0] 1054 | $P16 = $P16[1] 1055 | if llen == 1 goto DONE 1056 | 1057 | $P6 = $P16[0] 1058 | $P16 = $P16[1] 1059 | if llen == 2 goto DONE 1060 | 1061 | $P7 = $P16[0] 1062 | $P16 = $P16[1] 1063 | if llen == 3 goto DONE 1064 | 1065 | $P8 = $P16[0] 1066 | $P16 = $P16[1] 1067 | if llen == 4 goto DONE 1068 | 1069 | $P9 = $P16[0] 1070 | $P16 = $P16[1] 1071 | if llen == 5 goto DONE 1072 | 1073 | $P10 = $P16[0] 1074 | $P16 = $P16[1] 1075 | if llen == 6 goto DONE 1076 | 1077 | $P11 = $P16[0] 1078 | $P16 = $P16[1] 1079 | if llen == 7 goto DONE 1080 | 1081 | $P12 = $P16[0] 1082 | $P16 = $P16[1] 1083 | if llen == 8 goto DONE 1084 | 1085 | $P13 = $P16[0] 1086 | $P16 = $P16[1] 1087 | if llen == 9 goto DONE 1088 | 1089 | $P14 = $P16[0] 1090 | $P16 = $P16[1] 1091 | if llen == 10 goto DONE 1092 | 1093 | $P15 = $P16[0] 1094 | $P16 = $P16[1] 1095 | if llen == 11 goto DONE 1096 | 1097 | size = llen - 11 # Size of the overflow array 1098 | 1099 | $P3 = new 'Array' # Allocate overflow array 1100 | $P3 = size 1101 | 1102 | .local pmc elem 1103 | .local int indx 1104 | 1105 | indx = 0 # Initial index into overflow 1106 | OVERFLOW_LOOP: 1107 | if indx == size goto DONE_OVERFLOW 1108 | 1109 | elem = $P16[0] 1110 | 1111 | $P3[indx] = elem # Set next overflow element 1112 | inc indx 1113 | 1114 | $P16 = $P16[1] # Set next element in list 1115 | goto OVERFLOW_LOOP 1116 | 1117 | DONE_OVERFLOW: 1118 | llen = 11 # Only report # retv's in regs 1119 | goto DONE 1120 | 1121 | DONE: 1122 | # VALID_IN_PARROT_0_2_0 is_prototyped = 0 # Set up return registers 1123 | 1124 | # VALID_IN_PARROT_0_2_0 argcI = 0 1125 | # VALID_IN_PARROT_0_2_0 argcN = 0 1126 | # VALID_IN_PARROT_0_2_0 argcP = llen 1127 | # VALID_IN_PARROT_0_2_0 argcS = 0 1128 | 1129 | # VALID_IN_PARROT_0_2_0 returncc 1130 | .return() 1131 | .end 1132 | 1133 | .sub _add 1134 | .param pmc args 1135 | .local pmc lptr 1136 | .local pmc targ 1137 | .local pmc retv 1138 | 1139 | .INTEGER(retv, "0") # + with no args should give 0 1140 | 1141 | lptr = args 1142 | 1143 | LOOP: 1144 | .NULL(lptr, DONE) 1145 | 1146 | .CAR(targ,lptr) # Get the next arg and ensure 1147 | .ASSERT_TYPE(targ, "number") # it is numeric. 1148 | 1149 | retv = retv + targ # Add to the running total. 1150 | 1151 | .CDR(lptr,lptr) 1152 | goto LOOP 1153 | 1154 | DONE: 1155 | .return(retv) 1156 | .end 1157 | 1158 | .sub _subtract 1159 | .param pmc args 1160 | .local pmc lptr 1161 | .local pmc targ 1162 | .local pmc retv 1163 | .local int narg 1164 | 1165 | .ASSERT_MINIMUM_LENGTH(args,1,ERROR_NARGS) 1166 | 1167 | .CAR(retv,args) # Get the first argument and 1168 | .ASSERT_TYPE(retv, "number") # ensure it is numeric. 1169 | 1170 | .CDR(lptr,args) # Get a pointer to rest of args 1171 | narg = 1 # Number of args encountered 1172 | 1173 | LOOP: 1174 | .NULL(lptr,DONE_LOOP) 1175 | 1176 | .CAR(targ, lptr) # Get the next arg and ensure 1177 | .ASSERT_TYPE(targ, "number") # it is numeric. 1178 | 1179 | retv = retv - targ # Subtract from running total. 1180 | 1181 | .CDR(lptr,lptr) 1182 | inc narg # Increment # args processed 1183 | goto LOOP 1184 | 1185 | DONE_LOOP: 1186 | if narg > 1 goto DONE # If we only had one arg return 1187 | neg retv # its negative value 1188 | goto DONE 1189 | 1190 | ERROR_NARGS: 1191 | .ERROR_0("program-error", "wrong number of arguments to -") 1192 | goto DONE 1193 | 1194 | DONE: 1195 | .return(retv) 1196 | .end 1197 | 1198 | .sub _multiply 1199 | .param pmc args 1200 | .local pmc lptr 1201 | .local pmc targ 1202 | .local pmc retv 1203 | 1204 | .INTEGER(retv, "1") # + with no args should give 0 1205 | 1206 | lptr = args 1207 | 1208 | LOOP: 1209 | .NULL(lptr,DONE) 1210 | 1211 | .CAR(targ,lptr) # Get the next arg and ensure 1212 | .ASSERT_TYPE(targ, "number") # it is numeric. 1213 | 1214 | retv = retv * targ # Multiply the running product. 1215 | 1216 | .CDR(lptr,lptr) 1217 | goto LOOP 1218 | 1219 | DONE: 1220 | .return(retv) 1221 | .end 1222 | 1223 | .sub _divide 1224 | .param pmc args 1225 | .local pmc lptr 1226 | .local pmc targ 1227 | .local pmc retv 1228 | .local int narg 1229 | 1230 | .ASSERT_MINIMUM_LENGTH(args,1,ERROR_NARGS) 1231 | 1232 | .CAR(retv,args) # Get the first argument and 1233 | .ASSERT_TYPE(retv, "number") # ensure it is numeric. 1234 | 1235 | .CDR(lptr,args) # Get a pointer to rest of args 1236 | narg = 1 # Number of args encountered 1237 | 1238 | LOOP: 1239 | .NULL(lptr,DONE_LOOP) 1240 | 1241 | .CAR(targ,lptr) # Get the next arg and ensure 1242 | .ASSERT_TYPE(targ, "number") # it is numeric. 1243 | 1244 | retv = retv / targ # Divide the running total. 1245 | 1246 | .CDR(lptr,lptr) 1247 | inc narg # Increment # args processed 1248 | goto LOOP 1249 | 1250 | DONE_LOOP: 1251 | if narg > 1 goto DONE # If we only had one arg, return 1252 | .INTEGER(targ, 1) # its inverse 1253 | retv = targ / retv 1254 | goto DONE 1255 | 1256 | ERROR_NARGS: 1257 | .ERROR_0("program-error", "wrong number of arguments to /") 1258 | goto DONE 1259 | 1260 | DONE: 1261 | .return(retv) 1262 | .end 1263 | 1264 | .sub _modulus 1265 | .param pmc args 1266 | .local pmc retv 1267 | .local pmc numb 1268 | .local pmc div 1269 | 1270 | .ASSERT_LENGTH(args, 2, ERROR_NARGS) 1271 | 1272 | .CAR(numb,args) 1273 | .SECOND(div,args) 1274 | 1275 | .ASSERT_TYPE(numb, "number") # Ensure both of the args are 1276 | .ASSERT_TYPE(div, "number") # numeric. 1277 | 1278 | .INTEGER(retv,0) 1279 | 1280 | mod retv, numb, div # Compute the modulus 1281 | goto DONE 1282 | 1283 | ERROR_NARGS: 1284 | .ERROR_0("program-error", "wrong number of arguments to MOD") 1285 | goto DONE 1286 | 1287 | DONE: 1288 | .return(retv) 1289 | .end 1290 | 1291 | .sub _equal 1292 | .param pmc args 1293 | .local pmc lptr 1294 | .local pmc arg1 1295 | .local pmc arg2 1296 | .local pmc retv 1297 | 1298 | .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS) 1299 | 1300 | .CAR(arg1, args) # Get the first argument and 1301 | .ASSERT_TYPE(arg1, "number") # ensure it is numeric. 1302 | 1303 | .CDR(lptr,args) # Get a pointer to rest of args 1304 | 1305 | .TRUE(retv) 1306 | 1307 | LOOP: 1308 | .NULL(lptr, DONE) 1309 | 1310 | .CAR(arg2, lptr) # Get the next arg and ensure 1311 | .ASSERT_TYPE(arg2, "number") # it is numeric. 1312 | 1313 | if arg1 != arg2 goto NOT_EQUAL 1314 | 1315 | .CDR(lptr, lptr) 1316 | goto LOOP 1317 | 1318 | NOT_EQUAL: 1319 | .NIL(retv) 1320 | goto DONE 1321 | 1322 | ERROR_NARGS: 1323 | .ERROR_0("program-error", "wrong number of arguments to =") 1324 | goto DONE 1325 | 1326 | DONE: 1327 | .return(retv) 1328 | .end 1329 | 1330 | # Local Variables: 1331 | # mode: pir 1332 | # fill-column: 100 1333 | # End: 1334 | # vim: expandtab shiftwidth=4 ft=pir: 1335 | -------------------------------------------------------------------------------- /config/makefiles/root.in: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2005-2009, Parrot Foundation. 2 | # $Id$ 3 | 4 | # Setup some commands 5 | RM_F = @rm_f@ 6 | PERL = @perl@ 7 | PARROT = ../../parrot@exe@ 8 | BUILD_DIR = @build_dir@ 9 | RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl 10 | #CONDITIONED_LINE(darwin): 11 | #CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking 12 | #CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@ 13 | 14 | all: build 15 | 16 | # This is a listing of all targets, that are meant to be called by users 17 | help : 18 | @echo "" 19 | @echo "Following targets are available for the user:" 20 | @echo "" 21 | @echo " all: 'lisp.pbc'" 22 | @echo " This is the default." 23 | @echo "" 24 | @echo " help: Print this help message." 25 | @echo "" 26 | @echo " test: Run the test suite." 27 | @echo "" 28 | @echo " clean: Cleaning up." 29 | @echo "" 30 | 31 | # regenerate the Makefile 32 | Makefile: config/makefiles/root.in 33 | cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=lisp 34 | 35 | test: build 36 | $(PERL) -Ilib -I../../lib t/harness 37 | 38 | build: lisp.pir 39 | $(PARROT) -o lisp.pbc lisp.pir 40 | 41 | clean: testclean 42 | $(RM_F) core "*.pbc" "*~" 43 | 44 | testclean: 45 | $(RM_F) t/*.out t/*.l 46 | 47 | realclean: clean 48 | $(RM_F) Makefile 49 | 50 | # Local variables: 51 | # mode: makefile 52 | # End: 53 | # vim: ft=make: 54 | -------------------------------------------------------------------------------- /eval.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | eval.pir - evaluate forms 6 | 7 | =cut 8 | 9 | .sub _eval 10 | .param pmc args 11 | 12 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 13 | 14 | .local string symname 15 | .local string type 16 | .local pmc symbol 17 | .local int found 18 | .local pmc body 19 | .local pmc retv 20 | 21 | # switch based on the type of the first arg 22 | .local pmc form 23 | .CAR(form, args) 24 | type = typeof form 25 | if type == "LispSymbol" goto SYMBOL 26 | if type == "LispCons" goto FUNCTION_FORM 27 | if type == "LispInteger" goto SELF_EVALUATING_OBJECT 28 | if type == "LispString" goto SELF_EVALUATING_OBJECT 29 | if type == "LispFloat" goto SELF_EVALUATING_OBJECT 30 | 31 | .ERROR_1("internal", "Unknown object type in eval: %s", type) 32 | 33 | 34 | FUNCTION_FORM: 35 | .local pmc function 36 | .local pmc funcargs 37 | .local pmc funcptr 38 | .local pmc funcarg 39 | .local pmc test 40 | 41 | .CAR(symbol, form) 42 | .CDR(body, form) 43 | 44 | .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", FUNCTION_NOT_FOUND) 45 | 46 | # Retrieve the function from the symbol. 47 | function = symbol.'_get_function'() 48 | 49 | # If the function wasn't set for the symbol, throw an error. 50 | defined found, function 51 | unless found goto FUNCTION_NOT_FOUND 52 | 53 | # Check to see if the function is a special form (which aren't subject to 54 | # normal function evaluation rules). 55 | type = typeof function 56 | if type == "LispSpecialForm" goto SPECIAL_FORMS 57 | if type == "LispMacro" goto MACRO_FORM 58 | 59 | # Normal function - evaluate all arguments being passed into the function. 60 | .NIL(funcargs) 61 | 62 | funcptr = body 63 | 64 | FUNCTION_LOOP: 65 | .NULL(funcptr, FUNCTION_CALL) # Call the function if no args left. 66 | 67 | .CAR(funcarg, funcptr) # Pop the next arg off the list. 68 | 69 | .local pmc evalarg # Evaluate the argument. 70 | .LIST_1(evalarg, funcarg) 71 | funcarg = _eval(evalarg) 72 | 73 | .APPEND(funcargs,funcargs,funcarg) # Add the result to the args list. 74 | 75 | .CDR(funcptr,funcptr) # Move to the next arg in the list. 76 | 77 | goto FUNCTION_LOOP 78 | 79 | FUNCTION_CALL: 80 | .tailcall _FUNCTION_CALL(function,funcargs) 81 | # VALID_IN_PARROT_0_2_0 goto DONE 82 | 83 | FUNCTION_NOT_FOUND: 84 | .ERROR_1("undefined-function", "%s is not a function name", symbol) 85 | # VALID_IN_PARROT_0_2_0 goto DONE 86 | .return(retv) 87 | 88 | ERROR_NARGS: 89 | .ERROR_0("program-error", "wrong number of arguments to EVAL") 90 | # VALID_IN_PARROT_0_2_0 goto DONE 91 | .return(retv) 92 | 93 | SPECIAL_FORMS: 94 | # Special forms aren't subject to normal evaluation rules - keep the 95 | # arguments as is and call the function. 96 | funcargs = body 97 | goto FUNCTION_CALL 98 | 99 | MACRO_FORM: 100 | .local pmc macroexp 101 | .local pmc macrosym 102 | .local pmc macroenv 103 | .local pmc macroarg 104 | 105 | macrosym = _LOOKUP_SYMBOL("*MACROEXPAND-HOOK*") 106 | if_null macrosym, MACRO_NOT_INITIALIZED 107 | 108 | macroexp = macrosym.'_get_value'() # Get the expander function 109 | .ASSERT_TYPE_AND_BRANCH(macroexp, "function", MACRO_NOT_INITIALIZED) 110 | 111 | # VALID_IN_PARROT_0_2_0 peek_pad macroenv # Get current lexical scope 112 | 113 | .LIST_3(funcargs, symbol, body, macroenv) 114 | retv = _FUNCTION_CALL(macroexp, funcargs) # Call the macroexpand hook 115 | 116 | .LIST_1(macroarg, retv) 117 | _eval(macroarg) 118 | 119 | # VALID_IN_PARROT_0_2_0 goto DONE 120 | .return(retv) 121 | 122 | SYMBOL: 123 | symbol = form 124 | symname = symbol.'_get_name_as_string'() 125 | 126 | .local int is_special 127 | is_special = _IS_SPECIAL(symbol) # Check if we're a dynamic 128 | unless is_special goto LEXICAL_SYMBOL # variable 129 | goto DYNAMIC_SYMBOL 130 | 131 | DYNAMIC_SYMBOL: 132 | .local pmc package 133 | .local string pkgname 134 | package = symbol.'_get_package'() 135 | pkgname = package.'_get_name_as_string'() 136 | 137 | symbol = _LOOKUP_GLOBAL(pkgname, symname) 138 | goto CHECK_VALUE 139 | 140 | LEXICAL_SYMBOL: 141 | retv = _LOOKUP_LEXICAL(symname) # Check for a lexical shadow 142 | if_null retv, CHECK_VALUE # If not found, assume global 143 | symbol = retv # Use the lexical value 144 | goto CHECK_VALUE 145 | 146 | CHECK_VALUE: 147 | retv = symbol.'_get_value'() # Check for symbol's value 148 | 149 | defined found, retv 150 | unless found goto SYMBOL_NOT_FOUND 151 | 152 | DONE_SYMBOL: 153 | # VALID_IN_PARROT_0_2_0 argcP = 1 # One value returned 154 | # VALID_IN_PARROT_0_2_0 P5 = retv # Return value 155 | # VALID_IN_PARROT_0_2_0 156 | # VALID_IN_PARROT_0_2_0 goto DONE 157 | .return(retv) 158 | 159 | SYMBOL_NOT_FOUND: 160 | .ERROR_1("unbound-variable", "variable %s has no value", form) 161 | # VALID_IN_PARROT_0_2_0 goto DONE 162 | .return(retv) 163 | 164 | SELF_EVALUATING_OBJECT: 165 | # Object is a primitive type (ie. a string, integer or float). 166 | # VALID_IN_PARROT_0_2_0 argcP = 1 # One value returned 167 | # VALID_IN_PARROT_0_2_0 P5 = retv # Return value 168 | 169 | # VALID_IN_PARROT_0_2_0 goto DONE 170 | .return(form) 171 | 172 | MACRO_NOT_INITIALIZED: 173 | .ERROR_0("internal","the macro system has not been initialized") 174 | # VALID_IN_PARROT_0_2_0 goto DONE 175 | # VALID_IN_PARROT_0_2_0 176 | # VALID_IN_PARROT_0_2_0 DONE: 177 | # VALID_IN_PARROT_0_2_0 is_prototyped = 0 # Nonprototyped return 178 | # VALID_IN_PARROT_0_2_0 argcI = 0 # No integer values returned 179 | # VALID_IN_PARROT_0_2_0 argcN = 0 # No float values returned 180 | # VALID_IN_PARROT_0_2_0 argcS = 0 # No string values returned 181 | # VALID_IN_PARROT_0_2_0 182 | # VALID_IN_PARROT_0_2_0 returncc # Call the return continuation 183 | 184 | .return() 185 | .end 186 | 187 | # Local Variables: 188 | # mode: pir 189 | # fill-column: 100 190 | # End: 191 | # vim: expandtab shiftwidth=4 ft=pir: 192 | -------------------------------------------------------------------------------- /include/macros.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | include/macros.pir - include PIR file in F. 6 | 7 | =cut 8 | 9 | .include "include/macros/assert.pir" 10 | .include "include/macros/error.pir" 11 | .include "include/macros/list.pir" 12 | .include "include/macros/standard.pir" 13 | .include "include/macros/types.pir" 14 | 15 | # Local Variables: 16 | # mode: pir 17 | # fill-column: 100 18 | # End: 19 | # vim: expandtab shiftwidth=4 ft=pir: 20 | -------------------------------------------------------------------------------- /include/macros/assert.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | include/macros/assert.pir - macros for checking assumptions 6 | 7 | =head1 Macros 8 | 9 | =head2 ASSERT_TYPE(A,T) 10 | 11 | Asserts that A is of type T, throwing a error of type "type-error" on failure 12 | 13 | =cut 14 | 15 | .macro ASSERT_TYPE(A,T) 16 | .local string _atypes 17 | .local int _testi 18 | 19 | _testi = _IS_TYPE(.A, .T) 20 | if _testi == 1 goto .$DONE 21 | goto .$WRONG_TYPE 22 | 23 | .label $WRONG_TYPE: 24 | .ERROR_2("type-error", "%s is not of type %s", .A, .T) 25 | goto .$DONE 26 | 27 | .label $DONE: 28 | .endm 29 | 30 | =head2 ASSERT_TYPE_AND_BRANCH(A,T,B) 31 | 32 | Asserts that A is of type T, branching to B on failure. 33 | 34 | =cut 35 | 36 | .macro ASSERT_TYPE_AND_BRANCH(A,T,B) 37 | .local string _atypes 38 | .local int _testi 39 | 40 | _testi = _IS_TYPE(.A, .T) 41 | if _testi == 1 goto .$DONE 42 | goto .B 43 | 44 | .label $DONE: 45 | .endm 46 | 47 | =head2 ASSERT_LENGTH(A,L,B) 48 | 49 | Asserts that list A is of length L, branching to B on failure. 50 | 51 | =cut 52 | 53 | .macro ASSERT_LENGTH(A,L,B) 54 | .local int _leni 55 | 56 | _leni = _LIST_LENGTH(.A) # Get the length of the list 57 | if _leni == .L goto .$DONE # Branch on success 58 | goto .B # Branch on failure 59 | 60 | .label $DONE: 61 | .endm 62 | 63 | =head2 ASSERT_MINIMUM_LENGTH(A,L,B) 64 | 65 | Asserts that list A is at least of length L, branching to B on failure. 66 | 67 | =cut 68 | 69 | .macro ASSERT_MINIMUM_LENGTH(A,L,B) 70 | .local int _leni 71 | 72 | _leni = _LIST_LENGTH(.A) # Get the length of the list 73 | if _leni >= .L goto .$DONE # Branch on success 74 | goto .B # Branch on failure 75 | 76 | .label $DONE: 77 | .endm 78 | 79 | =head2 ASSERT_LENGTH_BETWEEN(A,L,M,B) 80 | 81 | Asserts that list A is at least of length L and at most of length M, branching to B on failure. 82 | 83 | =cut 84 | 85 | .macro ASSERT_LENGTH_BETWEEN(A,L,M,B) 86 | .local int _leni 87 | 88 | _leni = _LIST_LENGTH(.A) # Get the length of the list 89 | if _leni >= .L goto .$DONE # Branch on success (min bound) 90 | if _leni <= .M goto .$DONE # Branch on success (max bound) 91 | goto .B # Branch on failure 92 | 93 | .label $DONE: 94 | .endm 95 | 96 | =head2 ASSERT_EVEN_LENGTH(A,B) 97 | 98 | Asserts that list A is composed of an even number of elements, branching to B on failure. 99 | 100 | =cut 101 | 102 | .macro ASSERT_EVEN_LENGTH(A,B) 103 | .local int _leni 104 | .local int _modi 105 | 106 | _leni = _LIST_LENGTH(.A) # Get the length of the list 107 | mod _modi, _leni, 2 108 | if _modi == 0 goto .$DONE # Branch on success 109 | goto .B # Branch on failure 110 | 111 | .label $DONE: 112 | .endm 113 | 114 | # Local Variables: 115 | # mode: pir 116 | # fill-column: 100 117 | # End: 118 | # vim: expandtab shiftwidth=4 ft=pir: 119 | -------------------------------------------------------------------------------- /include/macros/error.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | include/macros/error.pir - macros for reporting errors 6 | 7 | =head1 Macros 8 | 9 | =cut 10 | 11 | .macro ERROR_0(T,M) 12 | _error(.T, .M) 13 | .endm 14 | 15 | .macro ERROR_1(T,M,A) 16 | .local string _errmsgs 17 | .local pmc _errargp 18 | 19 | _errargp = new 'Array' 20 | _errargp = 1 21 | _errargp[0] = .A 22 | 23 | sprintf _errmsgs, .M, _errargp 24 | _error(.T, _errmsgs) 25 | .endm 26 | 27 | .macro ERROR_2(T,M,A,B) 28 | .local string _errmsgs 29 | .local pmc _errargp 30 | 31 | _errargp = new 'Array' 32 | _errargp = 2 33 | _errargp[0] = .A 34 | _errargp[1] = .B 35 | 36 | sprintf _errmsgs, .M, _errargp 37 | _error(.T, _errmsgs) 38 | .endm 39 | 40 | # Local Variables: 41 | # mode: pir 42 | # fill-column: 100 43 | # End: 44 | # vim: expandtab shiftwidth=4 ft=pir: 45 | -------------------------------------------------------------------------------- /include/macros/list.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | include/macros/list.pir - list processing macros 6 | 7 | This file contains various list processing macros. 8 | All macro arguments are assumed to be PMC types unless otherwise noted. 9 | 10 | =head1 Macros 11 | 12 | =head2 .NULL(L,B) 13 | 14 | Branch to B if L is an empty list. 15 | 16 | =cut 17 | 18 | .macro NULL (L,B) 19 | .local pmc _nilp 20 | 21 | .NIL(_nilp) 22 | eq_addr .L, _nilp, .B 23 | .endm 24 | 25 | =head2 .CAR(R,A) 26 | 27 | Puts the car of A into R. A is assumed to be a valid list. 28 | 29 | =cut 30 | 31 | .macro CAR (R,A) 32 | .NULL(.A, .$IS_NULL) 33 | 34 | .R = .A[0] 35 | 36 | goto .$DONE 37 | 38 | .label $IS_NULL: 39 | .NIL(.R) 40 | goto .$DONE 41 | 42 | .label $DONE: 43 | .endm 44 | 45 | =head2 .APPEND(R,A,B) 46 | 47 | Appends B to list A, placing the result into R. A is assumed to be a valid list. 48 | 49 | =cut 50 | 51 | .macro APPEND (R,A,B) 52 | .local pmc _listptr1p 53 | .local pmc _listptr2p 54 | .local pmc _listtmpp 55 | 56 | .NULL(.A, .$EMPTY_LIST) # Special case if A is an empty list. 57 | 58 | _listptr1p = .A 59 | 60 | .label $APPEND_LOOP: # Loop until we reach the end of the list. 61 | .NULL(_listptr1p,.$DONE_LOOP) 62 | 63 | _listptr2p = _listptr1p 64 | 65 | .CDR(_listptr1p,_listptr1p) 66 | goto .$APPEND_LOOP 67 | 68 | .label $DONE_LOOP: # At the EOL, replace the list end (NIL) 69 | .LIST_1(_listtmpp, .B) # with a new cons containing the new element. 70 | _listptr2p[1] = _listtmpp 71 | goto .$DONE 72 | 73 | .label $EMPTY_LIST: 74 | .LIST_1(.R,.B) 75 | 76 | .label $DONE: 77 | .endm 78 | 79 | =head2 .CDR(R,A) 80 | 81 | Puts the cdr of A into R. A is assumed to be a valid list. 82 | 83 | =cut 84 | 85 | .macro CDR (R,A) 86 | 87 | .NULL(.A, .$IS_NULL) 88 | .R = .A[1] 89 | goto .$DONE 90 | 91 | .label $IS_NULL: 92 | .NIL(.R) 93 | goto .$DONE 94 | 95 | .label $DONE: 96 | .endm 97 | 98 | =head2 .SECOND(R,A) 99 | 100 | Puts the second element of A into R. A is assumed to be a valid list. 101 | 102 | =cut 103 | 104 | .macro SECOND (R,A) 105 | .local pmc _cdrp 106 | 107 | .CDR(_cdrp, .A) 108 | .CAR(.R, _cdrp) 109 | .endm 110 | 111 | =head2 .THIRD(R,A) 112 | 113 | Puts the third element of A into R. A is assumed to be a valid list. 114 | 115 | =cut 116 | 117 | .macro THIRD (R,A) 118 | .local pmc _cdrp 119 | 120 | .CDR(_cdrp, .A) 121 | .CDR(_cdrp, _cdrp) 122 | .CAR(.R, _cdrp) 123 | .endm 124 | 125 | =head2 .FOURTH(R,A) 126 | 127 | Puts the fourth element of A into R. A is assumed to be a valid list. 128 | 129 | =cut 130 | 131 | .macro FOURTH (R,A) 132 | .local pmc _cdrp 133 | 134 | .CDR(_cdrp, .A) 135 | .CDR(_cdrp, _cdrp) 136 | .CDR(_cdrp, _cdrp) 137 | .CAR(.R, _cdrp) 138 | .endm 139 | 140 | =head2 .LIST_1(R,A) 141 | 142 | Creates a one element list containing A, placing the result in R. 143 | 144 | =cut 145 | 146 | .macro LIST_1 (R,A) 147 | .local pmc _bp 148 | 149 | .NIL(_bp) 150 | .CONS(.R, .A, _bp) 151 | .endm 152 | 153 | 154 | =head2 .LIST_2(R,A,B) 155 | 156 | Creates a two element list containing A and B, placing the result in R. 157 | 158 | =cut 159 | 160 | .macro LIST_2 (R,A,B) 161 | .local pmc _cp 162 | 163 | .LIST_1(_cp, .B) 164 | .CONS(.R, .A, _cp) 165 | .endm 166 | 167 | .macro LIST_3 (R,A,B,C) 168 | .local pmc _cp 169 | 170 | .LIST_2(_cp, .B, .C) 171 | .CONS(.R, .A, _cp) 172 | .endm 173 | 174 | 175 | 176 | # Local Variables: 177 | # mode: pir 178 | # fill-column: 100 179 | # End: 180 | # vim: expandtab shiftwidth=4 ft=pir: 181 | -------------------------------------------------------------------------------- /include/macros/standard.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | include/macros/standard.pir - miscellaneous macros 6 | 7 | =head1 DESCRITPTION 8 | 9 | This file contains miscellaneous macros. 10 | 11 | =head1 Macros 12 | 13 | =head2 .NIL(R) 14 | 15 | Sets R to the empty list (the NIL symbol). 16 | 17 | =cut 18 | 19 | .macro NIL (R) 20 | get_global .R, ["SYMBOLS"], "NIL" 21 | .endm 22 | 23 | =head2 .TRUE(R) 24 | 25 | Sets R to true (the TRUE symbol). 26 | 27 | =cut 28 | 29 | .macro TRUE (R) 30 | get_global .R, ["SYMBOLS"], "T" 31 | .endm 32 | 33 | .macro CONSTANT (P) 34 | .local Boolean _const 35 | 36 | _const = new 'Boolean' 37 | _const = 1 38 | 39 | setprop .P, "constant", _const 40 | .endm 41 | 42 | .macro CONSTANTP (R,P) 43 | .local pmc _const 44 | 45 | getprop .R, "constant", .P 46 | .endm 47 | 48 | .macro SPECIAL_FORM (S,P,N,L) 49 | .local pmc _specialformp 50 | # VALID_IN_PARROT_0_2_0 .local pmc _funcp 51 | .local pmc _namep 52 | 53 | # VALID_IN_PARROT_0_2_0 newsub _funcp, .Sub, .L 54 | 55 | _specialformp = new "LispSpecialForm" 56 | # VALID_IN_PARROT_0_2_0 _specialformp._set_body(.L) 57 | .const 'Sub' _special_func = .L 58 | _specialformp.'_set_body'(_special_func) 59 | 60 | _namep = new "LispString" 61 | _namep = .N 62 | _specialformp.'_set_name'(_namep) 63 | 64 | .S = .P.'_intern_symbol'(.N) 65 | .S.'_set_function'(_specialformp) 66 | .S.'_set_package'(.P) 67 | .endm 68 | 69 | .macro DEFUN (S,P,N,L) 70 | .local pmc _functionp 71 | .local pmc _namep 72 | 73 | .FUNCTION(_functionp, .L) 74 | 75 | _namep = new "LispString" 76 | _namep = .N 77 | _functionp.'_set_name'(_namep) 78 | 79 | .S = .P.'_intern_symbol'(.N) 80 | .S.'_set_function'(_functionp) 81 | .S.'_set_package'(.P) 82 | .endm 83 | 84 | .macro DEFMACRO (S,P,N,L) 85 | .local pmc _macrop 86 | .local pmc _namep 87 | 88 | .MACRO(_macrop, .L) 89 | 90 | _namep = new "LispString" 91 | _namep = .N 92 | _macrop.'_set_name'(_namep) 93 | 94 | .S = .P.'_intern_symbol'(.N) 95 | .S.'_set_function'(_macrop) 96 | .S.'_set_package'(.P) 97 | .endm 98 | 99 | .macro DEFVAR (S,P,N,V) 100 | .local pmc _specialp 101 | 102 | .TRUE(_specialp) 103 | 104 | .S = .P.'_intern_symbol'(.N) 105 | .S.'_set_value'(.V) 106 | .S.'_set_package'(.P) 107 | .S.'_set_special'(_specialp) 108 | .endm 109 | 110 | # Local Variables: 111 | # mode: pir 112 | # fill-column: 100 113 | # End: 114 | # vim: expandtab shiftwidth=4 ft=pir: 115 | -------------------------------------------------------------------------------- /include/macros/types.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | include/macros/types.pir 6 | 7 | =head1 Macros 8 | 9 | =head2 .CONS(R,A,B) 10 | 11 | Creates a new cons with car A and cdr B, placing the result in R. 12 | 13 | =cut 14 | 15 | .macro CONS (R,A,B) 16 | .local pmc _consp 17 | 18 | 19 | _consp = new "LispCons" 20 | 21 | _consp[0] = .A 22 | _consp[1] = .B 23 | 24 | .R = _consp 25 | .endm 26 | 27 | =head2 .STRING(R,S) 28 | 29 | Creates a new string with value S, placing the result in R. 30 | 31 | =cut 32 | 33 | .macro STRING (R,S) 34 | .R = new "LispString" 35 | .R = .S 36 | .endm 37 | 38 | =head2 .STREAM(R,S) 39 | 40 | Create a new stream object from ParrotIO object S, placing the result in R. 41 | 42 | =cut 43 | 44 | .macro STREAM(R,S) 45 | .R = new "LispStream" 46 | .R.'_set_io'(.S) 47 | .endm 48 | 49 | =head2 .READTABLE(R) 50 | 51 | Create a new readtable object and places it in R. 52 | 53 | =cut 54 | 55 | .macro READTABLE(R) 56 | .R = new "LispReadtable" 57 | .endm 58 | 59 | =head2 .FLOAT(R,F) 60 | 61 | Creates a new float with value F, placing the result in R. 62 | 63 | =cut 64 | 65 | .macro FLOAT (R,F) 66 | .R = new "LispFloat" 67 | .R = .F 68 | .endm 69 | 70 | =head2 .INTEGER(R,I) 71 | 72 | Creates a new integer with value I, placing the result in R. 73 | 74 | =cut 75 | 76 | .macro INTEGER (R,I) 77 | .R = new "LispInteger" 78 | .R = .I 79 | .endm 80 | 81 | =head2 .HASH(R) 82 | 83 | Creates a new hash table, placing the result in R. 84 | 85 | =cut 86 | 87 | .macro HASH (R) 88 | .R = new "LispHash" 89 | .endm 90 | 91 | =head2 .PACKAGE(P,N) 92 | 93 | Create a new package with name N, placing the result in P. 94 | 95 | =cut 96 | 97 | .macro PACKAGE (P,N) 98 | .local string _ucname 99 | .local pmc _packagesp 100 | .local pmc _name 101 | 102 | .P = new "LispPackage" 103 | 104 | _ucname = .N 105 | upcase _ucname, _ucname 106 | .STRING(_name, _ucname) 107 | 108 | setattribute .P, "name", _name 109 | .endm 110 | 111 | =head2 .FUNCTION(F,L) 112 | 113 | Create a new function object with label L, placing the result in F. 114 | 115 | =cut 116 | 117 | .macro FUNCTION(F,L) 118 | 119 | .F = new "LispFunction" 120 | # VALID_IN_PARROT_0_2_0 newsub _func, .Sub, .L 121 | # VALID_IN_PARROT_0_2_0 setattribute .F, "LispFunction\0body", .L 122 | 123 | .local pmc _func 124 | .const 'Sub' _func = .L 125 | setattribute .F, "body", _func 126 | 127 | .endm 128 | 129 | =head2 .MACRO(F,L) 130 | 131 | Create a new macro object with label L, placing the result in F. 132 | 133 | =cut 134 | 135 | .macro MACRO(F,L) 136 | .local pmc _func 137 | 138 | .F = new "LispMacro" 139 | newsub _func, .Sub, .L 140 | 141 | # VALID_IN_PARROT_0_2_0 setattribute .F, "LispMacro\0body", _func 142 | setattribute .F, "body", _func 143 | .endm 144 | 145 | 146 | # Local Variables: 147 | # mode: pir 148 | # fill-column: 100 149 | # End: 150 | # vim: expandtab shiftwidth=4 ft=pir: 151 | -------------------------------------------------------------------------------- /internals.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | internals.pir - lexical and global variables, function call 6 | 7 | =head1 Functions 8 | 9 | =head2 _LOOKUP_GLOBAL(pkgname, symname) 10 | 11 | =cut 12 | 13 | .sub _LOOKUP_GLOBAL 14 | .param string pkgname 15 | .param string symname 16 | 17 | .local pmc package 18 | .local pmc retv 19 | 20 | upcase pkgname, pkgname # Convert names to all upcase 21 | upcase symname, symname 22 | 23 | push_eh PACKAGE_NOT_FOUND # Set an error handler 24 | get_global package, ["PACKAGES"], pkgname # Look for the package 25 | pop_eh 26 | 27 | retv = package.'_lookup_symbol'(symname) # Lookup the symbol 28 | 29 | goto DONE 30 | 31 | PACKAGE_NOT_FOUND: 32 | .ERROR_1("package-error", "there is no package with name \"%s\"", pkgname) 33 | goto DONE 34 | 35 | DONE: 36 | .return(retv) 37 | .end 38 | 39 | 40 | =head2 _LOOKUP_LEXICAL(symname) 41 | 42 | =cut 43 | 44 | .sub _LOOKUP_LEXICAL 45 | .param string symname 46 | 47 | push_eh LEXICAL_NOT_FOUND # Set an error handler 48 | .local pmc retv 49 | find_lex retv, symname # Look for the lexical symbol 50 | pop_eh 51 | 52 | goto DONE 53 | 54 | LEXICAL_NOT_FOUND: # Return null if not found 55 | null retv 56 | goto DONE 57 | 58 | DONE: 59 | .return(retv) 60 | .end 61 | 62 | 63 | =head2 _LOOKUP_SYMBOL(symname) 64 | 65 | =cut 66 | 67 | .sub _LOOKUP_SYMBOL 68 | .param string symname 69 | 70 | .local string pkgname 71 | .local pmc package 72 | .local pmc symbol 73 | .local pmc retv 74 | 75 | LEXICAL_SYMBOL: 76 | symbol = _LOOKUP_LEXICAL(symname) 77 | if_null retv, GLOBAL_SYMBOL 78 | goto DONE 79 | 80 | GLOBAL_SYMBOL: 81 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*PACKAGE*") 82 | if_null symbol, PACKAGE_NOT_FOUND 83 | 84 | package = symbol.'_get_value'() 85 | if_null package, PACKAGE_NOT_FOUND 86 | 87 | pkgname = package.'_get_name_as_string'() 88 | 89 | retv = _LOOKUP_GLOBAL(pkgname, symname) 90 | goto DONE 91 | 92 | PACKAGE_NOT_FOUND: 93 | .ERROR_0("internal", "current package not found") 94 | goto DONE 95 | 96 | DONE: 97 | .return(retv) 98 | .end 99 | 100 | 101 | =head2 _INTERN_GLOBAL(symbol, pkgname) 102 | 103 | =cut 104 | 105 | .sub _INTERN_GLOBAL 106 | .param pmc symbol 107 | .param string pkgname 108 | 109 | .local string symname 110 | 111 | symname = symbol.'_get_name_as_string'() 112 | 113 | set_global pkgname, symname, symbol 114 | .end 115 | 116 | 117 | =head2 .INTERN_LEXICAL(symbol) 118 | 119 | =cut 120 | 121 | .sub _INTERN_LEXICAL 122 | .param pmc symbol 123 | 124 | .local string symname 125 | 126 | symname = symbol.'_get_name_as_string'() 127 | 128 | # VALID_IN_PARROT_0_2_0 store_lex -1, symname, symbol 129 | store_lex symname, symbol 130 | .end 131 | 132 | 133 | =head2 _LEXICAL_SYMBOL 134 | 135 | =cut 136 | 137 | .sub _LEXICAL_SYMBOL 138 | .param string symname 139 | .param pmc value 140 | 141 | .local pmc package 142 | .local pmc symbol 143 | .local int test 144 | 145 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*PACKAGE*") 146 | package = symbol.'_get_value'() 147 | 148 | symbol = _SYMBOL(symname) # Create a new symbol 149 | symbol.'_set_package'(package) # Set the home package 150 | 151 | defined test, value # Set a value if provided 152 | if test == 0 goto DONE 153 | 154 | symbol.'_set_value'(value) 155 | goto DONE 156 | 157 | DONE: 158 | # VALID_IN_PARROT_0_2_0 store_lex -1, symname, symbol 159 | store_lex symname, symbol 160 | 161 | .return(symbol) 162 | .end 163 | 164 | 165 | =head2 _SYMBOL 166 | 167 | =cut 168 | 169 | .sub _SYMBOL 170 | .param string symname 171 | 172 | .local pmc symbol 173 | .local pmc name 174 | 175 | symbol = new "LispSymbol" 176 | 177 | name = new "LispString" 178 | name = symname 179 | symbol.'_set_name'(name) 180 | 181 | .return(symbol) 182 | .end 183 | 184 | 185 | =head2 _GLOBAL_SYMBOL 186 | 187 | =cut 188 | 189 | .sub _GLOBAL_SYMBOL 190 | .param string pkgname 191 | .param string symname 192 | .param pmc value 193 | .param pmc function 194 | 195 | .local pmc packages 196 | .local pmc package 197 | .local pmc symbol 198 | .local int test 199 | 200 | upcase pkgname, pkgname 201 | upcase symname, symname 202 | 203 | push_eh PACKAGE_NOT_CREATED 204 | get_global [package], "PACKAGES", pkgname 205 | pop_eh 206 | 207 | symbol = package.'_intern_symbol'(symname) 208 | symbol.'_set_package'(package) # Set the home package 209 | 210 | defined test, value # Set a value if provided 211 | if test == 0 goto FUNCTION 212 | 213 | symbol.'_set_value'(value) 214 | goto FUNCTION 215 | 216 | FUNCTION: # Set a function if provided 217 | defined test, function 218 | if test == 0 goto DONE 219 | 220 | function.'_set_name'(symname) 221 | symbol.'_set_function'(function) 222 | goto DONE 223 | 224 | PACKAGE_NOT_CREATED: 225 | .ERROR_1("package-error", "there is no package with name \"%s\"", pkgname) 226 | goto DONE 227 | 228 | DONE: 229 | .return(symbol) 230 | .end 231 | 232 | =head2 _FUNCTION_CALL 233 | 234 | Call a function. 235 | 236 | =cut 237 | 238 | .sub _FUNCTION_CALL 239 | .param pmc function 240 | .param pmc args 241 | 242 | .local pmc proto 243 | proto = function.'_get_args'() 244 | .local pmc body 245 | body = function.'_get_body'() 246 | 247 | .local string type 248 | type = typeof function # Get the function type 249 | # print function 250 | # print " of type " 251 | # print type 252 | type = typeof body # Get the function type 253 | # print " with body " 254 | # print body 255 | # print " with bodytype " 256 | # print type 257 | # print " in _FUNCTION_CALL\n" 258 | type = typeof body # Get the function type 259 | 260 | # print type 261 | # print " is the type\n" 262 | if type != 'Sub' goto NOT_A_COMPILED_FUNCTION 263 | .tailcall body( args ) 264 | NOT_A_COMPILED_FUNCTION: 265 | 266 | if type != 'LispCons' goto NOT_A_LISP_CONS 267 | .local pmc scope 268 | scope = function.'_get_scope'() 269 | 270 | # 1st arg - the code to evaluate 271 | # 2nd arg - the arg prototype 272 | # 3rd arg - the args to evaluate 273 | # The closure 274 | # set_args "0,0,0", body, proto, args 275 | .tailcall scope( body, proto, args ) 276 | # VALID_IN_PARROT_0_2_0 pushtopp # Save the upper registers 277 | # VALID_IN_PARROT_0_2_0 invokecc # Call the closure 278 | # VALID_IN_PARROT_0_2_0 poptopp # Restore the upper registers 279 | 280 | # VALID_IN_PARROT_0_2_0 returncc 281 | NOT_A_LISP_CONS: 282 | 283 | .return () 284 | 285 | DONE: 286 | .return() 287 | .end 288 | 289 | .sub _IS_SPECIAL 290 | .param pmc symbol 291 | 292 | .local int retv 293 | retv = 1 294 | 295 | .local pmc special 296 | special = getattribute symbol, "special" 297 | if_null special, NOT_SPECIAL 298 | 299 | goto DONE 300 | 301 | NOT_SPECIAL: 302 | retv = 0 303 | goto DONE 304 | 305 | DONE: 306 | .return(retv) 307 | .end 308 | 309 | .sub _IS_ORDINARY_LAMBDA_LIST 310 | .param pmc form 311 | 312 | .local string type 313 | .local pmc symbol 314 | .local pmc args 315 | .local int test 316 | .local int retv 317 | 318 | .CAR(symbol,form) # Ensure first element is a LAMBDA 319 | if symbol != "LAMBDA" goto NON_LAMBDA_LIST 320 | 321 | .SECOND(args,form) # Ensure second element is a lambda-list 322 | .ASSERT_TYPE_AND_BRANCH(args, "list", MISSING_LAMBDA_LIST) 323 | goto LAMBDA_LIST 324 | 325 | LAMBDA_LIST: 326 | retv = 1 327 | goto DONE 328 | 329 | NON_LAMBDA_LIST: 330 | retv = 0 331 | goto DONE 332 | 333 | MISSING_LAMBDA_LIST: 334 | _error("invalid-function", "The lambda-list for LAMBDA is missing") 335 | goto DONE 336 | 337 | DONE: 338 | .return(retv) 339 | .end 340 | 341 | .sub _MAKE_LAMBDA 342 | .param pmc form 343 | 344 | # .FIRST is 'lambda' 345 | 346 | # check the parameter declaration 347 | .local pmc args 348 | .SECOND(args, form) 349 | .local pmc lptr 350 | lptr = args 351 | .local pmc symbol 352 | ARG_LOOP_BEGIN: 353 | .NULL(lptr, ARG_LOOP_END) 354 | 355 | .CAR(symbol, lptr) # Ensure all the arguments are 356 | .ASSERT_TYPE(symbol, "symbol") # symbol types. 357 | 358 | .CDR(lptr, lptr) 359 | goto ARG_LOOP_BEGIN 360 | ARG_LOOP_END: 361 | 362 | .local pmc body 363 | .THIRD(body, form) 364 | 365 | .const 'Sub' sub_that_calls_eval = 'sub_that_calls_eval' 366 | .local pmc closure 367 | closure = newclosure sub_that_calls_eval # Capture the scope the closure 368 | 369 | .local pmc lisp_function 370 | lisp_function = new "LispFunction" 371 | lisp_function.'_set_args'(args) 372 | lisp_function.'_set_body'(body) 373 | lisp_function.'_set_scope'(closure) 374 | 375 | .return(lisp_function) 376 | .end 377 | 378 | .sub sub_that_calls_eval :outer('_MAKE_LAMBDA') # TODO: what is really :outer ??? 379 | .param pmc clbody 380 | .param pmc clprot 381 | .param pmc clargs 382 | 383 | # print "sub_that_calls_eval\n body: " 384 | # print clbody 385 | # print "\nproto: " 386 | # print clprot 387 | # print "\nargs: " 388 | # print clargs 389 | .local string clsymname 390 | .local pmc clargsptr 391 | .local pmc clprotptr 392 | .local pmc clbody 393 | .local pmc clprot 394 | .local pmc clargs 395 | .local pmc clarg 396 | .local pmc clval 397 | .local pmc clsym 398 | 399 | clargsptr = clargs 400 | clprotptr = clprot 401 | 402 | # VALID_IN_PARROT_0_2_0 new_pad -1 403 | 404 | goto CLOSURE_ARGS 405 | 406 | CLOSURE_ARGS: 407 | .NULL(clprotptr, CLOSURE_CHECK_ARGS) 408 | .NULL(clargsptr, CLOSURE_TOO_FEW_ARGS) 409 | 410 | .CAR(clval, clargsptr) # The lexical value 411 | .CAR(clarg, clprotptr) # The lexical arg prototype 412 | 413 | clsymname = clarg.'_get_name_as_string'() 414 | clsym = _LEXICAL_SYMBOL(clsymname, clval) # Create a new lexical symbol 415 | 416 | .CDR(clargsptr, clargsptr) 417 | .CDR(clprotptr, clprotptr) 418 | 419 | goto CLOSURE_ARGS 420 | 421 | CLOSURE_CHECK_ARGS: 422 | .NULL(clargsptr, CLOSURE_BODY) # Ensure we didn't have too 423 | goto CLOSURE_TOO_MANY_ARGS # many args 424 | 425 | CLOSURE_BODY: 426 | .local pmc clearg 427 | .local pmc clretv 428 | 429 | .LIST_1(clearg, clbody) 430 | # VALID_IN_PARROT_0_2_0 pop_pad 431 | .tailcall _eval(clearg) 432 | 433 | CLOSURE_TOO_FEW_ARGS: 434 | # VALID_IN_PARROT_0_2_0 pop_pad 435 | 436 | .ERROR_0("program-error", "Too few arguments given to LAMBDA") 437 | goto CLOSURE_DONE 438 | 439 | CLOSURE_TOO_MANY_ARGS: 440 | # VALID_IN_PARROT_0_2_0 pop_pad 441 | 442 | .ERROR_0("program-error", "Too many arguments given to LAMBDA") 443 | goto CLOSURE_DONE 444 | 445 | CLOSURE_DONE: 446 | .return() 447 | .end 448 | 449 | .sub _LIST_LENGTH 450 | .param pmc args 451 | 452 | .local pmc lptr 453 | lptr = args 454 | 455 | .local int alen 456 | alen = 0 457 | .local pmc _nilp 458 | 459 | .NIL(_nilp) 460 | 461 | LOOP: 462 | eq_addr lptr, _nilp, DONE 463 | inc alen 464 | .CDR(lptr, lptr) 465 | goto LOOP 466 | 467 | DONE: 468 | .return(alen) 469 | .end 470 | 471 | .sub _IS_TYPE 472 | .param pmc args 473 | .param string rtype 474 | 475 | .local string atype 476 | .local int retv 477 | 478 | atype = typeof args 479 | retv = 1 480 | 481 | if rtype == "cons" goto CONS_TYPE 482 | if rtype == "hash" goto HASH_TYPE 483 | if rtype == "integer" goto INTEGER_TYPE 484 | if rtype == "float" goto FLOAT_TYPE 485 | if rtype == "function" goto FUNCTION_TYPE 486 | if rtype == "list" goto LIST_TYPE 487 | if rtype == "number" goto NUMBER_TYPE 488 | if rtype == "package" goto PACKAGE_TYPE 489 | if rtype == "stream" goto STREAM_TYPE 490 | if rtype == "string" goto STRING_TYPE 491 | if rtype == "symbol" goto SYMBOL_TYPE 492 | 493 | goto WRONG_TYPE 494 | 495 | CONS_TYPE: 496 | if atype != "LispCons" goto WRONG_TYPE 497 | goto DONE 498 | 499 | HASH_TYPE: 500 | if atype != "LispHash" goto WRONG_TYPE 501 | goto DONE 502 | 503 | INTEGER_TYPE: 504 | if atype != "LispInteger" goto WRONG_TYPE 505 | goto DONE 506 | 507 | FLOAT_TYPE: 508 | if atype != "LispFloat" goto WRONG_TYPE 509 | goto DONE 510 | 511 | FUNCTION_TYPE: 512 | if atype != "LispFunction" goto WRONG_TYPE 513 | goto DONE 514 | 515 | LIST_TYPE: 516 | if atype != "LispSymbol" goto NONEMPTY_LIST 517 | .NULL(args, DONE) 518 | NONEMPTY_LIST: 519 | if atype != "LispCons" goto WRONG_TYPE 520 | goto DONE 521 | 522 | NUMBER_TYPE: 523 | if atype == "LispInteger" goto DONE 524 | if atype != "LispFloat" goto WRONG_TYPE 525 | goto DONE 526 | 527 | PACKAGE_TYPE: 528 | if atype != "LispPackage" goto WRONG_TYPE 529 | goto DONE 530 | 531 | STREAM_TYPE: 532 | if atype != "LispStream" goto WRONG_TYPE 533 | goto DONE 534 | 535 | STRING_TYPE: 536 | if atype != "LispString" goto WRONG_TYPE 537 | goto DONE 538 | 539 | SYMBOL_TYPE: 540 | if atype != "LispSymbol" goto WRONG_TYPE 541 | goto DONE 542 | 543 | WRONG_TYPE: 544 | retv = 0 545 | goto DONE 546 | 547 | DONE: 548 | .return(retv) 549 | .end 550 | 551 | # Local Variables: 552 | # mode: pir 553 | # fill-column: 100 554 | # End: 555 | # vim: expandtab shiftwidth=4 ft=pir: 556 | -------------------------------------------------------------------------------- /lib/Parrot/Test/Lisp.pm: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | package Parrot::Test::Lisp; 4 | 5 | # Copyright (C) 2007, Parrot Foundation. 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use File::Basename; 11 | 12 | =head1 NAME 13 | 14 | Parrot::Test::Lisp -- testing routines for languages/lisp 15 | 16 | This is largely a copy of Parrot::Test::Punie. 17 | 18 | =cut 19 | 20 | # Generate output_is(), output_isnt() and output_like() in current package. 21 | Parrot::Test::generate_languages_functions(); 22 | 23 | sub new { 24 | return bless {}; 25 | } 26 | 27 | 28 | sub get_lang_fn { 29 | my $self = shift; 30 | my ( $count, $options ) = @_; 31 | 32 | return File::Spec->rel2abs(Parrot::Test::per_test( '.l', $count )); 33 | } 34 | 35 | sub get_out_fn { 36 | my $self = shift; 37 | my ( $count, $options ) = @_; 38 | 39 | return File::Spec->rel2abs(Parrot::Test::per_test( '.out', $count )); 40 | } 41 | 42 | sub get_cd { 43 | my $self = shift; 44 | my ( $options ) = @_; 45 | 46 | return "$self->{relpath}/languages/lisp"; 47 | } 48 | 49 | # never skip 50 | sub skip_why { 51 | my $self = shift; 52 | my ($options) = @_; 53 | 54 | return; 55 | } 56 | 57 | sub get_test_prog { 58 | my $self = shift; 59 | my ( $count, $options ) = @_; 60 | 61 | my $lang_fn = Parrot::Test::per_test( '.l', $count ); 62 | ( undef, undef, my $current_dir ) = File::Spec->splitpath( Cwd::getcwd() ); 63 | if ( $current_dir eq 'languages' ) { 64 | $lang_fn = File::Spec->catdir( '..', $lang_fn ); 65 | } 66 | 67 | my $test_prog_args = $ENV{TEST_PROG_ARGS} || q{}; 68 | 69 | return 70 | join( ' ', 71 | "../../$self->{parrot}", 72 | 'lisp.pbc', 73 | $test_prog_args, 74 | $lang_fn ); 75 | } 76 | 77 | 1; 78 | 79 | # Local Variables: 80 | # mode: cperl 81 | # cperl-indent-level: 4 82 | # fill-column: 100 83 | # End: 84 | # vim: expandtab shiftwidth=4: 85 | -------------------------------------------------------------------------------- /lisp.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp.pir - main function of Parrot Common Lisp 6 | 7 | =head1 Description 8 | 9 | The C
sub is provided here. 10 | Some constants are defined 11 | Needed PIR code is included. 12 | 13 | =cut 14 | 15 | # standard libs 16 | .include "library/dumper.pir" 17 | 18 | .const int INVALID_CHAR = 0 19 | .const int CONSTITUENT_CHAR = 1 20 | .const int WHITESPACE_CHAR = 2 21 | .const int TERM_MACRO_CHAR = 3 22 | .const int NTERM_MACRO_CHAR = 4 23 | .const int SESCAPE_CHAR = 5 24 | .const int MESCAPE_CHAR = 6 25 | 26 | .sub _init_common_lisp :init 27 | $P1 = loadlib 'rational' # The rational PMC is needed for 'LispRational' 28 | .end 29 | 30 | 31 | .include 'include/macros.pir' 32 | .include 'types.pir' 33 | .include 'read.pir' 34 | .include 'eval.pir' 35 | .include 'system.pir' 36 | .include 'validate.pir' 37 | .include 'cl.pir' 38 | .include 'internals.pir' 39 | 40 | .sub _common_lisp :main 41 | .param pmc argv 42 | 43 | .local pmc args # piece together args of function 44 | .local pmc retv # return value of function calls 45 | .local int res 46 | 47 | load_bytecode 'PGE.pbc' # Parrot Grammar engine 48 | 49 | # compile a couple of regexes that are needed in validate.pir 50 | .local pmc p6rule 51 | p6rule = compreg "PGE::Perl6Regex" 52 | 53 | .local pmc is_integer 54 | is_integer = p6rule( '^<[+\-]>?\d+\.?$' ) 55 | set_global 'is_integer', is_integer 56 | 57 | .local pmc is_float 58 | is_float = p6rule( '^<[+\-]>?\d+\.\d+$' ) 59 | set_global 'is_float', is_float 60 | 61 | .local pmc is_qualified 62 | # todo keyword, split into qualifier, package and symbol 63 | is_qualified = p6rule( '(<[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789]>*)\:(<[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789%\-]>*)' ) 64 | set_global 'is_qualified', is_qualified 65 | 66 | # TODO: initialize the null lexical environment. 67 | 68 | # bootstrapping 69 | .local pmc bootstrap_filename 70 | .STRING(bootstrap_filename, "lisp/bootstrap.l") 71 | .LIST_1(args, bootstrap_filename) 72 | _load(args) 73 | 74 | # check the commandline whether we should read STDIN or load from file 75 | .local int argc 76 | argc = argv 77 | if argc <= 1 goto READ_STDIN 78 | 79 | # interpret a file 80 | .local pmc infile_name # name of the inputfile from the commandline 81 | .STRING(infile_name, argv[1]) 82 | .LIST_1(args, infile_name) 83 | retv = _load(args) # Load the specified file. 84 | 85 | end 86 | 87 | READ_STDIN: 88 | # Read-Eval-Print-Loop 89 | 90 | .local pmc symbol 91 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*STANDARD-INPUT*") 92 | .local pmc stdin 93 | stdin = symbol.'_get_value'() 94 | 95 | push_eh DEBUGGER # Setup error handler for debug loop. 96 | 97 | REP_LOOP: 98 | print "-> " # Display the top level prompt. 99 | 100 | .LIST_1(args, stdin) # Read! 101 | retv = _read(args) 102 | 103 | .LIST_1(args, retv) # Eval! 104 | # VALID_IN_PARROT_0_2_0 retv = _eval(args) 105 | 106 | # VALID_IN_PARROT_0_2_0 foldup retv 107 | ( retv :slurpy) = _eval(args) 108 | 109 | .local int nretv 110 | nretv = retv 111 | 112 | .local pmc tmpval 113 | .local int i 114 | i = 0 115 | 116 | PRINT_LOOP: 117 | tmpval = retv[i] 118 | 119 | print tmpval 120 | 121 | inc i 122 | if i == nretv goto PRINT_DONE 123 | 124 | print " ;\n" 125 | 126 | goto PRINT_LOOP 127 | 128 | PRINT_DONE: 129 | print "\n" 130 | 131 | goto REP_LOOP 132 | 133 | DEBUGGER: 134 | .local string message 135 | .local string msgtype 136 | .local pmc e 137 | 138 | .get_results (e) 139 | 140 | message = e 141 | 142 | print "*** ERROR: " 143 | print message 144 | print "\n" 145 | 146 | push_eh DEBUGGER 147 | 148 | goto REP_LOOP 149 | .end 150 | 151 | # Local Variables: 152 | # mode: pir 153 | # fill-column: 100 154 | # End: 155 | # vim: expandtab shiftwidth=4 ft=pir: 156 | -------------------------------------------------------------------------------- /lisp/bootstrap.l: -------------------------------------------------------------------------------- 1 | ;; Export external symbols from the COMMON-LISP package 2 | (sys:%export (sys:%find-package "COMMON-LISP") 3 | ;; List related functions 4 | "APPEND" "CAAR" "CADR" "CDAR" "CDDR" "CAAAR" "CAADR" "CADAR" 5 | "CADDR" "CDAAR" "CDADR" "CDDAR" "CDDDR" "CAAAAR" "CAAADR" "CAADAR" 6 | "CAADDR" "CADAAR" "CADADR" "CADDAR" "CDAAAR" "CDAADR" "CDADAR" 7 | "CDADDR" "CDDAAR" "CDDADR" "CDDDAR" "CDDDDR" 8 | 9 | "FIRST" "SECOND" "THIRD" "FOURTH" "FIFTH" "SIXTH" "SEVENTH" 10 | "EIGHTH" "NINTH" "TENTH" 11 | 12 | "ACONS" "CONS" "LIST" 13 | 14 | "COPY-TREE" "IDENTITY" 15 | 16 | ;; Math functions 17 | "*" "+" "-" "/" "=" "1+" "1-" "EVENP" "MOD" "ODDP" "ZEROP" 18 | 19 | ;; Predicate functions 20 | "BOUNDP" "CHARACTERP" "CONSP" "ENDP" "FLOATP" "FUNCTIONP" 21 | "HASH-TABLE-P" "INTEGERP" "KEYWORDP" "LISTP" "NUMBERP" "PACKAGEP" 22 | "STREAMP" "STRINGP" "SYMBOLP" 23 | 24 | ;; Macros 25 | "DEFUN" 26 | 27 | ;; Miscellaneous functions 28 | "APPLY" "ATOM" "CHAR" "EQ" "EQL" "EVAL" "FUNCTION" "GENSYM" "LET" 29 | "NOT" "NULL" "PACKAGE-NAME" "PRINT" "PROGN" "QUOTE" "READ" 30 | "READ-DELIMITED-LIST" "RPLACA" "RPLACD" "SETQ" "SYMBOL-FUNCTION" 31 | "SYMBOL-NAME" "SYMBOL-PACKAGE" "TYPE-OF" "VALUES" 32 | "IN-PACKAGE" 33 | 34 | ;; Miscellaneous symbols 35 | "*GENSYM-COUNTER*" "*MACROEXPAND-HOOK*" "*PACKAGE*" "*READ-EVAL*" 36 | "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "BASE-CHAR" 37 | "FLOAT" "HASH-TABLE" "INTEGER" "MACRO" "NIL" "PACKAGE" "STREAM" 38 | "STRING" "SYMBOL" "T") 39 | 40 | ;; Set the current package to SYSTEM so we don't have to prefix symbols. 41 | (cl:setq *package* (sys:%find-package "SYSTEM")) 42 | (%use-package (%find-package "SYSTEM") (%find-package "COMMON-LISP")) 43 | 44 | ;; Create a hash table used to store all the dispatching macros. 45 | (setq *dispatching-macros* (%make-hash-table)) 46 | 47 | ;;;;; ;; #'xxx macro. See CLtL section 2.4.8.2 for details. 48 | ;;;;; (%set-hash *dispatching-macros* 49 | ;;;;; "'" 50 | ;;;;; (function 51 | ;;;;; (lambda (stream char) 52 | ;;;;; (list 'function (read stream))))) 53 | ;;;;; 54 | ;;;;; ;; #.xxx macro. See CLtL section 2.4.8.6 for details. 55 | ;;;;; (setq *read-eval* t) 56 | ;;;;; (%set-hash *dispatching-macros* 57 | ;;;;; "." 58 | ;;;;; (function 59 | ;;;;; (lambda (stream char) 60 | ;;;;; (if *read-eval* 61 | ;;;;; (eval (read stream)) 62 | ;;;;; (error "reader-error" "*READ-EVAL* is NIL"))))) 63 | ;;;;; 64 | ;;;;; ;; #< macro. See CLtL section 2.4.8.20 for details. 65 | ;;;;; (%set-hash *dispatching-macros* 66 | ;;;;; "<" 67 | ;;;;; (function 68 | ;;;;; (lambda (stream char) 69 | ;;;;; (error "reader-error" "#< is invalid syntax")))) 70 | ;;;;; 71 | ;;;;; ;; ## macro. See CLtL section 2.4.8.21 for details. 72 | ;;;;; (%set-hash *dispatching-macros* 73 | ;;;;; " " 74 | ;;;;; (function 75 | ;;;;; (lambda (stream char) 76 | ;;;;; (error "reader-error" "#| | is invalid syntax")))) 77 | ;;;;; 78 | ;;;;; ;; #) macro. See CLtL section 2.4.8.22 for details. 79 | ;;;;; (%set-hash *dispatching-macros* 80 | ;;;;; ")" 81 | ;;;;; (function 82 | ;;;;; (lambda (stream char) 83 | ;;;;; (error "reader-error" "#) is invalid syntax")))) 84 | ;;;;; 85 | ;;;;; ; (setq *macroexpand-hook* #'(lambda (fn form env) 86 | ;;;;; ; (apply fn (list form env)))) 87 | ;;;;; (setq *macroexpand-hook* ( function(lambda (fn form env) 88 | ;;;;; (apply fn (list form env))))) 89 | ;;;;; 90 | ;;;;; ;; Create the KEYWORD package. 91 | ;;;;; (sys:%make-package "KEYWORD") 92 | ;;;;; 93 | ;;;;; (sys:load "lisp/objects.l") 94 | ;;;;; (sys:load "lisp/core.l") 95 | ;;;;; (sys:load "lisp/logic.l") 96 | ;;;;; (sys:load "lisp/pred.l") 97 | ;;;;; (sys:load "lisp/list.l") 98 | ;;;;; (sys:load "lisp/math.l") 99 | ;;;;; 100 | ;;;;; ;; Create and alias the COMMON-LISP-USER package. 101 | ;;;;; (sys:%make-package "COMMON-LISP-USER") 102 | ;;;;; (sys:%alias-package (sys:%find-package "COMMON-LISP-USER") "CL-USER") 103 | ;;;;; 104 | ;;;;; (cl:setq *package* (sys:%find-package "CL-USER")) 105 | ;;;;; (sys:%use-package (sys:%find-package "CL-USER") 106 | ;;;;; (sys:%find-package "COMMON-LISP")) 107 | 108 | ; (in-package "COMMON-LISP-USER") 109 | (cl:setq *package* (sys:%find-package "CL")) 110 | -------------------------------------------------------------------------------- /lisp/core.l: -------------------------------------------------------------------------------- 1 | (setq cl:*package* (sys:%find-package "COMMON-LISP")) 2 | 3 | ;; Define a temporary, primitive version of the defun macro. 4 | (sys:set-symbol-function 'defun 5 | (sys:%make-macro 6 | (function (lambda (form env) 7 | (let ((name (car form)) (body (cdr form))) 8 | (list 'progn 9 | (list 'sys:set-symbol-function 10 | (list 'quote name) 11 | (list 'function (cons 'lambda body))) 12 | (list 'sys:set-function-name 13 | (list 'sys:get-symbol-function (list 'quote name)) 14 | (list 'symbol-name (list 'quote name))) 15 | (list 'sys:get-symbol-function (list 'quote name)))))))) 16 | 17 | ; (defun in-package (pkg) 18 | ; (setq *package* (sys:%find-package pkg))) 19 | -------------------------------------------------------------------------------- /lisp/list.l: -------------------------------------------------------------------------------- 1 | ; (in-package "COMMON-LISP") 2 | ; 3 | ; ;; Define some list accessing functions. 4 | ; (defun caar (x) (car (car x))) 5 | ; (defun cadr (x) (car (cdr x))) 6 | ; (defun cdar (x) (cdr (car x))) 7 | ; (defun cddr (x) (cdr (cdr x))) 8 | ; 9 | ; (defun caaar (x) (car (car (car x)))) 10 | ; (defun caadr (x) (car (car (cdr x)))) 11 | ; (defun cadar (x) (car (cdr (car x)))) 12 | ; (defun caddr (x) (car (cdr (cdr x)))) 13 | ; (defun cdaar (x) (cdr (car (car x)))) 14 | ; (defun cdadr (x) (cdr (car (cdr x)))) 15 | ; (defun cddar (x) (cdr (cdr (car x)))) 16 | ; (defun cdddr (x) (cdr (cdr (cdr x)))) 17 | ; 18 | ; (defun caaaar (x) (car (car (car (car x))))) 19 | ; (defun caaadr (x) (car (car (car (cdr x))))) 20 | ; (defun caadar (x) (car (car (cdr (car x))))) 21 | ; (defun caaddr (x) (car (car (cdr (cdr x))))) 22 | ; (defun cadaar (x) (car (cdr (car (car x))))) 23 | ; (defun cadadr (x) (car (cdr (car (cdr x))))) 24 | ; (defun caddar (x) (car (cdr (cdr (car x))))) 25 | ; (defun cadddr (x) (car (cdr (cdr (cdr x))))) 26 | ; (defun cdaaar (x) (cdr (car (car (car x))))) 27 | ; (defun cdaadr (x) (cdr (car (car (cdr x))))) 28 | ; (defun cdadar (x) (cdr (car (cdr (car x))))) 29 | ; (defun cdaddr (x) (cdr (car (cdr (cdr x))))) 30 | ; (defun cddaar (x) (cdr (cdr (car (car x))))) 31 | ; (defun cddadr (x) (cdr (cdr (car (cdr x))))) 32 | ; (defun cdddar (x) (cdr (cdr (cdr (car x))))) 33 | ; (defun cddddr (x) (cdr (cdr (cdr (cdr x))))) 34 | ; 35 | ; (defun endp (x) (eq x nil)) 36 | ; 37 | ; (defun first (x) (car x)) 38 | ; (defun second (x) (cadr x)) 39 | ; (defun third (x) (caddr x)) 40 | ; (defun fourth (x) (cadddr x)) 41 | ; (defun fifth (x) (car (cddddr x))) 42 | ; (defun sixth (x) (cadr (cddddr x))) 43 | ; (defun seventh (x) (caddr (cddddr x))) 44 | ; (defun eighth (x) (cadddr (cddddr x))) 45 | ; (defun ninth (x) (car (cddddr (cddddr x)))) 46 | ; (defun tenth (x) (cadr (cddddr (cddddr x)))) 47 | ; 48 | ; ;; Appends list A to list B 49 | ; (sys:set-symbol-function 'append 50 | ; #'(lambda (a b) 51 | ; (if (null a) 52 | ; b 53 | ; (cons (car a) (append (cdr a) b))))) 54 | ; 55 | ; ;; Copies and returns the passed tree. 56 | ; (defun copy-tree (tree) 57 | ; (if (consp tree) 58 | ; (cons (copy-tree (car tree)) 59 | ; (copy-tree (cdr tree))) 60 | ; tree)) 61 | ; 62 | ; ;; Identity returns whatever was passed to the function 63 | ; (defun identity (object) object) 64 | ; 65 | ; ;; For working with association lists. 66 | ; (defun acons (key val list) 67 | ; (cons (cons key val) list)) 68 | ; 69 | -------------------------------------------------------------------------------- /lisp/logic.l: -------------------------------------------------------------------------------- 1 | ; (in-package "COMMON-LISP") 2 | ; 3 | ; ;; Define some logical functions 4 | ; (defun not (x) (null x)) 5 | ; 6 | -------------------------------------------------------------------------------- /lisp/math.l: -------------------------------------------------------------------------------- 1 | ; (in-package "COMMON-LISP") 2 | ; 3 | ; (defun 1+ (x) (+ x 1)) 4 | ; (defun 1- (x) (- x 1)) 5 | ; (defun evenp (x) (eql (mod x 2) 0)) 6 | ; (defun oddp (x) (eql (mod x 2) 1)) 7 | ; (defun zerop (x) (eql x 0)) 8 | -------------------------------------------------------------------------------- /lisp/objects.l: -------------------------------------------------------------------------------- 1 | (cl:setq cl:*package* (sys:%find-package "SYSTEM")) 2 | 3 | ;; Set up some of the accessors for the LispSymbol class attributes. 4 | (%set-object-attribute 'set-symbol-function 5 | "LispSymbol" 6 | "function" 7 | (function (lambda (s f) 8 | (%set-object-attribute s "LispSymbol" "function" f)))) 9 | 10 | ; (set-symbol-function 'get-symbol:% s/^/; /-function 11 | ; (function (lambda (s) 12 | ; (%get-object-attribute s "LispSymbol" "function")))) 13 | ; 14 | (set-symbol-function 'set-symbol-documentation 15 | (function (lambda (s d) 16 | (%set-object-attribute s "LispSymbol" "documentation" d)))) 17 | 18 | (set-symbol-function 'get-symbol-documentation 19 | (function (lambda (s) 20 | (%get-object-attribute s "LispSymbol" "documentation")))) 21 | 22 | (set-symbol-function 'set-symbol-name 23 | (function (lambda (s n) 24 | (%set-object-attribute s "LispSymbol" "name" n)))) 25 | 26 | (set-symbol-function 'get-symbol-name 27 | (function (lambda (s) 28 | (%get-object-attribute s "LispSymbol" "name")))) 29 | 30 | (set-symbol-function 'set-symbol-package 31 | (function (lambda (s p) 32 | (%set-object-attribute s "LispSymbol" "package" p)))) 33 | 34 | (set-symbol-function 'get-symbol-package 35 | (function (lambda (s) 36 | (%get-object-attribute s "LispSymbol" "package")))) 37 | 38 | (set-symbol-function 'set-symbol-value 39 | (function (lambda (s v) 40 | (%set-object-attribute s "LispSymbol" "value" v)))) 41 | 42 | (set-symbol-function 'get-symbol-value 43 | (function (lambda (s) 44 | (%get-object-attribute s "LispSymbol" "value")))) 45 | 46 | ;; Set up some of the accessors for the LispPackage class attributes. 47 | (set-symbol-function 'set-package-name 48 | (function (lambda (p n) 49 | (%set-object-attribute p "LispPackage" "name" n)))) 50 | 51 | (set-symbol-function 'get-package-name 52 | (function (lambda (p) 53 | (%get-object-attribute p "LispPackage" "name")))) 54 | 55 | ;; Set up some of the accessors for the LispFunction class attributes. 56 | (set-symbol-function 'set-function-documentation 57 | (function (lambda (f d) 58 | (%set-object-attribute f "LispFunction" "documentation" d)))) 59 | 60 | (set-symbol-function 'get-function-documentation 61 | (function (lambda (f) 62 | (%get-object-attribute f "LispFunction" "documentation")))) 63 | 64 | (set-symbol-function 'get-function-name 65 | (function (lambda (f) 66 | (%get-object-attribute f "LispFunction" "name")))) 67 | 68 | (set-symbol-function 'set-function-name 69 | (function (lambda (f n) 70 | (%set-object-attribute f "LispFunction" "name" n)))) 71 | 72 | 73 | ;; The following functions should be created in the COMMON-LISP package. 74 | (setq *package* (%find-package "COMMON-LISP")) 75 | 76 | (sys:set-symbol-function 'symbol-function 77 | (function (lambda (s) 78 | (sys:get-symbol-function s)))) 79 | 80 | (sys:set-symbol-function 'symbol-name 81 | (function (lambda (s) 82 | (sys:get-symbol-name s)))) 83 | 84 | (sys:set-symbol-function 'symbol-package 85 | (function (lambda (s) 86 | (sys:get-symbol-package s)))) 87 | 88 | (sys:set-symbol-function 'package-name 89 | (function (lambda (p) 90 | (sys:get-package-name p)))) 91 | -------------------------------------------------------------------------------- /lisp/pred.l: -------------------------------------------------------------------------------- 1 | ; (in-package "COMMON-LISP") 2 | ; 3 | ; ;; XXX - This should also compare characters (which we don't have yet). 4 | ; (defun eql (x y) 5 | ; (if (eq x y) 6 | ; t 7 | ; (if (numberp x) 8 | ; (if (numberp y) 9 | ; (if (eq (type-of x) (type-of y)) 10 | ; (= x y)))))) 11 | ; 12 | ; ;; Define some predicate functions. 13 | ; (defun characterp (x) (eq (type-of x) 'base-char)) 14 | ; 15 | ; (defun consp (x) (eq (type-of x) 'cons)) 16 | ; 17 | ; (defun floatp (x) (eq (type-of x) 'float)) 18 | ; 19 | ; (defun functionp (x) (eq (type-of x) 'function)) 20 | ; 21 | ; (defun hash-table-p (x) (eq (type-of x) 'hash-table)) 22 | ; 23 | ; (defun integerp (x) (eq (type-of x) 'integer)) 24 | ; 25 | ; (defun keywordp (x) 26 | ; (if (symbolp x) 27 | ; (eq (symbol-package x) (sys:%find-package "KEYWORD")) 28 | ; nil)) 29 | ; 30 | ; (defun listp (x) 31 | ; (if (eq x 'nil) 32 | ; t 33 | ; (eq (type-of x) 'cons))) 34 | ; 35 | ; (defun numberp (x) 36 | ; (if (eq (type-of x) 'integer) 37 | ; t 38 | ; (eq (type-of x) 'float))) 39 | ; 40 | ; (defun packagep (x) 41 | ; (eq (type-of x) 'package)) 42 | ; 43 | ; (defun streamp (x) 44 | ; (eq (type-of x) 'stream)) 45 | ; 46 | ; (defun stringp (x) 47 | ; (eq (type-of x) 'string)) 48 | ; 49 | ; (defun symbolp (x) 50 | ; (eq (type-of x) 'symbol)) 51 | ; 52 | -------------------------------------------------------------------------------- /read.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | read.pir - lexing and parsing, reader macros 6 | 7 | =head1 DESCRIPTION 8 | 9 | The Lisp reader is implemented here. 10 | See CLtL section 23.1 . 11 | 12 | =head1 SUBROUTINES 13 | 14 | =cut 15 | 16 | =head2 _read 17 | 18 | The function that implements the Lisp reader CLtL 2.2. 19 | 20 | =cut 21 | 22 | .sub _read 23 | .param pmc args 24 | 25 | .local pmc readmacros 26 | .local pmc readtable 27 | .local pmc readcase 28 | .local pmc readobj 29 | .local pmc symbol 30 | .local pmc istream 31 | .local pmc stream 32 | .local string token 33 | .local pmc retv 34 | .local int nretv 35 | 36 | .ASSERT_LENGTH(args,1,ERROR_NARGS) # We should have received one argument - 37 | # the input stream to read from. 38 | 39 | .CAR(istream, args) 40 | stream = istream.'_get_io'() 41 | 42 | symbol = _LOOKUP_GLOBAL("SYSTEM", "*READER-MACROS*") 43 | readmacros = symbol.'_get_value'() 44 | 45 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*READTABLE*") 46 | readobj = symbol.'_get_value'() 47 | 48 | readtable = readobj.'_get_table'() 49 | readcase = readobj.'_get_case'() 50 | 51 | .local string char 52 | .local int ordv 53 | .local int type 54 | 55 | STEP_1: 56 | read char, stream, 1 # Read a character from the stream 57 | if char == "" goto EOF 58 | 59 | ord ordv, char # Figure out what kind of character 60 | type = readtable[ordv] # it represents 61 | 62 | if type == INVALID_CHAR goto READER_ERROR 63 | if type == WHITESPACE_CHAR goto STEP_1 64 | if type == TERM_MACRO_CHAR goto STEP_4 65 | if type == NTERM_MACRO_CHAR goto STEP_4 66 | if type == SESCAPE_CHAR goto STEP_5 67 | if type == MESCAPE_CHAR goto STEP_6 68 | if type == CONSTITUENT_CHAR goto STEP_7 69 | goto READER_ERROR 70 | 71 | STEP_4: 72 | .local pmc macro 73 | .local pmc margs 74 | .local pmc mchar 75 | 76 | macro = readmacros[char] # Get the readmacro we're calling 77 | 78 | .STRING(mchar, char) 79 | 80 | .LIST_2(margs, istream, mchar) # Create a list of args to pass in 81 | # VALID_IN_PARROT_0_2_0 retv = _FUNCTION_CALL(macro, margs) # Call the readmacro 82 | 83 | null retv 84 | retv = _FUNCTION_CALL(macro, margs) # Call the readmacro 85 | # VALID_IN_PARROT_0_2_0 if argcP == 0 goto STEP_1 86 | if_null retv, STEP_1 87 | goto DONE 88 | 89 | STEP_5: 90 | read char, stream, 1 91 | if char == "" goto EOF 92 | 93 | token = char 94 | 95 | goto STEP_9 96 | 97 | STEP_6: 98 | token = "" 99 | goto STEP_9 100 | 101 | STEP_7: 102 | token = char 103 | 104 | STEP_8: 105 | peek char, stream # A bit of a workaround until a 106 | ord ordv, char # unget opcode is implemented 107 | type = readtable[ordv] # to push chars back on the stream. 108 | 109 | if char == "" goto STEP_10 110 | 111 | if type == WHITESPACE_CHAR goto STEP_10 112 | if type == TERM_MACRO_CHAR goto STEP_10 113 | 114 | read char, stream, 1 115 | 116 | if type == CONSTITUENT_CHAR goto STEP_8a 117 | if type == NTERM_MACRO_CHAR goto STEP_8a 118 | if type == SESCAPE_CHAR goto STEP_8c 119 | if type == MESCAPE_CHAR goto STEP_9 120 | if type == INVALID_CHAR goto READER_ERROR 121 | goto READER_ERROR 122 | 123 | STEP_8a: 124 | if readcase == 0 goto STEP_8b 125 | upcase char 126 | 127 | STEP_8b: 128 | concat token, char 129 | goto STEP_8 130 | 131 | STEP_8c: 132 | read char, stream, 1 133 | if char == "" goto EOF 134 | 135 | concat token, char 136 | goto STEP_8 137 | 138 | STEP_9: 139 | read char, stream, 1 140 | if char == "" goto EOF 141 | 142 | if type == CONSTITUENT_CHAR goto STEP_9a 143 | if type == WHITESPACE_CHAR goto STEP_9a 144 | if type == TERM_MACRO_CHAR goto STEP_9a 145 | if type == NTERM_MACRO_CHAR goto STEP_9a 146 | if type == SESCAPE_CHAR goto STEP_9b 147 | if type == MESCAPE_CHAR goto STEP_8 148 | if type == INVALID_CHAR goto READER_ERROR 149 | goto READER_ERROR 150 | 151 | STEP_9a: 152 | concat token, char 153 | goto STEP_9 154 | 155 | STEP_9b: 156 | read char, stream, 1 157 | if char == "" goto EOF 158 | 159 | concat token, char 160 | goto STEP_9 161 | 162 | STEP_10: 163 | retv = _VALIDATE_TOKEN(token) 164 | if_null retv, READER_ERROR 165 | 166 | goto DONE 167 | 168 | READER_ERROR: 169 | .ERROR_0("reader-error", "Invalid character found in input stream.") 170 | goto DONE 171 | 172 | EOF: 173 | .NIL(retv) 174 | goto DONE 175 | 176 | ERROR_NARGS: 177 | .ERROR_0("program-error", "wrong number of arguments to READ") 178 | goto DONE 179 | 180 | DONE: 181 | .return(retv) 182 | .end 183 | 184 | .sub _error 185 | .param string type # There's current no way to add more 186 | .param string mesg # than just a message to the exception. 187 | 188 | .local pmc e 189 | 190 | e = new 'Exception' 191 | e = mesg 192 | 193 | throw e 194 | .end 195 | 196 | .sub _read_delimited_list 197 | .param pmc args 198 | 199 | .local string dchar 200 | .local string char 201 | .local pmc readmacros 202 | .local pmc readtable 203 | .local pmc readobj 204 | .local pmc delimit 205 | .local pmc istream 206 | .local pmc stream 207 | .local pmc symbol 208 | .local pmc tretv 209 | .local pmc retv 210 | .local pmc lptr 211 | .local int ordv 212 | .local int type 213 | 214 | .ASSERT_LENGTH_BETWEEN(args, 1, 2, ERROR_NARGS) 215 | 216 | .CAR(delimit, args) # First arg is the delimit character 217 | .ASSERT_TYPE_AND_BRANCH(delimit, "string", ERROR_NONSTRING) 218 | dchar = delimit 219 | 220 | .SECOND(istream, args) # Second arg is the input stream 221 | .NULL(istream, GET_STDIN) # If we don't have a stream get stdin 222 | goto DONE_ARGS 223 | 224 | GET_STDIN: 225 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*STANDARD-INPUT*") 226 | istream = symbol.'_get_value'() 227 | goto DONE_ARGS 228 | 229 | DONE_ARGS: 230 | .ASSERT_TYPE_AND_BRANCH(istream, "stream", ERROR_NONSTREAM) 231 | stream = istream.'_get_io'() 232 | 233 | symbol = _LOOKUP_GLOBAL("SYSTEM", "*READER-MACROS*") 234 | readmacros = symbol.'_get_value'() 235 | 236 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*READTABLE*") 237 | readobj = symbol.'_get_value'() 238 | 239 | readtable = readobj.'_get_table'() 240 | 241 | .NIL(retv) # Initialize the return to NIL 242 | lptr = retv 243 | 244 | LOOP: 245 | peek char, stream # Read a character from the stream 246 | if char == "" goto EOF 247 | 248 | ord ordv, char # Figure out what kind of character 249 | type = readtable[ordv] # it represents 250 | 251 | if type == INVALID_CHAR goto READER_ERROR 252 | if type == WHITESPACE_CHAR goto WHITESPACE 253 | if char == dchar goto DELIMIT_CHAR 254 | if type == SESCAPE_CHAR goto READ_OBJECT 255 | if type == MESCAPE_CHAR goto READ_OBJECT 256 | if type == CONSTITUENT_CHAR goto READ_OBJECT 257 | if type == TERM_MACRO_CHAR goto CALL_MACRO 258 | if type == NTERM_MACRO_CHAR goto CALL_MACRO 259 | goto READER_ERROR 260 | 261 | READ_OBJECT: # We've found a constituent char - 262 | .local pmc rargs # use _read to read in an object 263 | 264 | .LIST_1(rargs, istream) # Create the arg list for _read 265 | tretv = _read(rargs) # Read in the object 266 | goto APPEND_TO_LIST 267 | 268 | APPEND_TO_LIST: 269 | .APPEND(retv, retv, tretv) 270 | goto LOOP 271 | 272 | WHITESPACE: 273 | read char, stream, 1 # Whitespace chars get consumed 274 | goto LOOP 275 | 276 | CALL_MACRO: 277 | .local pmc macro 278 | .local pmc margs 279 | .local pmc mchar 280 | 281 | read char, stream, 1 # Consume the macro character 282 | 283 | macro = readmacros[char] # Get the readmacro we're calling 284 | 285 | .STRING(mchar, char) 286 | .LIST_2(margs, istream, mchar) # Create a list of args to pass in 287 | 288 | null tretv 289 | tretv = _FUNCTION_CALL(macro, margs) # Call the readmacro 290 | if_null tretv, LOOP 291 | 292 | # VALID_IN_PARROT_0_2_0 if argcP == 0 goto LOOP # If macro is NULL, start loop again 293 | # VALID_IN_PARROT_0_2_0 ntretv = tretv 294 | # VALID_IN_PARROT_0_2_0 if ntretv == 0 goto LOOP # If macro is NULL, start loop again 295 | goto APPEND_TO_LIST # else add the return value to list 296 | 297 | DELIMIT_CHAR: # We've hit the delimiter char - 298 | read char, stream, 1 # consume it, and return the list 299 | goto DONE 300 | 301 | READER_ERROR: 302 | .ERROR_0("reader-error", "invalid character found in input stream.") 303 | goto DONE 304 | 305 | ERROR_NARGS: 306 | .ERROR_0("program-error", "wrong number of arguments to READ-DELIMITED-LIST") 307 | goto DONE 308 | 309 | ERROR_NONSTRING: 310 | .ERROR_1("type-error", "argument %s is not a character", delimit) 311 | goto DONE 312 | 313 | ERROR_NONSTREAM: 314 | .ERROR_1("type-error", "argument %s is not a stream", istream) 315 | goto DONE 316 | 317 | EOF: 318 | .ERROR_0("end-of-file", "EOF on input stream reached.") 319 | goto DONE 320 | 321 | DONE: 322 | .return(retv) 323 | .end 324 | 325 | =head2 _left_paren_macro 326 | 327 | CLtL section 2.4.1. 328 | 329 | =cut 330 | 331 | .sub _left_paren_macro 332 | .param pmc args 333 | 334 | .local pmc stream 335 | .CAR(stream, args) # Get the input stream off the args 336 | 337 | .local pmc delimit 338 | .STRING(delimit, ")") # ')' is the delimiter for this macro 339 | 340 | .local pmc rargs 341 | .LIST_2(rargs, delimit, stream) # Package it up for the call 342 | 343 | .local pmc retv 344 | retv = _read_delimited_list(rargs) # Read the delimited list in. 345 | 346 | .return(retv) 347 | .end 348 | 349 | =head2 _right_paren_macro 350 | 351 | As described in CLtL section 2.4.2 352 | 353 | =cut 354 | 355 | .sub _right_paren_macro 356 | .param pmc args 357 | 358 | .ERROR_0("reader-error", "An object cannot start with #\\)") 359 | .end 360 | 361 | =head2 _single_quote_macro 362 | 363 | As described in CLtL section 2.4.3 364 | 365 | =cut 366 | 367 | .sub _single_quote_macro 368 | .param pmc args 369 | 370 | .local pmc stream 371 | .CAR(stream, args) # Get the input stream off the args 372 | 373 | .local pmc rargs 374 | .LIST_1(rargs, stream) # Package it up for the call to _read 375 | 376 | .local pmc form 377 | form = _read(rargs) # Read in a new object 378 | 379 | .local pmc symbol 380 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "QUOTE") 381 | 382 | .local pmc retv 383 | .LIST_2(retv, symbol, form) # Create a list equiv to (quote token) 384 | 385 | RETURN: 386 | .return(retv) 387 | .end 388 | 389 | =head2 _semicolon_macro 390 | 391 | A comment. Skip everything till the end of line 392 | or the end of file. 393 | 394 | As described in CLtL section 2.4.4 395 | 396 | =cut 397 | 398 | .sub _semicolon_macro 399 | .param pmc args 400 | 401 | 402 | .local pmc stream 403 | .CAR(stream, args) # Get the input stream off the args 404 | .local pmc istream 405 | istream = stream.'_get_io'() 406 | 407 | .local string char 408 | LOOP: 409 | read char, istream, 1 410 | if char == "\n" goto RETURN 411 | if char == "" goto RETURN 412 | goto LOOP 413 | 414 | RETURN: 415 | .end 416 | 417 | =head2 418 | 419 | As described in CLtL section 2.4.5. 420 | 421 | =cut 422 | 423 | .sub _double_quote_macro 424 | .param pmc args 425 | 426 | .local pmc stream 427 | .CAR(stream, args) # Get the input stream off the args 428 | .local pmc istream 429 | istream = stream.'_get_io'() 430 | 431 | .local pmc symbol 432 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*READTABLE*") 433 | .local pmc readtable 434 | readtable = symbol.'_get_value'() 435 | .local pmc table 436 | table = readtable.'_get_table'() 437 | 438 | .local string strtok 439 | strtok = "" 440 | 441 | .local string char 442 | .local int ordval 443 | .local int chtype 444 | 445 | goto STEP_1 446 | 447 | STEP_1: 448 | read char, istream, 1 449 | if char == "" goto EOF_ERROR 450 | 451 | ord ordval, char 452 | chtype = table[ordval] 453 | 454 | if chtype == SESCAPE_CHAR goto STEP_1a 455 | if char == "\"" goto RETURN 456 | goto STEP_1b 457 | 458 | STEP_1a: 459 | read char, istream, 1 460 | if char == "" goto EOF_ERROR 461 | 462 | goto STEP_1b 463 | 464 | STEP_1b: 465 | concat strtok, char 466 | goto STEP_1 467 | 468 | EOF_ERROR: 469 | .ERROR_0("end-of-file", "EOF on input stream reached.") 470 | goto RETURN 471 | 472 | RETURN: 473 | .local pmc token 474 | .STRING(token, strtok) 475 | 476 | .return(token) 477 | .end 478 | 479 | =head2 _backquote_macro 480 | 481 | As described in CLtL section 2.4.6 482 | 483 | =cut 484 | 485 | .sub _backquote_macro 486 | 487 | .ERROR_0("reader-error", "The backquote macro has not yet been implemented.") 488 | .end 489 | 490 | =head2 _comma_macro 491 | 492 | As described in CLtL section 2.4.7 493 | 494 | =cut 495 | 496 | .sub _comma_macro 497 | 498 | .ERROR_0("reader-error", "Comma is illegal outside of backquote.") 499 | .end 500 | 501 | .sub _sharpsign_macro # As described in CLtL section 2.4.8 502 | .param pmc args 503 | 504 | .local string char 505 | .local pmc istream 506 | .local pmc stream 507 | .local pmc symbol 508 | .local pmc macros 509 | .local pmc macro 510 | .local pmc retv 511 | .local pmc func 512 | 513 | .CAR(stream,args) 514 | istream = stream.'_get_io'() 515 | 516 | read char, istream, 1 517 | 518 | symbol = _LOOKUP_GLOBAL("SYSTEM", "*DISPATCHING-MACROS*") 519 | .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", MACRO_NOT_INITIALIZED) 520 | 521 | macros = symbol.'_get_value'() 522 | .ASSERT_TYPE_AND_BRANCH(macros, "hash", MACRO_NOT_INITIALIZED) 523 | 524 | macro = macros[char] 525 | 526 | if_null macro, MACRO_NOT_DEFINED 527 | 528 | .ASSERT_TYPE(macro, "function") 529 | _FUNCTION_CALL(macro,args) 530 | 531 | goto DONE 532 | 533 | MACRO_NOT_INITIALIZED: 534 | .ERROR_0("reader-error","the dispatching macro table has not been created") 535 | goto DONE 536 | 537 | MACRO_NOT_DEFINED: 538 | .ERROR_1("reader-error","\"%s\" dispatching macro has not been defined",char) 539 | goto DONE 540 | 541 | DONE: 542 | returncc 543 | .end 544 | 545 | 546 | # Local Variables: 547 | # mode: pir 548 | # fill-column: 100 549 | # End: 550 | # vim: expandtab shiftwidth=4 ft=pir: 551 | -------------------------------------------------------------------------------- /system.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | system.pir - implementation specific package SYSTEM 6 | 7 | =head1 DESCRIPTION 8 | 9 | Used in bootstrapping. 10 | 11 | =cut 12 | 13 | .sub _init_system :init 14 | 15 | .local pmc package 16 | 17 | .PACKAGE(package, "SYSTEM") 18 | 19 | set_global ["PACKAGES"], "SYSTEM", package 20 | set_global ["PACKAGES"], "SYS", package 21 | 22 | _init_reader_macros( package ) 23 | 24 | .local pmc symbol, nil 25 | .NIL(nil) 26 | 27 | .DEFVAR(symbol, package, "*INSIDE-BACKQUOTE*", nil) # not used yet 28 | .DEFVAR(symbol, package, "*INSIDE-BACKQUOTE-LIST*", nil) # not used yet 29 | 30 | .DEFUN(symbol, package, "%GET-OBJECT-ATTRIBUTE", "_get_object_attr") 31 | .DEFUN(symbol, package, "%SET-OBJECT-ATTRIBUTE", "_set_object_attr") 32 | 33 | .DEFUN(symbol, package, "%MAKE-HASH-TABLE", "_make_hash_table") 34 | .DEFUN(symbol, package, "%SET-HASH", "_set_hash") 35 | .DEFUN(symbol, package, "%GET-HASH", "_get_hash") 36 | 37 | .DEFUN(symbol, package, "%ALIAS-PACKAGE", "_alias_package") 38 | .DEFUN(symbol, package, "%FIND-PACKAGE", "_find_package") 39 | .DEFUN(symbol, package, "%PACKAGE-NAME", "_package_name") 40 | .DEFUN(symbol, package, "%MAKE-PACKAGE", "_make_package") 41 | .DEFUN(symbol, package, "%USE-PACKAGE", "_use_package") 42 | .DEFUN(symbol, package, "%EXPORT", "_export") 43 | 44 | .DEFUN(symbol, package, "%OPEN-FILE", "_open_file") 45 | .DEFUN(symbol, package, "%PEEK", "_peek") 46 | .DEFUN(symbol, package, "%CLOSE", "_close") 47 | 48 | .DEFUN(symbol, package, "%STRING-EQUAL", "_string_equal") 49 | 50 | .DEFUN(symbol, package, "%MAKE-MACRO", "_make_macro") 51 | 52 | # XXX - THESE SHOULD BE REMOVED AND CONVERTED TO PROPER LISP FUNCTIONS 53 | .DEFUN(symbol, package, "ERROR", "_raise_error") 54 | 55 | .DEFUN(symbol, package, "LOAD", "_load") 56 | 57 | .return(1) 58 | .end 59 | 60 | 61 | .sub _init_reader_macros 62 | 63 | .param pmc package 64 | 65 | .local pmc function, reader_macros 66 | .HASH(reader_macros) 67 | 68 | .FUNCTION(function, "_left_paren_macro" ) 69 | reader_macros["("] = function 70 | 71 | .FUNCTION(function, "_right_paren_macro" ) 72 | reader_macros[")"] = function 73 | 74 | .FUNCTION(function, "_single_quote_macro" ) 75 | reader_macros["'"] = function 76 | 77 | .FUNCTION(function, "_semicolon_macro" ) 78 | reader_macros[";"] = function 79 | 80 | .FUNCTION(function, "_double_quote_macro" ) 81 | reader_macros['"'] = function 82 | 83 | .FUNCTION(function, "_backquote_macro" ) 84 | reader_macros["`"] = function 85 | 86 | .FUNCTION(function, "_comma_macro" ) 87 | reader_macros[","] = function 88 | 89 | .FUNCTION(function, "_sharpsign_macro" ) 90 | reader_macros["#"] = function 91 | 92 | .local pmc symbol 93 | .DEFVAR(symbol, package, "*READER-MACROS*", reader_macros) 94 | 95 | .return(1) 96 | .end 97 | 98 | .sub _set_hash 99 | .param pmc args 100 | .ASSERT_LENGTH(args,3,ERROR_NARGS) 101 | 102 | .local pmc hash 103 | .CAR(hash,args) 104 | .ASSERT_TYPE(hash, "hash") 105 | 106 | .local pmc key 107 | .SECOND(key,args) 108 | .ASSERT_TYPE(key, "string") 109 | 110 | .local pmc val 111 | .THIRD(val,args) 112 | 113 | .local string key_str 114 | key_str = key 115 | hash[key_str] = val 116 | 117 | goto DONE 118 | 119 | ERROR_NARGS: 120 | .ERROR_0("program-error", "wrong number of arguments to %SET-HASH") 121 | goto DONE 122 | 123 | DONE: 124 | .return(val) 125 | .end 126 | 127 | .sub _get_hash 128 | .param pmc args 129 | .ASSERT_LENGTH(args,2,ERROR_NARGS) 130 | 131 | .local pmc hash 132 | .CAR(hash,args) 133 | .ASSERT_TYPE(hash, "hash") 134 | 135 | .local pmc key 136 | .SECOND(key,args) 137 | .ASSERT_TYPE(key, "string") 138 | 139 | .local string key_str 140 | key_str = key # Convert the key to a string 141 | .local pmc val 142 | val = hash[key_str] 143 | 144 | if_null val, NO_VALUE_SET 145 | 146 | goto DONE 147 | 148 | NO_VALUE_SET: 149 | .NIL(val) 150 | goto DONE 151 | 152 | ERROR_NARGS: 153 | .ERROR_0("program-error", "wrong number of arguments to %GET-HASH") 154 | goto DONE 155 | 156 | DONE: 157 | .return(val) 158 | .end 159 | 160 | .sub _package_name 161 | .param pmc args 162 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 163 | 164 | .local pmc pkg 165 | .CAR(pkg, args) 166 | .ASSERT_TYPE(pkg, "package") 167 | 168 | .local pmc pkgname 169 | pkgname = pkg.'_get_name'() 170 | 171 | goto DONE 172 | 173 | ERROR_NARGS: 174 | .ERROR_0("program-error", "wrong number of arguments to SYS:%PACKAGE-NAME") 175 | goto DONE 176 | 177 | DONE: 178 | .return(pkgname) 179 | .end 180 | 181 | 182 | .sub _find_package 183 | .param pmc args 184 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 185 | 186 | .local pmc pkgname 187 | .CAR(pkgname, args) 188 | .ASSERT_TYPE(pkgname, "string") 189 | 190 | .local string pkgname_str 191 | pkgname_str = pkgname 192 | upcase pkgname_str 193 | 194 | push_eh PACKAGE_NOT_FOUND 195 | .local pmc retv 196 | retv = get_global ["PACKAGES"], pkgname_str 197 | if_null retv, PACKAGE_NOT_FOUND 198 | pop_eh 199 | 200 | goto DONE 201 | 202 | PACKAGE_NOT_FOUND: 203 | .NIL(retv) 204 | goto DONE 205 | 206 | ERROR_NARGS: 207 | .ERROR_0("program-error", "wrong number of arguments to %FIND-PACKAGE") 208 | goto DONE 209 | 210 | DONE: 211 | .return(retv) 212 | .end 213 | 214 | .sub _alias_package 215 | .param pmc args 216 | .ASSERT_LENGTH(args, 2, ERROR_NARGS) 217 | 218 | .local pmc package 219 | .CAR(package, args) 220 | .ASSERT_TYPE(package, "package") 221 | 222 | .local pmc pkgname 223 | .SECOND(pkgname, args) 224 | .ASSERT_TYPE(pkgname, "string") 225 | 226 | .local string pkgname_str 227 | pkgname_str = pkgname 228 | upcase pkgname_str 229 | 230 | set_global ["PACKAGES"], pkgname_str, package 231 | 232 | .local pmc retv 233 | .TRUE(retv) 234 | goto DONE 235 | 236 | ERROR_NARGS: 237 | .ERROR_0("program-error", "wrong number of arguments to %ALIAS-PACKAGE") 238 | goto DONE 239 | 240 | DONE: 241 | .return(retv) 242 | .end 243 | 244 | .sub _make_package 245 | .param pmc args 246 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 247 | 248 | .local pmc pkgname 249 | .CAR(pkgname, args) 250 | .ASSERT_TYPE(pkgname, "string") 251 | 252 | .local pmc package 253 | .PACKAGE(package, pkgname) 254 | 255 | .local string pkgname_str 256 | pkgname_str = pkgname 257 | upcase pkgname_str 258 | 259 | set_global ["PACKAGES"], pkgname_str, package 260 | 261 | goto DONE 262 | 263 | ERROR_NARGS: 264 | .ERROR_0("program-error", "wrong number of arguments to %MAKE-PACKAGE") 265 | goto DONE 266 | 267 | DONE: 268 | .return(package) 269 | .end 270 | 271 | .sub _use_package 272 | .param pmc args 273 | .local string symnames 274 | .local pmc frompkg 275 | .local pmc intopkg 276 | .local pmc exports 277 | .local pmc symname 278 | .local pmc symbol 279 | .local pmc retv 280 | .local pmc i 281 | 282 | .ASSERT_LENGTH(args, 2, ERROR_NARGS) 283 | 284 | .CAR(intopkg, args) 285 | .SECOND(frompkg, args) 286 | 287 | .ASSERT_TYPE(intopkg, "package") 288 | .ASSERT_TYPE(frompkg, "package") 289 | 290 | exports = frompkg.'_get_exports'() 291 | 292 | iter i, exports 293 | 294 | push_eh DONE 295 | 296 | LOOP: 297 | shift symname, i 298 | symnames = symname 299 | 300 | symbol = frompkg.'_lookup_symbol'(symnames) 301 | intopkg.'_import_symbol'(symbol) 302 | 303 | goto LOOP 304 | 305 | ERROR_NARGS: 306 | .ERROR_0("program-error", "wrong number of arguments to %USE-PACKAGE") 307 | goto DONE 308 | 309 | DONE: 310 | .TRUE(retv) 311 | .return(retv) 312 | .end 313 | 314 | .sub _export 315 | .param pmc args 316 | 317 | .local string symname 318 | .local pmc package 319 | .local pmc symbols 320 | .local pmc symbol 321 | .local pmc retv 322 | 323 | .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS) 324 | 325 | .CAR(package, args) 326 | .ASSERT_TYPE(package, "package") 327 | 328 | .CDR(symbols, args) 329 | # TODO: looks like find-package is called twice, problem in eval.pir ? 330 | .CDR(symbols, symbols) 331 | 332 | LOOP: 333 | .NULL(symbols, DONE) 334 | 335 | .CAR(symbol, symbols) 336 | .ASSERT_TYPE(symbol, "string") 337 | 338 | symname = symbol 339 | package.'_export_symbol'(symname) 340 | 341 | .CDR(symbols, symbols) 342 | goto LOOP 343 | 344 | ERROR_NARGS: 345 | .ERROR_0("program-error", "wrong number of arguments to %EXPORT") 346 | goto DONE 347 | 348 | DONE: 349 | .TRUE(retv) 350 | .return(retv) 351 | .end 352 | 353 | .sub _make_hash_table 354 | .param pmc args 355 | .ASSERT_LENGTH(args,0,ERROR_NARGS) 356 | 357 | .local pmc retv 358 | .HASH(retv) 359 | goto DONE 360 | 361 | ERROR_NARGS: 362 | .ERROR_0("program-error", "wrong number of arguments to %MAKE-HASH-TABLE") 363 | goto DONE 364 | 365 | DONE: 366 | .return(retv) 367 | .end 368 | 369 | .sub _raise_error 370 | .param pmc args 371 | .local string types 372 | .local string mesgs 373 | .local pmc type 374 | .local pmc mesg 375 | .local pmc retv 376 | 377 | .ASSERT_LENGTH(args,2,ERROR_NARGS) 378 | 379 | .CAR(type,args) 380 | .SECOND(mesg,args) 381 | 382 | .NIL(retv) 383 | 384 | types = type 385 | mesgs = mesg 386 | 387 | .ERROR_0(types, mesgs) 388 | 389 | goto DONE 390 | 391 | ERROR_NARGS: 392 | .ERROR_0("program-error", "wrong number of arguments to %ERROR") 393 | goto DONE 394 | 395 | DONE: 396 | .return(retv) 397 | .end 398 | 399 | .sub _load 400 | .param pmc args 401 | 402 | .local string fname1 403 | .local pmc stream 404 | .local pmc fname2 405 | .local pmc farg 406 | .local pmc rretv 407 | .local pmc eretv 408 | .local pmc retv 409 | .local pmc fd 410 | 411 | .ASSERT_LENGTH(args, 1,ERROR_NARGS) 412 | 413 | .CAR(fname2,args) 414 | fname1 = fname2 415 | 416 | open fd, fname1, "r" 417 | unless fd, OPEN_FAILED 418 | 419 | .STREAM(stream, fd) 420 | .TRUE(retv) 421 | 422 | LOAD_LOOP: 423 | .LIST_1(farg,stream) 424 | rretv = _read(farg) 425 | 426 | .NULL(rretv, CLEANUP) 427 | 428 | .LIST_1(farg,rretv) 429 | 430 | eretv = _eval(farg) 431 | 432 | 433 | goto LOAD_LOOP 434 | 435 | OPEN_FAILED: 436 | .NIL(retv) 437 | goto DONE 438 | 439 | CLEANUP: 440 | close fd 441 | .TRUE(retv) 442 | goto DONE 443 | 444 | ERROR_NARGS: 445 | .ERROR_0("program-error", "wrong number of arguments to %LOAD") 446 | goto DONE 447 | 448 | DONE: 449 | .return(retv) 450 | .end 451 | 452 | .sub _get_object_attr 453 | .param pmc args 454 | .ASSERT_LENGTH(args,3,ERROR_NARGS) 455 | 456 | .local pmc symbol 457 | .CAR(symbol,args) 458 | 459 | .local pmc obj_type 460 | .SECOND(obj_type,args) 461 | .ASSERT_TYPE(obj_type, "string") 462 | # TODO: check type of symbol 463 | 464 | .local pmc attr_name 465 | .THIRD(attr_name,args) 466 | .ASSERT_TYPE(attr_name, "string") 467 | .local string attr_name_str 468 | attr_name_str = attr_name 469 | 470 | .local pmc retv 471 | retv = getattribute symbol, attr_name_str 472 | if_null retv, NO_VALUE 473 | goto DONE 474 | 475 | NO_VALUE: 476 | .NIL(retv) 477 | goto DONE 478 | 479 | ERROR_NARGS: 480 | .ERROR_0("program-error","wrong number of arguments to %GET-OBJECT-ATTRIBUTE") 481 | goto DONE 482 | 483 | DONE: 484 | .return(retv) 485 | .end 486 | 487 | .sub _set_object_attr 488 | .param pmc args 489 | .ASSERT_LENGTH(args,4,ERROR_NARGS) 490 | 491 | .local pmc symbol 492 | .CAR(symbol,args) 493 | 494 | .local pmc obj_type 495 | .SECOND(obj_type,args) 496 | .ASSERT_TYPE(obj_type, "string") 497 | # TODO: check type of symbol 498 | 499 | .local pmc attr_name 500 | .THIRD(attr_name,args) 501 | .ASSERT_TYPE(attr_name, "string") 502 | .local string attr_name_str 503 | attr_name_str = attr_name 504 | 505 | .local pmc value 506 | .FOURTH(value,args) 507 | 508 | setattribute symbol, attr_name_str, value 509 | goto DONE 510 | 511 | ERROR_NARGS: 512 | .ERROR_0("program-error","wrong number of arguments to %SET-SYMBOL-ATTRIBUTE") 513 | goto DONE 514 | 515 | DONE: 516 | .return(value) 517 | .end 518 | 519 | .sub _open_file 520 | .param pmc args 521 | 522 | .local string modes 523 | .local string names 524 | .local pmc stream 525 | .local pmc name 526 | .local pmc mode 527 | .local pmc retv 528 | .local int test 529 | 530 | .ASSERT_LENGTH(args,2,ERROR_NARGS) 531 | 532 | .CAR(name, args) 533 | .SECOND(mode, args) 534 | 535 | .ASSERT_TYPE(name, "string") 536 | .ASSERT_TYPE(mode, "string") 537 | 538 | names = name 539 | modes = mode 540 | 541 | open stream, names, modes 542 | 543 | defined test, stream 544 | if test != 1 goto FILE_NOT_FOUND 545 | 546 | .STREAM(retv, stream) 547 | 548 | goto DONE 549 | 550 | FILE_NOT_FOUND: 551 | .ERROR_1("file-error", "error opening file %s", name) 552 | goto DONE 553 | 554 | ERROR_NARGS: 555 | .ERROR_0("program-error", "wrong number of arguments to %OPEN-FILE") 556 | goto DONE 557 | 558 | DONE: 559 | .return(retv) 560 | .end 561 | 562 | .sub _peek 563 | .param pmc args 564 | .local string char 565 | .local pmc stream 566 | .local pmc retv 567 | .local pmc io 568 | 569 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 570 | 571 | .CAR(stream, args) 572 | .ASSERT_TYPE(stream, "stream") 573 | 574 | io = stream.'_get_io'() 575 | 576 | peek char, io 577 | if char == "" goto ERROR_EOF 578 | 579 | .STRING(retv, char) 580 | 581 | goto DONE 582 | 583 | ERROR_NARGS: 584 | .ERROR_0("program-error", "wrong number of arguments to %PEEK") 585 | goto DONE 586 | 587 | ERROR_EOF: 588 | .ERROR_0("end-of-file", "EOF on input stream reached.") 589 | goto DONE 590 | 591 | DONE: 592 | .return(retv) 593 | .end 594 | 595 | .sub _close 596 | .param pmc args 597 | .local pmc stream 598 | .local pmc retv 599 | .local pmc io 600 | 601 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 602 | 603 | .CAR(stream, args) 604 | .ASSERT_TYPE(stream, "stream") 605 | 606 | io = stream.'_get_io'() 607 | close io 608 | 609 | .TRUE(retv) 610 | 611 | goto DONE 612 | 613 | ERROR_NARGS: 614 | .ERROR_0("program-error", "wrong number of arguments to %CLOSE") 615 | goto DONE 616 | 617 | DONE: 618 | .return(retv) 619 | .end 620 | 621 | .sub _string_equal 622 | .param pmc args 623 | .local string val1 624 | .local string val2 625 | .local pmc str1 626 | .local pmc str2 627 | .local pmc retv 628 | 629 | .ASSERT_LENGTH(args, 2, ERROR_NARGS) 630 | 631 | .CAR(str1, args) 632 | .SECOND(str2, args) 633 | 634 | .ASSERT_TYPE(str1, "string") 635 | .ASSERT_TYPE(str2, "string") 636 | 637 | val1 = str1 638 | val2 = str2 639 | 640 | if val1 == val2 goto STRING_EQUAL 641 | 642 | .NIL(retv) 643 | goto DONE 644 | 645 | STRING_EQUAL: 646 | .TRUE(retv) 647 | goto DONE 648 | 649 | ERROR_NARGS: 650 | .ERROR_0("program-error", "wrong number of arguments to %STRING-EQUAL") 651 | goto DONE 652 | 653 | DONE: 654 | .return(retv) 655 | .end 656 | 657 | .sub _make_macro 658 | .param pmc args 659 | .local int type 660 | .local pmc macro 661 | .local pmc val 662 | .local pmc form 663 | .local pmc retv 664 | 665 | .ASSERT_LENGTH(args, 1, ERROR_NARGS) 666 | 667 | .CAR(form, args) 668 | 669 | # XXX - This is pretty hackish - should probably use the __morph method 670 | 671 | macro = new "LispMacro" 672 | 673 | val = form.'_get_args'() 674 | macro.'_set_args'(val) 675 | 676 | val = form.'_get_scope'() 677 | macro.'_set_scope'(val) 678 | 679 | val = form.'_get_body'() 680 | macro.'_set_body'(val) 681 | 682 | goto DONE 683 | 684 | ERROR_NARGS: 685 | .ERROR_0("program-error", "wrong number of arguments to %MAKE-MACRO") 686 | goto DONE 687 | 688 | DONE: 689 | .return(macro) 690 | .end 691 | 692 | # Local Variables: 693 | # mode: pir 694 | # fill-column: 100 695 | # End: 696 | # vim: expandtab shiftwidth=4 ft=pir: 697 | -------------------------------------------------------------------------------- /t/arithmetics.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/arithmetics.t - tests for Parrot Common Lisp 6 | 7 | =head1 DESCRIPTION 8 | 9 | Basic math. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More tests => 6; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', 'addition' ); 27 | ( print ( + 1 3 ) ) 28 | END_CODE 29 | 4 30 | END_OUT 31 | 32 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', 'negation' ); 33 | ( print ( - 3 ) ) 34 | END_CODE 35 | -3 36 | END_OUT 37 | 38 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '1 equals 1' ); 39 | ( print ( = 1 1 ) ) 40 | END_CODE 41 | T 42 | END_OUT 43 | 44 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '1 does not equal 2' ); 45 | ( print ( = 1 2 ) ) 46 | END_CODE 47 | NIL 48 | END_OUT 49 | 50 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '2 equals 1+1' ); 51 | ( print ( = 2 ( + 1 1 ) ) ) 52 | END_CODE 53 | T 54 | END_OUT 55 | 56 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '2 equals 1+1' ); 57 | ( print ( mod 11 3 ) ) 58 | END_CODE 59 | 2 60 | END_OUT 61 | -------------------------------------------------------------------------------- /t/atoms.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/atoms.t - tests for atoms in Parrot Common Lisp 6 | 7 | =head1 DESCRIPTION 8 | 9 | Atoms. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | my @test_cases = ( 27 | [ q{ 0 }, 28 | 0, 29 | q{T}, 30 | 'integer 0', 31 | todo => '0 is still strange', 32 | ], 33 | [ q{ -0 }, 34 | -0, 35 | q{T}, 36 | 'integer negative 0', 37 | todo => '0 is still strange', 38 | ], 39 | [ q{ 1 }, 40 | 1, 41 | q{T}, 42 | 'integer 1' 43 | ], 44 | [ q{ -1 }, 45 | -1, 46 | q{T}, 47 | 'integer -1' 48 | ], 49 | [ q{ 2 }, 50 | 2, 51 | q{T}, 52 | 'integer 2' 53 | ], 54 | [ q{ 2 }, 55 | 2, 56 | q{T}, 57 | 'integer 2' 58 | ], 59 | [ q{ 123456789 }, 60 | 123456789, 61 | q{T}, 62 | 'integer 123456789' 63 | ], 64 | [ q{ -123456789 }, 65 | -123456789, 66 | q{T}, 67 | 'integer -123456789' 68 | ], 69 | [ q{ nil }, 70 | 'NIL', 71 | q{T}, 72 | 'false' 73 | ], 74 | [ q{ NIL }, 75 | 'NIL', 76 | q{T}, 77 | 'NIL' 78 | ], 79 | [ q{ Nil }, 80 | 'NIL', 81 | q{T}, 82 | 'Nil' 83 | ], 84 | [ q{ t }, 85 | 'T', 86 | q{T}, 87 | 'true' 88 | ], 89 | [ q{ T }, 90 | 'T', 91 | q{T}, 92 | 'true' 93 | ], 94 | [ q{ () }, 95 | 'NIL', 96 | q{T}, 97 | 'empty list is NIL' 98 | ], 99 | [ q{ (atom 999) }, 100 | 'T', 101 | q{T}, 102 | 'integer 999 is an atom' 103 | ], 104 | [ q{ "neunhundertneunundneunzig" }, 105 | 'neunhundertneunundneunzig', 106 | q{T}, 107 | 'string in double quotes' 108 | ], 109 | [ q{ " single quote '" }, 110 | q{ single quote '}, 111 | q{T}, 112 | 'string with single quote' 113 | ], 114 | [ q{ " double quote \"" }, 115 | q{ double quote "}, 116 | q{T}, 117 | 'string with double quote' 118 | ], 119 | [ q{ " backslash \\\\" }, 120 | q{ backslash \\}, 121 | q{T}, 122 | 'string with backslash' 123 | ], 124 | [ q{ "" }, 125 | '', 126 | q{T}, 127 | 'empty string' 128 | ], 129 | [ q{ " " }, 130 | ' ', 131 | q{T}, 132 | 'single space' 133 | ], 134 | [ q{ " a s d f " }, 135 | ' a s d f ', 136 | q{T}, 137 | 'string with spaces' 138 | ], 139 | [ q{ (atom ( + 1 2 )) }, 140 | 'T', 141 | q{T}, 142 | 'result of an addition is an atom' 143 | ], 144 | [ q{ (atom '( + 1 2 )) }, 145 | 'NIL', 146 | q{T}, 147 | 'a quoted addition is not an atom' 148 | ], 149 | ); 150 | 151 | Test::More::plan( tests => 2 * scalar( @test_cases ) ); 152 | 153 | foreach ( @test_cases ) 154 | { 155 | my ( $code, $out, $is_atom, $desc, @other ) = @{ $_ }; 156 | 157 | language_output_is( 'Lisp', "( print $code )", $out . "\n", "print $desc", @other ); 158 | language_output_is( 'Lisp', "( print ( atom $code ))", $is_atom . "\n", "atom: $desc", @other ); 159 | } 160 | -------------------------------------------------------------------------------- /t/cl.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/cl.t - tests function in COMMON-LISP 6 | 7 | =head1 DESCRIPTION 8 | 9 | Functions defined in cl.pir. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | my @test_cases = ( 27 | [ q{ ( print *gensym-counter* ) 28 | }, 29 | q{1}, 30 | q{defined var *gensym-counter*}, 31 | ], 32 | [ q{ ( print *package* ) 33 | }, 34 | q{#}, 35 | q{*package* stringified}, 36 | ], 37 | [ q{ ( print *readtable* ) 38 | }, 39 | q{#}, 40 | q{*readtable* stringified}, 41 | ], 42 | [ q{ ( print *standard-input* ) 43 | }, 44 | q{#}, 45 | q{*standard-input* stringified}, 46 | ], 47 | [ q{ ( print *standard-output* ) 48 | }, 49 | q{#}, 50 | q{*standard-output* stringified}, 51 | ], 52 | [ q{ (print '(1 2)) }, 53 | q{(1 . (2 . NIL))}, 54 | q{quoting a list}, 55 | ], 56 | [ q{ ( setq my_function '+) ( print (boundp 'my_function) ) }, 57 | q{T}, 58 | q{boundp on a bound variable}, 59 | ], 60 | [ q{ ( setq my_function '+) ( print (boundp 'your_function) ) }, 61 | q{NIL}, 62 | q{boundp on an unbound variable}, 63 | ], 64 | [ q{ ( print ( car ( list 1 2 )) ) }, 65 | q{1}, 66 | ], 67 | [ q{ ( print ( car ( cons 1 2 )) ) }, 68 | q{1}, 69 | ], 70 | [ q{( print ( cdr ( list 1 2 )) ) }, 71 | q{(2 . NIL)}, 72 | ], 73 | [ q{ ( print ( cdr ( cons 1 2 )) ) }, 74 | q{2}, 75 | ], 76 | [ q{ ( print ( char "asdf" 0 ) ) }, 77 | q{a}, 78 | q{first character}, 79 | todo => 'still cannot pass 0', 80 | ], 81 | [ q{ ( print ( char "asdf" 1 ) ) }, 82 | q{s}, 83 | ], 84 | [ q{ ( print ( char "asdf" 3 ) ) }, 85 | q{f}, 86 | ], 87 | [ q{ ( print ( cons 1 2 ) ) }, 88 | q{(1 . 2)}, 89 | ], 90 | [ q{ ( print ( cons 1 ( cons 2 3 ) ) ) }, 91 | q{(1 . (2 . 3))}, 92 | ], 93 | [ q{ ( print ( eq 1 1 ) ) }, 94 | q{T}, 95 | q{function eq}, 96 | todo => 'eq is broken', 97 | ], 98 | [ q{ ( print ( eval '( + 1 1 ) ) ) }, 99 | q{2}, 100 | q{eval an addition}, 101 | ], 102 | [ q{ ( print "How does function work?" ) }, 103 | q{}, 104 | q{function}, 105 | todo => 'test the function function' 106 | ], 107 | [ q{ ( print ( gensym ) ) }, 108 | q{G000001}, 109 | ], 110 | [ q{ ( gensym ) ( print *gensym-counter* ) }, 111 | q{2}, 112 | ], 113 | [ q{ ( gensym )( gensym )( gensym ) ( print *gensym-counter* ) }, 114 | q{4}, 115 | ], 116 | [ q{ ( if T ( print "T is true" ) ( print "T is false" ) ) }, 117 | q{T is true}, 118 | ], 119 | [ q{ ( if NIL ( print "NIL is true" ) ( print "NIL is false" ) ) }, 120 | q{NIL is false}, 121 | ], 122 | [ q{ ( if ( - 3 3 ) ( print "3-3 is true" ) ( print "3-3 is false" ) ) }, 123 | q{3-3 is true}, 124 | ], 125 | [ q{ ( if ( + 3 3 ) ( print "3+3 is true" ) ( print "3+3 is false" ) ) }, 126 | q{3+3 is true}, 127 | ], 128 | [ q{ ( "let" ) }, 129 | q{NIL}, 130 | q{let not tested yet}, 131 | todo => 'understand let' 132 | ], 133 | [ q{ ( print ( list 1 2 ) ) }, 134 | q{(1 . (2 . NIL))}, 135 | ], 136 | [ q{ ( print ( null nil ) ) }, 137 | q{T}, 138 | ], 139 | [ q{ ( print ( null 1 ) ) }, 140 | q{NIL}, 141 | ], 142 | [ q{ ( print ( null ' ( ) ) ) }, 143 | q{T}, 144 | ], 145 | [ q{ ( print ( null T ) ) }, 146 | q{NIL}, 147 | ], 148 | [ q{ ( print ( progn 1 ( + 1 1 ) ( + 1 1 1 ) ) ) }, 149 | q{3}, 150 | ], 151 | [ q{ ( setq asdf 1234 ) ( print asdf ) }, 152 | q{1234}, 153 | ], 154 | [ q{ ( print ( quote ( + 1 1 ) ) ) }, 155 | q{(+ . (1 . (1 . NIL)))}, 156 | ], 157 | [ q{ ( print ( quote '1 ) ) }, 158 | q{(QUOTE . (1 . NIL))}, 159 | ], 160 | [ q{ ( print ( rplaca ( cons 1 2 ) 3 ) ) }, 161 | q{(3 . 2)}, 162 | ], 163 | [ q{ ( print ( rplacd ( cons 1 2 ) 3 ) ) }, 164 | q{(1 . 3)}, 165 | ], 166 | [ q{ ( setq asdf 1234 ) ( print asdf ) }, 167 | q{1234}, 168 | ], 169 | [ q{ ( setq asdf 1234 ) ( print ( type-of asdf ) ) }, 170 | q{INTEGER}, 171 | ], 172 | [ q{ ( setq asdf 1234 ) ( print ( type-of 'asdf ) ) }, 173 | q{SYMBOL}, 174 | ], 175 | [ q{ ( print ( type-of ( cons 1 2 ) ) ) }, 176 | q{CONS}, 177 | ], 178 | [ q{ ( print ( type-of '( cons 1 2 ) ) ) }, 179 | q{CONS}, 180 | ], 181 | [ q{ ( print ( type-of T ) ) }, 182 | q{BOOLEAN}, 183 | q{type-of T}, 184 | todo => q{sbcl says T is a BOOLEAN} 185 | ], 186 | [ q{ ( print ( type-of NIL ) ) }, 187 | q{NULL}, 188 | q{type-of NIL}, 189 | todo => q{sbcl says NIL is a NULL} 190 | ], 191 | [ q{ ( print (values 3 4 5 ) ) }, 192 | q{3}, 193 | q{values}, 194 | todo => 'values is not evaluated', 195 | ], 196 | ); 197 | 198 | Test::More::plan( tests => scalar @test_cases ); 199 | 200 | foreach ( @test_cases ) 201 | { 202 | my ( $code, $out, $desc, @other ) = @{ $_ }; 203 | 204 | $desc ||= substr( $code, 0, 32 ); 205 | language_output_is( 'Lisp', $code, $out . "\n", $desc, @other ); 206 | } 207 | -------------------------------------------------------------------------------- /t/function.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/function.t - tests the function 'function' 6 | 7 | =head1 DESCRIPTION 8 | 9 | Needed for 'defun'. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | my @test_cases_without_exit_code = ( 27 | [ q{ ( print (apply ( function +) ( list 1 2)) ) }, 28 | q{3}, 29 | q{apply of builtin function}, 30 | ], 31 | [ q{ ( print (funcall ( function +) 1 2) ) }, 32 | q{3}, 33 | q{funcall of builtin function}, 34 | todo => 'no FUNCALL yet' 35 | ], 36 | [ q{ ( setq my_function '+) ( print (apply my_function ( list 1 2)) ) }, 37 | q{3}, 38 | q{apply of setq'd builtin function}, 39 | ], 40 | [ q{ ( setq my_function '+) ( print (funcall my_function 1 2) ) }, 41 | q{3}, 42 | q{funcall of setq'd builtin function}, 43 | todo => 'no FUNCALL yet' 44 | ], 45 | [ q{ ( print ( function (lambda () ( + 1 5 ) ) )) 46 | }, 47 | q{#}, 48 | q{stringification of a function with 0 params }, 49 | ], 50 | [ q{ ( print ( funcall ( function (lambda () ( + 1 5 ) ) ) ) ) 51 | }, 52 | q{6}, 53 | q{funcall a function with 0 params }, 54 | todo => 'funcall does not work yet' 55 | ], 56 | [ q{ ( print ( apply ( function (lambda () ( + 1 5 ) ) ) () ) ) 57 | }, 58 | q{6}, 59 | q{apply a function with 0 params }, 60 | ], 61 | [ q{ ( print ( function (lambda ( a b ) ( + a b ) ) )) 62 | }, 63 | q{#}, 64 | q{stringification of a function with two params }, 65 | ], 66 | [ q{ ( print ( funcall ( function (lambda (a b) ( + a b ) ) ) 2 40 ) ) 67 | }, 68 | q{42}, 69 | q{funcall a function with 2 params }, 70 | todo => 'funcall does not work yet' 71 | ], 72 | [ q{ ( print ( apply ( function (lambda (a b) ( + a b ) ) ) ( list 2 40 ) ) ) 73 | }, 74 | q{42}, 75 | q{apply a function with 2 params }, 76 | todo => 'apply does not work yet' 77 | ], 78 | ); 79 | 80 | my @test_cases_with_exit_code = ( 81 | ); 82 | 83 | Test::More::plan( tests => scalar @test_cases_without_exit_code 84 | + scalar @test_cases_with_exit_code ); 85 | 86 | foreach ( @test_cases_without_exit_code ) 87 | { 88 | my ( $code, $out, $desc, @other ) = @{ $_ }; 89 | 90 | $desc ||= substr( $code, 0, 32 ); 91 | language_output_is( 'Lisp', $code, $out . "\n", $desc, @other ); 92 | } 93 | 94 | foreach ( @test_cases_with_exit_code ) 95 | { 96 | my ( $code, $regex, $desc, @other ) = @{ $_ }; 97 | 98 | $desc ||= substr( $code, 0, 32 ); 99 | language_error_output_like( 'Lisp', $code, $regex, $desc, @other ); 100 | } 101 | -------------------------------------------------------------------------------- /t/harness: -------------------------------------------------------------------------------- 1 | #! perl 2 | 3 | # $Id$ 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use lib 'lib', '../../lib'; 9 | 10 | use Parrot::Test::Harness language => 'lisp'; 11 | -------------------------------------------------------------------------------- /t/hello.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/hello.t - tests for Parrot Common Lisp 6 | 7 | =head1 DESCRIPTION 8 | 9 | A couple of 'Hello World' tests. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More tests => 1; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', 'hello 1' ); 27 | ( print "Hello, World!" ) 28 | END_CODE 29 | Hello, World! 30 | END_OUT 31 | -------------------------------------------------------------------------------- /t/lexicals.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/lexicals.t - test lexical variables 6 | 7 | =head1 DESCRIPTION 8 | 9 | PDD20 compatibility. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | my @test_cases_without_exit_code = ( 27 | [ q{ ( setq a 42 ) ( print a ) }, 28 | q{42}, 29 | q{not a lexical}, 30 | ], 31 | # infinity lurking here 32 | #[ q{ ( let (( x 2 )) ( print x ) ) 33 | #}, 34 | #qr{has no value}, 35 | #q{no lexicals yet} 36 | #], 37 | ); 38 | 39 | my @test_cases_with_exit_code = ( 40 | ); 41 | 42 | Test::More::plan( tests => scalar @test_cases_without_exit_code 43 | + scalar @test_cases_with_exit_code ); 44 | 45 | foreach ( @test_cases_without_exit_code ) 46 | { 47 | my ( $code, $out, $desc, @other ) = @{ $_ }; 48 | 49 | $desc ||= substr( $code, 0, 32 ); 50 | language_output_is( 'Lisp', $code, $out . "\n", $desc, @other ); 51 | } 52 | 53 | foreach ( @test_cases_with_exit_code ) 54 | { 55 | my ( $code, $regex, $desc, @other ) = @{ $_ }; 56 | 57 | $desc ||= substr( $code, 0, 32 ); 58 | language_error_output_like( 'Lisp', $code, $regex, $desc, @other ); 59 | } 60 | -------------------------------------------------------------------------------- /t/read.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/read.t - test reader macros 6 | 7 | =head1 DESCRIPTION 8 | 9 | Reader macros and their error reporting. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More; 22 | 23 | # Parrot modules 24 | use Parrot::Test tests => 7; 25 | 26 | language_error_output_like( 27 | 'Lisp', 28 | " ( \n", 29 | qr/EOF on input stream reached\./, 30 | '_left_paren_macro() with missing right parenthesis' 31 | ); 32 | 33 | language_error_output_like( 34 | 'Lisp', 35 | " ) something else \n", 36 | qr/An object cannot start with/, 37 | '_right_paren_macro() without a left paren' 38 | ); 39 | 40 | language_output_is( 41 | 'Lisp', 42 | "(print '( + 2 3 ))", 43 | "(+ . (2 . (3 . NIL)))\n", 44 | '_single_quote_macro' 45 | ); 46 | 47 | language_output_is( 48 | 'Lisp', 49 | "(print ; Servus \n 1 \n ); comment till end of file", 50 | "1\n", 51 | '_semicolon_macro' 52 | ); 53 | 54 | language_error_output_like( 55 | 'Lisp', 56 | ' " something else \n', 57 | qr/EOF on input stream reached\./, 58 | '_double_quote_macro(), no closing double quote' 59 | ); 60 | 61 | language_error_output_like( 62 | 'Lisp', 63 | ' ` something else after backquote', 64 | qr/The backquote macro has not yet been implemented\./, 65 | '_backquote_macro(), not yet implemented' 66 | ); 67 | 68 | language_error_output_like( 69 | 'Lisp', 70 | ' , something else after comma', 71 | qr/Comma is illegal outside of backquote\./, 72 | '_comma_macro(), illegal almost everywhere' 73 | ); 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /t/system.t: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | lisp/t/system.t - tests functions in SYSTEM 6 | 7 | =head1 DESCRIPTION 8 | 9 | Implementations specific functions. 10 | 11 | =cut 12 | 13 | # pragmata 14 | use strict; 15 | use warnings; 16 | 17 | use FindBin; 18 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib"; 19 | 20 | # core Perl modules 21 | use Test::More; 22 | 23 | # Parrot modules 24 | use Parrot::Test; 25 | 26 | my @test_cases_without_exit_code = ( 27 | [ q{ ( print (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "name")) 28 | }, 29 | q{*GENSYM-COUNTER*}, 30 | q{get-object-attribute name}, 31 | ], 32 | [ q{ ( print ( sys:%package-name (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "package"))) 33 | }, 34 | q{COMMON-LISP}, 35 | q{get-object-attribute package}, 36 | ], 37 | [ q{ ( print (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "value")) 38 | }, 39 | q{1}, 40 | q{get-object-attribute value}, 41 | ], 42 | [ q{ ( sys:%set-object-attribute '*gensym-counter* "LispSymbol" "value" (* 42 2) ) 43 | ( print (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "value")) 44 | }, 45 | q{84}, 46 | q{get-object-attribute value}, 47 | ], 48 | [ q{ (setq english_to_german (sys:%make-hash-table)) 49 | (sys:%set-hash english_to_german "House" "Haus") 50 | ( print (sys:%get-hash english_to_german "House" )) 51 | }, 52 | q{Haus}, 53 | q{make-hash-table set-hash get-hash}, 54 | ], 55 | [ q{ (setq english_to_german (sys:%make-hash-table)) 56 | (setf (sys:%get-hash "House" table) "Haus") 57 | ( print (sys:%get-hash "House" table)) 58 | }, 59 | q{Haus}, 60 | q{hash-table}, 61 | todo => 'setf not implemented yet' 62 | ], 63 | [ q{ ( print (sys:%package-name (sys:%find-package "common-lisp"))) 64 | }, 65 | q{COMMON-LISP}, 66 | q{package-name of 'common-lisp' package}, 67 | ], 68 | [ q{ ( print (sys:%package-name (sys:%find-package "cl"))) 69 | }, 70 | q{COMMON-LISP}, 71 | q{package-name of 'cl' package}, 72 | ], 73 | [ q{ ( print ( null (sys:%find-package "common-lisp"))) 74 | }, 75 | q{NIL}, 76 | q{null of find-package "common-lisp"}, 77 | ], 78 | [ q{ ( print ( null (sys:%find-package "un-common-lisp"))) 79 | }, 80 | q{T}, 81 | q{null of find-package "uncommon-lisp"}, 82 | ], 83 | [ q{( sys:%alias-package (sys:%find-package "common-lisp") "un-common-lisp") 84 | ( print ( null ( sys:%find-package "un-common-lisp")) ) 85 | }, 86 | q{NIL}, 87 | q{null of find-package "uncommon-lisp" after alias-package}, 88 | ], 89 | [ q{( sys:%alias-package (sys:%find-package "common-lisp") "un-common-lisp") 90 | ( print ( sys:%package-name ( sys:%find-package "un-common-lisp")) ) 91 | }, 92 | q{COMMON-LISP}, 93 | q{package-name of find-package "uncommon-lisp" after alias-package}, 94 | ], 95 | ); 96 | 97 | my @test_cases_with_exit_code = ( 98 | [ q{ ( print SYS:*INSIDE-BACKQUOTE* ) 99 | }, 100 | qr{has no value}, 101 | q{undefined var *INSIDE-BACKQUOTE*}, 102 | ], 103 | [ q{ ( print sys:*inside-backquote-list*) 104 | }, 105 | qr{has no value}, 106 | q{undefined var *INSIDE-BACKQUOTE-LIST*}, 107 | ], 108 | ); 109 | 110 | Test::More::plan( tests => scalar @test_cases_without_exit_code 111 | + scalar @test_cases_with_exit_code ); 112 | 113 | foreach ( @test_cases_without_exit_code ) 114 | { 115 | my ( $code, $out, $desc, @other ) = @{ $_ }; 116 | 117 | $desc ||= substr( $code, 0, 32 ); 118 | language_output_is( 'Lisp', $code, $out . "\n", $desc, @other ); 119 | } 120 | 121 | foreach ( @test_cases_with_exit_code ) 122 | { 123 | my ( $code, $regex, $desc, @other ) = @{ $_ }; 124 | 125 | $desc ||= substr( $code, 0, 32 ); 126 | language_error_output_like( 'Lisp', $code, $regex, $desc, @other ); 127 | } 128 | -------------------------------------------------------------------------------- /types.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | types.pir - Lisp data types 6 | 7 | =head1 subs 8 | 9 | =cut 10 | 11 | =head2 _init_types 12 | 13 | Set up the types. 14 | 15 | =cut 16 | 17 | .sub _init_types :init 18 | 19 | .local pmc class 20 | 21 | class = subclass "FixedPMCArray", "LispCons" 22 | 23 | class = subclass "Float", "LispFloat" 24 | 25 | class = newclass "LispFunction" 26 | addattribute class, "documentation" 27 | addattribute class, "args" 28 | addattribute class, "body" 29 | addattribute class, "name" 30 | addattribute class, "scope" 31 | 32 | class = subclass "LispFunction", "LispMacro" 33 | 34 | class = subclass "LispFunction", "LispSpecialForm" 35 | 36 | class = subclass "Hash", "LispHash" 37 | 38 | class = subclass "Integer", "LispInteger" 39 | 40 | class = newclass "LispPackage" 41 | addattribute class, "external" 42 | addattribute class, "internal" 43 | addattribute class, "name" 44 | 45 | class = subclass "Rational", "LispRational" 46 | 47 | class = newclass "LispReadtable" 48 | addattribute class, "table" 49 | addattribute class, "case" 50 | 51 | class = newclass "LispStream" 52 | addattribute class, "stream" 53 | 54 | class = subclass "String", "LispString" 55 | 56 | class = newclass "LispSymbol" 57 | addattribute class, "documentation" 58 | addattribute class, "function" 59 | addattribute class, "name" 60 | addattribute class, "package" 61 | addattribute class, "special" 62 | addattribute class, "value" 63 | 64 | .return () 65 | .end 66 | 67 | .namespace ["LispCons"] 68 | 69 | .sub __init :method 70 | self = 2 # a cons cell has two fields, car and cdr 71 | .end 72 | 73 | .sub __get_string :method 74 | 75 | .local pmc retv 76 | retv = new 'String' 77 | retv = "(" 78 | 79 | .local string car 80 | car = self[0] 81 | concat retv, retv, car 82 | 83 | concat retv, retv, " . " 84 | 85 | .local string cdr 86 | cdr = self[1] 87 | concat retv, retv, cdr 88 | 89 | concat retv, retv, ")" 90 | 91 | .return(retv) 92 | .end 93 | 94 | .namespace ["LispFunction"] 95 | 96 | .sub _get_args :method 97 | .local pmc retv 98 | retv = getattribute self, "args" 99 | 100 | .return(retv) 101 | .end 102 | 103 | .sub _set_args :method 104 | .param pmc args 105 | 106 | setattribute self, "args", args 107 | 108 | .return(args) 109 | .end 110 | 111 | .sub _get_body :method 112 | .local pmc retv 113 | retv = getattribute self, "body" 114 | 115 | .return(retv) 116 | .end 117 | 118 | .sub _set_body :method 119 | .param pmc body 120 | 121 | setattribute self, "body", body 122 | 123 | .return(body) 124 | .end 125 | 126 | .sub _get_name :method 127 | .local pmc retv 128 | retv = getattribute self, "name" 129 | 130 | .return(retv) 131 | .end 132 | 133 | .sub _set_name :method 134 | .param pmc name 135 | 136 | setattribute self, "name", name 137 | 138 | .return(name) 139 | .end 140 | 141 | .sub _get_scope :method 142 | .local pmc retv 143 | 144 | retv = getattribute self, "scope" 145 | 146 | .return(retv) 147 | .end 148 | 149 | .sub _set_scope :method 150 | .param pmc scope 151 | 152 | setattribute self, "scope", scope 153 | 154 | .return(scope) 155 | .end 156 | 157 | .sub __get_string :method 158 | .local pmc retv 159 | .local pmc tmps 160 | 161 | .local pmc name 162 | name = self.'_get_name'() 163 | 164 | .local int test 165 | defined test, name 166 | if test goto NAMED_FUNCTION 167 | 168 | name = new 'String' 169 | name = "ANONYMOUS" 170 | 171 | NAMED_FUNCTION: 172 | retv = new 'String' 173 | retv = "# 543 | table[63] = CONSTITUENT_CHAR # ? 544 | table[64] = CONSTITUENT_CHAR # @ 545 | table[65] = CONSTITUENT_CHAR # A 546 | table[66] = CONSTITUENT_CHAR # B 547 | table[67] = CONSTITUENT_CHAR # C 548 | table[68] = CONSTITUENT_CHAR # D 549 | table[69] = CONSTITUENT_CHAR # E 550 | table[70] = CONSTITUENT_CHAR # F 551 | table[71] = CONSTITUENT_CHAR # G 552 | table[72] = CONSTITUENT_CHAR # H 553 | table[73] = CONSTITUENT_CHAR # I 554 | table[74] = CONSTITUENT_CHAR # J 555 | table[75] = CONSTITUENT_CHAR # K 556 | table[76] = CONSTITUENT_CHAR # L 557 | table[77] = CONSTITUENT_CHAR # M 558 | table[78] = CONSTITUENT_CHAR # N 559 | table[79] = CONSTITUENT_CHAR # O 560 | table[80] = CONSTITUENT_CHAR # P 561 | table[81] = CONSTITUENT_CHAR # Q 562 | table[82] = CONSTITUENT_CHAR # R 563 | table[83] = CONSTITUENT_CHAR # S 564 | table[84] = CONSTITUENT_CHAR # T 565 | table[85] = CONSTITUENT_CHAR # U 566 | table[86] = CONSTITUENT_CHAR # V 567 | table[87] = CONSTITUENT_CHAR # W 568 | table[88] = CONSTITUENT_CHAR # X 569 | table[89] = CONSTITUENT_CHAR # Y 570 | table[90] = CONSTITUENT_CHAR # Z 571 | table[91] = CONSTITUENT_CHAR # [ 572 | table[92] = SESCAPE_CHAR # \ 573 | table[93] = CONSTITUENT_CHAR # ] 574 | table[94] = CONSTITUENT_CHAR # ^ 575 | table[95] = CONSTITUENT_CHAR # _ 576 | table[96] = TERM_MACRO_CHAR # ` 577 | table[97] = CONSTITUENT_CHAR # a 578 | table[98] = CONSTITUENT_CHAR # b 579 | table[99] = CONSTITUENT_CHAR # c 580 | table[100] = CONSTITUENT_CHAR # d 581 | table[101] = CONSTITUENT_CHAR # e 582 | table[102] = CONSTITUENT_CHAR # f 583 | table[103] = CONSTITUENT_CHAR # g 584 | table[104] = CONSTITUENT_CHAR # h 585 | table[105] = CONSTITUENT_CHAR # i 586 | table[106] = CONSTITUENT_CHAR # j 587 | table[107] = CONSTITUENT_CHAR # k 588 | table[108] = CONSTITUENT_CHAR # l 589 | table[109] = CONSTITUENT_CHAR # m 590 | table[110] = CONSTITUENT_CHAR # n 591 | table[111] = CONSTITUENT_CHAR # o 592 | table[112] = CONSTITUENT_CHAR # p 593 | table[113] = CONSTITUENT_CHAR # q 594 | table[114] = CONSTITUENT_CHAR # r 595 | table[115] = CONSTITUENT_CHAR # s 596 | table[116] = CONSTITUENT_CHAR # t 597 | table[117] = CONSTITUENT_CHAR # u 598 | table[118] = CONSTITUENT_CHAR # v 599 | table[119] = CONSTITUENT_CHAR # w 600 | table[120] = CONSTITUENT_CHAR # x 601 | table[121] = CONSTITUENT_CHAR # y 602 | table[122] = CONSTITUENT_CHAR # z 603 | table[123] = CONSTITUENT_CHAR # { 604 | table[124] = MESCAPE_CHAR # | 605 | table[125] = CONSTITUENT_CHAR # } 606 | table[126] = CONSTITUENT_CHAR # ~ 607 | table[127] = CONSTITUENT_CHAR # Rubout 608 | 609 | case = new 'Boolean' 610 | case = 0 611 | 612 | setattribute self, "table", table 613 | setattribute self, "case", case 614 | .end 615 | 616 | .sub __get_string :method 617 | .local pmc name 618 | .local pmc tmps 619 | .local pmc retv 620 | 621 | retv = new 'String' 622 | retv = "#" 623 | 624 | .return(retv) 625 | .end 626 | 627 | .namespace ["LispStream"] 628 | 629 | .sub _get_io :method 630 | .local pmc retv 631 | retv = getattribute self, "stream" 632 | 633 | .return(retv) 634 | .end 635 | 636 | .sub _set_io :method 637 | .param pmc io 638 | 639 | setattribute self, "stream", io 640 | 641 | .return(io) 642 | .end 643 | 644 | .sub __get_string :method 645 | .local pmc name 646 | name = new 'String' 647 | name = "#" 648 | 649 | .return(name) 650 | .end 651 | 652 | .namespace ["LispSymbol"] 653 | 654 | .sub _get_documentation :method 655 | .local pmc retv 656 | retv = getattribute self, "documentation" 657 | 658 | .return(retv) 659 | .end 660 | 661 | .sub _set_documentation :method 662 | .param pmc docs 663 | 664 | setattribute self, 'documentation', docs 665 | 666 | .return(docs) 667 | .end 668 | 669 | .sub _get_function :method 670 | .local pmc retv 671 | retv = getattribute self, "function" 672 | 673 | .return(retv) 674 | .end 675 | 676 | .sub _set_function :method 677 | .param pmc function 678 | setattribute self, 'function', function 679 | 680 | .return(function) 681 | .end 682 | 683 | .sub _get_name :method 684 | .local pmc retv 685 | retv = getattribute self, 'name' 686 | 687 | .return(retv) 688 | .end 689 | 690 | .sub _set_name :method 691 | .param pmc name 692 | 693 | setattribute self, "name", name 694 | 695 | .return(name) 696 | .end 697 | 698 | .sub _get_name_as_string :method 699 | .local pmc name 700 | name = getattribute self, "name" 701 | 702 | .local string retv 703 | retv = name 704 | 705 | .return(retv) 706 | .end 707 | 708 | .sub _get_package :method 709 | .local pmc retv 710 | retv = getattribute self, "package" 711 | 712 | .return(retv) 713 | .end 714 | 715 | .sub _set_package :method 716 | .param pmc package 717 | setattribute self, "package", package 718 | 719 | .return(package) 720 | .end 721 | 722 | .sub _get_special :method 723 | .local pmc retv 724 | retv = getattribute self, "special" 725 | 726 | .return(retv) 727 | .end 728 | 729 | .sub _set_special :method 730 | .param pmc special 731 | setattribute self, "special", special 732 | 733 | .return(special) 734 | .end 735 | 736 | .sub _get_value :method 737 | .local pmc retv 738 | retv = getattribute self, "value" 739 | 740 | .return(retv) 741 | .end 742 | 743 | .sub _set_value :method 744 | .param pmc value 745 | 746 | setattribute self, "value", value 747 | 748 | .return(value) 749 | .end 750 | 751 | .sub __get_string :method 752 | .local pmc name 753 | name = getattribute self, "name" 754 | 755 | .return(name) 756 | .end 757 | 758 | .sub __get_bool :method 759 | .local pmc retv 760 | retv = getprop "defined", self 761 | 762 | .return(retv) 763 | .end 764 | 765 | .namespace [] 766 | 767 | # Local Variables: 768 | # mode: pir 769 | # fill-column: 100 770 | # End: 771 | # vim: expandtab shiftwidth=4 ft=pir: 772 | -------------------------------------------------------------------------------- /validate.pir: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | =head1 NAME 4 | 5 | validate.pir - lexing 6 | 7 | =cut 8 | 9 | .sub _VALIDATE_TOKEN 10 | .param string token 11 | 12 | .local string pkgname 13 | .local string symname 14 | .local pmc package 15 | .local pmc symbol 16 | .local pmc retv 17 | .local int capture 18 | .local pmc nil 19 | 20 | # VALID_IN_PARROT_0_2_0 flag = _IS_INTEGER(token) 21 | .local pmc is_integer 22 | is_integer = get_global 'is_integer' 23 | capture = is_integer(token) # attempt to parse token as an integer 24 | if capture goto INTEGER 25 | 26 | # VALID_IN_PARROT_0_2_0 flag = _IS_FLOAT(token) 27 | .local pmc is_float 28 | is_float = get_global 'is_float' 29 | capture = is_float(token) # attempt to parse token as a float 30 | if capture goto FLOAT 31 | 32 | goto QUALIFIED_SYMBOL # else interpret it as a symbol 33 | 34 | INTEGER: 35 | .INTEGER(retv,token) # create a LispInteger object 36 | goto DONE 37 | 38 | FLOAT: 39 | .FLOAT(retv,token) # create a ListFloat object 40 | goto DONE 41 | 42 | QUALIFIED_SYMBOL: 43 | # VALID_IN_PARROT_0_2_0 (flag,pkgname,symname) = _IS_QUALIFIED(token) 44 | .local pmc is_qualified, capture 45 | is_qualified = get_global 'is_qualified' 46 | capture = is_qualified(token) 47 | unless capture goto SYMBOL 48 | 49 | pkgname = capture[0] 50 | symname = capture[1] 51 | retv = _LOOKUP_GLOBAL(pkgname, symname) 52 | if_null retv, SYMBOL_NOT_FOUND 53 | goto DONE 54 | 55 | SYMBOL: 56 | symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*PACKAGE*") 57 | if_null symbol, PACKAGE_NOT_FOUND 58 | 59 | package = symbol.'_get_value'() # Get the current package 60 | if_null package, PACKAGE_NOT_FOUND 61 | 62 | pkgname = package.'_get_name_as_string'() 63 | symname = token 64 | 65 | retv = _LOOKUP_GLOBAL(pkgname, symname) 66 | if_null retv, SYMBOL_NOT_FOUND # If not found, intern a new symbol 67 | 68 | goto DONE 69 | 70 | SYMBOL_NOT_FOUND: 71 | null nil # Intern a new global symbol 72 | retv = _GLOBAL_SYMBOL(pkgname, symname, nil, nil) 73 | 74 | goto DONE 75 | 76 | PACKAGE_NOT_FOUND: 77 | .ERROR_0("internal-error", "the *PACKAGE* symbol could not be located") 78 | goto DONE 79 | 80 | DONE: 81 | .return(retv) 82 | .end 83 | 84 | # VALID_IN_PARROT_0_2_0 .sub _IS_INTEGER 85 | # VALID_IN_PARROT_0_2_0 .param string token 86 | # VALID_IN_PARROT_0_2_0 87 | # VALID_IN_PARROT_0_2_0 .local int retv 88 | # VALID_IN_PARROT_0_2_0 .local int ndig 89 | # VALID_IN_PARROT_0_2_0 .local int idx 90 | # VALID_IN_PARROT_0_2_0 91 | # VALID_IN_PARROT_0_2_0 ndig = 0 92 | # VALID_IN_PARROT_0_2_0 idx = 0 93 | # VALID_IN_PARROT_0_2_0 94 | # VALID_IN_PARROT_0_2_0 SIGNS: 95 | # VALID_IN_PARROT_0_2_0 rx_oneof token, idx, '+-', DIGIT # check for +/- signs (optional) 96 | # VALID_IN_PARROT_0_2_0 goto DIGIT 97 | # VALID_IN_PARROT_0_2_0 98 | # VALID_IN_PARROT_0_2_0 DIGIT: # ensure the rest is all digits 99 | # VALID_IN_PARROT_0_2_0 rx_is_d token, idx, DECIMAL 100 | # VALID_IN_PARROT_0_2_0 ndig = ndig + 1 101 | # VALID_IN_PARROT_0_2_0 goto DIGIT 102 | # VALID_IN_PARROT_0_2_0 103 | # VALID_IN_PARROT_0_2_0 DECIMAL: 104 | # VALID_IN_PARROT_0_2_0 rx_literal token, idx, '.', EOS # Check for an optional decimal point 105 | # VALID_IN_PARROT_0_2_0 goto EOS 106 | # VALID_IN_PARROT_0_2_0 107 | # VALID_IN_PARROT_0_2_0 EOS: # check to see if we're at string end 108 | # VALID_IN_PARROT_0_2_0 rx_zwa_atend token, idx, FAIL 109 | # VALID_IN_PARROT_0_2_0 goto MATCH 110 | # VALID_IN_PARROT_0_2_0 111 | # VALID_IN_PARROT_0_2_0 MATCH: 112 | # VALID_IN_PARROT_0_2_0 if ndig == 0 goto FAIL # ensure we had at least one digit 113 | # VALID_IN_PARROT_0_2_0 retv = 1 114 | # VALID_IN_PARROT_0_2_0 goto DONE 115 | # VALID_IN_PARROT_0_2_0 116 | # VALID_IN_PARROT_0_2_0 FAIL: 117 | # VALID_IN_PARROT_0_2_0 retv = 0 118 | # VALID_IN_PARROT_0_2_0 goto DONE 119 | # VALID_IN_PARROT_0_2_0 120 | # VALID_IN_PARROT_0_2_0 DONE: 121 | # VALID_IN_PARROT_0_2_0 .return(retv) 122 | # VALID_IN_PARROT_0_2_0 .end 123 | # VALID_IN_PARROT_0_2_0 124 | # VALID_IN_PARROT_0_2_0 .sub _IS_FLOAT 125 | # VALID_IN_PARROT_0_2_0 .param string token 126 | # VALID_IN_PARROT_0_2_0 127 | # VALID_IN_PARROT_0_2_0 .local int retv 128 | # VALID_IN_PARROT_0_2_0 .local int idx 129 | # VALID_IN_PARROT_0_2_0 130 | # VALID_IN_PARROT_0_2_0 idx = 0 131 | # VALID_IN_PARROT_0_2_0 132 | # VALID_IN_PARROT_0_2_0 SIGNS: 133 | # VALID_IN_PARROT_0_2_0 rx_oneof token, idx, '+-', PREDIGITS # check for +/- signs (optional) 134 | # VALID_IN_PARROT_0_2_0 goto PREDIGITS 135 | # VALID_IN_PARROT_0_2_0 136 | # VALID_IN_PARROT_0_2_0 PREDIGITS: # check for pre-decimal digits 137 | # VALID_IN_PARROT_0_2_0 rx_is_d token, idx, DECIMAL 138 | # VALID_IN_PARROT_0_2_0 goto PREDIGITS 139 | # VALID_IN_PARROT_0_2_0 140 | # VALID_IN_PARROT_0_2_0 DECIMAL: 141 | # VALID_IN_PARROT_0_2_0 rx_literal token, idx, '.', FAIL # check for a decimal point 142 | # VALID_IN_PARROT_0_2_0 goto POSTDIGIT 143 | # VALID_IN_PARROT_0_2_0 144 | # VALID_IN_PARROT_0_2_0 POSTDIGIT: 145 | # VALID_IN_PARROT_0_2_0 rx_is_d token, idx, FAIL # check for at least one required digit 146 | # VALID_IN_PARROT_0_2_0 goto POSTDIGITS 147 | # VALID_IN_PARROT_0_2_0 148 | # VALID_IN_PARROT_0_2_0 POSTDIGITS: # check for option post-decimal digits 149 | # VALID_IN_PARROT_0_2_0 rx_is_d token, idx, EOS 150 | # VALID_IN_PARROT_0_2_0 goto POSTDIGITS 151 | # VALID_IN_PARROT_0_2_0 152 | # VALID_IN_PARROT_0_2_0 EOS: # check to see if we're at string end 153 | # VALID_IN_PARROT_0_2_0 rx_zwa_atend token, idx, FAIL 154 | # VALID_IN_PARROT_0_2_0 goto MATCH 155 | # VALID_IN_PARROT_0_2_0 156 | # VALID_IN_PARROT_0_2_0 MATCH: 157 | # VALID_IN_PARROT_0_2_0 retv = 1 158 | # VALID_IN_PARROT_0_2_0 goto DONE 159 | # VALID_IN_PARROT_0_2_0 160 | # VALID_IN_PARROT_0_2_0 FAIL: 161 | # VALID_IN_PARROT_0_2_0 retv = 0 162 | # VALID_IN_PARROT_0_2_0 goto DONE 163 | # VALID_IN_PARROT_0_2_0 164 | # VALID_IN_PARROT_0_2_0 DONE: 165 | # VALID_IN_PARROT_0_2_0 .return(retv) 166 | # VALID_IN_PARROT_0_2_0 .end 167 | # VALID_IN_PARROT_0_2_0 168 | # VALID_IN_PARROT_0_2_0 .sub _IS_QUALIFIED 169 | # VALID_IN_PARROT_0_2_0 .param string token 170 | # VALID_IN_PARROT_0_2_0 171 | # VALID_IN_PARROT_0_2_0 .local string package 172 | # VALID_IN_PARROT_0_2_0 .local string symbol 173 | # VALID_IN_PARROT_0_2_0 .local string vchar 174 | # VALID_IN_PARROT_0_2_0 .local int retv 175 | # VALID_IN_PARROT_0_2_0 .local int idx1 176 | # VALID_IN_PARROT_0_2_0 .local int idx2 177 | # VALID_IN_PARROT_0_2_0 .local int idx3 178 | # VALID_IN_PARROT_0_2_0 .local int type 179 | # VALID_IN_PARROT_0_2_0 180 | # VALID_IN_PARROT_0_2_0 vchar = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$%&*<=>?@^_~-./+" 181 | # VALID_IN_PARROT_0_2_0 idx1 = 0 182 | # VALID_IN_PARROT_0_2_0 183 | # VALID_IN_PARROT_0_2_0 PACKAGE: 184 | # VALID_IN_PARROT_0_2_0 rx_oneof token, idx1, vchar, COLON 185 | # VALID_IN_PARROT_0_2_0 goto PACKAGE 186 | # VALID_IN_PARROT_0_2_0 187 | # VALID_IN_PARROT_0_2_0 COLON: 188 | # VALID_IN_PARROT_0_2_0 idx2 = idx1 # Index of last valid symbol character 189 | # VALID_IN_PARROT_0_2_0 190 | # VALID_IN_PARROT_0_2_0 rx_literal token, idx1, ':', FAIL # If we don't have this -> not qualified 191 | # VALID_IN_PARROT_0_2_0 192 | # VALID_IN_PARROT_0_2_0 idx3 = idx1 # Start of symbol character 193 | # VALID_IN_PARROT_0_2_0 type = 0 # External symbol 194 | # VALID_IN_PARROT_0_2_0 195 | # VALID_IN_PARROT_0_2_0 rx_literal token, idx1, ':', SYMBOL # If we don't have this -> not external 196 | # VALID_IN_PARROT_0_2_0 197 | # VALID_IN_PARROT_0_2_0 idx3 = idx1 # Start of symbol character 198 | # VALID_IN_PARROT_0_2_0 type = 1 # Internal symbol 199 | # VALID_IN_PARROT_0_2_0 200 | # VALID_IN_PARROT_0_2_0 goto SYMBOL 201 | # VALID_IN_PARROT_0_2_0 202 | # VALID_IN_PARROT_0_2_0 SYMBOL: 203 | # VALID_IN_PARROT_0_2_0 rx_oneof token, idx1, vchar, EOS 204 | # VALID_IN_PARROT_0_2_0 goto SYMBOL 205 | # VALID_IN_PARROT_0_2_0 206 | # VALID_IN_PARROT_0_2_0 EOS: 207 | # VALID_IN_PARROT_0_2_0 rx_zwa_atend token, idx1, FAIL # check to see if we're at string end 208 | # VALID_IN_PARROT_0_2_0 goto MATCH 209 | # VALID_IN_PARROT_0_2_0 210 | # VALID_IN_PARROT_0_2_0 KEYWORD: 211 | # VALID_IN_PARROT_0_2_0 package = "KEYWORD" 212 | # VALID_IN_PARROT_0_2_0 goto KEYWORD_RETURN 213 | # VALID_IN_PARROT_0_2_0 214 | # VALID_IN_PARROT_0_2_0 MATCH: 215 | # VALID_IN_PARROT_0_2_0 idx3 = idx3 216 | # VALID_IN_PARROT_0_2_0 217 | # VALID_IN_PARROT_0_2_0 KEYWORD_CHECK1: 218 | # VALID_IN_PARROT_0_2_0 if idx2 != 0 goto NOT_KEYWORD 219 | # VALID_IN_PARROT_0_2_0 if idx3 <= 2 goto KEYWORD 220 | # VALID_IN_PARROT_0_2_0 goto NOT_KEYWORD 221 | # VALID_IN_PARROT_0_2_0 222 | # VALID_IN_PARROT_0_2_0 NOT_KEYWORD: 223 | # VALID_IN_PARROT_0_2_0 substr package, token, 0, idx2 224 | # VALID_IN_PARROT_0_2_0 225 | # VALID_IN_PARROT_0_2_0 KEYWORD_RETURN: 226 | # VALID_IN_PARROT_0_2_0 substr symbol, token, idx3, idx1 227 | # VALID_IN_PARROT_0_2_0 228 | # VALID_IN_PARROT_0_2_0 retv = 1 229 | # VALID_IN_PARROT_0_2_0 goto DONE 230 | # VALID_IN_PARROT_0_2_0 231 | # VALID_IN_PARROT_0_2_0 FAIL: 232 | # VALID_IN_PARROT_0_2_0 package = "" 233 | # VALID_IN_PARROT_0_2_0 symbol = "" 234 | # VALID_IN_PARROT_0_2_0 type = 0 235 | # VALID_IN_PARROT_0_2_0 retv = 0 236 | # VALID_IN_PARROT_0_2_0 goto DONE 237 | # VALID_IN_PARROT_0_2_0 238 | # VALID_IN_PARROT_0_2_0 DONE: 239 | # VALID_IN_PARROT_0_2_0 .return(retv,package,symbol,type) 240 | # VALID_IN_PARROT_0_2_0 .end 241 | 242 | # Local Variables: 243 | # mode: pir 244 | # fill-column: 100 245 | # End: 246 | # vim: expandtab shiftwidth=4 ft=pir: 247 | --------------------------------------------------------------------------------