dist-3.0at70b/mcon/pl/eval.pl

   1 ;# $Id: eval.pl,v 3.0.1.1 1995/01/30 14:48:37 ram Exp $
   2 ;#
   3 ;#  Copyright (c) 1991-1993, Raphael Manfredi
   4 ;#
   5 ;#  You may redistribute only under the terms of the Artistic Licence,
   6 ;#  as specified in the README file that comes with the distribution.
   7 ;#  You may reuse parts of this distribution only within the terms of
   8 ;#  that same Artistic Licence; a copy of which may be found at the root
   9 ;#  of the source tree for dist 3.0.
  10 ;#
  11 ;# $Log: eval.pl,v $
  12 ;# Revision 3.0.1.1  1995/01/30  14:48:37  ram
  13 ;# patch49: removed old "do name()" routine call constructs
  14 ;#
  15 ;# Revision 3.0  1993/08/18  12:10:22  ram
  16 ;# Baseline for dist 3.0 netwide release.
  17 ;#
  18 ;#
  19 ;# The built-in interpreter
  20 ;#
  21 package interpreter;
  22
  23 # States used by our interpeter -- in sync with @Keep
  24 sub main'init_keep {
  25         # Status in which we keep lines -- $Keep[$status]
  26         @Keep = (0, 1, 1, 0, 1);
  27
  28         # Available status ($status)
  29         $SKIP = 0;
  30         $IF = 1;
  31         $ELSE = 2;
  32         $NOT = 3;
  33         $OUT = 4;
  34 }
  35
  36 # Priorities for operators -- magic numbers :-)
  37 sub main'init_priority {
  38         $Priority{'&&'} = 4;
  39         $Priority{'||'} = 3;
  40 }
  41
  42 # Initializes the state stack of the interpreter
  43 sub main'init_interp {
  44         @state = ();
  45         push(@state, $OUT);
  46 }
  47
  48 # Print error messages -- asssumes $unit and $. correctly set.
  49 sub error {
  50         warn "\"$main'file\", line $.: @_.\n";
  51 }
  52
  53 # If some states are still in the stack, warn the user
  54 sub main'check_state {
  55         &error("one statement pending") if $#state == 1;
  56         &error("$#state statements pending") if $#state > 1;
  57 }
  58
  59 # Add a value on the stack, modified by all the monadic operators.
  60 # We use the locals @val and @mono from eval_expr.
  61 sub push_val {
  62         local($val) = shift(@_);
  63         while ($#mono >= 0) {
  64                 # Cheat... the only monadic operator is '!'.
  65                 pop(@mono);
  66                 $val = !$val;
  67         }
  68         push(@val, $val);
  69 }
  70
  71 # Execute a stacked operation, leave result in stack.
  72 # We use the locals @val and @op from eval_expr.
  73 # If the value stack holds only one operand, do nothing.
  74 sub execute {
  75         return unless $#val > 0;
  76         local($op) = pop(@op);
  77         local($val1) = pop(@val);
  78         local($val2) = pop(@val);
  79         push(@val, eval("$val1 $op $val2") ? 1: 0);
  80 }
  81
  82 # Given an operator, either we add it in the stack @op, because its
  83 # priority is lower than the one on top of the stack, or we first execute
  84 # the stacked operations until we reach the end of stack or an operand
  85 # whose priority is lower than ours.
  86 # We use the locals @val and @op from eval_expr.
  87 sub update_stack {
  88         local($op) = shift(@_);         # Operator
  89         if (!$Priority{$op}) {
  90                 &error("illegal operator $op");
  91                 return;
  92         } else {
  93                 if ($#val < 0) {
  94                         &error("missing first operand for '$op' (diadic operator)");
  95                         return;
  96                 }
  97                 # Because of the special behaviour of do-SUBR with the while modifier,
  98                 # I'm using a while-BLOCK construct. I consider this to be a bug of perl
  99                 # 4.0 PL19, although it is clearly documented in the man page.
 100                 while (
 101                         $Priority{$op[$#op]} > $Priority{$op}   # Higher priority op
 102                         && $#val > 0                                                    # At least 2 values
 103                 ) {
 104                         &execute;               # Execute an higher priority stacked operation
 105                 }
 106                 push(@op, $op);         # Everything at higher priority has been executed
 107         }
 108 }
 109
 110 # This is the heart of our little interpreter. Here, we evaluate
 111 # a logical expression and return its value.
 112 sub eval_expr {
 113         local(*expr) = shift(@_);       # Expression to parse
 114         local(@val) = ();                       # Stack of values
 115         local(@op) = ();                        # Stack of diadic operators
 116         local(@mono) =();                       # Stack of monadic operators
 117         local($tmp);
 118         $_ = $expr;
 119         while (1) {
 120                 s/^\s+//;                               # Remove spaces between words
 121                 # The '(' construct
 122                 if (s/^\(//) {
 123                         &push_val(&eval_expr(*_));
 124                         # A final '\' indicates an end of line
 125                         &error("missing final parenthesis") if !s/^\\//;
 126                 }
 127                 # Found a ')' or end of line
 128                 elsif (/^\)/ || /^$/) {
 129                         s/^\)/\\/;                                              # Signals: left parenthesis found
 130                         $expr = $_;                                             # Remove interpreted stuff
 131                         &execute() while $#val > 0;             # Executed stacked operations
 132                         while ($#op >= 0) {
 133                                 $_ = pop(@op);
 134                                 &error("missing second operand for '$_' (diadic operator)");
 135                         }
 136                         return $val[0];
 137                 }
 138                 # A perl statement '{{'
 139                 elsif (s/^\{\{//) {
 140                         if (s/^(.*)\}\}//) {
 141                                 &push_val((system
 142                                         ('perl','-e', "if ($1) {exit 0;} else {exit 1;}"
 143                                         ))? 0 : 1);
 144                         } else {
 145                                 &error("incomplete perl statement");
 146                         }
 147                 }
 148                 # A shell statement '{'
 149                 elsif (s/^\{//) {
 150                         if (s/^(.*)\}//) {
 151                                 &push_val((system
 152                                         ("if $1 >/dev/null 2>&1; then exit 0; else exit 1; fi"
 153                                         ))? 0 : 1);
 154                         } else {
 155                                 &error("incomplete shell statement");
 156                         }
 157                 }
 158                 # Operator '||' and '&&'
 159                 elsif (s/^(\|\||&&)//) {
 160                         $tmp = $1;                      # Save for perl5 (Dataloaded update_stack)
 161                         &update_stack($tmp);
 162                 }
 163                 # Unary operator '!'
 164                 elsif (s/^!//) {
 165                         push(@mono,'!');
 166                 }
 167                 # Everything else is a test for a defined value
 168                 elsif (s/^([\?%]?\w+)//) {
 169                         $tmp = $1;
 170                         # Test for wanted
 171                         if ($tmp =~ s/^\?//) {
 172                                 &push_val(($main'symwanted{$tmp})? 1 : 0);
 173                         }
 174                         # Test for conditionally wanted
 175                         elsif ($tmp =~ s/^%//) {
 176                                 &push_val(($main'condwanted{$tmp})? 1 : 0);
 177                         }
 178                         # Default: test for definition (see op @define)
 179                         else {
 180                                 &push_val((
 181                                         $main'symwanted{$tmp} ||
 182                                         $main'cmaster{$tmp} ||
 183                                         $main'userdef{$tmp}) ? 1 : 0);
 184                         }
 185                 }
 186                 # An error occured -- we did not recognize the expression
 187                 else {
 188                         s/^([^\s\(\)\{\|&!]+)//;        # Skip until next meaningful char
 189                 }
 190         }
 191 }
 192
 193 # Given an expression in a '@' command, returns a boolean which is
 194 # the result of the evaluation. Evaluate is collecting all the lines
 195 # in the expression into a single string, and then calls eval_expr to
 196 # really evaluate it.
 197 sub evaluate {
 198         local($val);                    # Value returned
 199         local($expr) = "";              # Expression to be parsed
 200         chop;
 201         while (s/\\$//) {               # While end of line escaped
 202                 $expr .= $_;
 203                 $_ = <UNIT>;            # Fetch next line
 204                 unless ($_) {
 205                         &error("EOF in expression");
 206                         last;
 207                 }
 208                 chop;
 209         }
 210         $expr .= $_;
 211         while ($expr ne '') {
 212                 $val = &eval_expr(*expr);               # Expression will be modified
 213                 # We return from eval_expr either when a closing parenthisis
 214                 # is found, or when the expression has been fully analysed.
 215                 &error("extra closing parenthesis ignored") if $expr ne '';
 216         }
 217         $val;
 218 }
 219
 220 # Given a line, we search for commands (lines starting with '@').
 221 # If there is no command in the line, then we return the boolean state.
 222 # Otherwise, the command is analysed and a new state is computed.
 223 # The returned value of interpret is 1 if the line is to be printed.
 224 sub main'interpret {
 225         local($value);
 226         local($status) = $state[$#state];               # Current status
 227         if (s|^\s*@\s*(\w+)\s*(.*)|$2|) {
 228                 local($cmd) = $1;
 229                 $cmd =~ y/A-Z/a-z/;             # Canonicalize to lower case
 230                 # The 'define' command
 231                 if ($cmd eq 'define') {
 232                         chop;
 233                         $userdef{$_}++ if $Keep[$status];
 234                         return 0;
 235                 }
 236                 # The 'if' command
 237                 elsif ($cmd eq 'if') {
 238                         # We always evaluate, in order to find possible errors
 239                         $value = &evaluate($_);
 240                         if (!$Keep[$status]) {
 241                                 # We have to skip until next 'end'
 242                                 push(@state, $SKIP);            # Record structure
 243                                 return 0;
 244                         }
 245                         if ($value) {                   # True
 246                                 push(@state, $IF);
 247                                 return 0;
 248                         } else {                                # False
 249                                 push(@state, $NOT);
 250                                 return 0;
 251                         }
 252                 }
 253                 # The 'else' command
 254                 elsif ($cmd eq 'else') {
 255                         &error("expression after 'else' ignored") if /\S/;
 256                         $state[$#state] = $SKIP if $state[$#state] == $IF;
 257                         return 0 if $state[$#state] == $SKIP;
 258                         if ($state[$#state] == $OUT) {
 259                                 &error("unexpected 'else'");
 260                                 return 0;
 261                         }
 262                         $state[$#state] = $ELSE;
 263                         return 0;
 264                 }
 265                 # The 'elsif' command
 266                 elsif ($cmd eq 'elsif') {
 267                         # We always evaluate, in order to find possible errors
 268                         $value = &evaluate($_);
 269                         $state[$#state] = $SKIP if $state[$#state] == $IF;
 270                         return 0 if $state[$#state] == $SKIP;
 271                         if ($state[$#state] == $OUT) {
 272                                 &error("unexpected 'elsif'");
 273                                 return 0;
 274                         }
 275                         if ($value) {                   # True
 276                                 $state[$#state] = $IF;
 277                                 return 0;
 278                         } else {                                # False
 279                                 $state[$#state] = $NOT;
 280                                 return 0;
 281                         }
 282                 }
 283                 # The 'end' command
 284                 elsif ($cmd eq 'end') {
 285                         &error("expression after 'end' ignored") if /\S/;
 286                         pop(@state);
 287                         &error("unexpected 'end'") if $#state < 0;
 288                         return 0;
 289                 }
 290                 # Unknown command
 291                 else {
 292                         &error("unknown command '$cmd'");
 293                         return 0;
 294                 }
 295         }
 296         $Keep[$status];
 297 }
 298
 299 package main;
 300