package Language::INTERCAL::Backend::ListObject;

# Produce a (non-executable) listing of an object

# This file is part of CLC-INTERCAL

# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Backend/ListObject.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::ByteCode '1.-94.-2',
	qw(:BC bc_xtype bc_skip is_constant is_multibyte bc_forall reg_decode);
use Language::INTERCAL::Object '1.-94.-2';

use constant default_suffix => 'iasm';
use constant default_mode   => 0666;

use constant BYTES_PER_LINE => 8;

sub generate {
    @_ == 4 || @_ == 5
	or croak "Usage: BACKEND->generate(INTERPRETER, NAME, FILEHANDLE)";
    my ($class, $int, $name, $fh, $options) = @_;
    _generate($int, $fh);
}

sub _generate {
    my ($int, $fh) = @_;
    my $object = $int->object;

    my ($perversion) = $Language::INTERCAL::Object::PERVERSION =~ /\s(\S+)$/;

    $fh->read_text("CLC-INTERCAL $perversion Object List\n\n");

    # object flags
    $fh->read_text("FLAGS:\n");
    for my $fn (sort { lc($a) cmp lc($b) } $object->all_flags) {
	my $fv = $object->flag_value($fn);
	$fh->read_text("    $fn <- $fv\n");
    }
    $fh->read_text("\n");

    # code listing
    $fh->read_text("CODE:\n");
    my ($cs, $ch) = $object->code;
    my $source = $object->source;
    for my $sp (sort { $a <=> $b } keys %$ch) {
	for my $p (@{$ch->{$sp}}) {
	    my ($ju, $sl, $ls, $ll, $ds, $dl,
		$ge, $ab, $qu, $xs, $xl, @ru) = @$p;
	    my $se = $sp + $sl - 1;
	    my $s = '';
	    if ($source ne '') {
		$s = substr($source, $sp, $sl);
		$s =~ s/\s+/ /g;
		$s =~ s/^ //;
		$s =~ s/ $//;
	    }
	    _fold($fh, "    \@$sp..$se", $s);
	    if ($ll > 0) {
		$fh->read_text("    LABEL:\n");
		_list_code($fh, $cs, $ls, $ls + $ll);
	    } elsif ($ls > 0) {
		$fh->read_text("    LABEL: $ls\n");
	    }
	    if ($dl > 0) {
		$fh->read_text("    DSX:\n");
		_list_code($fh, $cs, $ds, $ds + $dl);
	    } elsif ($ds > 0) {
		$fh->read_text("    DSX: $ds\n");
	    }
	    $ju = $ju ? "; COMMENT($ju)" : '';
	    $ab = $ab ? '; INITIALLY ABSTAINED FROM' : '';
	    $qu = $qu ? "; QUANTUM" : "";
	    my ($gn) = bytedecode($ge);
	    $gn = defined $gn ? " ($gn)" : "";
	    $fh->read_text("    GERUND: $ge$gn$ju$ab$qu\n");
	    _fold($fh, "    DEPENDS ON", join(' ', @ru));
	    _list_code($fh, $cs, $xs, $xs + $xl);
	    $fh->read_text("\n");
	}
    }

    # grammar and symbol table listing
    $fh->read_text("SYMBOL TABLE:\n");
    _list_symbols($fh, $object->symboltable);
    $fh->read_text("\n");
    for (my $p = 1; $p <= $object->num_parsers; $p++) {
	$fh->read_text("GRAMMAR #$p:\n");
	_list_grammar($fh, $int, $p, $object->symboltable, $object->parser($p));
	$fh->read_text("\n");
    }

    # register listing
    $fh->read_text("REGISTERS:\n");
    my $rcode = sub {
	my ($rname, $rvalue) = @_;
	my $d = reg_decode($rname);
	$rname = "$d ($rname)" if $d ne $rname;
	$fh->read_text("    $rname\n");
	_fold($fh, "        ", $rvalue->print) if $d !~ /^\@/;
    };
    $int->allreg($rcode, 'n');
    $fh->read_text("\n");

    # XXX optimiser listing
}

sub _fold {
    my ($fh, $first, $text) = @_;
    $first .= ': ' if $first =~ /\S/ && $text =~ /\S/;
    my $space = 74 - length($first);
    while (length($text) > $space) {
	my $l = substr($text, 0, $space);
	$l =~ s/\S+$//;
	$l =~ s/\s+$//;
	$l = substr($text, 0, $space) if $l eq '';
	$fh->read_text($first . $l . "\n");
	$first = ' ' x length $first;
	substr($text, 0, length $l) = '';
	$text =~ s/^\s+//;
    }
    $fh->read_text($first . $text . "\n");
}

sub _code_text {
    my ($fh, $cs, $cp, $ep) = @_;
    my $len = bc_skip($cs, $cp, $ep);
    if (! defined $len) {
	_code_line($fh, $cs, $cp, 1, '???', 0);
	return 1;
    }
    my $v = ord(substr($cs, $cp, 1));
    my ($op, $desc, $type, $value, $args, $function) = bytedecode($v);
    my $sp = 0;
    if ($len >= BYTES_PER_LINE) {
	_code_line($fh, $cs, $cp, 1, $op, 0);
	$cp++;
	$type = $args;
	$sp = 2;
    }
    my @text = ();
    my $co = sub {
	my ($byte, $name) = @_;
	if (defined $name) {
	    push @text, $name;
	} else {
	    if (@text) {
		my $text = join(' ', @text);
		$text =~ s/<\s+/</g;
		$text =~ s/\s+>/>/g;
		_code_line($fh, $cs, $cp, $byte - $cp, $text, $sp);
		@text = ();
	    }
	    $cp = $byte;
	}
    };
    bc_forall($type, $cs, $cp, $ep, $co);
    return $len;
}

sub _list_code {
    my ($fh, $cs, $cp, $ep) = @_;
    while ($cp < $ep) {
	$cp += _code_text($fh, $cs, $cp, $ep);
    }
}

sub _code_line {
    my ($fh, $cs, $cp, $cl, $ts, $sp) = @_;
    while ($cl > 0 || $ts ne '') {
	my $code = sprintf("        %04X", $cp);
	my $c = $cl > BYTES_PER_LINE ? BYTES_PER_LINE : $cl;
	$cl -= $c;
	while ($c-- > 0) {
	    my $byte = ord(substr($cs, $cp++, 1));
	    $code .= sprintf(" %02X", $byte);
	}
	$code .= ' ' x (40 + $sp - length $code);
	my $text = substr($ts, 0, 32 - $sp);
	$text =~ s/\S+$// if $text ne $ts;
	$text =~ s/\s+$//;
	$text = substr($ts, 0, 32 - $sp) if $text eq '';
	$fh->read_text($code . $text . "\n");
	$ts = substr($ts, length $text);
	$ts =~ s/^\s+//;
    }
}

sub _list_symbols {
    my ($fh, $table) = @_;
    my %s = map { ($table->symbol($_) => $_) } (1..$table->max);
    my $lk = 0;
    my $lv = 0;
    for my $s (keys %s) {
	$lk = length($s) if $lk < length($s);
	$lv = length($s{$s}) if $lv < length($s{$s});
    }
    my $ll = $lk + $lv + 3;
    my @s0 = map { sprintf("%-${ll}s", "$_: $s{$_}") }
		 sort { lc($a) cmp lc($b) } keys %s;
    my @s1 = map { sprintf("%${lv}d: %s", $s{$_}, $_) }
		 sort { $s{$a} <=> $s{$b} } keys %s;
    while (@s0) {
	$fh->read_text("    " . shift(@s0) . "     " . shift(@s1) . "\n");
    }
}

sub _list_grammar {
    my ($fh, $int, $gra, $table, $grammar) = @_;
    my $rules = $int->getrules($gra);
    my $code = sub {
	my ($g, $s, $prodnum, $sym, $left, $right) = @_;
	# determine if these rules are enabled
	my $enab = $rules->[$prodnum] && ${$rules->[$prodnum]}
		 ? "ENABLED"
		 : "DISABLED";
	$fh->read_text("    #$prodnum $enab\n");
	my $start = "        ?" . $table->symbol($sym);
	my $data = '';
	$data .= ' ,,' unless @$left;
	for my $l (@$left) {
	    my ($t, $v, $c) = @$l;
	    if ($t eq 's') {
		$data .= ' ?' . $table->symbol($v);
	    } else {
		$data .= ' ,';
		$data .= '!' if $t eq 'r';
		if ($v =~ /^[^\W_]+$/) {
		    $data .= $v;
		} else {
		    $data .= join(' + ', map { "#$_" } unpack('C*', $v));
		}
		$data .= ',';
	    }
	    $data .= '=' . $c if $c && $c < 65535;
	    $data .= '=*' if $c == 65535;
	}
	$data .= ' ==>';
	while (@$right) {
	    my ($t, $c, $v) = @{shift @$right};
	    if ($t eq 's' || $t eq 'n') {
		$data .= ' ';
		$data .= $t eq 'n' ? '!' : '?';
		$data .= $table->symbol($v);
	    } elsif ($t eq 'c' || $t eq 'r') {
		$data .= ' ,';
		$data .= '!' if $t eq 'r';
		if ($v =~ /^[^\W_]+$/) {
		    $data .= $v;
		} else {
		    $data .= join(' + ', map { "#$_" } unpack('C*', $v));
		}
		$data .= ',';
	    } elsif ($t eq 'b') {
		if ($c eq '') {
		    $data .= ' ,,';
		} else {
		    my $plus = ' ';
		    for my $u (unpack('C*', $c)) {
			$data .= $plus;
			$data .= bytedecode($u) || "?#$u";
			$plus = ' + ';
		    }
		}
		next;
	    } elsif ($t eq 'm') {
		unshift @$right, @$c;
		next;
	    } elsif ($t eq '*') {
		$data .= ' *';
		next;
	    } else {
		$data .= '???';
	    }
	    $data .= ' #' . $c;
	}
	$data =~ s/^ //;
	_fold($fh, $start, $data);
    };
    $grammar->forall($code);
}

1;
__END__

sub _list_right {
    my ($indent, $left, $right, $s, $fh) = @_;
    my $i = $indent;
    for (my $ep = 0; $ep < @$right; $ep++) {
	my ($type, $value) = @{$right->[$ep]};
	if ($type eq 's' || $type eq 'n') {
	    my $w = $value + 1;
	    my $bang = $type eq 'n' ? '!' : '';
	    $fh->read_text("$i$bang$s->[$left->[$value][1]]($w)");
	} elsif ($type eq 'r') {
	    my $v = $left->[$value][1];
	    $v =~ s/([\\\@])/\\$1/g;
	    $v =~ s/\n/\\n/g;
	    $v =~ s/\t/\\t/g;
	    $v =~ s/([\000-\037\177-\377])/
		    sprintf "\\%03o", ord($1)/ge;
	    my $w = $value + 1;
	    $fh->read_text("$i\@$v\@($w)");
	} elsif ($type eq 'c') {
	    my $v = $left->[$value][1];
	    $v =~ s/([\\"])/\\$1/g;
	    $v =~ s/\n/\\n/g;
	    $v =~ s/\t/\\t/g;
	    $v =~ s/([\000-\037\177-\377])/
		    sprintf "\\%03o", ord($1)/ge;
	    my $w = $value + 1;
	    $fh->read_text("$i\"$v\"($w)");
	} elsif ($type eq 'b') {
	    $fh->read_text("$i\{\n");
	    $ep++;
	    while ($ep < @$right && $right->[$ep][0] eq 'b') {
		$value .= $right->[$ep][1];
		$ep++;
	    }
	    $ep--;
	    _list_code($value, $fh, $indent . '    ');
	    $fh->read_text("$indent}");
	} elsif ($type eq 'm') {
	    $fh->read_text("$i\{{\n");
	    _list_right($indent . '    ', $left, $value, $s, $fh);
	    $fh->read_text("$indent}}");
	}
	$i = ' ' ;
    }
    $fh->read_text("\n");
}

1;