#!/afs/athena/contrib/perl/perl

$DBG_PARSE_STR=0x01;  $DBG_PARSE_COMMENT=0x02;  $DBG_PARSE_BLOCK=0x04;
$DBG_PARSE=($DBG_PARSE_STR | $DBG_PARSE_COMMENT | $DBG_PARSE_BLOCK);
$DBG_SYNTAX=0x10;   $DBG_CHAR=0x100;
$DBG_ALL = 0xFF;    $DBG_ALL_REALLY = 0xFFF;

$DEBUG = $DBG_ALL;

## syntactic class definitions (must be single characters right now)

&block('{', '}');   &block('[', ']');   &block('(', ')');

&comment('#', "\n");

&string('"', '"');

## start!

&parse;

##### subroutines

## syntax definition processing code

sub block {
    local($open, $close) = @_;
    print STDERR "syntax> defining block:    ",&pstr($open),"...",
                                  &pstr($close),"\n" if ($DEBUG & $DBG_SYNTAX);
    $openblock{$open} = $close;
    $closeblock{$close} = $open;
}

sub comment {
    local($open, $close) = @_;
    print STDERR "syntax> defining comment:  ",&pstr($open),"...",
                                  &pstr($close),"\n" if ($DEBUG & $DBG_SYNTAX);
    $opencomment{$open} = $close;
    $closecomment{$close} = $open;
}

sub string {
    local($open, $close) = @_;
    print STDERR "syntax> defining string:   ",&pstr($open),"...",
                                  &pstr($close),"\n" if ($DEBUG & $DBG_SYNTAX);
    $openstring{$open} = $close;
    $closestring{$close} = $open;
}

## simple finite-state-machine parsing code

sub parse_string {
    local($save, $end_delim) = @_;
    local($n);
    local(@trace) = ("while parsing a string, start=" . &pstr($save)
		     . ", end=" . &pstr($end_delim), @trace);

    while (($n = &next_char) ne "") {
	$save .= $n;
	if ($n =~ /[$end_delim]/) {
	    print STDERR "parse> string: ", &pstr($save), "\n"
		if ($DEBUG & $DBG_PARSE_STR);
	    # normal exit point from this function is here.
	    return $save;
	}
	# all other characters are ignored inside strings.
    }

    # if we end up here, we've reached the end of file unexpectedly.
    print STDERR "Unexpected end of file\n\t", join("\n\t", @trace), "\n";
    print STDERR "Partial result: ", &pstr($save), "\n";
    exit(1);
}

# this one is identical, but the debugging output is different. =)
sub parse_comment {
    local($save, $end_delim) = @_;
    local($n);
    local(@trace) = ("while parsing a comment, start=" . &pstr($save)
		     . ", end=" . &pstr($end_delim), @trace);

    while (($n = &next_char) ne "") {
	$save .= $n;
	if ($n =~ /[$end_delim]/) {
	    print STDERR "parse> comment: ", &pstr($save), "\n"
		if ($DEBUG & $DBG_PARSE_COMMENT);
	    # normal exit point from this function is here.
	    return $save;
	}
	# all other characters are ignored inside comment.
    }

    # if we end up here, we've reached the end of file unexpectedly.
    print STDERR "Unexpected end of file\n\t", join("\n\t", @trace), "\n";
    print STDERR "Partial result: ", &pstr($save), "\n";
    exit(1);
}

sub parse_block {
    local($save, $end_delim) = @_;
    local($n);
    local(@trace) = ("while parsing a block, start=" . &pstr($save)
		     . ", end=" . &pstr($end_delim), @trace);

  CHAR:
    while (($n = &next_char) ne "") {
	if ($end_delim && ($n =~ /[$end_delim]/)) {
	    $save .= $n;
	    print STDERR "parse> block: ", &pstr($save), "\n"
		if ($DEBUG & $DBG_PARSE_BLOCK);
	    # normal exit point from this function is here.
	    return $save;
	}
	($opencomment{$n}) &&
	    ($save .= &parse_comment($n, $opencomment{$n}), next CHAR);
	($openstring{$n}) &&
	    ($save .= &parse_string($n, $openstring{$n}), next CHAR);
	($openblock{$n}) &&
	    ($save .= &parse_block($n, $openblock{$n}), next CHAR);

	$save .= $n;
#	($closecomment{$n}) &&
#	    (&warn_matchless($n, 'comment '), next CHAR);
	($closestring{$n}) &&
	    (&warn_matchless($n, 'string '), next CHAR);
	($closeblock{$n}) &&
	    (&warn_matchless($n, 'block '), next CHAR);
    }

    # if we end up here, we've reached the end of file.
    # if $end_delim is empty, we were waiting for that.
    if (! $end_delim) {
	print STDERR "parse> level: ", &pstr($save), "\n"
	    if ($DEBUG & $DBG_PARSE_BLOCK);
	return $save;
    }

    # if we end up here, we've reached the end of file unexpectedly.
    print STDERR "Unexpected end of file\n\t", join("\n\t", @trace), "\n";
    print STDERR "Partial result: ", &pstr($save), "\n";
    exit(1);
}

sub parse {
    return &parse_block;
}

## helper functions

sub warn_matchless {
    local($delim, $type) = @_;
    printf STDERR "Warning: unmatched closing %sdelimiter: %s\n",
	   $type, &pstr($delim);
}

sub pchr {
    if ((@_[0] gt "\040") && (@_[0] lt "\177")) {
	return @_[0];
    } else {
	return sprintf("\\%03o", ord(@_[0]));
    }
}

sub pstr {
    local($result);
    for $i (split (//, @_[0])) {
	$result .= &pchr($i);
    }
    return $result;
}

sub next_char {
    if (! @buf) {
	local($_) = scalar(<>);
	if ($_) {
	    @buf = split(//);
	}
    }

    if (@buf) {
	print STDERR "next_char> ", &pchr($buf[0]), "\n"
	    if ($DEBUG & $DBG_CHAR);
	return shift(@buf);
    } else {
	print STDERR "next_char> end_of_file\n"
	    if ($DEBUG & $DBG_CHAR);
	return undef;
    }
}