cvs -q diff -u Index: config/gen/makefiles/m4.in =================================================================== RCS file: /cvs/public/parrot/config/gen/makefiles/m4.in,v retrieving revision 1.5 diff -u -u -r1.5 m4.in --- config/gen/makefiles/m4.in 3 Jun 2004 07:35:14 -0000 1.5 +++ config/gen/makefiles/m4.in 6 Jul 2004 19:50:22 -0000 @@ -1,10 +1,26 @@ # $Id: m4.in,v 1.5 2004/06/03 07:35:14 leo Exp $ # Setup of some commands -LN_SF = ln -s -f -PARROT = ..${slash}..${slash}parrot${exe} -PERL = ${perl} -RM_RF = ${rm_rf} +LN_SF = ln -s -f +PARROT = ..${slash}..${slash}parrot${exe} +PERL = ${perl} +RM_RF = ${rm_rf} + +# Compile commands and flags +CC = ${cc} +CFLAGS = ${ccflags} -I../../include +CC_SHARED = ${cc_shared} # e.g. -fpic +DEBUG = ${cc_debug} +WARN = ${ccwarn} + +# Linker command and flags +LINK = ${link} +LINKFLAGS = ${linkflags} + +# Shared-library building +LD = ${ld} +LDFLAGS = ${ldflags} +LD_SHARED = ${ld_shared} # e.g. -shared # some constants M4_EVAL_COMPILER_SO = ../../runtime/parrot/dynext/m4_eval_compiler.so @@ -32,21 +48,21 @@ @echo "" test: build - cd ..; $(PERL) -I../lib m4/t/harness + cd .. && $(PERL) -I../lib m4/t/harness -build: blib runtime $(M4_EVAL_COMPILER_SO) m4.pbc +build: runtime $(M4_EVAL_COMPILER_SO) m4.pbc -blib: - $(LN_SF) ../../blib - -runtime: +# TODO: get rid of this, as soon as _PARROTLIB is the default +runtime: $(LN_SF) ../../runtime m4.pbc: src/m4.pbc $(LN_SF) src/m4.pbc $(M4_EVAL_COMPILER_SO): src/eval.c - $(CC) -shared -fpic src/eval.c -o $@ -g -Wall -I../../include + $(CC) $(CFLAGS) $(CC_SHARED) $(DEBUG) $(WARN) -c $< + $(LD) $(LD_SHARED) $(LDFLAGS) -o $@ eval.o + src/m4.imc: src/builtin.imc src/freeze.imc src/input.imc src/macro.imc touch $@ @@ -57,8 +73,7 @@ clean: $(RM_RF) \ -*.pbc \ -blib \ +m4.pbc \ runtime \ src/*.pbc \ src/*/*.pbc \ @@ -71,13 +86,9 @@ realclean: clean $(RM_RF) \ - Makefile +Makefile distclean: realclean %.pbc: %.imc $(PARROT) -o $@ $< - -distclean: clean - -.PRECIOUS: %.imc Index: config/init/data.pl =================================================================== RCS file: /cvs/public/parrot/config/init/data.pl,v retrieving revision 1.30 diff -u -u -r1.30 data.pl --- config/init/data.pl 1 Jul 2004 20:37:04 -0000 1.30 +++ config/init/data.pl 6 Jul 2004 19:50:23 -0000 @@ -45,6 +45,9 @@ cc => $Config{cc}, ccflags => $Config{ccflags}, ccwarn => exists($Config{ccwarn}) ? $Config{ccwarn} : '', + # Flags used to indicate this object file is to be compiled + # with position-independent code suitable for dynamic loading. + cc_shared => $Config{cccdlflags}, # e.g. -fpic for GNU cc. # C++ compiler -- used to compile parts of ICU. ICU's configure # will try to find a suitable compiler, but it prefers GNU c++ over Index: languages/m4/ChangeLog =================================================================== RCS file: /cvs/public/parrot/languages/m4/ChangeLog,v retrieving revision 1.4 diff -u -u -r1.4 ChangeLog --- languages/m4/ChangeLog 3 Jun 2004 07:35:18 -0000 1.4 +++ languages/m4/ChangeLog 6 Jul 2004 19:50:41 -0000 @@ -1,5 +1,19 @@ # $Id: ChangeLog,v 1.4 2004/06/03 07:35:18 leo Exp $ +2004-07-06 Bernhard Schmalhofer + * Make tests work again + * add some tests for 'eval' + * yank it up to revision 0.0.7 + +2004-06-27 Andy Dougherty + * Build patches for Solaris, RT#30320 + +2004-06-21 Bernhard Schmalhofer + * Don't write test files into '/tmp' + +2004-06-10 Bernhard Schmalhofer + * The symbolic link 'blib' isn't needed any more + 2004-06-02 Bernhard Schmalhofer * Start to use t/harness and Parrot::Test * yank it up to revision 0.0.6 Index: languages/m4/doc/features.pod =================================================================== RCS file: /cvs/public/parrot/languages/m4/doc/features.pod,v retrieving revision 1.2 diff -u -u -r1.2 features.pod --- languages/m4/doc/features.pod 26 Jan 2004 10:14:19 -0000 1.2 +++ languages/m4/doc/features.pod 6 Jul 2004 19:50:41 -0000 @@ -8,6 +8,8 @@ =head1 What doesn't works? +L<../TODO.pod> + =head1 What are the differences to GNU m4? =head1 SEE ALSO Index: languages/m4/doc/running.pod =================================================================== RCS file: /cvs/public/parrot/languages/m4/doc/running.pod,v retrieving revision 1.2 diff -u -u -r1.2 running.pod --- languages/m4/doc/running.pod 26 Jan 2004 10:14:19 -0000 1.2 +++ languages/m4/doc/running.pod 6 Jul 2004 19:50:41 -0000 @@ -7,12 +7,14 @@ =head1 What is Parrot m4? C is C ported to C. It is implemented in the -Parrot Intermediate Language (C). +Parrot Intermediate Representation (C). GNU m4, and thus Parrot m4, is a macro processor. =head2 Installing Parrot m4 -Unpack the archive. +Get the Parrot distribution. Build parrot. + cd languages/m4 + make =head1 Running the test suite @@ -20,12 +22,18 @@ =head1 Running your own code + ../../parrot m4.pbc + =head2 Command line arguments + ../../parrot m4.pbc --help + =head2 A simple example =head1 SEE ALSO =head1 AUTHOR +Bernhard.Schmalhofer at gmx.de + =cut Index: languages/m4/examples/eval.imc =================================================================== RCS file: /cvs/public/parrot/languages/m4/examples/eval.imc,v retrieving revision 1.1 diff -u -u -r1.1 eval.imc --- languages/m4/examples/eval.imc 20 Apr 2004 08:35:55 -0000 1.1 +++ languages/m4/examples/eval.imc 6 Jul 2004 19:50:41 -0000 @@ -4,7 +4,7 @@ =head1 NAME -m4_eval.c - Integer arithmetic evaluation for Parrot m4 +eval.imc - Integer arithmetic evaluation for Parrot m4 =head1 DESCRIPTION Index: languages/m4/src/builtin.imc =================================================================== RCS file: /cvs/public/parrot/languages/m4/src/builtin.imc,v retrieving revision 1.4 diff -u -u -r1.4 builtin.imc --- languages/m4/src/builtin.imc 20 Apr 2004 08:35:59 -0000 1.4 +++ languages/m4/src/builtin.imc 6 Jul 2004 19:50:42 -0000 @@ -15,7 +15,7 @@ =cut # Some named constants -.include 'iterator.pasm' +.include '../../runtime/parrot/include/iterator.pasm' =head1 SUBROUTINES Index: languages/m4/src/eval.c =================================================================== RCS file: /cvs/public/parrot/languages/m4/src/eval.c,v retrieving revision 1.2 diff -u -u -r1.2 eval.c --- languages/m4/src/eval.c 3 Jun 2004 07:35:25 -0000 1.2 +++ languages/m4/src/eval.c 6 Jul 2004 19:50:43 -0000 @@ -19,6 +19,7 @@ */ #include +#include #include #include typedef int boolean; @@ -26,7 +27,6 @@ typedef int eval_t; /* Error handling. */ -#define M4ERROR(Arglist) ( error Arglist) #define CODE_SIZE 128 /* This file contains the functions to evaluate integer expressions for @@ -282,39 +282,32 @@ break; case MISSING_RIGHT: - M4ERROR ((warning_status, 0, - "Bad expression in eval (missing right parenthesis): %s", - expr)); + fprintf( stderr, "Bad expression in eval (missing right parenthesis): %s", + expr); break; case SYNTAX_ERROR: - M4ERROR ((warning_status, 0, - "Bad expression in eval: %s", expr)); + fprintf( stderr, "Bad expression in eval: %s", expr); break; case UNKNOWN_INPUT: - M4ERROR ((warning_status, 0, - "Bad expression in eval (bad input): %s", expr)); + fprintf( stderr, "Bad expression in eval (bad input): %s", expr); break; case EXCESS_INPUT: - M4ERROR ((warning_status, 0, - "Bad expression in eval (excess input): %s", expr)); + fprintf( stderr, "Bad expression in eval (excess input): %s", expr); break; case DIVIDE_ZERO: - M4ERROR ((warning_status, 0, - "Divide by zero in eval: %s", expr)); + fprintf( stderr, "Divide by zero in eval: %s", expr); break; case MODULO_ZERO: - M4ERROR ((warning_status, 0, - "Modulo by zero in eval: %s", expr)); + fprintf( stderr, "Modulo by zero in eval: %s", expr); break; default: - M4ERROR ((warning_status, 0, - "INTERNAL ERROR: Bad error code in evaluate ()")); + fprintf( stderr, "INTERNAL ERROR: Bad error code in evaluate ()"); abort (); } @@ -553,8 +546,7 @@ break; default: - M4ERROR ((warning_status, 0, - "INTERNAL ERROR: Bad comparison operator in cmp_term ()")); + fprintf( stderr, "INTERNAL ERROR: Bad comparison operator in cmp_term ()"); abort (); } } @@ -596,8 +588,7 @@ break; default: - M4ERROR ((warning_status, 0, - "INTERNAL ERROR: Bad shift operator in shift_term ()")); + fprintf( stderr, "INTERNAL ERROR: Bad shift operator in shift_term ()"); abort (); } } @@ -679,8 +670,7 @@ break; default: - M4ERROR ((warning_status, 0, - "INTERNAL ERROR: Bad operator in mult_term ()")); + fprintf( stderr, "INTERNAL ERROR: Bad operator in mult_term ()"); abort (); } } Index: languages/m4/src/input.imc =================================================================== RCS file: /cvs/public/parrot/languages/m4/src/input.imc,v retrieving revision 1.5 diff -u -u -r1.5 input.imc --- languages/m4/src/input.imc 21 May 2004 19:28:11 -0000 1.5 +++ languages/m4/src/input.imc 6 Jul 2004 19:50:43 -0000 @@ -215,7 +215,7 @@ .local pmc struct struct = new SArray struct = 3 - .include "datatypes.pasm" + .include "../../runtime/parrot/include/datatypes.pasm" struct[0] = .DATATYPE_INT struct[1] = 2 struct[2] = 0 Index: languages/m4/src/m4.imc =================================================================== RCS file: /cvs/public/parrot/languages/m4/src/m4.imc,v retrieving revision 1.7 diff -u -u -r1.7 m4.imc --- languages/m4/src/m4.imc 3 Jun 2004 07:35:25 -0000 1.7 +++ languages/m4/src/m4.imc 6 Jul 2004 19:50:44 -0000 @@ -87,7 +87,7 @@ # Was '--version' passed ? is_defined = defined opt["version"] unless is_defined goto NO_VERSION_FLAG - print "Parrot m4 0.0.6\n" + print "Parrot m4 0.0.7\n" end NO_VERSION_FLAG: @@ -309,7 +309,7 @@ .sub _usage .param string program_name - print "Usage: ./parrot " + print "Usage: ../../parrot " print program_name print " [OPTION]... FILE\n" print "\n" Index: languages/m4/t/harness =================================================================== RCS file: /cvs/public/parrot/languages/m4/t/harness,v retrieving revision 1.1 diff -u -u -r1.1 harness --- languages/m4/t/harness 3 Jun 2004 07:35:08 -0000 1.1 +++ languages/m4/t/harness 6 Jul 2004 19:50:45 -0000 @@ -14,7 +14,14 @@ =head1 SYNOPSIS - cd languages && perl m4/t/harness -files + cd languages && perl -I../lib m4/t/harness -files + + cd languages && perl -I../lib m4/t/harness + + cd languages && perl -I../lib m4/t/harness \ + m4/t/basic/006_define_with_rest \ + m4/t/regex/003_two_compiles.t + =head1 DESCRIPTION @@ -24,13 +31,13 @@ If I'm called with no args, I run all tests. -Otherwise I try to run list of passed tests. +Otherwise I try to run the list of passed tests. =cut -if ( grep { /^-files$/ } @ARGV ) +if ( grep { m/^-files$/ } @ARGV ) { - # I must be running out of languages/ + # Only the Makefile in 'parrot/languages' uses -file my $dir = File::Spec->catfile( $language, 't' ); my @files = glob( File::Spec->catfile( $dir, '*/*.t' ) ); print join( "\n", @files ); @@ -46,8 +53,7 @@ } else { - # I must be running out of languages/$language - # You may want a deeper search than this. + # Propably called out of 'parrot/languages' @files = glob( "m4/t/*/*.t" ); } runtests( @files ) if scalar(@files); @@ -59,7 +65,7 @@ =head1 SEE ALSO - L + L, L =head1 AUTHOR Index: languages/m4/t/basic/003_getopt.t =================================================================== RCS file: /cvs/public/parrot/languages/m4/t/basic/003_getopt.t,v retrieving revision 1.5 diff -u -u -r1.5 003_getopt.t --- languages/m4/t/basic/003_getopt.t 3 Jun 2004 07:35:28 -0000 1.5 +++ languages/m4/t/basic/003_getopt.t 6 Jul 2004 19:50:45 -0000 @@ -6,14 +6,14 @@ use Test::More tests => 25; my $real_out; -my $parrot_m4 = 'cd ..; ./parrot languages/m4/m4.pbc'; +my $parrot_m4 = 'cd .. && ./parrot languages/m4/m4.pbc'; my $examples_dir = 'languages/m4/examples'; #-------------------------------------------- $real_out = `$parrot_m4 --help 2>&1`; is( $real_out, << "END_OUT", '--help' ); -Usage: ./parrot languages/m4/m4.pbc [OPTION]... FILE +Usage: ../../parrot languages/m4/m4.pbc [OPTION]... FILE Currently only long options are available. @@ -31,7 +31,7 @@ #-------------------------------------------- $real_out = `$parrot_m4 --version 2>&1`; is( $real_out, << 'END_OUT', '--version' ); -Parrot m4 0.0.6 +Parrot m4 0.0.7 END_OUT Index: languages/m4/t/basic/012_eval.t =================================================================== RCS file: /cvs/public/parrot/languages/m4/t/basic/012_eval.t,v retrieving revision 1.2 diff -u -u -r1.2 012_eval.t --- languages/m4/t/basic/012_eval.t 3 Jun 2004 07:35:28 -0000 1.2 +++ languages/m4/t/basic/012_eval.t 6 Jul 2004 19:50:45 -0000 @@ -6,7 +6,6 @@ my $real_out; my $parrot = 'cd .. && ./parrot'; -my $parrot_m4 = "$parrot languages/m4/m4.pbc"; $real_out = `$parrot languages/m4/examples/eval.imc 2>&1`; is( $real_out, << 'END_OUT', 'single file' ); Index: languages/m4/t/builtins/011_eval.t =================================================================== RCS file: /cvs/public/parrot/languages/m4/t/builtins/011_eval.t,v retrieving revision 1.2 diff -u -u -r1.2 011_eval.t --- languages/m4/t/builtins/011_eval.t 3 Jun 2004 07:35:04 -0000 1.2 +++ languages/m4/t/builtins/011_eval.t 6 Jul 2004 19:50:45 -0000 @@ -2,16 +2,28 @@ use strict; -use Parrot::Test tests => 1; +use Parrot::Test tests => 2; + +# Test the m4-Builtin function 'eval' { - language_output_is( 'm4', <<'CODE', <<'OUT', 'substring in middle of string' ); + language_output_is( 'm4', <<'CODE', <<'OUT', 'basic expressions' ); eval( `4') eval( `0') eval( `-4') eval( `-0') eval( ` 1 + 1 ' ) eval( ` 42 + -43 ' ) +eval( `42 + -44' ) +eval(`4*4') +eval(`4*4') +eval( `5 * 6' ) +eval( `-20 / 4' ) +eval( `-20 / 4 * 8' ) +eval( `-20 / 4 * 8 + 17' ) +asdf eval( `-20 / 4 * 8 + 17' ) jklm +-23 = eval( `-20 / 4 * 8 + 17' ) jklm +-20 / 4 * 8 + 17 = eval( `-20 / 4 * 8 + 17' ) jklm CODE 4 0 @@ -19,6 +31,61 @@ 0 2 -1 +-2 +16 +16 +30 +-5 +-40 +-23 +asdf -23 jklm +-23 = -23 jklm +-20 / 4 * 8 + 17 = -23 jklm +OUT +} + + +{ + language_output_is( 'm4', <<'CODE', <<'OUT', 'all ops besides bitwise ops' ); +1 eval( `4**5') +2 eval( `2**10') +3 eval( ` 2 ** 10 ' ) +4 eval( ` -2 ** 10 ' ) +5 eval( ` -4 *512 / -2 ' ) +6 eval( ` 2049 % 1025 ' ) +7 eval( ` 2048 >> 1 ' ) +8 eval( ` 256 <<2 ' ) +9 eval( ` 256 == 1024 / 4' ) +10 eval( ` 256 != 1024 / 4' ) +11 eval( ` 256 <= 256' ) +12 eval( ` 256 >= 256' ) +13 eval( ` 256 > 256' ) +14 eval( ` 256 > 256' ) +15 eval( ` 256 > 257' ) +16 eval( ` ! 256 > 257' ) +17 eval( ` !! ! 256 > 257' ) +18 eval( ` 1 && 0' ) +19 eval( ` 1026 || 0' ) +CODE +1 1024 +2 1024 +3 1024 +4 1024 +5 1024 +6 1024 +7 1024 +8 1024 +9 1 +10 0 +11 1 +12 1 +13 0 +14 0 +15 0 +16 1 +17 1 +18 0 +19 1 OUT } Index: languages/m4/t/regex/003_two_compiles.t =================================================================== RCS file: /cvs/public/parrot/languages/m4/t/regex/003_two_compiles.t,v retrieving revision 1.3 diff -u -u -r1.3 003_two_compiles.t --- languages/m4/t/regex/003_two_compiles.t 3 Jun 2004 07:35:34 -0000 1.3 +++ languages/m4/t/regex/003_two_compiles.t 6 Jul 2004 19:50:46 -0000 @@ -220,15 +220,7 @@ # compile regular expression 'df' .local pmc re_df - .pcc_begin prototyped - .arg 'df' - .arg 0 - .arg error - .arg errptr - .arg NULL - .nci_call pcre_compile - .result re_df - .pcc_end + .PCRE_COMPILE('df', 0, re_df, error, errptr) # Variables for matching .local string s @@ -254,8 +246,9 @@ .result ok .pcc_end if ok < 0 goto EXEC_FAILED + print "ok: " print ok - print " match(es):\n" + print " 'as' matches\n" # Try another match .pcc_begin prototyped @@ -270,9 +263,10 @@ .nci_call pcre_exec .result ok .pcc_end + print "ok: " print ok if ok < 0 goto NO_MATCH - print " match(es):\n" + print " 'df' matches\n" end @@ -290,8 +284,8 @@ END_PIR pir_output_is( $pir, << 'OUTPUT', "calling pcre_compile directly two times" ); -1 match(es): -1 match(es): +ok: 1 'as' matches +ok: 1 'df' matches OUTPUT } if ( 0 ) @@ -437,12 +431,8 @@ END_PIR pir_output_is( $pir, << 'OUTPUT', "calling .PCRE_COMPILE two times" ); - -1 match(es): -as - -1 match(es): -df +ok: 1 'as' match(es): +ok: 1 'df' match(es): OUTPUT } Index: lib/Parrot/Test/m4.pm =================================================================== RCS file: /cvs/public/parrot/lib/Parrot/Test/m4.pm,v retrieving revision 1.2 diff -u -u -r1.2 m4.pm --- lib/Parrot/Test/m4.pm 3 Jun 2004 07:35:40 -0000 1.2 +++ lib/Parrot/Test/m4.pm 6 Jul 2004 19:50:47 -0000 @@ -2,18 +2,24 @@ use strict; +use Data::Dumper; use File::Basename; package Parrot::Test::m4; -use Data::Dumper; +=head1 NAME + +Test/m4.pm - Testing routines specific to 'm4'. + +=head1 DESCRIPTION -=head1 +Call 'Parrot m4' and 'GNU m4'. -Provide language specific testing routines here... +=head1 METHODS -This is currently alarmingly similar to the generated subs in Parrot::Test. -Perhaps someone can do a better job of delegation here. +=head2 new + +Yet another constructor. =cut @@ -22,48 +28,43 @@ return bless {}; } -sub output_is() + +=head2 output_is + +This gets called when language_output_is() is called in a test file. + +=cut + +sub output_is { - my ( $self, $code, $output, $desc ) = @_; + my $self = shift; + my ( $code, $output, $desc ) = @_; my $count = $self->{builder}->current_test + 1; # flatten filenames (don't use directories) - # but, always put the test in a tempdir, so we're not cluttering my $lang_f = Parrot::Test::per_test( '.m4', $count ); - $lang_f = ( File::Spec->splitpath( $lang_f ) )[2]; - $lang_f = File::Spec->catfile( File::Spec->tmpdir(), $lang_f ); - my $parrot_m4_out_f = Parrot::Test::per_test( '.parrot_out', $count ); - $parrot_m4_out_f = ( File::Spec->splitpath( $parrot_m4_out_f ) )[2]; - $parrot_m4_out_f = File::Spec->catfile( File::Spec->tmpdir(), $parrot_m4_out_f ); - my $gnu_m4_out_f = Parrot::Test::per_test( '.gnu_out', $count ); - $gnu_m4_out_f = ( File::Spec->splitpath( $gnu_m4_out_f ) )[2]; - $gnu_m4_out_f = File::Spec->catfile( File::Spec->tmpdir(), $gnu_m4_out_f ); + my $test_prog_args = $ENV{TEST_PROG_ARGS} || ''; + my $parrot_m4 = "(cd $self->{relpath} && $self->{parrot} languages/m4/m4.pbc ${test_prog_args} languages/${lang_f})"; + my $gnu_m4 = "(cd $self->{relpath} && m4 ${test_prog_args} languages/${lang_f})"; + + # This does nor create byte code, but m4 code my $parrotdir = File::Basename::dirname( $self->{parrot} ); Parrot::Test::generate_pbc_for( $code, $parrotdir, $count, $lang_f ); - my $test_prog_args = $ENV{TEST_PROG_ARGS} || ''; - my $parrot_m4 = "(cd $self->{relpath} && $self->{parrot} languages/m4/m4.pbc ${test_prog_args} ${lang_f})"; - my $gnu_m4 = "(cd $self->{relpath} && m4 ${test_prog_args} ${lang_f})"; - - # For some reason, if you redirect both STDERR and STDOUT here, - # you get a 38M file of garbage. We'll temporarily assume everything - # works and ignore stderr. + # TODO: Don't ignore STDERR my $exit_code = Parrot::Test::_run_command( $parrot_m4, STDOUT => $parrot_m4_out_f ); $exit_code = Parrot::Test::_run_command( $gnu_m4, STDOUT => $gnu_m4_out_f ); my $pass = $self->{builder}->is_eq( Parrot::Test::slurp_file($parrot_m4_out_f) . Parrot::Test::slurp_file($parrot_m4_out_f), , $output . $output, $desc ); $self->{builder}->diag( "'$parrot_m4' failed with exit code $exit_code" ) if $exit_code and not $pass; + # die Data::Dumper::Dumper( $lang_f, `pwd`, $parrot_m4, $parrotdir, $parrot_m4_out_f ); - unless ( $ENV{POSTMORTEM} ) - { - unlink( $lang_f ); - unlink( $parrot_m4_out_f ); - unlink( $gnu_m4_out_f ); - } + # The generated files are left in the t/* directories. + # Let 'make clean' and '.cvsignore' take care of them. return $pass; } Index: runtime/parrot/library/Getopt/Long.imc =================================================================== RCS file: /cvs/public/parrot/runtime/parrot/library/Getopt/Long.imc,v retrieving revision 1.1 diff -u -u -r1.1 Long.imc --- runtime/parrot/library/Getopt/Long.imc 26 May 2004 08:51:14 -0000 1.1 +++ runtime/parrot/library/Getopt/Long.imc 6 Jul 2004 19:50:53 -0000 @@ -11,15 +11,16 @@ =head1 DESCRIPTION This PIR library can be used for parsing command line options. -A single subroutine, get_options(), is provided. +A single subroutine, _get_options(), is provided. =head1 SUBROUTINES =head2 _get_options This should work like the Perl5 module Getopt::Long. -Takes a format specifier and an argument vector. -Returns a PerlHash. +Takes an array of options and an array of specifications. + +A PerlHash is returned. =cut @@ -28,32 +29,33 @@ .param PerlArray spec # Loop over the array spec and build up two simple hashes - .local PerlHash type # the type of the option: binary, string, integer + .local pmc type # the type of the option: binary, string, integer type = new PerlHash - .local int cnt_spec # a counter for looping over the array 'spec' - cnt_spec = 0 - .local int len_spec # for end condition of loop over 'spec' - len_spec = spec + .local int curr_spec # a counter for looping over the array 'spec' + curr_spec = 0 + .local int max_spec # for end condition of loop over 'spec' + max_spec = spec .local int spec_index # searching for patterns in 'spec' .local string opt_name # name of specified option .local string opt_type # tyep of specified option goto CHECK_PARSE_SPEC NEXT_PARSE_SPEC: # Look at next element in 'spec' - opt_name = spec[cnt_spec] + opt_name = spec[curr_spec] spec_index = index opt_name, '=' # when '=' is not in 'opt_name' then it's binary if spec_index != -1 goto NOT_A_BINARY_OPTION opt_type = 'b' goto OPTION_TYPE_IS_NOW_KNOWN NOT_A_BINARY_OPTION: - inc spec_index # we know where '=', thus the type is one further + inc spec_index # we know where '=', thus the type is one further opt_type = substr opt_name, spec_index, 1 - dec spec_index # Go back to the '=' - opt_name = substr spec_index, 2, '' # The stuff before '=' is the option name + dec spec_index # Go back to the '=' + # TODO: what if we have something like name=xy ? + opt_name = substr spec_index, 2, '' # The stuff before '=' is the option name OPTION_TYPE_IS_NOW_KNOWN: type[opt_name] = opt_type - inc cnt_spec + inc curr_spec CHECK_PARSE_SPEC: # check wether loop over 'spec' is complete - if cnt_spec < len_spec goto NEXT_PARSE_SPEC + if curr_spec < max_spec goto NEXT_PARSE_SPEC # uncomment this if you want debug output goto SKIP_DEBUG_OUTPUT @@ -64,7 +66,7 @@ # we actually parse the argument vector # TODO: do this correctly # shift from argv until a non-option is encountered - .local PerlHash opt # the return PMC + .local pmc opt # the return PMC opt = new PerlHash .local string arg # element of argument array .local string value # element of argument array @@ -75,12 +77,20 @@ NEXT_PARSE_ARGV: # first we take a peek at the first remaining element arg = argv[0] - # Is arg a option string like '--help' + + # Is arg a long option string like '--help' + # TODO: how about asdf--jkl ??? arg_index = index arg, '--' - if arg_index > -1 goto HANDLE_OPTION + if arg_index > -1 goto HANDLE_LONG_OPTION + + # Is arg a short option string like '-v' + arg_index = index arg, '-' + if arg_index > -1 goto HANDLE_SHORT_OPTION # We are done, and don't want to loose the nonoption argument goto FINISH_PARSE_ARGV - HANDLE_OPTION: + + HANDLE_SHORT_OPTION: + HANDLE_LONG_OPTION: # we take the current option off argv arg = shift argv # get rid of the leading '--' @@ -117,6 +127,7 @@ CHECK_PARSE_ARGV: num_remaining_args = argv if num_remaining_args > 0 goto NEXT_PARSE_ARGV + FINISH_PARSE_ARGV: # Nothing to do here