All -- I have fixed the macro facility in the assembler (there was a goof in argument processing in expand_macro). I discovered this while implementing label arithmetic for the assembler so all the tests in t/basic.t could be enabled. It now works, and as an added bonus, the net result is "poor man's subroutines". See the attached file call.pasm for an example.
Regards, -- Gregor _____________________________________________________________________ / perl -e 'srand(-2091643526); print chr rand 90 for (0..4)' \ Gregor N. Purdy [EMAIL PROTECTED] Focus Research, Inc. http://www.focusresearch.com/ 8080 Beckett Center Drive #203 513-860-3570 vox West Chester, OH 45069 513-860-3579 fax \_____________________________________________________________________/
? ChangeLog ? asm.patch ? call.pasm Index: disassemble.pl =================================================================== RCS file: /home/perlcvs/parrot/disassemble.pl,v retrieving revision 1.13 diff -a -u -r1.13 disassemble.pl --- disassemble.pl 2001/09/30 20:25:22 1.13 +++ disassemble.pl 2001/10/03 16:59:42 @@ -221,10 +221,10 @@ printf "#\n"; printf "# Segments:\n"; printf "#\n"; - printf "# * Magic Number: %8d bytes\n", sizeof('iv'); + printf "# * Magic Number: %8d bytes\n", sizeof('intval'); printf "# * Fixup Table: %8d bytes\n", $pf->fixup_table->packed_size; printf "# * Const Table: %8d bytes\n", $pf->const_table->packed_size; - printf "# * Byte Code: %8d bytes (%d IVs)\n", length($pf->byte_code), length($pf->byte_code) / sizeof('iv'); + printf "# * Byte Code: %8d bytes (%d IVs)\n", length($pf->byte_code), +length($pf->byte_code) / sizeof('intval'); dump_const_table($pf); disassemble_byte_code($pf); Index: Parrot/Assembler.pm =================================================================== RCS file: /home/perlcvs/parrot/Parrot/Assembler.pm,v retrieving revision 1.1 diff -a -u -r1.1 Assembler.pm --- Parrot/Assembler.pm 2001/09/30 20:25:23 1.1 +++ Parrot/Assembler.pm 2001/10/03 16:59:43 @@ -9,6 +9,7 @@ # use strict; +use Carp qw(&confess); ############################################################################### @@ -423,9 +424,34 @@ add_line_to_listing( sprintf( "\t%08x %s\n", $label{$_}, $_ ) ); } + # + # Resolve label arithmetic: + # + + foreach my $label (keys %fixup) { + next unless $label =~ m/^\[(.*)\]$/; + + my $exp = $1; + + $exp =~ s/([A-Za-z_][A-Za-z0-9_]*)/$label{$1}/g; + + my $result = (eval $exp) / sizeof('intval'); + + while (scalar(@{$fixup{$label}})) { + my $offset = shift @{$fixup{$label}}; + substr($bytecode, $offset, sizeof('intval')) = pack_arg('intval', $result); + } + + delete $fixup{$label}; + } + + # + # Complain about undefined symbols: + # + return unless keys %fixup; - print STDERR "SQUAK! These symbols were referenced but not defined:\n"; + print STDERR "These symbols were referenced but not defined:\n"; add_line_to_listing( "\nUNDEFINED SYMBOLS:\n" ); @@ -437,8 +463,10 @@ print STDERR "\n"; add_line_to_listing( "\t$_\n" ); } + + # TODO: some day, unresolved symbols won't be an error! - exit; # some day, unresolved symbols won't be an error! + error("Cannot assemble with unresolved symbols!\n", $file, $line); } @@ -548,6 +576,9 @@ } $code = replace_constants($code); + + while ($code =~ s/\[([^\] \t]*)\s+/[$1/) { }; # Erase all space within label +arithmetic + $code =~ s/,/ /g; $code =~ s/#.*$//; # strip end of line comments @@ -556,6 +587,7 @@ if( exists( $macros{$opcode} ) ) { # found a macro, expand it and append its lines to the front of # the program lines array. + my @expanded_lines = expand_macro( $opcode, @args ); unshift( @program, @expanded_lines ); $lineinfo->[2] = ''; @@ -667,7 +699,7 @@ $macros{$name} = [ [split( /,\s*/, $args)], [] ]; while( 1 ) { if( !scalar( @program ) ) { - error( "The end of the macro was never seen" ); + error( "The end of the macro was never seen", $file, $line); } my $l = shift( @program ); ($file, $line, $pline, $sline) = @$l; @@ -675,7 +707,7 @@ last; } elsif( $pline =~ /^\S+\s+macro/ ) { - error( "Cannot define a macro inside of another macro" ); + error( "Cannot define a macro inside of another macro", $file, $line ); } else { push( @{$macros{$cur_macro}[1]}, $l ); @@ -699,48 +731,66 @@ sub handle_label { my ($label, $code) = $pline =~ /^(\S+):\s*(.+)?/; - # if the label starts with a dollar sign, then it is a local label. - if( $label =~ /^\$/ ) { - # a local label + + # + # Local labels (begin with '$'): + # + + if ($label =~ /^\$/) { if( exists( $local_label{ $label } ) ) { error( "local label '$label' already defined in $last_label!", $file, $line ); } + if( exists( $local_fixup{ $label } ) ) { # backpatch everything with this PC. while(scalar(@{$local_fixup{$label}})) { my $op_pc=shift(@{$local_fixup{$label}}); my $offset=shift(@{$local_fixup{$label}}); - substr($bytecode,$offset,sizeof('i'))=pack_arg('i', ($pc-$op_pc)/sizeof('i')); + substr($bytecode,$offset,sizeof('i')) = pack_arg('i', +($pc-$op_pc)/sizeof('i')); } + delete($local_fixup{$label}); } + $local_label{$label} = $pc; } + + # + # Global labels: + # + else { - # a global label if( exists( $label{ $label } ) ) { error( "'$label' already defined!", $file, $line ); } + if( exists( $fixup{$label} ) ) { # backpatch everything with this PC. while( scalar( @{ $fixup{ $label } } ) ) { my $op_pc = shift( @{ $fixup{ $label } } ); my $offset = shift( @{ $fixup{ $label } } ); - substr($bytecode,$offset,sizeof('i'))=pack_arg('i', ($pc-$op_pc)/sizeof('i')); + substr($bytecode,$offset,sizeof('i')) = pack_arg('i', +($pc-$op_pc)/sizeof('i')); } + delete($fixup{$label}); } + + # + # Clear out any local labels + # - # clear out any local labels %local_label = (); + if( keys( %local_fixup ) ) { # oops, some local labels are unresolved error( "These local labels were undefined in $last_label: " . join( ",", sort( keys( %local_fixup ) ) ), $file, $line ); } + $label{ $label } = $pc; # store it $last_label = $label; } + return $code; } @@ -755,23 +805,31 @@ =cut sub expand_macro { - my ($opcode, @args) = shift; + my ($opcode, @args) = @_; + my (@margs) = @{ $macros{$opcode}[0] }; my (@macro); + # we have to make sure to copy the macro, to avoid mangling the # original macro definition. + foreach (@{ $macros{ $opcode }[1] } ) { push( @macro, [@$_] ); - } - if( scalar(@margs) != scalar(@args) ) { - error( "Wrong number of arguments to macro '$opcode'", $file, $line ); } + + my $nargs = scalar(@args); + my $eargs = scalar(@margs); + + error( "Wrong number ($nargs) of arguments to macro '$opcode' (expected $eargs)", +$file, $line ) + if $eargs != $nargs; + #fixup parameters. + while( my $marg = shift( @margs ) ) { my $param = shift( @args ); foreach( @macro ) { - $_->[2] =~ s/([\s,])$marg\b/$1$param/g; - $_->[3] =~ s/([\s,])$marg\b/$1$param/g; + $_->[2] =~ s|([^A-Za-z0-9_])$marg\b|$1$param|g; + $_->[3] =~ s|([^A-Za-z0-9_])$marg\b|$1$param|g; } } @@ -844,11 +902,13 @@ } elsif (m/^\[([a-z]+):(\d+)\s*\]$/) { # constant (sc or nc for now) push @arg_t, $1; } elsif(m/^((-?\d+)|(0b[01]+)|(0x[0-9a-f]+))$/i) { # integer + push @arg_t,'ic'; + } elsif(m/^\[.*\]$/) { # label arithmetic push @arg_t,'ic'; - } elsif(m/^[\$A-Za-z_][\w]*$/i) { # label + } elsif(m/^\$?[A-Za-z_][\w]*$/i) { # label push @arg_t,'ic'; } else { - error("Unrecognized argument '$_'!"); + error("Unrecognized argument '$_'!", $file, $line); } } @@ -971,20 +1031,44 @@ my ($code, $opcode, @args) = @_; foreach (0..$#args) { - my($rtype)= $opcodes{$opcode}{TYPES}[$_]; + my $rtype = $opcodes{$opcode}{TYPES}[$_]; + # + # Register arguments: + # + if($rtype eq "I" || $rtype eq "N" || $rtype eq "P" || $rtype eq "S") { # its a register argument $args[$_] =~ s/^[INPS](\d+)$/$1/i - or error("Expected m/[INPS]\\d+/, but got '$args[$_]'!"); + or error("Expected m/[INPS]\\d+/, but got '$args[$_]'!", $file, $line); error("Register $1 out of range (should be 0-31) in '$opcode'",$file,$line) if $1 < 0 or $1 > 31; } + + # + # Destination arguments: + # + elsif($rtype eq "D") { - # a destination - if( $args[$_] =~ /^\$/ ) { - # a local label + # + # Label arithmetic: + # + + if ($args[$_] =~ m/^\[(.*)\]$/) { + my $mult = sizeof('intval'); + $args[$_] =~ s/(\d+)/$mult * $1/eg; # Hard-coded INTVAL +offsets ---> byte offsets + $args[$_] =~ s/[\@]/$op_pc/; # Map '@' to $op_pc + + push @{$fixup{$args[$_]}}, $pc; + $args[$_] = 0xffffffff; + } + + # + # Local labels: + # + + elsif ($args[$_] =~ /^\$/) { if( !exists($local_label{$args[$_]}) ) { # we have not seen it yet...put it on the fixup list push(@{$local_fixup{$args[$_]}},$op_pc,$pc); @@ -994,6 +1078,11 @@ $args[$_] = ($local_label{$args[$_]}-$op_pc)/sizeof('i'); } } + + # + # Regular labels: + # + else { if( !exists($label{$args[$_]}) ) { # we have not seen it yet...put it on the fixup list @@ -1005,14 +1094,46 @@ } } } - elsif($rtype eq 's') { + + # + # String arguments: + # + + elsif ($rtype eq 's') { $args[$_] =~ s/[\[]sc:(.*)[\]]/$1/; } - elsif($rtype eq 'n') { + + # + # Number arguments: + # + + elsif ($rtype eq 'n') { $args[$_] =~ s/[\[]nc:(.*)[\]]/$1/; } - else { - if ($args[$_] =~ /^0b[01]+$/i) { + + # + # Integer arguments: + # + + elsif ($rtype eq 'i') { + # + # Label arithmetic: + # + + if ($args[$_] =~ m/^\[(.*)\]$/) { + my $mult = sizeof('intval'); + $args[$_] =~ s/(\d+)/$mult * $1/eg; # Hard-coded INTVAL +offsets ---> byte offsets + $args[$_] =~ s/[\@]/$op_pc/; # Map '@' to $op_pc + + push @{$fixup{$args[$_]}}, $pc; + $args[$_] = 0xffffffff; + } + + # + # Handle conversions of hexadecimal and octal: + # + + elsif ($args[$_] =~ /^0b[01]+$/i) { $args[$_] = from_binary( $args[$_] ); } elsif ($args[$_] =~ /^0x?[0-9a-f]*$/i) { @@ -1020,6 +1141,20 @@ } } + # + # Unknown argument types: + # + + else { + error("Unrecognized argument type '$rtype'!\n", $file, $line); + } + + # + # Continue: + # + # NOTE: Too bad $rtype wouldn't be visible in a continue block... + # + $pc += sizeof($rtype); $bytecode .= pack_arg($rtype, $args[$_]); } @@ -1065,8 +1200,14 @@ =cut sub error { - my($message,$file,$line)=@_; + my ($message, $file, $line) = @_; + + die("\$message undefined!") unless defined $message; + die("\$file undefined!") unless defined $file; + die("\$line undefined!") unless defined $line; + print STDERR "Error ($file:$line): $message\n"; + exit 1; } @@ -1161,6 +1302,7 @@ my($sline)=$_; s/^\s*//; s/\s*$//; + push(@lines,[$file,$line,$_,$sline]); if(m/^INCLUDE\s+['"](.+)["']/i) { my $newfile=$1; Index: t/op/basic.t =================================================================== RCS file: /home/perlcvs/parrot/t/op/basic.t,v retrieving revision 1.2 diff -a -u -r1.2 basic.t --- t/op/basic.t 2001/09/25 09:12:57 1.2 +++ t/op/basic.t 2001/10/03 16:59:43 @@ -27,17 +27,34 @@ end CODE -SKIP: { - skip( "label constants unimplemented in assembler", 1 ); output_is( <<'CODE', <<OUTPUT, "jump" ); - set I4, 42 - set I5, HERE - jump I5 - set I4, 1234 -HERE: - print I4 - end +neg macro R + set I0, R + set R, 0 + sub R, R, I0 +endm + +call macro R, D + set R, [D - @ - 3] + jump R +endm + +return macro R, D + neg R + inc R, [D - @ - 1] + jump R +endm + +MAIN: set I1, 42 + call I31, PRINTIT + set I1, 1234 + call I31, PRINTIT + end + +PRINTIT: print I1 + print "\n" + return I31, PRINTIT CODE -I reg 4 is 42 +42 +1234 OUTPUT -}
neg macro R set I0, R set R, 0 sub R, R, I0 endm call macro R, D set R, [D - @ - 3] jump R endm return macro R, D neg R inc R, [D - @ - 1] jump R endm MAIN: set I1, 42 call I31, PRINTIT set I1, 1234 call I31, PRINTIT end PRINTIT: print I1 print "\n" return I31, PRINTIT