# $Id: zwgc2zion_rules.pm,v 1.5 1996/09/08 23:58:32 bert Exp $

package zwgc2zion_rules;

use vars qw( @functions @operators @commands @tokens );
use vars qw( %function  %operator  %command  %regop);

use vars qw ( $VERSION $DATE $header $footer );

$VERSION = '0.201';
$DATE = '<08sep1996>';
# $Revision: 1.5 $

$header = <<"EndOfHeader";
use FileHandle;
use IPC::Open2;

use lib '/afs/sipb/user/bert/dev/zion/dev';
use Zion::Zwgc 0.20;
BEGIN { \$Zion::Zwgc::Debug = 1; }   # comment this out to suppress messages

use vars qw( \%ZVAR \%port );
\%ZVAR = Zion::Zwgc::zephyr_variables("\$ENV{'HOME'}/.zephyr.vars")
	unless \%ZVAR;

my \$_buffer_ = '';
my \@fields = Zion::fields();

EndOfHeader
$footer = '';

#### support functions

sub argl {
  my @argl = ( '(', ( '{expr}', ',' ) x $_[0] );
  $argl[$#argl ? $#argl : 1] = ')';
  \@argl;  # [this works because @argl is my()!]
}

sub tokens2vars_1 {
  map( ($_ eq ',' ? $_ : "\$$_"), @{$_[1]});
}

#### classification of tokens

@functions = ('buffer', 'downcase', 'get', 'getenv', 'lany', 'lbreak',
	      'lspan', 'protect', 'rany', 'rbreak', 'rspan',
	      'substitute', 'upcase', 'verbatim', 'zvar' );

@primary   = ('appendport', 'break', 'case', 'clearbuf', 'closeinput',
	      'closeoutput', 'closeport', 'fields', 'exec',
	      'execport', 'exit', 'if', 'inputport', 'noop',
	      'outputport', 'print', 'put', 'set', 'show', 'while');
@commands  = (@primary, 'default', 'match', 'endcase', 'then',
	      'elseif', 'else', 'endif', 'do', 'endwhile' );

%function  =  map( ($_, 1), @functions);
%primary   =  map( ($_, 1), @primary);
%command   =  map( ($_, 1), @commands);

%regop     = ('=~'		=> '=~',
	      '!~'		=> '!~');
%operator  = (%regop,
	      '+'		=> '.',
	      '=='		=> ' eq ',
	      '!='		=> ' ne ',
	      '&'		=> '&&',
	      '|'		=> '||',
	      '!'		=> '!');
@operators = keys %operator;

#### translation mappings: currently hairy and undocumented

## Things that change @Zephyr[controls] and $variables embedded in strings.

$expect{'protect'}	= argl(1);
$perlify{'protect'}	= [' Zion::Zwgc::protect(', '$1', ')'];
$expect{'substitute'}	= argl(1);
$perlify{'substitute'}	= [' Zion::Zwgc::substitute(', '$1', ')'];
$expect{'verbatim'}	= argl(1);
$perlify{'verbatim'}	= [' Zion::Zwgc::verbatim(', '$1', ')'];

## Things that transform strings.

$expect{'downcase'}	= argl(1);
$perlify{'downcase'}	= [' lc(', '$1', ')'];
$expect{'upcase'}	= argl(1);
$perlify{'upcase'}	= [' uc(', '$1', ')'];

## Things that may modify string variables.

$expect{'lany'}		= argl(2);;
$perlify{'lany'}	= [ sub {
  my ($state, $expr1, $expr2) = @_;
  if (($#$expr1 == 0) && ($expr1->[0] =~ /^\$/)) {
    # the first arg is a variable, and thus modifiable.
    ( ' Zion::Zwgc::any(', '\\' . $expr1->[0], ', 0, length(', @$expr2, '))' );
  } else {
    # the first arg is not modifiable; a substr will do.
    ( ' substr(', @$expr1, ', 0, length(', @$expr2, '))' );
  }
} ];

$expect{'rany'}		= argl(2);;
$perlify{'rany'}	= [ sub {
  my ($state, $expr1, $expr2) = @_;
  if (($#$expr1 == 0) && ($expr1->[0] =~ /^\$/)) {
    # the first arg is a variable, and thus modifiable.
    ( ' Zion::Zwgc::any(', '\\' . $expr1->[0], ', -length(', @$expr2, '))' );
  } else {
    # the first arg is not modifiable; a substr will do.
    ( ' substr(', @$expr1, ', -length(', @$expr2, '))' );
  }
} ];

$expect{'lbreak'}	= argl(2);;
$perlify{'lbreak'}	= [ sub {
  my ($state, $expr1, $expr2) = @_;
  my (@charset);
  if (($#$expr1 == 0) && ($expr1->[0] =~ /^\$/)) {
    # the first arg is a variable, and thus modifiable.
    ( ' Zion::Zwgc::break(', '\\' . $expr1->[0], ', "^", ', @$expr2, ', "")' );
  } else {
    # the first arg is not modifiable; a match will do.
    if (($#$expr1 == 0) && ($expr1->[0] =~ /^\"/)) {	# "
      # The second arg is a string.
      @charset = ($expr2->[0]);
      $charset[0] =~ s/^\"/m"^([^\\Q/;
      $charset[0] =~ s/\"$/\\E]*)"/;
    } else {
      # The second arg is truly an expression.
      @charset = ( 'm{^([^\Q@{[', @$expr2, ']}\E]*)}' );
    }
    ( '((', @$expr1, ') =~ ', @charset, ')[0]' );
  }
} ];

$expect{'rbreak'}	= argl(2);;
$perlify{'rbreak'}	= [ sub {
  my ($state, $expr1, $expr2) = @_;
  my (@charset);
  if (($#$expr1 == 0) && ($expr1->[0] =~ /^\$/)) {
    # the first arg is a variable, and thus modifiable.
    ( ' Zion::Zwgc::break(', '\\' . $expr1->[0], ', "", ', @$expr2, ', "\$")');
  } else {
    # the first arg is not modifiable; a match will do.
    if (($#$expr1 == 0) && ($expr1->[0] =~ /^\"/)) {	# "
      # The second arg is a string.
      @charset = ($expr2->[0]);
      $charset[0] =~ s/^\"/m"([^\\Q/;
      $charset[0] =~ s/\"$/\\E]*)\$"/;
    } else {
      # The second arg is truly an expression.
      @charset = ( 'm{([^\Q@{[', @$expr2, ']}\E]*)$}' );
    }
    ( '((', @$expr1, ') =~ ', @charset, ')[0]' );
  }
} ];

$expect{'lspan'}	= argl(2);;
$perlify{'lspan'}	= [ sub {
  my ($state, $expr1, $expr2) = @_;
  my (@charset);
  if (($#$expr1 == 0) && ($expr1->[0] =~ /^\$/)) {
    # the first arg is a variable, and thus modifiable.
    ( ' Zion::Zwgc::span(', '\\' . $expr1->[0], ', "^", ', @$expr2, ', "")' );
  } else {
    # the first arg is not modifiable; a match will do.
    if (($#$expr1 == 0) && ($expr1->[0] =~ /^\"/)) {	# "
      # The second arg is a string.
      @charset = ($expr2->[0]);
      $charset[0] =~ s/^\"/m"^([\\Q/;
      $charset[0] =~ s/\"$/\\E]*)"/;
    } else {
      # The second arg is truly an expression.
      @charset = ( 'm{^([\Q@{[', @$expr2, ']}\E]*)}' );
    }
    ( '((', @$expr1, ') =~ ', @charset, ')[0]' );
  }
} ];

$expect{'rspan'}	= argl(2);;
$perlify{'rspan'}	= [ sub {
  my ($state, $expr1, $expr2) = @_;
  my (@charset);
  if (($#$expr1 == 0) && ($expr1->[0] =~ /^\$/)) {
    # the first arg is a variable, and thus modifiable.
    ( ' Zion::Zwgc::span(', '\\' . $expr1->[0], ', "", ', @$expr2, ', "\$")');
  } else {
    # the first arg is not modifiable; a match will do.
    if (($#$expr1 == 0) && ($expr1->[0] =~ /^\"/)) {	# "
      # The second arg is a string.
      @charset = ($expr2->[0]);
      $charset[0] =~ s/^\"/m"([\\Q/;
      $charset[0] =~ s/\"$/\\E]*)\$"/;
    } else {
      # The second arg is truly an expression.
      @charset = ( 'm{([\Q@{[', @$expr2, ']}\E]*)$}' );
    }
    ( '((', @$expr1, ') =~ ', @charset, ')[0]' );
  }
} ];

## Things that set variables.

$expect{'set'}		= ['{token}', '=', '{expr}'];
$perlify{'set'}		= [ \&tokens2vars_1, '=', '$2', ';'];

$expect{'fields'}	= ['{tokens}'];
$perlify{'fields'}	= ['(', \&tokens2vars_1, ') = @fields; '];

## Things that control the flow.

$expect{'if'}		= ['{expr}',		':: >if @then'];
$perlify{'if'}		= [' if( ', '$1', ' ) '];
$expect{'then'}		= [':: ?if', '{cmds}',	':: @elseif/else/endif'];
$perlify{'then'}	= ['{', '$1', '}'];
$expect{'elseif'}	= [':: ?if', '{expr}',	':: @then'];
$perlify{'elseif'}	= [' elsif( ', '$1', ' ) '];
$expect{'else'}		= [':: ?if', '{cmds}',	':: @endif'];
$perlify{'else'}	= ['{', '$1', '}'];
$expect{'endif'}	= [			':: <if'];
$perlify{'endif'}	= [];

$expect{'case'}		= ['{expr}',		 ':: >case @match/default'];
$perlify{'case'}	= ['{', 'my $_case_ = ', '$1', ';',
			   ' if (0) {}', " # so every 'match' is an elsif\n"];
$expect{'match'}	= [':: ?case', '{expr,s}', '{cmds}',
			   			 ':: @match/default/endcase'];
$perlify{'match'}	= [' elsif(grep($_case_ eq $_,','$1','))',
			   '{', '$2', '}'];
$expect{'default'}	= [':: ?case', '{cmds}', ':: @endcase'];
$perlify{'default'}	= [' else ', '{', '$1', '}'];
$expect{'endcase'}	= [			 ':: <case'];
$perlify{'endcase'}	= ['}'];

$expect{'while'}	= ['{expr}',			':: >while @do'];
$perlify{'while'}	= [' while( ', '$1', ' ) '];
$expect{'do'}		= [':: ?while', '{cmds}',	':: @endwhile'];
$perlify{'do'}		= ['{', '$1', '}'];
$expect{'endwhile'}	= [				':: <while'];
$perlify{'endwhile'}	= [];

$expect{'exit'}		= [];
$perlify{'exit'}	= [' exit; '];

$expect{'break'}	= [];
$perlify{'break'}	= [ sub {
  my ($state) = @_;
  @$state || croak("can't break out of the top level\n  aborting");
  ($state->[0] eq 'while')
          || croak("can't break out of a \U$state->[0]\E block\n  aborting");
  ( ' last;' );
} ];

## Things which deal with the "current output buffer".

$expect{'buffer'}	= argl(0);
$perlify{'buffer'}	= [' ($_buffer_) '];
$expect{'clearbuf'}	= [];
$perlify{'clearbuf'}	= [' $_buffer_ = ""; '];
$expect{'print'}	= ['{expr s}'];
$perlify{'print'}	= [' $_buffer_ .= join(" ", ', '$1', '); '];

## Things which suck and blow (excuse me, do I/O).

$expect{'put'}		= ['{expr s}'];
$perlify{'put'}		= [ sub {
  my ($state, $expr_ref) = @_;
  my (@expr_l) = @$expr_ref;
  my (@comma) = grep( $expr_l[$_] eq ',', 0..$#expr_l );
  if (! @expr_l) {
    # no arguments: just call Zion::put().
    (' Zion::put($_buffer_); ');
  } elsif (@comma) {
    # 2 or more arguments: use the specified port and data
    my (@port) = splice @expr_l, 0, $comma[0]+1;
    pop @port;	# remove the final ','
    (' print { $port{', @port, '}->[1] } join(" ", ', @expr_l, '); ');
  } else {
    # 1 argument: use the specified port and the output buffer
    (' print { $port{', @expr_l, '}->[1] }  $_buffer_; ');
  }
} ];


$expect{'get'}		= ['{expr}'];
$perlify{'get'}		= [' <($port{', '$1', '}->[0])> '];

$expect{'inputport'}	= ['{expr}', '{expr}'];
$perlify{'inputport'}	= [' $port{','$1','} = [ new FileHandle "<" . ','$2',
			   ', undef ]; '];
$expect{'outputport'}	= ['{expr}', '{expr}'];
$perlify{'outputport'}	= [' $port{','$1','} = [ undef, ',
			   ' new FileHandle ">" . ', '$2', ' ]; '];
$expect{'appendport'}	= ['{expr}', '{expr}'];
$perlify{'appendport'}	= [' $port{','$1','} = [ undef, ',
			   ' new FileHandle ">>" . ', '$2', ' ]; '];

$expect{'closeinput'}	= ['{expr}'];
$perlify{'closeinput'}	= ['{', 'my $P = $port{', '$1', '};',
			   ' close($P->[0]); ', ' $P->[0] = undef; ', '}'];
$expect{'closeoutput'}	= ['{expr}'];
$perlify{'closeoutput'}	= ['{', 'my $P = $port{', '$1', '};',
			   ' close($P->[1]); ', ' $P->[1] = undef; ', '}'];
$expect{'closeport'}	= ['{expr}'];
$perlify{'closeport'}	= ['{', 'my $P = $port{', '$1', '};',
			   ' close($P->[0]); ', ' close($P->[1]); ',
			   ' $#$P = -1; ', '}'];

## Things that go exec in the night.

$expect{'exec'}		= ['{expr}', '{expr s}'];
$perlify{'exec'}	= [' system ', '$1', ' ', '$1', ', ', '$2', '; '];

$expect{'execport'}	= ['{expr}', '{expr s}'];
$perlify{'execport'}	= ['{ my $P = [ new FileHandle, new FileHandle ]; ',
			   ' open2( $P->[0], $P->[1], ', '$2', '); ',
			   '$port{','$1','} = $P; }'];

## Things that go "boink" (and are thus like scientific progress).

$expect{'getenv'}	= argl(1);
$perlify{'getenv'}	= [' $ENV{', '$1', '}'];
$expect{'zvar'}		= argl(1);
$perlify{'zvar'}	= [' $ZVAR{', '$1', '}'];    # see $header for support

1;

# $expect{''}	= argl(1);
# $perlify{''}	= [' Zion::Zwgc::(', '$1', ')'];

# CURRENTLY UNSUPPORTED COMMANDS:
#	      'noop'
#	      'show'
# COMMANDS WHOSE IMPLEMENTATION MAY NOT MATCH ALL ZWGC.DESC CASES:
#	      'break'
