[svn:languages] r108 - in forth/trunk: . config forth forth/library ports ports/plumage t
fperrad at svn.parrot.org
fperrad at svn.parrot.org
Mon Dec 28 23:19:21 UTC 2009
Author: fperrad
Date: Mon Dec 28 23:19:19 2009
New Revision: 108
URL: https://trac.parrot.org/languages/changeset/108
Log:
[forth] some updates
Added:
forth/trunk/forth/ (props changed)
forth/trunk/forth/forth.pir
- copied, changed from r107, forth/trunk/forth.pir
forth/trunk/forth/library/ (props changed)
forth/trunk/forth/library/tokenstream.pir
- copied unchanged from r107, forth/trunk/tokenstream.pir
forth/trunk/forth/library/variablestack.pir
- copied unchanged from r107, forth/trunk/variablestack.pir
forth/trunk/forth/library/virtualstack.pir
- copied unchanged from r107, forth/trunk/virtualstack.pir
forth/trunk/forth/words.pir
- copied, changed from r107, forth/trunk/words.pir
forth/trunk/ports/
forth/trunk/ports/plumage/
forth/trunk/ports/plumage/forth.json
forth/trunk/setup.pir
Deleted:
forth/trunk/Configure.pl
forth/trunk/config/
forth/trunk/t/harness
forth/trunk/tokenstream.pir
forth/trunk/variablestack.pir
forth/trunk/virtualstack.pir
forth/trunk/words.pir
Modified:
forth/trunk/ (props changed)
forth/trunk/forth.pir
forth/trunk/t/stack.t
forth/trunk/test.pir
Deleted: forth/trunk/Configure.pl
==============================================================================
--- forth/trunk/Configure.pl Mon Dec 28 23:19:19 2009 (r107)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,66 +0,0 @@
-# Copyright (C) 2009, Parrot Foundation.
-# $Id$
-
-use strict;
-use warnings;
-use 5.008;
-
-# Get a list of parrot-configs to invoke.
-my @parrot_config_exe = (
- 'parrot/parrot_config',
- '../../parrot_config',
- 'parrot_config',
-);
-
-# Get configuration information from parrot_config
-my %config = read_parrot_config(@parrot_config_exe);
-unless (%config) {
- die "Unable to locate parrot_config.";
-}
-
-# Create the Makefile using the information we just got
-create_makefiles(%config);
-
-sub read_parrot_config {
- my @parrot_config_exe = @_;
- my %config = ();
- for my $exe (@parrot_config_exe) {
- no warnings;
- if (open my $PARROT_CONFIG, '-|', "$exe --dump") {
- print "Reading configuration information from $exe\n";
- while (<$PARROT_CONFIG>) {
- $config{$1} = $2 if (/(\w+) => '(.*)'/);
- }
- close $PARROT_CONFIG;
- last if %config;
- }
- }
- %config;
-}
-
-
-# Generate Makefiles from a configuration
-sub create_makefiles {
- my %config = @_;
- my %makefiles = (
- 'config/makefiles/root.in' => 'Makefile',
-# 'config/makefiles/pmc.in' => 'src/pmc/Makefile',
-# 'config/makefiles/ops.in' => 'src/ops/Makefile',
- );
- my $build_tool = $config{libdir} . $config{versiondir}
- . '/tools/dev/gen_makefile.pl';
-
- foreach my $template (keys %makefiles) {
- my $makefile = $makefiles{$template};
- print "Creating $makefile\n";
- system($config{perl}, $build_tool, $template, $makefile);
- }
-}
-
-# Local Variables:
-# mode: cperl
-# cperl-indent-level: 4
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4:
-
Modified: forth/trunk/forth.pir
==============================================================================
--- forth/trunk/forth.pir Mon Dec 21 20:04:39 2009 (r107)
+++ forth/trunk/forth.pir Mon Dec 28 23:19:19 2009 (r108)
@@ -1,61 +1,46 @@
-.HLL 'Forth'
-.namespace []
-
-.include 'languages/forth/words.pir'
+.sub 'main' :main
+ .param pmc args
+ $S0 = shift args
-.sub ' init' :load
- # load the libraries we depend on
- load_bytecode 'languages/forth/tokenstream.pbc'
- load_bytecode 'languages/forth/variablestack.pbc'
- load_bytecode 'languages/forth/virtualstack.pbc'
-
- # initialize the rstack
- .local pmc stack
- stack = new 'ResizablePMCArray'
- set_hll_global ' stack', stack
-
- # word dictionary - used for compilation
- .local pmc dict
- dict = new 'Hash'
- set_hll_global ' dict', dict
-
- .local pmc vars, vstack
- vars = new 'Hash'
- vstack = new 'VariableStack'
- set_hll_global ' variables', vars
- set_hll_global ' vstack', vstack
-
- # register the actual compiler
- .local pmc compiler
- compiler = get_hll_global ' compile'
- compreg 'forth', compiler
-.end
+ load_language 'forth'
-.sub main :main :anon
- .param pmc args
.local int argc
argc = elements args
- ' init'()
if argc == 0 goto prompt
+ $S0 = shift args
+ compile_file($S0)
+ end
-prompt:
- ' prompt'()
+ prompt:
+ prompt()
end
.end
+.sub 'compile_file'
+ .param string filename
+
+ .local string source
+ $P0 = open filename
+ source = $P0.'readall'()
+ close $P0
-.sub ' prompt'
- .local pmc stdin, stdout, forth
+ .local pmc forth
+ forth = compreg 'forth'
+
+ $P0 = forth(source)
+ $P0()
+.end
+
+.sub 'prompt'
+ .local pmc stdin, forth
stdin = getstdin
- stdout = getstdout
forth = compreg 'forth'
- $S0 = pop stdout
print "Parrot Forth\n"
-loop:
+ loop:
print "> "
$S0 = readline stdin
unless stdin goto end
@@ -67,10 +52,10 @@
print " ok\n"
goto loop
-end:
+ end:
.return()
-exception:
+ exception:
.get_results ($P0)
$S0 = $P0
print $S0
@@ -78,101 +63,6 @@
goto loop
.end
-
-.sub ' compile'
- .param string input
-
- .local pmc code, stream, stack
- code = new 'CodeString'
- stream = new 'TokenStream'
- set stream, input
- stack = new 'VirtualStack'
-
- code.'emit'(<<"END_PIR")
-.sub code :anon
- .local pmc stack
- stack = get_hll_global " stack"
-END_PIR
-
- .local pmc token
-next_token:
- unless stream goto done
- token = shift stream
-
- ' dispatch'(code, stream, stack, token)
-
- goto next_token
-
-done:
- $S0 = stack.'consolidate_to_cstack'()
- code .= $S0
- code.'emit'(<<"END_PIR")
- .return(stack)
-.end
-END_PIR
-
- $P0 = compreg "PIR"
- .tailcall $P0(code)
-.end
-
-.sub ' dispatch'
- .param pmc code
- .param pmc stream
- .param pmc stack
- .param pmc token
-
- $I0 = isa token, 'Integer'
- if $I0 goto numeric
-
- .local pmc dict, vars
- dict = get_hll_global ' dict'
- vars = get_hll_global ' variables'
-
- $S0 = token
- $I0 = exists dict[$S0]
- if $I0 goto user_word
- $I0 = exists vars[$S0]
- if $I0 goto user_var
-
- $P0 = get_hll_global $S0
- if null $P0 goto undefined
- $P0(code, stream, stack)
- .return()
-
-user_word:
- $S1 = stack.'consolidate_to_cstack'()
- code .= $S1
- $S0 = dict[$S0]
- code.'emit'(" '%0'(stack)", $S0)
- .return()
-
-user_var:
- $I0 = vars[$S0]
- $S0 = code.'unique'('$P')
- code.'emit'(<<'END_PIR', $S0, $I0)
- %0 = new 'Integer'
- %0 = %1
-END_PIR
- push stack, $S0
- .return()
-
-undefined:
- $S0 = token
- $S0 = "undefined symbol: " . $S0
- $P0 = new 'Exception'
- $P0[0] = $S0
- throw $P0
-
-numeric:
- $S0 = code.'unique'('$P')
- code.'emit'(<<"END_PIR", $S0, token)
- %0 = new 'Integer'
- %0 = %1
-END_PIR
- push stack, $S0
- .return()
-.end
-
# Local Variables:
# mode: pir
# fill-column: 100
Copied and modified: forth/trunk/forth/forth.pir (from r107, forth/trunk/forth.pir)
==============================================================================
--- forth/trunk/forth.pir Mon Dec 21 20:04:39 2009 (r107, copy source)
+++ forth/trunk/forth/forth.pir Mon Dec 28 23:19:19 2009 (r108)
@@ -2,13 +2,13 @@
.HLL 'Forth'
.namespace []
-.include 'languages/forth/words.pir'
+.include 'forth/words.pir'
-.sub ' init' :load
+.sub '' :load
# load the libraries we depend on
- load_bytecode 'languages/forth/tokenstream.pbc'
- load_bytecode 'languages/forth/variablestack.pbc'
- load_bytecode 'languages/forth/virtualstack.pbc'
+ load_bytecode 'tokenstream.pbc'
+ load_bytecode 'variablestack.pbc'
+ load_bytecode 'virtualstack.pbc'
# initialize the rstack
.local pmc stack
@@ -32,53 +32,6 @@
compreg 'forth', compiler
.end
-.sub main :main :anon
- .param pmc args
- .local int argc
- argc = elements args
-
- ' init'()
- if argc == 0 goto prompt
-
-prompt:
- ' prompt'()
- end
-.end
-
-
-.sub ' prompt'
- .local pmc stdin, stdout, forth
- stdin = getstdin
- stdout = getstdout
- forth = compreg 'forth'
-
- $S0 = pop stdout
- print "Parrot Forth\n"
-
-loop:
- print "> "
- $S0 = readline stdin
- unless stdin goto end
-
- push_eh exception
- $P0 = forth($S0)
- $P0()
- pop_eh
-
- print " ok\n"
- goto loop
-end:
- .return()
-
-exception:
- .get_results ($P0)
- $S0 = $P0
- print $S0
- print "\n"
- goto loop
-.end
-
-
.sub ' compile'
.param string input
Copied: forth/trunk/forth/library/tokenstream.pir (from r107, forth/trunk/tokenstream.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/forth/library/tokenstream.pir Mon Dec 28 23:19:19 2009 (r108, copy of r107, forth/trunk/tokenstream.pir)
@@ -0,0 +1,117 @@
+
+.HLL 'Forth'
+.namespace ['TokenStream']
+
+.sub init :anon :load
+ .local pmc class
+ class = newclass 'TokenStream'
+
+ addattribute class, '$code'
+ addattribute class, '$pos'
+.end
+
+
+.sub 'set_string_native' :vtable :method
+ .param string str
+
+ .local pmc code
+ code = new 'String'
+ code = str
+
+ .local pmc pos
+ pos = new 'Integer'
+ pos = 0
+
+ setattribute self, '$code', code
+ setattribute self, '$pos', pos
+.end
+
+
+.sub 'get_bool' :vtable :method
+ .local string code
+ .local pmc pos
+ pos = getattribute self, '$pos'
+ $P0 = getattribute self, '$code'
+ code = $P0
+
+ .local int len
+ len = length code
+
+ .include 'cclass.pasm'
+ $I0 = pos
+ $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len
+ if $I0 == len goto false
+
+ pos = $I0
+ .return(1)
+
+false:
+ .return(0)
+.end
+
+.sub 'shift_pmc' :vtable :method
+ .local pmc token, pos
+ .local string code, str
+ null token
+ pos = getattribute self, '$pos'
+ $P0 = getattribute self, '$code'
+ code = $P0
+
+ .local int len
+ len = length code
+
+ .include 'cclass.pasm'
+ $I0 = pos
+ $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len
+ $I1 = find_cclass .CCLASS_WHITESPACE, code, $I0, len
+ if $I0 == len goto return
+
+ $I2 = $I1 - $I0
+ str = substr code, $I0, $I2
+ str = downcase str
+ pos = $I1
+
+ $I0 = length str
+ $I1 = find_not_cclass .CCLASS_NUMERIC, str, 0, $I0
+ if $I1 == $I0 goto numeric
+
+ token = new 'String'
+ token = str
+ goto return
+
+numeric:
+ $I0 = str
+ token = new 'Integer'
+ token = $I0
+
+return:
+ .return(token)
+.end
+
+
+.sub remove_upto :method
+ .param string str
+
+ .local pmc code, pos
+ code = getattribute self, '$code'
+ pos = getattribute self, '$pos'
+
+ $S0 = code
+ $I0 = pos
+ inc $I0 # skip a space
+ $I1 = index $S0, str, $I0
+
+ $I2 = $I1 - $I0
+ $S1 = substr $S0, $I0, $I2
+
+ inc $I1
+ pos = $I1
+
+ .return($S1)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Copied: forth/trunk/forth/library/variablestack.pir (from r107, forth/trunk/variablestack.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/forth/library/variablestack.pir Mon Dec 28 23:19:19 2009 (r108, copy of r107, forth/trunk/variablestack.pir)
@@ -0,0 +1,53 @@
+
+.HLL 'Forth'
+.namespace ['VariableStack']
+
+.sub init :anon :load
+ .local pmc class
+ class = newclass 'VariableStack'
+
+ addattribute class, '@stack'
+ addattribute class, '$next'
+.end
+
+.sub init :vtable :method
+ .local pmc stack, cell
+ stack = new 'ResizableIntegerArray'
+ cell = new 'Integer'
+ cell = 0
+
+ setattribute self, '@stack', stack
+ setattribute self, '$next', cell
+.end
+
+.sub get_integer :vtable :method
+ .local pmc next
+ next = getattribute self, '$next'
+ $I0 = next
+ inc next
+ .return($I0)
+.end
+
+.sub get_pmc_keyed_int :vtable :method
+ .param int key
+ .local pmc stack
+ stack = getattribute self, '@stack'
+
+ $P0 = stack[key]
+ .return($P0)
+.end
+
+.sub set_pmc_keyed_int :vtable :method
+ .param int key
+ .param pmc value
+
+ .local pmc stack
+ stack = getattribute self, '@stack'
+ stack[key] = value
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Copied: forth/trunk/forth/library/virtualstack.pir (from r107, forth/trunk/virtualstack.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/forth/library/virtualstack.pir Mon Dec 28 23:19:19 2009 (r108, copy of r107, forth/trunk/virtualstack.pir)
@@ -0,0 +1,81 @@
+
+.HLL 'Forth'
+.namespace ['VirtualStack']
+
+.sub init :anon :load
+ .local pmc class
+ class = newclass 'VirtualStack'
+
+ addattribute class, '@cstack'
+.end
+
+.sub init :vtable :method
+ .local pmc cstack
+ cstack = new 'ResizableStringArray'
+ setattribute self, '@cstack', cstack
+.end
+
+.sub elements :vtable :method
+ $P0 = getattribute self, '@cstack'
+ $I0 = elements $P0
+ .return($I0)
+.end
+
+.sub get_bool :vtable :method
+ $P0 = getattribute self, '@cstack'
+ $I0 = elements $P0
+ .return($I0)
+.end
+
+.sub get_string_keyed_int :vtable :method
+ .param int key
+ $P0 = getattribute self, '@cstack'
+ $S0 = $P0[key]
+ .return($S0)
+.end
+
+.sub pop_string :vtable :method
+ .local pmc cstack
+ cstack = getattribute self, '@cstack'
+
+ $I0 = elements cstack
+ if $I0 == 0 goto rstack
+
+ $S0 = pop cstack
+ .return($S0)
+
+rstack:
+ .return("pop stack")
+.end
+
+.sub push_string :vtable :method
+ .param string elem
+
+ .local pmc cstack
+ cstack = getattribute self, '@cstack'
+ push cstack, elem
+
+ .return()
+.end
+
+.sub consolidate_to_cstack :method
+ .local pmc cstack, iter
+ cstack = getattribute self, '@cstack'
+ .local string code
+ code = ""
+loop:
+ unless cstack goto done
+ $S0 = shift cstack
+ code .= " push stack, "
+ code .= $S0
+ code .= "\n"
+ goto loop
+done:
+ .return(code)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Copied and modified: forth/trunk/forth/words.pir (from r107, forth/trunk/words.pir)
==============================================================================
--- forth/trunk/words.pir Mon Dec 21 20:04:39 2009 (r107, copy source)
+++ forth/trunk/forth/words.pir Mon Dec 28 23:19:19 2009 (r108)
@@ -1,5 +1,6 @@
.HLL 'Forth'
+.namespace []
.sub 'variable'
.param pmc code
Added: forth/trunk/ports/plumage/forth.json
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/ports/plumage/forth.json Mon Dec 28 23:19:19 2009 (r108)
@@ -0,0 +1,63 @@
+{
+ "meta-spec" : {
+ "version" : 1,
+ "uri" : "https://trac.parrot.org/parrot/wiki/ModuleEcosystem"
+ },
+ "general" : {
+ "name" : "forth",
+ "abstract" : "Forth on Parrot",
+ "version" : "HEAD",
+ "license" : {
+ "type" : "Artistic License 2.0",
+ "uri" : "http://www.perlfoundation.org/artistic_license_2_0"
+ },
+ "copyright_holder" : "Parrot Foundation",
+ "generated_by" : "distutils",
+ "keywords" : ["forth"],
+ "description" : "Forth on Parrot VM"
+ },
+ "instructions" : {
+ "fetch" : {
+ "type" : "repository"
+ },
+ "update" : {
+ "type" : "parrot_setup"
+ },
+ "build" : {
+ "type" : "parrot_setup"
+ },
+ "test" : {
+ "type" : "parrot_setup"
+ },
+ "smoke" : {
+ "type" : "parrot_setup"
+ },
+ "install" : {
+ "type" : "parrot_setup"
+ },
+ "uninstall": {
+ "type" : "parrot_setup"
+ },
+ "clean" : {
+ "type" : "parrot_setup"
+ }
+ },
+ "dependency-info" : {
+ "provides" : ["forth"],
+ "requires" : {
+ "fetch" : ["svn"],
+ "build" : [],
+ "test" : ["perl5"],
+ "install" : [],
+ "runtime" : []
+ }
+ },
+ "resources" : {
+ "repository" : {
+ "type" : "svn",
+ "checkout_uri": "https://svn.parrot.org/languages/forth/trunk",
+ "browser_uri" : "https://trac.parrot.org/languages/browser/forth",
+ "project_uri" : "https://trac.parrot.org/parrot/wiki/Languages"
+ }
+ }
+}
Added: forth/trunk/setup.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/setup.pir Mon Dec 28 23:19:19 2009 (r108)
@@ -0,0 +1,85 @@
+#!/usr/bin/env parrot
+# Copyright (C) 2009, Parrot Foundation.
+
+=head1 NAME
+
+setup.pir - Python distutils style
+
+=head1 DESCRIPTION
+
+No Configure step, no Makefile generated.
+
+See <runtime/parrot/library/distutils.pir>.
+
+=head1 USAGE
+
+ $ parrot setup.pir build
+ $ parrot setup.pir test
+ $ sudo parrot setup.pir install
+
+=cut
+
+.sub 'main' :main
+ .param pmc args
+ $S0 = shift args
+ load_bytecode 'distutils.pbc'
+
+ $P0 = new 'Hash'
+ $P0['name'] = 'Forth'
+ $P0['abstract'] = 'Forth on Parrot'
+ $P0['description'] = 'Forth on Parrot VM'
+ $P1 = split ',', 'forth'
+ $P0['keywords'] = $P1
+ $P0['license_type'] = 'Artistic License 2.0'
+ $P0['license_uri'] = 'http://www.perlfoundation.org/artistic_license_2_0'
+ $P0['copyright_holder'] = 'Parrot Foundation'
+ $P0['checkout_uri'] = 'https://svn.parrot.org/languages/forth/trunk'
+ $P0['browser_uri'] = 'https://trac.parrot.org/languages/browser/forth'
+ $P0['project_uri'] = 'https://trac.parrot.org/parrot/wiki/Languages'
+
+ # build
+ $P2 = new 'Hash'
+ $P3 = split "\n", <<'SOURCES'
+forth/forth.pir
+forth/words.pir
+SOURCES
+ $S0 = pop $P3
+ $P2['forth/forth.pbc'] = $P3
+ $P2['forth/library/tokenstream.pbc'] = 'forth/library/tokenstream.pir'
+ $P2['forth/library/variablestack.pbc'] = 'forth/library/variablestack.pir'
+ $P2['forth/library/virtualstack.pbc'] = 'forth/library/virtualstack.pir'
+ $P2['forth.pbc'] = 'forth.pir'
+ $P0['pbc_pir'] = $P2
+
+ $P4 = new 'Hash'
+ $P4['parrot-forth'] = 'forth.pbc'
+ $P0['installable_pbc'] = $P4
+
+ # test
+ $S0 = get_parrot()
+ $S0 .= ' test.pir'
+ $P0['prove_exec'] = $S0
+
+ # install
+ $P5 = split "\n", <<'LIBS'
+forth/forth.pbc
+forth/library/tokenstream.pbc
+forth/library/variablestack.pbc
+forth/library/virtualstack.pbc
+LIBS
+ $S0 = pop $P5
+ $P0['inst_lang'] = $P5
+
+ # dist
+ $P0['manifest_includes'] = 'test.pir'
+ $P0['doc_files'] = 'MAINTAINER'
+
+ .tailcall setup(args :flat, $P0 :flat :named)
+.end
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Deleted: forth/trunk/t/harness
==============================================================================
--- forth/trunk/t/harness Mon Dec 28 23:19:19 2009 (r107)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,8 +0,0 @@
-#!/usr/bin/perl
-
-# $Id$
-
-use FindBin;
-use lib qw( . lib ../lib ../../lib ../../lib );
-use Parrot::Test::Harness language => 'forth';
-
Modified: forth/trunk/t/stack.t
==============================================================================
--- forth/trunk/t/stack.t Mon Dec 21 20:04:39 2009 (r107)
+++ forth/trunk/t/stack.t Mon Dec 28 23:19:19 2009 (r108)
@@ -16,7 +16,8 @@
DUP
1 2 3 3 4 4
-3 0SP
+3 0SP .S
+<0>
1 2 3 ROT
2 3 1
Modified: forth/trunk/test.pir
==============================================================================
--- forth/trunk/test.pir Mon Dec 21 20:04:39 2009 (r107)
+++ forth/trunk/test.pir Mon Dec 28 23:19:19 2009 (r108)
@@ -8,22 +8,20 @@
# the stack (where the elements are joined by a space) or the message of a
# thrown exception.
-.sub main :main
+.sub 'main' :main
.param pmc args
- .local int argc
- $P0 = shift args
- argc = elements args
+ $S0 = shift args
- load_bytecode 'languages/forth/forth.pir'
+ load_language 'forth'
.local pmc it
it = iter args
-next_file:
+ next_file:
unless it goto done
$S0 = shift it
test($S0)
goto next_file
-done:
+ done:
end
.end
@@ -32,48 +30,35 @@
#
# Test a particular filename: read it, parse it, compare the input/output.
#
-.sub test
+.sub 'test'
.param string filename
.local pmc file
file = open filename
- .local string line, input, expected
+ .local string input, expected
.local int num_of_tests
num_of_tests = 0
-next_test:
- bsr next_line
- if null line goto done
- if line == "" goto next_test
- input = line
-
- bsr next_line
- if null line goto missing_output
- expected = line
+ next_test:
+ input = next_line(file)
+ if null input goto done
+ if input == "" goto next_test
+
+ expected = next_line(file)
+ if null expected goto missing_output
inc num_of_tests
is(input, expected, num_of_tests)
goto next_test
-next_line:
- line = readline file
- if line == '' goto end_of_file
- $S0 = substr line, 0, 1
- if $S0 == "#" goto next_line
- chopn line, 1
- ret
-end_of_file:
- null line
- ret
-
-done:
+ done:
print "1.."
print num_of_tests
print "\n"
close file
.return()
-missing_output:
+ missing_output:
print "Missing test output for test #"
inc num_of_tests
print num_of_tests
@@ -81,6 +66,36 @@
exit 1
.end
+.sub 'next_line' :anon
+ .param pmc file
+ .local string line
+ next_line:
+ line = readline file
+ if line == '' goto end_of_file
+ $S0 = substr line, 0, 1
+ if $S0 == "\n" goto next_line
+ if $S0 == "\r" goto next_line
+ if $S0 == "#" goto next_line
+ line = chomp(line)
+ .return (line)
+ end_of_file:
+ null line
+ .return (line)
+.end
+
+.sub 'chomp' :anon
+ .param string str
+ $I0 = index str, "\r"
+ if $I0 < 0 goto L1
+ str = substr str, 0, $I0
+ L1:
+ $I1 = index str, "\n"
+ if $I1 < 0 goto L2
+ str = substr str, 0, $I1
+ L2:
+ .return (str)
+.end
+
#
# is(forth code, expected output, test number)
#
@@ -89,7 +104,7 @@
# 2) the stack
# 3) the exception message
#
-.sub is
+.sub 'is'
.param string input
.param string expected
.param int test_num
@@ -97,26 +112,29 @@
.local pmc forth
forth = compreg 'forth'
- .local pmc stack, stdout
+ .local pmc stack, stdout, fh
.local string output
stdout = getstdout
- push stdout, "string"
+ fh = new 'StringHandle'
+ fh.'open'('dummy', 'wr')
+ setstdout fh
push_eh exception
$P0 = forth(input)
stack = $P0()
pop_eh
- output = readline stdout
- $S0 = pop stdout
+ setstdout stdout
+ output = readline fh
if output != "" goto compare
output = join " ", stack
goto compare
-exception:
+ exception:
.local pmc except
.get_results (except)
+ setstdout stdout
output = except
-compare:
+ compare:
if output == expected goto ok
print "not ok "
print test_num
@@ -131,7 +149,7 @@
print "'\n"
.return()
-ok:
+ ok:
print "ok "
print test_num
print "\n"
Deleted: forth/trunk/tokenstream.pir
==============================================================================
--- forth/trunk/tokenstream.pir Mon Dec 28 23:19:19 2009 (r107)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,117 +0,0 @@
-
-.HLL 'Forth'
-.namespace ['TokenStream']
-
-.sub init :anon :load
- .local pmc class
- class = newclass 'TokenStream'
-
- addattribute class, '$code'
- addattribute class, '$pos'
-.end
-
-
-.sub 'set_string_native' :vtable :method
- .param string str
-
- .local pmc code
- code = new 'String'
- code = str
-
- .local pmc pos
- pos = new 'Integer'
- pos = 0
-
- setattribute self, '$code', code
- setattribute self, '$pos', pos
-.end
-
-
-.sub 'get_bool' :vtable :method
- .local string code
- .local pmc pos
- pos = getattribute self, '$pos'
- $P0 = getattribute self, '$code'
- code = $P0
-
- .local int len
- len = length code
-
- .include 'cclass.pasm'
- $I0 = pos
- $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len
- if $I0 == len goto false
-
- pos = $I0
- .return(1)
-
-false:
- .return(0)
-.end
-
-.sub 'shift_pmc' :vtable :method
- .local pmc token, pos
- .local string code, str
- null token
- pos = getattribute self, '$pos'
- $P0 = getattribute self, '$code'
- code = $P0
-
- .local int len
- len = length code
-
- .include 'cclass.pasm'
- $I0 = pos
- $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len
- $I1 = find_cclass .CCLASS_WHITESPACE, code, $I0, len
- if $I0 == len goto return
-
- $I2 = $I1 - $I0
- str = substr code, $I0, $I2
- str = downcase str
- pos = $I1
-
- $I0 = length str
- $I1 = find_not_cclass .CCLASS_NUMERIC, str, 0, $I0
- if $I1 == $I0 goto numeric
-
- token = new 'String'
- token = str
- goto return
-
-numeric:
- $I0 = str
- token = new 'Integer'
- token = $I0
-
-return:
- .return(token)
-.end
-
-
-.sub remove_upto :method
- .param string str
-
- .local pmc code, pos
- code = getattribute self, '$code'
- pos = getattribute self, '$pos'
-
- $S0 = code
- $I0 = pos
- inc $I0 # skip a space
- $I1 = index $S0, str, $I0
-
- $I2 = $I1 - $I0
- $S1 = substr $S0, $I0, $I2
-
- inc $I1
- pos = $I1
-
- .return($S1)
-.end
-
-# Local Variables:
-# mode: pir
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
Deleted: forth/trunk/variablestack.pir
==============================================================================
--- forth/trunk/variablestack.pir Mon Dec 28 23:19:19 2009 (r107)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,53 +0,0 @@
-
-.HLL 'Forth'
-.namespace ['VariableStack']
-
-.sub init :anon :load
- .local pmc class
- class = newclass 'VariableStack'
-
- addattribute class, '@stack'
- addattribute class, '$next'
-.end
-
-.sub init :vtable :method
- .local pmc stack, cell
- stack = new 'ResizableIntegerArray'
- cell = new 'Integer'
- cell = 0
-
- setattribute self, '@stack', stack
- setattribute self, '$next', cell
-.end
-
-.sub get_integer :vtable :method
- .local pmc next
- next = getattribute self, '$next'
- $I0 = next
- inc next
- .return($I0)
-.end
-
-.sub get_pmc_keyed_int :vtable :method
- .param int key
- .local pmc stack
- stack = getattribute self, '@stack'
-
- $P0 = stack[key]
- .return($P0)
-.end
-
-.sub set_pmc_keyed_int :vtable :method
- .param int key
- .param pmc value
-
- .local pmc stack
- stack = getattribute self, '@stack'
- stack[key] = value
-.end
-
-# Local Variables:
-# mode: pir
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
Deleted: forth/trunk/virtualstack.pir
==============================================================================
--- forth/trunk/virtualstack.pir Mon Dec 28 23:19:19 2009 (r107)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,81 +0,0 @@
-
-.HLL 'Forth'
-.namespace ['VirtualStack']
-
-.sub init :anon :load
- .local pmc class
- class = newclass 'VirtualStack'
-
- addattribute class, '@cstack'
-.end
-
-.sub init :vtable :method
- .local pmc cstack
- cstack = new 'ResizableStringArray'
- setattribute self, '@cstack', cstack
-.end
-
-.sub elements :vtable :method
- $P0 = getattribute self, '@cstack'
- $I0 = elements $P0
- .return($I0)
-.end
-
-.sub get_bool :vtable :method
- $P0 = getattribute self, '@cstack'
- $I0 = elements $P0
- .return($I0)
-.end
-
-.sub get_string_keyed_int :vtable :method
- .param int key
- $P0 = getattribute self, '@cstack'
- $S0 = $P0[key]
- .return($S0)
-.end
-
-.sub pop_string :vtable :method
- .local pmc cstack
- cstack = getattribute self, '@cstack'
-
- $I0 = elements cstack
- if $I0 == 0 goto rstack
-
- $S0 = pop cstack
- .return($S0)
-
-rstack:
- .return("pop stack")
-.end
-
-.sub push_string :vtable :method
- .param string elem
-
- .local pmc cstack
- cstack = getattribute self, '@cstack'
- push cstack, elem
-
- .return()
-.end
-
-.sub consolidate_to_cstack :method
- .local pmc cstack, iter
- cstack = getattribute self, '@cstack'
- .local string code
- code = ""
-loop:
- unless cstack goto done
- $S0 = shift cstack
- code .= " push stack, "
- code .= $S0
- code .= "\n"
- goto loop
-done:
- .return(code)
-.end
-
-# Local Variables:
-# mode: pir
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
Deleted: forth/trunk/words.pir
==============================================================================
--- forth/trunk/words.pir Mon Dec 28 23:19:19 2009 (r107)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,448 +0,0 @@
-
-.HLL 'Forth'
-
-.sub 'variable'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- .local pmc token
- .local string name
- token = shift stream
- name = token
-
- .local pmc variables, vstack
- variables = get_hll_global ' variables'
- vstack = get_hll_global ' vstack'
-
- $P0 = new 'Integer'
- $I0 = vstack
- $P0 = $I0
-
- variables[name] = $P0
-.end
-
-.sub ':'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- .local string name, subname
- .local pmc token, dict, nstack, nword
- token = shift stream
- name = token
- dict = get_hll_global ' dict'
- nstack = new 'VirtualStack'
- nword = new 'CodeString'
-
- subname = ' ' . name
- subname = nword.'unique'(subname)
- nword.'emit'(<<"END_PIR", subname)
-.sub '%0'
- .param pmc stack
-END_PIR
-
-loop:
- unless stream goto done
- token = shift stream
-
- $S0 = token
- if $S0 == ";" goto done
-
- ' dispatch'(nword, stream, nstack, token)
- goto loop
-
-done:
- $S0 = nstack.'consolidate_to_cstack'()
- nword .= $S0
- nword.'emit'(<<"END_PIR")
- .return()
-.end
-END_PIR
-
- $P0 = compreg "PIR"
- $P0(nword)
-
- dict[name] = subname
- .return()
-.end
-
-# print the last element on the stack (destructive)
-.sub '.'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- $S0 = pop stack
- code.'emit'(<<"END_PIR", $S0)
- $P0 = %0
- print $P0
- print " "
-END_PIR
-
- .return()
-.end
-
-# print the stack (non-destructive)
-.sub '.s'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- if stack goto compiletime
-
- code.'emit'(<<"END_PIR")
- print "<"
- $I0 = elements stack
- print $I0
- print "> "
-
- $S0 = join " ", stack
- print $S0
- print " "
-END_PIR
- .return()
-
-compiletime:
- $I0 = elements stack
- $S0 = $I0
- $S1 = join "\nprint ' '\nprint ", stack
- $S2 = code.'unique'('empty')
-
- code.'emit'(<<"END_PIR", $S0, $S1, $S2)
- print "<"
- $I0 = elements stack
- $I1 = $I0 + %0
- print $I1
- print "> "
-
- unless $I0 goto %2
- $S0 = join " ", stack
- print $S0
- print " "
-%2:
- print %1
- print " "
-END_PIR
-
- .return()
-.end
-
-# clear the stack
-.sub '0sp'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
-loop:
- unless stack goto done
- $S0 = pop stack
- goto loop
-done:
-
- $S0 = code.'unique'('loop')
- $S1 = code.'unique'('done')
- code.'emit'(<<"END_PIR", $S0, $S1)
-%0:
- unless stack goto %1
- $S0 = pop stack
- goto %0
-%1:
-END_PIR
-.end
-
-# print what's on the stream upto the next "
-.sub '."'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- $S0 = stream.'remove_upto'('"')
- $S0 = code.'escape'($S0)
- code.'emit'("print %0", $S0)
-
- .return()
-.end
-
-# remove the top element
-.sub 'drop'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- if stack goto compiletime
-
- code.'emit'('$P0 = pop stack')
- .return()
-
-compiletime:
- $P0 = pop stack
- .return()
-.end
-
-# copy the item below the top
-.sub 'over'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- code.'emit'(<<'END_PIR')
- $P0 = stack[-2]
- push stack, $P0
-END_PIR
-
- .return()
-.end
-
-# swap the top 2 elements
-.sub 'swap'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- code.'emit'(<<'END_PIR')
- $P0 = pop stack
- $P1 = pop stack
- push stack, $P0
- push stack, $P1
-END_PIR
-
- .return()
-.end
-
-# copy the top element
-.sub 'dup'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- if stack goto compiletime
-
- code.'emit'(<<'END_PIR')
- $P0 = stack[-1]
- push stack, $P0
-END_PIR
- .return()
-
-compiletime:
- $I0 = elements stack
- $S0 = stack[-1]
- push stack, $S0
- .return()
-.end
-
-# move top - 2 to top
-.sub 'rot'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- .local string a, b, c
- c = pop stack
- b = pop stack
- a = pop stack
-
- $S0 = code.'unique'("$P")
- $S1 = code.'unique'("$P")
- $S2 = code.'unique'("$P")
-
- code.'emit'(<<"END_PIR", a, b, c, $S0, $S1, $S2)
- %3 = %0
- %4 = %1
- %5 = %2
-END_PIR
- push stack, $S1
- push stack, $S2
- push stack, $S0
-
- .return()
-.end
-
-.sub 'begin'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- $S0 = stack.'consolidate_to_cstack'()
- code .= $S0
-
- .local string label
- label = code.'unique'('loop')
- code.'emit'(<<"END_PIR", label)
-%0:
-END_PIR
-
- .local pmc token
-next_token:
- unless stream goto error
- token = shift stream
-
- $S0 = token
- if $S0 == "until" goto until
-
- ' dispatch'(code, stream, stack, token)
-
- goto next_token
-
-until:
- $S1 = pop stack
- $S2 = code.'unique'("$P")
- $S0 = stack.'consolidate_to_cstack'()
- code .= $S0
- code.'emit'(<<"END_PIR", label, $S1, $S2)
- %2 = %1
- unless %2 goto %0
-END_PIR
-
- .return()
-
-error:
- say "error in BEGIN"
- exit 0
-.end
-
-.sub 'if'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- $S4 = pop stack
- $S1 = code.'unique'('$P')
- $S2 = code.'unique'('else')
- $S3 = code.'unique'('done')
-
- $S0 = stack.'consolidate_to_cstack'()
- code .= $S0
- code.'emit'(<<"END_PIR", $S4, $S1, $S2, $S3)
- %1 = %0
- unless %1 goto %2
-END_PIR
-
- .local pmc token
-if_loop:
- unless stream goto error
- token = shift stream
-
- $S0 = token
- if $S0 == "else" goto else
- if $S0 == "then" goto done
- ' dispatch'(code, stream, stack, token)
-
- goto if_loop
-
-else:
- $S0 = stack.'consolidate_to_cstack'()
- code .= $S0
- code.'emit'(<<"END_PIR", $S2, $S3)
- goto %1
-%0:
-END_PIR
-
-else_loop:
- unless stream goto error
- token = shift stream
-
- $S0 = token
- if $S0 == "then" goto done
- ' dispatch'(code, stream, stack, token)
-
- goto else_loop
-
-if_done:
- code.'emit'("%0:", $S2)
-done:
- code.'emit'("%0:", $S3)
- $S0 = stack.'consolidate_to_cstack'()
- code .= $S0
- .return()
-
-error:
- print "error in IF!"
- exit 0
-.end
-
-# print a carriage-return
-.sub 'cr'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- code.'emit'('print "\n"')
-
- .return()
-.end
-
-# is less than 0?
-.sub '0<'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- .local string a
- a = pop stack
- $S0 = code.'unique'("$P")
-
- code.'emit'(<<"END_PIR", a, $S0)
- $I0 = %0
- $I0 = islt $I0, 0
- %1 = new 'Integer'
- %1 = $I0
-END_PIR
- push stack, $S0
-
- .return()
-.end
-
-# addition
-.sub '+'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- .local string a, b
- b = pop stack
- a = pop stack
- $S0 = code.'unique'("$P")
- $S1 = code.'unique'("$P")
- $S2 = code.'unique'("$P")
-
- code.'emit'(<<"END_PIR", b, a, $S0, $S1, $S2)
- %2 = %0
- %3 = %1
- %4 = new 'Float'
- %4 = %3 + %2
-END_PIR
- push stack, $S2
-
- .return()
-.end
-
-# subtraction
-.sub '-'
- .param pmc code
- .param pmc stream
- .param pmc stack
-
- .local string a, b
- b = pop stack
- a = pop stack
- $S0 = code.'unique'("$P")
- $S1 = code.'unique'("$P")
- $S2 = code.'unique'("$P")
-
- code.'emit'(<<"END_PIR", b, a, $S0, $S1, $S2)
- %2 = %0
- %3 = %1
- %4 = new 'Float'
- %4 = %3 - %2
-END_PIR
- push stack, $S2
-
- .return()
-.end
-
-# Local Variables:
-# mode: pir
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
More information about the parrot-commits
mailing list