├── .gitignore ├── LICENSE ├── MAINTAINER ├── forth.pir ├── forth ├── forth.pir ├── library │ ├── tokenstream.pir │ ├── variablestack.pir │ └── virtualstack.pir └── words.pir ├── ports └── plumage │ └── forth.json ├── setup.pir ├── t ├── comparison.t ├── conditionals.t ├── loop.t ├── math.t ├── new_words.t ├── output.t ├── stack.t └── variables.t └── test.pir /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.c 3 | *.o 4 | *.obj 5 | *.pbc 6 | *.exe 7 | *.iss 8 | 9 | forth 10 | installable_forth -------------------------------------------------------------------------------- /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: Matt Diephouse 4 | E: matt at diephouse dot com 5 | -------------------------------------------------------------------------------- /forth.pir: -------------------------------------------------------------------------------- 1 | 2 | .sub 'main' :main 3 | .param pmc args 4 | $S0 = shift args 5 | 6 | load_language 'forth' 7 | 8 | .local int argc 9 | argc = elements args 10 | 11 | if argc == 0 goto prompt 12 | $S0 = shift args 13 | compile_file($S0) 14 | end 15 | 16 | prompt: 17 | prompt() 18 | end 19 | .end 20 | 21 | .sub 'compile_file' 22 | .param string filename 23 | 24 | .local string source 25 | $P0 = new 'FileHandle' 26 | $P0.'open'(filename) 27 | source = $P0.'readall'() 28 | $P0.'close'() 29 | 30 | .local pmc forth 31 | forth = compreg 'forth' 32 | 33 | $P0 = forth(source) 34 | $P0() 35 | .end 36 | 37 | .sub 'prompt' 38 | .local pmc stdin, forth 39 | stdin = getstdin 40 | forth = compreg 'forth' 41 | 42 | print "Parrot Forth\n" 43 | 44 | loop: 45 | print "> " 46 | $S0 = stdin.'readline'() 47 | unless stdin goto end 48 | 49 | push_eh exception 50 | $P0 = forth($S0) 51 | $P0() 52 | pop_eh 53 | 54 | print " ok\n" 55 | goto loop 56 | end: 57 | .return() 58 | 59 | exception: 60 | .get_results ($P0) 61 | $S0 = $P0 62 | print $S0 63 | print "\n" 64 | goto loop 65 | .end 66 | 67 | # Local Variables: 68 | # mode: pir 69 | # fill-column: 100 70 | # End: 71 | # vim: expandtab shiftwidth=4 ft=pir: 72 | -------------------------------------------------------------------------------- /forth/forth.pir: -------------------------------------------------------------------------------- 1 | 2 | .HLL 'Forth' 3 | .namespace [] 4 | 5 | .include 'forth/words.pir' 6 | 7 | .sub '' :load 8 | # load the libraries we depend on 9 | load_bytecode 'tokenstream.pbc' 10 | load_bytecode 'variablestack.pbc' 11 | load_bytecode 'virtualstack.pbc' 12 | load_bytecode 'PGE.pbc' 13 | 14 | # initialize the rstack 15 | .local pmc stack 16 | stack = new 'ResizablePMCArray' 17 | set_hll_global ' stack', stack 18 | 19 | # word dictionary - used for compilation 20 | .local pmc dict 21 | dict = new 'Hash' 22 | set_hll_global ' dict', dict 23 | 24 | .local pmc vars, vstack 25 | vars = new 'Hash' 26 | vstack = new 'VariableStack' 27 | set_hll_global ' variables', vars 28 | set_hll_global ' vstack', vstack 29 | 30 | # register the actual compiler 31 | .local pmc compiler 32 | compiler = get_hll_global ' compile' 33 | compreg 'forth', compiler 34 | .end 35 | 36 | .sub ' compile' 37 | .param string input 38 | 39 | .local pmc code, stream, stack 40 | code = new 'StringBuilder' 41 | stream = new 'TokenStream' 42 | set stream, input 43 | stack = new 'VirtualStack' 44 | 45 | push code, <<'END_PIR' 46 | .sub code :anon 47 | .local pmc stack 48 | stack = get_hll_global " stack" 49 | END_PIR 50 | 51 | .local pmc token 52 | next_token: 53 | unless stream goto done 54 | token = shift stream 55 | 56 | ' dispatch'(code, stream, stack, token) 57 | 58 | goto next_token 59 | 60 | done: 61 | $S0 = stack.'consolidate_to_cstack'() 62 | push code, $S0 63 | push code, <<'END_PIR' 64 | .return(stack) 65 | .end 66 | END_PIR 67 | 68 | $P0 = compreg "PIR" 69 | 70 | # Workaround for -tailcall problem after imcc_compreg_pmc merge 71 | #.tailcall $P0(code) 72 | $P99 = $P0(code) 73 | .return($P99) 74 | .end 75 | 76 | .sub ' dispatch' 77 | .param pmc code 78 | .param pmc stream 79 | .param pmc stack 80 | .param pmc token 81 | 82 | $I0 = isa token, 'Integer' 83 | if $I0 goto numeric 84 | 85 | .local pmc dict, vars 86 | dict = get_hll_global ' dict' 87 | vars = get_hll_global ' variables' 88 | 89 | $S0 = token 90 | $I0 = exists dict[$S0] 91 | if $I0 goto user_word 92 | $I0 = exists vars[$S0] 93 | if $I0 goto user_var 94 | 95 | $P0 = get_hll_global $S0 96 | if null $P0 goto undefined 97 | $P0(code, stream, stack) 98 | .return() 99 | 100 | user_word: 101 | $S1 = stack.'consolidate_to_cstack'() 102 | push code, $S1 103 | $S0 = dict[$S0] 104 | code.'append_format'(<<'END_PIR', $S0) 105 | '%0'(stack) 106 | END_PIR 107 | .return() 108 | 109 | user_var: 110 | $I0 = vars[$S0] 111 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 112 | $S0 = $P0('$P') 113 | code.'append_format'(<<'END_PIR', $S0, $I0) 114 | %0 = new 'Integer' 115 | %0 = %1 116 | END_PIR 117 | push stack, $S0 118 | .return() 119 | 120 | undefined: 121 | $S0 = token 122 | $S0 = "undefined symbol: " . $S0 123 | $P0 = new 'Exception' 124 | $P0['message'] = $S0 125 | throw $P0 126 | 127 | numeric: 128 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 129 | $S0 = $P0('$P') 130 | code.'append_format'(<<'END_PIR', $S0, token) 131 | %0 = new 'Integer' 132 | %0 = %1 133 | END_PIR 134 | push stack, $S0 135 | .return() 136 | .end 137 | 138 | # Local Variables: 139 | # mode: pir 140 | # fill-column: 100 141 | # End: 142 | # vim: expandtab shiftwidth=4 ft=pir: 143 | -------------------------------------------------------------------------------- /forth/library/tokenstream.pir: -------------------------------------------------------------------------------- 1 | 2 | .HLL 'Forth' 3 | .namespace ['TokenStream'] 4 | 5 | .sub init :anon :load 6 | .local pmc class 7 | class = newclass 'TokenStream' 8 | 9 | addattribute class, '$code' 10 | addattribute class, '$pos' 11 | .end 12 | 13 | 14 | .sub 'set_string_native' :vtable :method 15 | .param string str 16 | 17 | .local pmc code 18 | code = new 'String' 19 | code = str 20 | 21 | .local pmc pos 22 | pos = new 'Integer' 23 | pos = 0 24 | 25 | setattribute self, '$code', code 26 | setattribute self, '$pos', pos 27 | .end 28 | 29 | 30 | .sub 'get_bool' :vtable :method 31 | .local string code 32 | .local pmc pos 33 | pos = getattribute self, '$pos' 34 | $P0 = getattribute self, '$code' 35 | code = $P0 36 | 37 | .local int len 38 | len = length code 39 | 40 | .include 'cclass.pasm' 41 | $I0 = pos 42 | $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len 43 | if $I0 == len goto false 44 | 45 | pos = $I0 46 | .return(1) 47 | 48 | false: 49 | .return(0) 50 | .end 51 | 52 | .sub 'shift_pmc' :vtable :method 53 | .local pmc token, pos 54 | .local string code, str 55 | null token 56 | pos = getattribute self, '$pos' 57 | $P0 = getattribute self, '$code' 58 | code = $P0 59 | 60 | .local int len 61 | len = length code 62 | 63 | .include 'cclass.pasm' 64 | $I0 = pos 65 | $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len 66 | $I1 = find_cclass .CCLASS_WHITESPACE, code, $I0, len 67 | if $I0 == len goto return 68 | 69 | $I2 = $I1 - $I0 70 | str = substr code, $I0, $I2 71 | str = downcase str 72 | pos = $I1 73 | 74 | $I0 = length str 75 | $I1 = find_not_cclass .CCLASS_NUMERIC, str, 0, $I0 76 | if $I1 == $I0 goto numeric 77 | 78 | token = new 'String' 79 | token = str 80 | goto return 81 | 82 | numeric: 83 | $I0 = str 84 | token = new 'Integer' 85 | token = $I0 86 | 87 | return: 88 | .return(token) 89 | .end 90 | 91 | 92 | .sub remove_upto :method 93 | .param string str 94 | 95 | .local pmc code, pos 96 | code = getattribute self, '$code' 97 | pos = getattribute self, '$pos' 98 | 99 | $S0 = code 100 | $I0 = pos 101 | inc $I0 # skip a space 102 | $I1 = index $S0, str, $I0 103 | 104 | $I2 = $I1 - $I0 105 | $S1 = substr $S0, $I0, $I2 106 | 107 | inc $I1 108 | pos = $I1 109 | 110 | .return($S1) 111 | .end 112 | 113 | # Local Variables: 114 | # mode: pir 115 | # fill-column: 100 116 | # End: 117 | # vim: expandtab shiftwidth=4 ft=pir: 118 | -------------------------------------------------------------------------------- /forth/library/variablestack.pir: -------------------------------------------------------------------------------- 1 | 2 | .HLL 'Forth' 3 | .namespace ['VariableStack'] 4 | 5 | .sub init :anon :load 6 | .local pmc class 7 | class = newclass 'VariableStack' 8 | 9 | addattribute class, '@stack' 10 | addattribute class, '$next' 11 | .end 12 | 13 | .sub init :vtable :method 14 | .local pmc stack, cell 15 | stack = new 'ResizableIntegerArray' 16 | cell = new 'Integer' 17 | cell = 0 18 | 19 | setattribute self, '@stack', stack 20 | setattribute self, '$next', cell 21 | .end 22 | 23 | .sub get_integer :vtable :method 24 | .local pmc next 25 | next = getattribute self, '$next' 26 | $I0 = next 27 | inc next 28 | .return($I0) 29 | .end 30 | 31 | .sub get_pmc_keyed_int :vtable :method 32 | .param int key 33 | .local pmc stack 34 | stack = getattribute self, '@stack' 35 | 36 | $P0 = stack[key] 37 | .return($P0) 38 | .end 39 | 40 | .sub set_pmc_keyed_int :vtable :method 41 | .param int key 42 | .param pmc value 43 | 44 | .local pmc stack 45 | stack = getattribute self, '@stack' 46 | stack[key] = value 47 | .end 48 | 49 | # Local Variables: 50 | # mode: pir 51 | # fill-column: 100 52 | # End: 53 | # vim: expandtab shiftwidth=4 ft=pir: 54 | -------------------------------------------------------------------------------- /forth/library/virtualstack.pir: -------------------------------------------------------------------------------- 1 | 2 | .HLL 'Forth' 3 | .namespace ['VirtualStack'] 4 | 5 | .sub init :anon :load 6 | .local pmc class 7 | class = newclass 'VirtualStack' 8 | 9 | addattribute class, '@cstack' 10 | .end 11 | 12 | .sub init :vtable :method 13 | .local pmc cstack 14 | cstack = new 'ResizableStringArray' 15 | setattribute self, '@cstack', cstack 16 | .end 17 | 18 | .sub elements :vtable :method 19 | $P0 = getattribute self, '@cstack' 20 | $I0 = elements $P0 21 | .return($I0) 22 | .end 23 | 24 | .sub get_bool :vtable :method 25 | $P0 = getattribute self, '@cstack' 26 | $I0 = elements $P0 27 | .return($I0) 28 | .end 29 | 30 | .sub get_string_keyed_int :vtable :method 31 | .param int key 32 | $P0 = getattribute self, '@cstack' 33 | $S0 = $P0[key] 34 | .return($S0) 35 | .end 36 | 37 | .sub pop_string :vtable :method 38 | .local pmc cstack 39 | cstack = getattribute self, '@cstack' 40 | 41 | $I0 = elements cstack 42 | if $I0 == 0 goto rstack 43 | 44 | $S0 = pop cstack 45 | .return($S0) 46 | 47 | rstack: 48 | .return("pop stack") 49 | .end 50 | 51 | .sub push_string :vtable :method 52 | .param string elem 53 | 54 | .local pmc cstack 55 | cstack = getattribute self, '@cstack' 56 | push cstack, elem 57 | 58 | .return() 59 | .end 60 | 61 | .sub consolidate_to_cstack :method 62 | .local pmc cstack, iter 63 | cstack = getattribute self, '@cstack' 64 | .local string code 65 | code = "" 66 | loop: 67 | unless cstack goto done 68 | $S0 = shift cstack 69 | code .= " push stack, " 70 | code .= $S0 71 | code .= "\n" 72 | goto loop 73 | done: 74 | .return(code) 75 | .end 76 | 77 | # Local Variables: 78 | # mode: pir 79 | # fill-column: 100 80 | # End: 81 | # vim: expandtab shiftwidth=4 ft=pir: 82 | -------------------------------------------------------------------------------- /forth/words.pir: -------------------------------------------------------------------------------- 1 | 2 | .HLL 'Forth' 3 | .namespace [] 4 | 5 | .sub 'variable' 6 | .param pmc code 7 | .param pmc stream 8 | .param pmc stack 9 | 10 | .local pmc token 11 | .local string name 12 | token = shift stream 13 | name = token 14 | 15 | .local pmc variables, vstack 16 | variables = get_hll_global ' variables' 17 | vstack = get_hll_global ' vstack' 18 | 19 | $P0 = new 'Integer' 20 | $I0 = vstack 21 | $P0 = $I0 22 | 23 | variables[name] = $P0 24 | .end 25 | 26 | .sub ':' 27 | .param pmc code 28 | .param pmc stream 29 | .param pmc stack 30 | 31 | .local string name, subname 32 | .local pmc token, dict, nstack, nword 33 | token = shift stream 34 | name = token 35 | dict = get_hll_global ' dict' 36 | nstack = new 'VirtualStack' 37 | nword = new 'StringBuilder' 38 | 39 | subname = ' ' . name 40 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 41 | subname = $P0(subname) 42 | nword.'append_format'(<<'END_PIR', subname) 43 | .sub '%0' 44 | .param pmc stack 45 | END_PIR 46 | 47 | loop: 48 | unless stream goto done 49 | token = shift stream 50 | 51 | $S0 = token 52 | if $S0 == ";" goto done 53 | 54 | ' dispatch'(nword, stream, nstack, token) 55 | goto loop 56 | 57 | done: 58 | $S0 = nstack.'consolidate_to_cstack'() 59 | push nword, $S0 60 | push nword, <<'END_PIR' 61 | .return() 62 | .end 63 | END_PIR 64 | 65 | $P0 = compreg "PIR" 66 | $P0(nword) 67 | 68 | dict[name] = subname 69 | .return() 70 | .end 71 | 72 | # print the last element on the stack (destructive) 73 | .sub '.' 74 | .param pmc code 75 | .param pmc stream 76 | .param pmc stack 77 | 78 | $S0 = pop stack 79 | code.'append_format'(<<'END_PIR', $S0) 80 | $P0 = %0 81 | print $P0 82 | print " " 83 | END_PIR 84 | 85 | .return() 86 | .end 87 | 88 | # print the stack (non-destructive) 89 | .sub '.s' 90 | .param pmc code 91 | .param pmc stream 92 | .param pmc stack 93 | 94 | if stack goto compiletime 95 | 96 | push code, <<'END_PIR' 97 | print "<" 98 | $I0 = elements stack 99 | print $I0 100 | print "> " 101 | 102 | $S0 = join " ", stack 103 | print $S0 104 | print " " 105 | END_PIR 106 | .return() 107 | 108 | compiletime: 109 | $I0 = elements stack 110 | $S0 = $I0 111 | $S1 = join "\nprint ' '\nprint ", stack 112 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 113 | $S2 = $P0('empty') 114 | 115 | code.'append_format'(<<'END_PIR', $S0, $S1, $S2) 116 | print "<" 117 | $I0 = elements stack 118 | $I1 = $I0 + %0 119 | print $I1 120 | print "> " 121 | 122 | unless $I0 goto %2 123 | $S0 = join " ", stack 124 | print $S0 125 | print " " 126 | %2: 127 | print %1 128 | print " " 129 | END_PIR 130 | 131 | .return() 132 | .end 133 | 134 | # clear the stack 135 | .sub '0sp' 136 | .param pmc code 137 | .param pmc stream 138 | .param pmc stack 139 | 140 | loop: 141 | unless stack goto done 142 | $S0 = pop stack 143 | goto loop 144 | done: 145 | 146 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 147 | $S0 = $P0('loop') 148 | $S1 = $P0('done') 149 | code.'append_format'(<<'END_PIR', $S0, $S1) 150 | %0: 151 | unless stack goto %1 152 | $S0 = pop stack 153 | goto %0 154 | %1: 155 | END_PIR 156 | .end 157 | 158 | # print what's on the stream upto the next " 159 | .sub '."' 160 | .param pmc code 161 | .param pmc stream 162 | .param pmc stack 163 | 164 | $S0 = stream.'remove_upto'('"') 165 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'pir_str_escape' 166 | $S0 = $P0($S0) 167 | code.'append_format'(<<'END_PIR', $S0) 168 | print %0 169 | END_PIR 170 | 171 | .return() 172 | .end 173 | 174 | # remove the top element 175 | .sub 'drop' 176 | .param pmc code 177 | .param pmc stream 178 | .param pmc stack 179 | 180 | if stack goto compiletime 181 | 182 | push code, <<'END_PIR' 183 | $P0 = pop stack 184 | END_PIR 185 | .return() 186 | 187 | compiletime: 188 | $P0 = pop stack 189 | .return() 190 | .end 191 | 192 | # copy the item below the top 193 | .sub 'over' 194 | .param pmc code 195 | .param pmc stream 196 | .param pmc stack 197 | 198 | push code, <<'END_PIR' 199 | $P0 = stack[-2] 200 | push stack, $P0 201 | END_PIR 202 | 203 | .return() 204 | .end 205 | 206 | # swap the top 2 elements 207 | .sub 'swap' 208 | .param pmc code 209 | .param pmc stream 210 | .param pmc stack 211 | 212 | push code, <<'END_PIR' 213 | $P0 = pop stack 214 | $P1 = pop stack 215 | push stack, $P0 216 | push stack, $P1 217 | END_PIR 218 | 219 | .return() 220 | .end 221 | 222 | # copy the top element 223 | .sub 'dup' 224 | .param pmc code 225 | .param pmc stream 226 | .param pmc stack 227 | 228 | if stack goto compiletime 229 | 230 | push code, <<'END_PIR' 231 | $P0 = stack[-1] 232 | push stack, $P0 233 | END_PIR 234 | .return() 235 | 236 | compiletime: 237 | $I0 = elements stack 238 | $S0 = stack[-1] 239 | push stack, $S0 240 | .return() 241 | .end 242 | 243 | # move top - 2 to top 244 | .sub 'rot' 245 | .param pmc code 246 | .param pmc stream 247 | .param pmc stack 248 | 249 | .local string a, b, c 250 | c = pop stack 251 | b = pop stack 252 | a = pop stack 253 | 254 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 255 | $S0 = $P0('$P') 256 | $S1 = $P0('$P') 257 | $S2 = $P0('$P') 258 | 259 | code.'append_format'(<<'END_PIR', a, b, c, $S0, $S1, $S2) 260 | %3 = %0 261 | %4 = %1 262 | %5 = %2 263 | END_PIR 264 | push stack, $S1 265 | push stack, $S2 266 | push stack, $S0 267 | 268 | .return() 269 | .end 270 | 271 | .sub 'begin' 272 | .param pmc code 273 | .param pmc stream 274 | .param pmc stack 275 | 276 | $S0 = stack.'consolidate_to_cstack'() 277 | push code, $S0 278 | 279 | .local string label 280 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 281 | label = $P0('loop') 282 | code.'append_format'(<<'END_PIR', label) 283 | %0: 284 | END_PIR 285 | 286 | .local pmc token 287 | next_token: 288 | unless stream goto error 289 | token = shift stream 290 | 291 | $S0 = token 292 | if $S0 == "until" goto until 293 | 294 | ' dispatch'(code, stream, stack, token) 295 | 296 | goto next_token 297 | 298 | until: 299 | $S1 = pop stack 300 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 301 | $S2 = $P0('$P') 302 | $S0 = stack.'consolidate_to_cstack'() 303 | push code, $S0 304 | code.'append_format'(<<'END_PIR', label, $S1, $S2) 305 | %2 = %1 306 | unless %2 goto %0 307 | END_PIR 308 | 309 | .return() 310 | 311 | error: 312 | say "error in BEGIN" 313 | exit 0 314 | .end 315 | 316 | .sub 'if' 317 | .param pmc code 318 | .param pmc stream 319 | .param pmc stack 320 | 321 | $S4 = pop stack 322 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 323 | $S1 = $P0('$P') 324 | $S2 = $P0('else') 325 | $S3 = $P0('done') 326 | 327 | $S0 = stack.'consolidate_to_cstack'() 328 | push code, $S0 329 | code.'append_format'(<<'END_PIR', $S4, $S1, $S2, $S3) 330 | %1 = %0 331 | unless %1 goto %2 332 | END_PIR 333 | 334 | .local pmc token 335 | if_loop: 336 | unless stream goto error 337 | token = shift stream 338 | 339 | $S0 = token 340 | if $S0 == "else" goto else 341 | if $S0 == "then" goto done 342 | ' dispatch'(code, stream, stack, token) 343 | 344 | goto if_loop 345 | 346 | else: 347 | $S0 = stack.'consolidate_to_cstack'() 348 | push code, $S0 349 | code.'append_format'(<<'END_PIR', $S2, $S3) 350 | goto %1 351 | %0: 352 | END_PIR 353 | 354 | else_loop: 355 | unless stream goto error 356 | token = shift stream 357 | 358 | $S0 = token 359 | if $S0 == "then" goto done 360 | ' dispatch'(code, stream, stack, token) 361 | 362 | goto else_loop 363 | 364 | if_done: 365 | code.'append_format'(<<'END_PIR', $S2) 366 | %0: 367 | END_PIR 368 | done: 369 | code.'append_format'(<<'END_PIR', $S3) 370 | %0: 371 | END_PIR 372 | $S0 = stack.'consolidate_to_cstack'() 373 | push code, $S0 374 | .return() 375 | 376 | error: 377 | print "error in IF!" 378 | exit 0 379 | .end 380 | 381 | # print a carriage-return 382 | .sub 'cr' 383 | .param pmc code 384 | .param pmc stream 385 | .param pmc stack 386 | 387 | push code, <<'END_PIR' 388 | print "\n" 389 | END_PIR 390 | 391 | .return() 392 | .end 393 | 394 | # is less than 0? 395 | .sub '0<' 396 | .param pmc code 397 | .param pmc stream 398 | .param pmc stack 399 | 400 | .local string a 401 | a = pop stack 402 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 403 | $S0 = $P0('$P') 404 | 405 | code.'append_format'(<<'END_PIR', a, $S0) 406 | $I0 = %0 407 | $I0 = islt $I0, 0 408 | %1 = new 'Integer' 409 | %1 = $I0 410 | END_PIR 411 | push stack, $S0 412 | 413 | .return() 414 | .end 415 | 416 | # addition 417 | .sub '+' 418 | .param pmc code 419 | .param pmc stream 420 | .param pmc stack 421 | 422 | .local string a, b 423 | b = pop stack 424 | a = pop stack 425 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 426 | $S0 = $P0('$P') 427 | $S1 = $P0('$P') 428 | $S2 = $P0('$P') 429 | 430 | code.'append_format'(<<'END_PIR', b, a, $S0, $S1, $S2) 431 | %2 = %0 432 | %3 = %1 433 | %4 = new 'Float' 434 | %4 = %3 + %2 435 | END_PIR 436 | push stack, $S2 437 | 438 | .return() 439 | .end 440 | 441 | # subtraction 442 | .sub '-' 443 | .param pmc code 444 | .param pmc stream 445 | .param pmc stack 446 | 447 | .local string a, b 448 | b = pop stack 449 | a = pop stack 450 | $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' 451 | $S0 = $P0('$P') 452 | $S1 = $P0('$P') 453 | $S2 = $P0('$P') 454 | 455 | code.'append_format'(<<'END_PIR', b, a, $S0, $S1, $S2) 456 | %2 = %0 457 | %3 = %1 458 | %4 = new 'Float' 459 | %4 = %3 - %2 460 | END_PIR 461 | push stack, $S2 462 | 463 | .return() 464 | .end 465 | 466 | # Local Variables: 467 | # mode: pir 468 | # fill-column: 100 469 | # End: 470 | # vim: expandtab shiftwidth=4 ft=pir: 471 | -------------------------------------------------------------------------------- /ports/plumage/forth.json: -------------------------------------------------------------------------------- 1 | { 2 | "meta-spec" : { 3 | "version" : 1, 4 | "uri" : "https://trac.parrot.org/parrot/wiki/ModuleEcosystem" 5 | }, 6 | "general" : { 7 | "name" : "forth", 8 | "abstract" : "Forth on Parrot", 9 | "version" : "HEAD", 10 | "license" : { 11 | "type" : "Artistic License 2.0", 12 | "uri" : "http://www.perlfoundation.org/artistic_license_2_0" 13 | }, 14 | "copyright_holder" : "Parrot Foundation", 15 | "generated_by" : "distutils", 16 | "keywords" : ["forth"], 17 | "description" : "Forth on Parrot VM" 18 | }, 19 | "instructions" : { 20 | "fetch" : { 21 | "type" : "repository" 22 | }, 23 | "update" : { 24 | "type" : "parrot_setup" 25 | }, 26 | "build" : { 27 | "type" : "parrot_setup" 28 | }, 29 | "test" : { 30 | "type" : "parrot_setup" 31 | }, 32 | "smoke" : { 33 | "type" : "parrot_setup" 34 | }, 35 | "install" : { 36 | "type" : "parrot_setup" 37 | }, 38 | "uninstall": { 39 | "type" : "parrot_setup" 40 | }, 41 | "clean" : { 42 | "type" : "parrot_setup" 43 | } 44 | }, 45 | "dependency-info" : { 46 | "provides" : ["forth"], 47 | "requires" : { 48 | "fetch" : ["svn"], 49 | "build" : [], 50 | "test" : ["perl5"], 51 | "install" : [], 52 | "runtime" : [] 53 | } 54 | }, 55 | "resources" : { 56 | "repository" : { 57 | "type" : "svn", 58 | "checkout_uri": "https://svn.parrot.org/languages/forth/trunk", 59 | "browser_uri" : "https://trac.parrot.org/languages/browser/forth", 60 | "project_uri" : "https://trac.parrot.org/parrot/wiki/Languages" 61 | } 62 | } 63 | } 64 | -------------------------------------------------------------------------------- /setup.pir: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env parrot 2 | # Copyright (C) 2009, Parrot Foundation. 3 | 4 | =head1 NAME 5 | 6 | setup.pir - Python distutils style 7 | 8 | =head1 DESCRIPTION 9 | 10 | No Configure step, no Makefile generated. 11 | 12 | See . 13 | 14 | =head1 USAGE 15 | 16 | $ parrot setup.pir build 17 | $ parrot setup.pir test 18 | $ sudo parrot setup.pir install 19 | 20 | =cut 21 | 22 | .sub 'main' :main 23 | .param pmc args 24 | $S0 = shift args 25 | load_bytecode 'distutils.pbc' 26 | 27 | $P0 = new 'Hash' 28 | $P0['name'] = 'Forth' 29 | $P0['abstract'] = 'Forth on Parrot' 30 | $P0['description'] = 'Forth on Parrot VM' 31 | $P1 = split ',', 'forth' 32 | $P0['keywords'] = $P1 33 | $P0['license_type'] = 'Artistic License 2.0' 34 | $P0['license_uri'] = 'http://www.perlfoundation.org/artistic_license_2_0' 35 | $P0['copyright_holder'] = 'Parrot Foundation' 36 | $P0['checkout_uri'] = 'https://svn.parrot.org/languages/forth/trunk' 37 | $P0['browser_uri'] = 'https://trac.parrot.org/languages/browser/forth' 38 | $P0['project_uri'] = 'https://trac.parrot.org/parrot/wiki/Languages' 39 | 40 | # build 41 | $P2 = new 'Hash' 42 | $P3 = split "\n", <<'SOURCES' 43 | forth/forth.pir 44 | forth/words.pir 45 | SOURCES 46 | $S0 = pop $P3 47 | $P2['forth/forth.pbc'] = $P3 48 | $P2['forth/library/tokenstream.pbc'] = 'forth/library/tokenstream.pir' 49 | $P2['forth/library/variablestack.pbc'] = 'forth/library/variablestack.pir' 50 | $P2['forth/library/virtualstack.pbc'] = 'forth/library/virtualstack.pir' 51 | $P2['forth.pbc'] = 'forth.pir' 52 | $P0['pbc_pir'] = $P2 53 | 54 | $P4 = new 'Hash' 55 | $P4['parrot-forth'] = 'forth.pbc' 56 | $P0['installable_pbc'] = $P4 57 | 58 | # test 59 | $S0 = get_parrot() 60 | $S0 .= ' test.pir' 61 | $P0['prove_exec'] = $S0 62 | 63 | # install 64 | $P5 = split "\n", <<'LIBS' 65 | forth/forth.pbc 66 | forth/library/tokenstream.pbc 67 | forth/library/variablestack.pbc 68 | forth/library/virtualstack.pbc 69 | LIBS 70 | $S0 = pop $P5 71 | $P0['inst_lang'] = $P5 72 | 73 | # dist 74 | $P0['manifest_includes'] = 'test.pir' 75 | $P0['doc_files'] = 'MAINTAINER' 76 | 77 | .tailcall setup(args :flat, $P0 :flat :named) 78 | .end 79 | 80 | 81 | # Local Variables: 82 | # mode: pir 83 | # fill-column: 100 84 | # End: 85 | # vim: expandtab shiftwidth=4 ft=pir: 86 | -------------------------------------------------------------------------------- /t/comparison.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | 0SP 1 0< 4 | 0 5 | 6 | 0SP 0 0< 7 | 0 8 | 9 | 0SP 0 1 - 0< 10 | 1 11 | -------------------------------------------------------------------------------- /t/conditionals.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | 1 IF ." true" ELSE ." false" THEN 4 | true 5 | 6 | 0 IF ." true" ELSE ." false" THEN 7 | false 8 | 9 | 4 0 IF 1 - ELSE 2 4 + - THEN 10 | -2 11 | -------------------------------------------------------------------------------- /t/loop.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | 5 BEGIN DUP 1 - DUP 0< UNTIL 4 | 5 4 3 2 1 0 -1 5 | -------------------------------------------------------------------------------- /t/math.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | # addition 4 | 3 4 + 5 | 7 6 | 7 | # <1> 7 8 | 3 + 5 + 9 | 15 10 | 11 | # <0> 12 | 5 - 13 | 10 14 | -------------------------------------------------------------------------------- /t/new_words.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | # function to add 2 4 | : add2 2 + ; 15 add2 5 | 17 6 | 7 | # function within a function 8 | : add3 add2 1 + ; add3 9 | 20 10 | 11 | # change definition of add2 and make sure add3 doesn't change 12 | : add2 2 - ; add3 13 | 23 14 | 15 | # make sure parsing happens correctly in new words 16 | : GREET ." Hello, World!" ; GREET 17 | Hello, World! 18 | -------------------------------------------------------------------------------- /t/output.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | # .S 4 | 4 5 .S 5 | <2> 4 5 6 | 7 | # . (make sure it removes the top element too) 8 | . .S 9 | 5 <1> 4 10 | 11 | ." Hello, World!".S 12 | Hello, World!<1> 4 13 | -------------------------------------------------------------------------------- /t/stack.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | 3 | # non-empty stack 4 | 1 2 3 4 5 5 | 1 2 3 4 5 6 | 7 | DROP 8 | 1 2 3 4 9 | 10 | OVER 11 | 1 2 3 4 3 12 | 13 | SWAP 14 | 1 2 3 3 4 15 | 16 | DUP 17 | 1 2 3 3 4 4 18 | 19 | 3 0SP .S 20 | <0> 21 | 22 | 1 2 3 ROT 23 | 2 3 1 24 | -------------------------------------------------------------------------------- /t/variables.t: -------------------------------------------------------------------------------- 1 | #!../../parrot test.pir 2 | -------------------------------------------------------------------------------- /test.pir: -------------------------------------------------------------------------------- 1 | 2 | # this is the test program for the forth implementation targeting parrot. 3 | # this script can be passed the names of any number of test files. each test is 4 | # a series of input/output pairs, with optional comments that start with #s. 5 | # 6 | # the first non-blank, non-comment line is considered the first input. the line 7 | # immediately following that is the first output line. the output can be either 8 | # the stack (where the elements are joined by a space) or the message of a 9 | # thrown exception. 10 | 11 | .loadlib 'io_ops' 12 | 13 | .sub 'main' :main 14 | .param pmc args 15 | $S0 = shift args 16 | 17 | load_language 'forth' 18 | 19 | .local pmc it 20 | it = iter args 21 | next_file: 22 | unless it goto done 23 | $S0 = shift it 24 | test($S0) 25 | goto next_file 26 | done: 27 | end 28 | .end 29 | 30 | # 31 | # test(filename) 32 | # 33 | # Test a particular filename: read it, parse it, compare the input/output. 34 | # 35 | .sub 'test' 36 | .param string filename 37 | 38 | .local pmc file 39 | file = new 'FileHandle' 40 | file.'open'(filename) 41 | 42 | .local string input, expected 43 | .local int num_of_tests 44 | num_of_tests = 0 45 | next_test: 46 | input = next_line(file) 47 | if null input goto done 48 | if input == "" goto next_test 49 | 50 | expected = next_line(file) 51 | if null expected goto missing_output 52 | 53 | inc num_of_tests 54 | is(input, expected, num_of_tests) 55 | goto next_test 56 | 57 | done: 58 | print "1.." 59 | print num_of_tests 60 | print "\n" 61 | file.'close'() 62 | .return() 63 | 64 | missing_output: 65 | print "Missing test output for test #" 66 | inc num_of_tests 67 | print num_of_tests 68 | print "\n" 69 | exit 1 70 | .end 71 | 72 | .sub 'next_line' :anon 73 | .param pmc file 74 | .local string line 75 | next_line: 76 | line = file.'readline'() 77 | if line == '' goto end_of_file 78 | $S0 = substr line, 0, 1 79 | if $S0 == "\n" goto next_line 80 | if $S0 == "\r" goto next_line 81 | if $S0 == "#" goto next_line 82 | line = chomp(line) 83 | .return (line) 84 | end_of_file: 85 | null line 86 | .return (line) 87 | .end 88 | 89 | .sub 'chomp' :anon 90 | .param string str 91 | $I0 = index str, "\r" 92 | if $I0 < 0 goto L1 93 | str = substr str, 0, $I0 94 | L1: 95 | $I1 = index str, "\n" 96 | if $I1 < 0 goto L2 97 | str = substr str, 0, $I1 98 | L2: 99 | .return (str) 100 | .end 101 | 102 | # 103 | # is(forth code, expected output, test number) 104 | # 105 | # An individual test. Execute the forth code and compare one of the following: 106 | # 1) the first line of stdout 107 | # 2) the stack 108 | # 3) the exception message 109 | # 110 | .sub 'is' 111 | .param string input 112 | .param string expected 113 | .param int test_num 114 | 115 | .local pmc forth 116 | forth = compreg 'forth' 117 | 118 | .local pmc interp, stdout 119 | stdout = getstdout 120 | 121 | .local pmc fh 122 | fh = new 'StringHandle' 123 | fh.'open'('dummy', 'wr') 124 | setstdout fh 125 | push_eh exception 126 | $P0 = forth(input) 127 | .local pmc stack 128 | stack = $P0() 129 | pop_eh 130 | setstdout stdout 131 | .local string output 132 | output = fh.'readline'() 133 | if output != "" goto compare 134 | output = join " ", stack 135 | goto compare 136 | 137 | exception: 138 | .local pmc except 139 | .get_results (except) 140 | setstdout stdout 141 | output = except 142 | 143 | compare: 144 | if output == expected goto ok 145 | print "not ok " 146 | print test_num 147 | print "\n" 148 | 149 | print "# Failed test\n" 150 | print "# got: '" 151 | print output 152 | print "'\n" 153 | print "# expected: '" 154 | print expected 155 | print "'\n" 156 | .return() 157 | 158 | ok: 159 | print "ok " 160 | print test_num 161 | print "\n" 162 | .return() 163 | .end 164 | 165 | # Local Variables: 166 | # mode: pir 167 | # fill-column: 100 168 | # End: 169 | # vim: expandtab shiftwidth=4 ft=pir: 170 | --------------------------------------------------------------------------------