rsalz@uunet.uu.net (Rich Salz) (07/12/88)
Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Posting-number: Volume 15, Issue 99
Archive-name: perl2/part10
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 15 through sh. When all 15 kits have been run, read README.
echo "This is perl 2.0 kit 10 (of 15). If kit 10 is complete, the line"
echo '"'"End of kit 10 (of 15)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg eg/g x2p 2>/dev/null
echo Extracting perl.y
sed >perl.y <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: perl.y,v 2.0 88/06/05 00:09:36 root Exp $
X *
X * $Log: perl.y,v $
X * Revision 2.0 88/06/05 00:09:36 root
X * Baseline version 2.0.
X *
X */
X
X%{
X#include "INTERN.h"
X#include "perl.h"
X
Xchar *tokename[] = {
X"256",
X"word",
X"append","open","write","select","close","loopctl",
X"using","format","do","shift","push","pop","chop/study",
X"while","until","if","unless","else","elsif","continue","split","sprintf",
X"for", "eof", "tell", "seek", "stat",
X"function(no args)","function(1 arg)","function(2 args)","function(3 args)","array function",
X"join", "sub", "file test", "local", "delete",
X"format lines",
X"register","array_length", "array",
X"s","pattern",
X"string","tr",
X"list operator",
X"..",
X"||",
X"&&",
X"==","!=", "EQ", "NE",
X"<=",">=", "LT", "GT", "LE", "GE",
X"unary operation",
X"file test",
X"<<",">>",
X"=~","!~",
X"unary -",
X"++", "--",
X"???"
X};
X
XSTAB *scrstab;
X
X%}
X
X%start prog
X
X%union {
X int ival;
X char *cval;
X ARG *arg;
X CMD *cmdval;
X struct compcmd compval;
X STAB *stabval;
X FCMD *formval;
X}
X
X%token <cval> WORD
X%token <ival> APPEND OPEN WRITE SELECT CLOSE LOOPEX
X%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
X%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT SPRINTF
X%token <ival> FOR FEOF TELL SEEK STAT
X%token <ival> FUNC0 FUNC1 FUNC2 FUNC3 STABFUN
X%token <ival> JOIN SUB FILETEST LOCAL DELETE
X%token <formval> FORMLIST
X%token <stabval> REG ARYLEN ARY
X%token <arg> SUBST PATTERN
X%token <arg> RSTRING TRANS
X
X%type <ival> prog decl format
X%type <stabval>
X%type <cmdval> block lineseq line loop cond sideff nexpr else
X%type <arg> expr sexpr term
X%type <arg> condmod loopmod
X%type <arg> texpr listop
X%type <cval> label
X%type <compval> compblock
X
X%nonassoc <ival> LISTOP
X%left ','
X%right '='
X%right '?' ':'
X%nonassoc DOTDOT
X%left OROR
X%left ANDAND
X%left '|' '^'
X%left '&'
X%nonassoc EQ NE SEQ SNE
X%nonassoc '<' '>' LE GE SLT SGT SLE SGE
X%nonassoc <ival> UNIOP
X%nonassoc FILETEST
X%left LS RS
X%left '+' '-' '.'
X%left '*' '/' '%' 'x'
X%left MATCH NMATCH
X%right '!' '~' UMINUS
X%nonassoc INC DEC
X%left '('
X
X%% /* RULES */
X
Xprog : lineseq
X { if (in_eval)
X eval_root = block_head($1);
X else
X main_root = block_head($1); }
X ;
X
Xcompblock: block CONTINUE block
X { $$.comp_true = $1; $$.comp_alt = $3; }
X | block else
X { $$.comp_true = $1; $$.comp_alt = $2; }
X ;
X
Xelse : /* NULL */
X { $$ = Nullcmd; }
X | ELSE block
X { $$ = $2; }
X | ELSIF '(' expr ')' compblock
X { cmdline = $1;
X $$ = make_ccmd(C_IF,$3,$5); }
X ;
X
Xblock : '{' lineseq '}'
X { $$ = block_head($2); }
X ;
X
Xlineseq : /* NULL */
X { $$ = Nullcmd; }
X | lineseq line
X { $$ = append_line($1,$2); }
X ;
X
Xline : decl
X { $$ = Nullcmd; }
X | label cond
X { $$ = add_label($1,$2); }
X | loop /* loops add their own labels */
X | label ';'
X { if ($1 != Nullch) {
X $$ = add_label($1, make_acmd(C_EXPR, Nullstab,
X Nullarg, Nullarg) );
X } else
X $$ = Nullcmd; }
X | label sideff ';'
X { $$ = add_label($1,$2); }
X ;
X
Xsideff : expr
X { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); }
X | expr condmod
X { $$ = addcond(
X make_acmd(C_EXPR, Nullstab, Nullarg, $1), $2); }
X | expr loopmod
X { $$ = addloop(
X make_acmd(C_EXPR, Nullstab, Nullarg, $1), $2); }
X ;
X
Xcond : IF '(' expr ')' compblock
X { cmdline = $1;
X $$ = make_ccmd(C_IF,$3,$5); }
X | UNLESS '(' expr ')' compblock
X { cmdline = $1;
X $$ = invert(make_ccmd(C_IF,$3,$5)); }
X | IF block compblock
X { cmdline = $1;
X $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
X | UNLESS block compblock
X { cmdline = $1;
X $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
X ;
X
Xloop : label WHILE '(' texpr ')' compblock
X { cmdline = $2;
X $$ = wopt(add_label($1,
X make_ccmd(C_WHILE,$4,$6) )); }
X | label UNTIL '(' expr ')' compblock
X { cmdline = $2;
X $$ = wopt(add_label($1,
X invert(make_ccmd(C_WHILE,$4,$6)) )); }
X | label WHILE block compblock
X { cmdline = $2;
X $$ = wopt(add_label($1,
X make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); }
X | label UNTIL block compblock
X { cmdline = $2;
X $$ = wopt(add_label($1,
X invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
X | label FOR REG '(' expr ')' compblock
X { cmdline = $2;
X /*
X * The following gobbledygook catches EXPRs that
X * aren't explicit array refs and translates
X * foreach VAR (EXPR) {
X * into
X * @ary = EXPR;
X * foreach VAR (@ary) {
X * where @ary is a hidden array made by genstab().
X */
X if ($5->arg_type != O_ARRAY) {
X scrstab = aadd(genstab());
X $$ = append_line(
X make_acmd(C_EXPR, Nullstab,
X l(make_op(O_ASSIGN,2,
X listish(make_op(O_ARRAY, 1,
X stab2arg(A_STAB,scrstab),
X Nullarg,Nullarg, 1)),
X listish($5),
X Nullarg,1)),
X Nullarg),
X wopt(over($3,add_label($1,
X make_ccmd(C_WHILE,
X make_op(O_ARRAY, 1,
X stab2arg(A_STAB,scrstab),
X Nullarg,Nullarg, 1 ),
X $7)))));
X }
X else {
X $$ = wopt(over($3,add_label($1,
X make_ccmd(C_WHILE,$5,$7) )));
X }
X }
X | label FOR '(' expr ')' compblock
X { cmdline = $2;
X if ($4->arg_type != O_ARRAY) {
X scrstab = aadd(genstab());
X $$ = append_line(
X make_acmd(C_EXPR, Nullstab,
X l(make_op(O_ASSIGN,2,
X listish(make_op(O_ARRAY, 1,
X stab2arg(A_STAB,scrstab),
X Nullarg,Nullarg, 1 )),
X listish($4),
X Nullarg,1)),
X Nullarg),
X wopt(over(defstab,add_label($1,
X make_ccmd(C_WHILE,
X make_op(O_ARRAY, 1,
X stab2arg(A_STAB,scrstab),
X Nullarg,Nullarg, 1 ),
X $6)))));
X }
X else { /* lisp, anyone? */
X $$ = wopt(over(defstab,add_label($1,
X make_ccmd(C_WHILE,$4,$6) )));
X }
X }
X | label FOR '(' nexpr ';' texpr ';' nexpr ')' block
X /* basically fake up an initialize-while lineseq */
X { yyval.compval.comp_true = $10;
X yyval.compval.comp_alt = $8;
X cmdline = $2;
X $$ = append_line($4,wopt(add_label($1,
X make_ccmd(C_WHILE,$6,yyval.compval) ))); }
X | label compblock /* a block is a loop that happens once */
X { $$ = add_label($1,make_ccmd(C_BLOCK,Nullarg,$2)); }
X ;
X
Xnexpr : /* NULL */
X { $$ = Nullcmd; }
X | sideff
X ;
X
Xtexpr : /* NULL means true */
X { scanstr("1"); $$ = yylval.arg; }
X | expr
X ;
X
Xlabel : /* empty */
X { $$ = Nullch; }
X | WORD ':'
X ;
X
Xloopmod : WHILE expr
X { $$ = $2; }
X | UNTIL expr
X { $$ = make_op(O_NOT,1,$2,Nullarg,Nullarg,0); }
X ;
X
Xcondmod : IF expr
X { $$ = $2; }
X | UNLESS expr
X { $$ = make_op(O_NOT,1,$2,Nullarg,Nullarg,0); }
X ;
X
Xdecl : format
X { $$ = 0; }
X | subrout
X { $$ = 0; }
X ;
X
Xformat : FORMAT WORD '=' FORMLIST '.'
X { stabent($2,TRUE)->stab_form = $4; safefree($2); }
X | FORMAT '=' FORMLIST '.'
X { stabent("stdout",TRUE)->stab_form = $3; }
X ;
X
Xsubrout : SUB WORD block
X { make_sub($2,$3); }
X ;
X
Xexpr : sexpr ',' expr
X { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg,0); }
X | sexpr
X ;
X
Xsexpr : sexpr '=' sexpr
X { $1 = listish($1);
X if ($1->arg_type == O_LIST)
X $3 = listish($3);
X $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg,1)); }
X | sexpr '*' '=' sexpr
X { $$ = l(make_op(O_MULTIPLY, 2, $1, $4, Nullarg,0)); }
X | sexpr '/' '=' sexpr
X { $$ = l(make_op(O_DIVIDE, 2, $1, $4, Nullarg,0)); }
X | sexpr '%' '=' sexpr
X { $$ = l(make_op(O_MODULO, 2, $1, $4, Nullarg,0)); }
X | sexpr 'x' '=' sexpr
X { $$ = l(make_op(O_REPEAT, 2, $1, $4, Nullarg,0)); }
X | sexpr '+' '=' sexpr
X { $$ = l(make_op(O_ADD, 2, $1, $4, Nullarg,0)); }
X | sexpr '-' '=' sexpr
X { $$ = l(make_op(O_SUBTRACT, 2, $1, $4, Nullarg,0)); }
X | sexpr LS '=' sexpr
X { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg,0)); }
X | sexpr RS '=' sexpr
X { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg,0)); }
X | sexpr '&' '=' sexpr
X { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg,0)); }
X | sexpr '^' '=' sexpr
X { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg,0)); }
X | sexpr '|' '=' sexpr
X { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg,0)); }
X | sexpr '.' '=' sexpr
X { $$ = l(make_op(O_CONCAT, 2, $1, $4, Nullarg,0)); }
X
X
X | sexpr '*' sexpr
X { $$ = make_op(O_MULTIPLY, 2, $1, $3, Nullarg,0); }
X | sexpr '/' sexpr
X { $$ = make_op(O_DIVIDE, 2, $1, $3, Nullarg,0); }
X | sexpr '%' sexpr
X { $$ = make_op(O_MODULO, 2, $1, $3, Nullarg,0); }
X | sexpr 'x' sexpr
X { $$ = make_op(O_REPEAT, 2, $1, $3, Nullarg,0); }
X | sexpr '+' sexpr
X { $$ = make_op(O_ADD, 2, $1, $3, Nullarg,0); }
X | sexpr '-' sexpr
X { $$ = make_op(O_SUBTRACT, 2, $1, $3, Nullarg,0); }
X | sexpr LS sexpr
X { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg,0); }
X | sexpr RS sexpr
X { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg,0); }
X | sexpr '<' sexpr
X { $$ = make_op(O_LT, 2, $1, $3, Nullarg,0); }
X | sexpr '>' sexpr
X { $$ = make_op(O_GT, 2, $1, $3, Nullarg,0); }
X | sexpr LE sexpr
X { $$ = make_op(O_LE, 2, $1, $3, Nullarg,0); }
X | sexpr GE sexpr
X { $$ = make_op(O_GE, 2, $1, $3, Nullarg,0); }
X | sexpr EQ sexpr
X { $$ = make_op(O_EQ, 2, $1, $3, Nullarg,0); }
X | sexpr NE sexpr
X { $$ = make_op(O_NE, 2, $1, $3, Nullarg,0); }
X | sexpr SLT sexpr
X { $$ = make_op(O_SLT, 2, $1, $3, Nullarg,0); }
X | sexpr SGT sexpr
X { $$ = make_op(O_SGT, 2, $1, $3, Nullarg,0); }
X | sexpr SLE sexpr
X { $$ = make_op(O_SLE, 2, $1, $3, Nullarg,0); }
X | sexpr SGE sexpr
X { $$ = make_op(O_SGE, 2, $1, $3, Nullarg,0); }
X | sexpr SEQ sexpr
X { $$ = make_op(O_SEQ, 2, $1, $3, Nullarg,0); }
X | sexpr SNE sexpr
X { $$ = make_op(O_SNE, 2, $1, $3, Nullarg,0); }
X | sexpr '&' sexpr
X { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg,0); }
X | sexpr '^' sexpr
X { $$ = make_op(O_XOR, 2, $1, $3, Nullarg,0); }
X | sexpr '|' sexpr
X { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg,0); }
X | sexpr DOTDOT sexpr
X { $$ = make_op(O_FLIP, 4,
X flipflip($1),
X flipflip($3),
X Nullarg,0);}
X | sexpr ANDAND sexpr
X { $$ = make_op(O_AND, 2, $1, $3, Nullarg,0); }
X | sexpr OROR sexpr
X { $$ = make_op(O_OR, 2, $1, $3, Nullarg,0); }
X | sexpr '?' sexpr ':' sexpr
X { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5,0); }
X | sexpr '.' sexpr
X { $$ = make_op(O_CONCAT, 2, $1, $3, Nullarg,0); }
X | sexpr MATCH sexpr
X { $$ = mod_match(O_MATCH, $1, $3); }
X | sexpr NMATCH sexpr
X { $$ = mod_match(O_NMATCH, $1, $3); }
X | term INC
X { $$ = addflags(1, AF_POST|AF_UP,
X l(make_op(O_ITEM,1,$1,Nullarg,Nullarg,0))); }
X | term DEC
X { $$ = addflags(1, AF_POST,
X l(make_op(O_ITEM,1,$1,Nullarg,Nullarg,0))); }
X | INC term
X { $$ = addflags(1, AF_PRE|AF_UP,
X l(make_op(O_ITEM,1,$2,Nullarg,Nullarg,0))); }
X | DEC term
X { $$ = addflags(1, AF_PRE,
X l(make_op(O_ITEM,1,$2,Nullarg,Nullarg,0))); }
X | term
X { $$ = $1; }
X ;
X
Xterm : '-' term %prec UMINUS
X { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg,0); }
X | '!' term
X { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg,0); }
X | '~' term
X { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg,0);}
X | FILETEST WORD
X { opargs[$1] = 0; /* force it special */
X $$ = make_op($1, 1,
X stab2arg(A_STAB,stabent($2,TRUE)),
X Nullarg, Nullarg,0);
X }
X | FILETEST sexpr
X { opargs[$1] = 1;
X $$ = make_op($1, 1, $2, Nullarg, Nullarg,0); }
X | FILETEST
X { opargs[$1] = ($1 != O_FTTTY);
X $$ = make_op($1, 1,
X stab2arg(A_STAB,
X $1 == O_FTTTY?stabent("stdin",TRUE):defstab),
X Nullarg, Nullarg,0); }
X | LOCAL '(' expr ')'
X { $$ = localize(listish(make_list(hide_ary($3)))); }
X | '(' expr ')'
X { $$ = make_list(hide_ary($2)); }
X | '(' ')'
X { $$ = make_list(Nullarg); }
X | DO sexpr %prec FILETEST
X { $$ = make_op(O_DOFILE,1,$2,Nullarg,Nullarg,0);
X allstabs = TRUE;}
X | DO block %prec '('
X { $$ = cmd_to_arg($2); }
X | REG %prec '('
X { $$ = stab2arg(A_STAB,$1); }
X | REG '[' expr ']' %prec '('
X { $$ = make_op(O_ARRAY, 2,
X $3, stab2arg(A_STAB,aadd($1)), Nullarg,0); }
X | ARY %prec '('
X { $$ = make_op(O_ARRAY, 1,
X stab2arg(A_STAB,$1),
X Nullarg, Nullarg, 1); }
X | REG '{' expr '}' %prec '('
X { $$ = make_op(O_HASH, 2,
X $3, stab2arg(A_STAB,hadd($1)), Nullarg,0); }
X | DELETE REG '{' expr '}' %prec '('
X { $$ = make_op(O_DELETE, 2,
X $4, stab2arg(A_STAB,hadd($2)), Nullarg,0); }
X | ARYLEN %prec '('
X { $$ = stab2arg(A_ARYLEN,$1); }
X | RSTRING %prec '('
X { $$ = $1; }
X | PATTERN %prec '('
X { $$ = $1; }
X | SUBST %prec '('
X { $$ = $1; }
X | TRANS %prec '('
X { $$ = $1; }
X | DO WORD '(' expr ')'
X { $$ = make_op(O_SUBR, 2,
X make_list($4),
X stab2arg(A_WORD,stabent($2,TRUE)),
X Nullarg,1); }
X | DO WORD '(' ')'
X { $$ = make_op(O_SUBR, 2,
X make_list(Nullarg),
X stab2arg(A_WORD,stabent($2,TRUE)),
X Nullarg,1); }
X | DO REG '(' expr ')'
X { $$ = make_op(O_SUBR, 2,
X make_list($4),
X stab2arg(A_STAB,$2),
X Nullarg,1); }
X | DO REG '(' ')'
X { $$ = make_op(O_SUBR, 2,
X make_list(Nullarg),
X stab2arg(A_STAB,$2),
X Nullarg,1); }
X | LOOPEX
X { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg,0); }
X | LOOPEX WORD
X { $$ = make_op($1,1,cval_to_arg($2),
X Nullarg,Nullarg,0); }
X | UNIOP
X { $$ = make_op($1,1,Nullarg,Nullarg,Nullarg,0); }
X | UNIOP sexpr
X { $$ = make_op($1,1,$2,Nullarg,Nullarg,0); }
X | WRITE
X { $$ = make_op(O_WRITE, 0,
X Nullarg, Nullarg, Nullarg,0); }
X | WRITE '(' ')'
X { $$ = make_op(O_WRITE, 0,
X Nullarg, Nullarg, Nullarg,0); }
X | WRITE '(' WORD ')'
X { $$ = l(make_op(O_WRITE, 1,
X stab2arg(A_STAB,stabent($3,TRUE)),
X Nullarg, Nullarg,0)); safefree($3); }
X | WRITE '(' expr ')'
X { $$ = make_op(O_WRITE, 1, $3, Nullarg, Nullarg,0); }
X | SELECT '(' WORD ')'
X { $$ = l(make_op(O_SELECT, 1,
X stab2arg(A_STAB,stabent($3,TRUE)),
X Nullarg, Nullarg,0)); safefree($3); }
X | SELECT '(' expr ')'
X { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg,0); }
X | OPEN WORD %prec '('
X { $$ = make_op(O_OPEN, 2,
X stab2arg(A_WORD,stabent($2,TRUE)),
X stab2arg(A_STAB,stabent($2,TRUE)),
X Nullarg,0); }
X | OPEN '(' WORD ')'
X { $$ = make_op(O_OPEN, 2,
X stab2arg(A_WORD,stabent($3,TRUE)),
X stab2arg(A_STAB,stabent($3,TRUE)),
X Nullarg,0); }
X | OPEN '(' WORD ',' expr ')'
X { $$ = make_op(O_OPEN, 2,
X stab2arg(A_WORD,stabent($3,TRUE)),
X $5, Nullarg,0); }
X | OPEN '(' sexpr ',' expr ')'
X { $$ = make_op(O_OPEN, 2,
X $3,
X $5, Nullarg,0); }
X | CLOSE '(' WORD ')'
X { $$ = make_op(O_CLOSE, 1,
X stab2arg(A_WORD,stabent($3,TRUE)),
X Nullarg, Nullarg,0); }
X | CLOSE '(' expr ')'
X { $$ = make_op(O_CLOSE, 1,
X $3,
X Nullarg, Nullarg,0); }
X | CLOSE WORD %prec '('
X { $$ = make_op(O_CLOSE, 1,
X stab2arg(A_WORD,stabent($2,TRUE)),
X Nullarg, Nullarg,0); }
X | FEOF '(' WORD ')'
X { $$ = make_op(O_EOF, 1,
X stab2arg(A_WORD,stabent($3,TRUE)),
X Nullarg, Nullarg,0); }
X | FEOF '(' expr ')'
X { $$ = make_op(O_EOF, 1,
X $3,
X Nullarg, Nullarg,0); }
X | FEOF '(' ')'
X { $$ = make_op(O_EOF, 1,
X stab2arg(A_WORD,Nullstab),
X Nullarg, Nullarg,0); }
X | FEOF
X { $$ = make_op(O_EOF, 0,
X Nullarg, Nullarg, Nullarg,0); }
X | TELL '(' WORD ')'
X { $$ = make_op(O_TELL, 1,
X stab2arg(A_WORD,stabent($3,TRUE)),
X Nullarg, Nullarg,0); }
X | TELL '(' expr ')'
X { $$ = make_op(O_TELL, 1,
X $3,
X Nullarg, Nullarg,0); }
X | TELL
X { $$ = make_op(O_TELL, 0,
X Nullarg, Nullarg, Nullarg,0); }
X | SEEK '(' WORD ',' sexpr ',' expr ')'
X { $$ = make_op(O_SEEK, 3,
X stab2arg(A_WORD,stabent($3,TRUE)),
X $5, $7,1); }
X | SEEK '(' sexpr ',' sexpr ',' expr ')'
X { $$ = make_op(O_SEEK, 3,
X $3,
X $5, $7,1); }
X | PUSH '(' WORD ',' expr ')'
X { $$ = make_op($1, 2,
X make_list($5),
X stab2arg(A_STAB,aadd(stabent($3,TRUE))),
X Nullarg,1); }
X | PUSH '(' ARY ',' expr ')'
X { $$ = make_op($1, 2,
X make_list($5),
X stab2arg(A_STAB,$3),
X Nullarg,1); }
X | POP WORD %prec '('
X { $$ = make_op(O_POP, 1,
X stab2arg(A_STAB,aadd(stabent($2,TRUE))),
X Nullarg, Nullarg,0); }
X | POP '(' WORD ')'
X { $$ = make_op(O_POP, 1,
X stab2arg(A_STAB,aadd(stabent($3,TRUE))),
X Nullarg, Nullarg,0); }
X | POP ARY %prec '('
X { $$ = make_op(O_POP, 1,
X stab2arg(A_STAB,$2),
X Nullarg,
X Nullarg,
X 0); }
X | POP '(' ARY ')'
X { $$ = make_op(O_POP, 1,
X stab2arg(A_STAB,$3),
X Nullarg,
X Nullarg,
X 0); }
X | SHIFT WORD %prec '('
X { $$ = make_op(O_SHIFT, 1,
X stab2arg(A_STAB,aadd(stabent($2,TRUE))),
X Nullarg, Nullarg,0); }
X | SHIFT '(' WORD ')'
X { $$ = make_op(O_SHIFT, 1,
X stab2arg(A_STAB,aadd(stabent($3,TRUE))),
X Nullarg, Nullarg,0); }
X | SHIFT ARY %prec '('
X { $$ = make_op(O_SHIFT, 1,
X stab2arg(A_STAB,$2), Nullarg, Nullarg,0); }
X | SHIFT '(' ARY ')'
X { $$ = make_op(O_SHIFT, 1,
X stab2arg(A_STAB,$3), Nullarg, Nullarg,0); }
X | SHIFT %prec '('
X { $$ = make_op(O_SHIFT, 1,
X stab2arg(A_STAB,aadd(stabent("ARGV",TRUE))),
X Nullarg, Nullarg,0); }
X | SPLIT %prec '('
X { scanpat("/\\s+/");
X $$ = make_split(defstab,yylval.arg); }
X | SPLIT '(' WORD ')'
X { scanpat("/\\s+/");
X $$ = make_split(stabent($3,TRUE),yylval.arg); }
X | SPLIT '(' WORD ',' PATTERN ')'
X { $$ = make_split(stabent($3,TRUE),$5); }
X | SPLIT '(' WORD ',' PATTERN ',' sexpr ')'
X { $$ = mod_match(O_MATCH,
X $7,
X make_split(stabent($3,TRUE),$5) ); }
X | SPLIT '(' sexpr ',' sexpr ')'
X { $$ = mod_match(O_MATCH, $5, make_split(defstab,$3) ); }
X | SPLIT '(' sexpr ')'
X { $$ = mod_match(O_MATCH,
X stab2arg(A_STAB,defstab),
X make_split(defstab,$3) ); }
X | JOIN '(' WORD ',' expr ')'
X { $$ = make_op(O_JOIN, 2,
X $5,
X stab2arg(A_STAB,aadd(stabent($3,TRUE))),
X Nullarg,0); }
X | JOIN '(' sexpr ',' expr ')'
X { $$ = make_op(O_JOIN, 2,
X $3,
X make_list($5),
X Nullarg,2); }
X | SPRINTF '(' expr ')'
X { $$ = make_op(O_SPRINTF, 1,
X make_list($3),
X Nullarg,
X Nullarg,1); }
X | STAT '(' WORD ')'
X { $$ = l(make_op(O_STAT, 1,
X stab2arg(A_STAB,stabent($3,TRUE)),
X Nullarg, Nullarg,0)); }
X | STAT '(' expr ')'
X { $$ = make_op(O_STAT, 1, $3, Nullarg, Nullarg,0); }
X | LVALFUN
X { $$ = l(make_op($1, 1,
X stab2arg(A_STAB,defstab),
X Nullarg, Nullarg,0)); }
X | LVALFUN '(' expr ')'
X { $$ = l(make_op($1, 1, $3, Nullarg, Nullarg,0)); }
X | FUNC0
X { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg,0); }
X | FUNC1 '(' expr ')'
X { $$ = make_op($1, 1, $3, Nullarg, Nullarg,0); }
X | FUNC2 '(' sexpr ',' expr ')'
X { $$ = make_op($1, 2, $3, $5, Nullarg, 0);
X if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
X fbmcompile($$[2].arg_ptr.arg_str); }
X | FUNC3 '(' sexpr ',' sexpr ',' expr ')'
X { $$ = make_op($1, 3, $3, $5, $7, 0); }
X | STABFUN '(' WORD ')'
X { $$ = make_op($1, 1,
X stab2arg(A_STAB,hadd(stabent($3,TRUE))),
X Nullarg,
X Nullarg, 0); }
X | listop
X ;
X
Xlistop : LISTOP
X { $$ = make_op($1,2,
X stab2arg(A_STAB,defstab),
X stab2arg(A_WORD,Nullstab),
X Nullarg,0); }
X | LISTOP expr
X { $$ = make_op($1,2,make_list($2),
X stab2arg(A_WORD,Nullstab),
X Nullarg,1); }
X | LISTOP WORD
X { $$ = make_op($1,2,
X stab2arg(A_STAB,defstab),
X stab2arg(A_WORD,stabent($2,TRUE)),
X Nullarg,1); }
X | LISTOP WORD expr
X { $$ = make_op($1,2,make_list($3),
X stab2arg(A_WORD,stabent($2,TRUE)),
X Nullarg,1); }
X | LISTOP REG expr
X { $$ = make_op($1,2,make_list($3),
X stab2arg(A_STAB,$2),
X Nullarg,1); }
X ;
X
X%% /* PROGRAM */
!STUFFY!FUNK!
echo Extracting cmd.c
sed >cmd.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: cmd.c,v 2.0 88/06/05 00:08:24 root Exp $
X *
X * $Log: cmd.c,v $
X * Revision 2.0 88/06/05 00:08:24 root
X * Baseline version 2.0.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
Xstatic STR str_chop;
X
X/* This is the main command loop. We try to spend as much time in this loop
X * as possible, so lots of optimizations do their activities in here. This
X * means things get a little sloppy.
X */
X
XSTR *
Xcmd_exec(cmd)
X#ifdef cray /* nobody else has complained yet */
XCMD *cmd;
X#else
Xregister CMD *cmd;
X#endif
X{
X SPAT *oldspat;
X int oldsave;
X#ifdef DEBUGGING
X int olddlevel;
X int entdlevel;
X#endif
X register STR *retstr;
X register char *tmps;
X register int cmdflags;
X register int match;
X register char *go_to = goto_targ;
X FILE *fp;
X ARRAY *ar;
X
X retstr = &str_no;
X#ifdef DEBUGGING
X entdlevel = dlevel;
X#endif
Xtail_recursion_entry:
X#ifdef DEBUGGING
X dlevel = entdlevel;
X#endif
X if (cmd == Nullcmd)
X return retstr;
X cmdflags = cmd->c_flags; /* hopefully load register */
X if (go_to) {
X if (cmd->c_label && strEQ(go_to,cmd->c_label))
X goto_targ = go_to = Nullch; /* here at last */
X else {
X switch (cmd->c_type) {
X case C_IF:
X oldspat = curspat;
X oldsave = savestack->ary_fill;
X#ifdef DEBUGGING
X olddlevel = dlevel;
X#endif
X retstr = &str_yes;
X if (cmd->ucmd.ccmd.cc_true) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 't';
X debdelim[dlevel++] = '_';
X }
X#endif
X retstr = cmd_exec(cmd->ucmd.ccmd.cc_true);
X }
X if (!goto_targ) {
X go_to = Nullch;
X } else {
X retstr = &str_no;
X if (cmd->ucmd.ccmd.cc_alt) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 'e';
X debdelim[dlevel++] = '_';
X }
X#endif
X retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt);
X }
X }
X if (!goto_targ)
X go_to = Nullch;
X curspat = oldspat;
X if (savestack->ary_fill > oldsave)
X restorelist(oldsave);
X#ifdef DEBUGGING
X dlevel = olddlevel;
X#endif
X break;
X case C_BLOCK:
X case C_WHILE:
X if (!(cmdflags & CF_ONCE)) {
X cmdflags |= CF_ONCE;
X loop_ptr++;
X loop_stack[loop_ptr].loop_label = cmd->c_label;
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Pushing label #%d %s)\n",
X loop_ptr,cmd->c_label);
X }
X#endif
X }
X switch (setjmp(loop_stack[loop_ptr].loop_env)) {
X case O_LAST: /* not done unless go_to found */
X go_to = Nullch;
X retstr = &str_no;
X#ifdef DEBUGGING
X olddlevel = dlevel;
X#endif
X curspat = oldspat;
X if (savestack->ary_fill > oldsave)
X restorelist(oldsave);
X goto next_cmd;
X case O_NEXT: /* not done unless go_to found */
X go_to = Nullch;
X goto next_iter;
X case O_REDO: /* not done unless go_to found */
X go_to = Nullch;
X goto doit;
X }
X oldspat = curspat;
X oldsave = savestack->ary_fill;
X#ifdef DEBUGGING
X olddlevel = dlevel;
X#endif
X if (cmd->ucmd.ccmd.cc_true) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 't';
X debdelim[dlevel++] = '_';
X }
X#endif
X cmd_exec(cmd->ucmd.ccmd.cc_true);
X }
X if (!goto_targ) {
X go_to = Nullch;
X goto next_iter;
X }
X#ifdef DEBUGGING
X dlevel = olddlevel;
X#endif
X if (cmd->ucmd.ccmd.cc_alt) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 'a';
X debdelim[dlevel++] = '_';
X }
X#endif
X cmd_exec(cmd->ucmd.ccmd.cc_alt);
X }
X if (goto_targ)
X break;
X go_to = Nullch;
X goto finish_while;
X }
X cmd = cmd->c_next;
X if (cmd && cmd->c_head == cmd)
X /* reached end of while loop */
X return retstr; /* targ isn't in this block */
X if (cmdflags & CF_ONCE) {
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Popping label #%d %s)\n",loop_ptr,
X loop_stack[loop_ptr].loop_label);
X }
X#endif
X loop_ptr--;
X }
X goto tail_recursion_entry;
X }
X }
X
Xuntil_loop:
X
X /* Set line number so run-time errors can be located */
X
X line = cmd->c_line;
X
X#ifdef DEBUGGING
X if (debug) {
X if (debug & 2) {
X deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n",
X cmdname[cmd->c_type],cmd,cmd->c_expr,
X cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt,cmd->c_next,
X curspat);
X }
X debname[dlevel] = cmdname[cmd->c_type][0];
X debdelim[dlevel++] = '!';
X }
X#endif
X while (tmps_max > tmps_base) /* clean up after last eval */
X str_free(tmps_list[tmps_max--]);
X
X /* Here is some common optimization */
X
X if (cmdflags & CF_COND) {
X switch (cmdflags & CF_OPTIMIZE) {
X
X case CFT_FALSE:
X retstr = cmd->c_short;
X match = FALSE;
X if (cmdflags & CF_NESURE)
X goto maybe;
X break;
X case CFT_TRUE:
X retstr = cmd->c_short;
X match = TRUE;
X if (cmdflags & CF_EQSURE)
X goto flipmaybe;
X break;
X
X case CFT_REG:
X retstr = STAB_STR(cmd->c_stab);
X match = str_true(retstr); /* => retstr = retstr, c2 should fix */
X if (cmdflags & (match ? CF_EQSURE : CF_NESURE))
X goto flipmaybe;
X break;
X
X case CFT_ANCHOR: /* /^pat/ optimization */
X if (multiline) {
X if (*cmd->c_short->str_ptr && !(cmdflags & CF_EQSURE))
X goto scanner; /* just unanchor it */
X else
X break; /* must evaluate */
X }
X /* FALL THROUGH */
X case CFT_STROP: /* string op optimization */
X retstr = STAB_STR(cmd->c_stab);
X if (*cmd->c_short->str_ptr == *str_get(retstr) &&
X strnEQ(cmd->c_short->str_ptr, str_get(retstr),
X cmd->c_slen) ) {
X if (cmdflags & CF_EQSURE) {
X match = !(cmdflags & CF_FIRSTNEG);
X retstr = &str_yes;
X goto flipmaybe;
X }
X }
X else if (cmdflags & CF_NESURE) {
X match = cmdflags & CF_FIRSTNEG;
X retstr = &str_no;
X goto flipmaybe;
X }
X break; /* must evaluate */
X
X case CFT_SCAN: /* non-anchored search */
X scanner:
X retstr = STAB_STR(cmd->c_stab);
X if (retstr->str_pok == 5)
X if (screamfirst[cmd->c_short->str_rare] >= 0)
X tmps = screaminstr(retstr, cmd->c_short);
X else
X tmps = Nullch;
X else {
X tmps = str_get(retstr); /* make sure it's pok */
X tmps = fbminstr(tmps, tmps + retstr->str_cur, cmd->c_short);
X }
X if (tmps) {
X if (cmdflags & CF_EQSURE) {
X ++*(long*)&cmd->c_short->str_nval;
X match = !(cmdflags & CF_FIRSTNEG);
X retstr = &str_yes;
X goto flipmaybe;
X }
X else
X hint = tmps;
X }
X else {
X if (cmdflags & CF_NESURE) {
X ++*(long*)&cmd->c_short->str_nval;
X match = cmdflags & CF_FIRSTNEG;
X retstr = &str_no;
X goto flipmaybe;
X }
X }
X if (--*(long*)&cmd->c_short->str_nval < 0) {
X str_free(cmd->c_short);
X cmd->c_short = Nullstr;
X cmdflags &= ~CF_OPTIMIZE;
X cmdflags |= CFT_EVAL; /* never try this optimization again */
X cmd->c_flags = cmdflags;
X }
X break; /* must evaluate */
X
X case CFT_NUMOP: /* numeric op optimization */
X retstr = STAB_STR(cmd->c_stab);
X switch (cmd->c_slen) {
X case O_EQ:
X match = (str_gnum(retstr) == cmd->c_short->str_nval);
X break;
X case O_NE:
X match = (str_gnum(retstr) != cmd->c_short->str_nval);
X break;
X case O_LT:
X match = (str_gnum(retstr) < cmd->c_short->str_nval);
X break;
X case O_LE:
X match = (str_gnum(retstr) <= cmd->c_short->str_nval);
X break;
X case O_GT:
X match = (str_gnum(retstr) > cmd->c_short->str_nval);
X break;
X case O_GE:
X match = (str_gnum(retstr) >= cmd->c_short->str_nval);
X break;
X }
X if (match) {
X if (cmdflags & CF_EQSURE) {
X retstr = &str_yes;
X goto flipmaybe;
X }
X }
X else if (cmdflags & CF_NESURE) {
X retstr = &str_no;
X goto flipmaybe;
X }
X break; /* must evaluate */
X
X case CFT_INDGETS: /* while (<$foo>) */
X last_in_stab = stabent(str_get(STAB_STR(cmd->c_stab)),TRUE);
X if (!last_in_stab->stab_io)
X last_in_stab->stab_io = stio_new();
X goto dogets;
X case CFT_GETS: /* really a while (<file>) */
X last_in_stab = cmd->c_stab;
X dogets:
X fp = last_in_stab->stab_io->fp;
X retstr = defstab->stab_val;
X if (fp && str_gets(retstr, fp)) {
X if (*retstr->str_ptr == '0' && !retstr->str_ptr[1])
X match = FALSE;
X else
X match = TRUE;
X last_in_stab->stab_io->lines++;
X }
X else if (last_in_stab->stab_io->flags & IOF_ARGV)
X goto doeval; /* doesn't necessarily count as EOF yet */
X else {
X retstr = &str_no;
X match = FALSE;
X }
X goto flipmaybe;
X case CFT_EVAL:
X break;
X case CFT_UNFLIP:
X retstr = eval(cmd->c_expr,Null(STR***),-1);
X match = str_true(retstr);
X if (cmd->c_expr->arg_type == O_FLIP) /* undid itself? */
X cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
X goto maybe;
X case CFT_CHOP:
X retstr = cmd->c_stab->stab_val;
X match = (retstr->str_cur != 0);
X tmps = str_get(retstr);
X tmps += retstr->str_cur - match;
X str_set(&str_chop,tmps);
X *tmps = '\0';
X retstr->str_nok = 0;
X retstr->str_cur = tmps - retstr->str_ptr;
X retstr = &str_chop;
X goto flipmaybe;
X case CFT_ARRAY:
X ar = cmd->c_expr[1].arg_ptr.arg_stab->stab_array;
X match = ar->ary_index; /* just to get register */
X
X if (match < 0) /* first time through here? */
X cmd->c_short = cmd->c_stab->stab_val;
X
X if (match >= ar->ary_fill) {
X ar->ary_index = -1;
X/* cmd->c_stab->stab_val = cmd->c_short; - Can't be done in LAST */
X match = FALSE;
X }
X else {
X match++;
X retstr = cmd->c_stab->stab_val = ar->ary_array[match];
X ar->ary_index = match;
X match = TRUE;
X }
X goto maybe;
X }
X
X /* we have tried to make this normal case as abnormal as possible */
X
X doeval:
X lastretstr = retstr;
X retstr = eval(cmd->c_expr,Null(STR***),-1);
X match = str_true(retstr);
X goto maybe;
X
X /* if flipflop was true, flop it */
X
X flipmaybe:
X if (match && cmdflags & CF_FLIP) {
X if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */
X retstr = eval(cmd->c_expr,Null(STR***),-1);/*let eval undo it*/
X cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
X }
X else {
X retstr = eval(cmd->c_expr,Null(STR***),-1);/* let eval do it */
X if (cmd->c_expr->arg_type == O_FLOP) /* still toggled? */
X cmdflags = copyopt(cmd,cmd->c_expr[4].arg_ptr.arg_cmd);
X }
X }
X else if (cmdflags & CF_FLIP) {
X if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */
X match = TRUE; /* force on */
X }
X }
X
X /* at this point, match says whether our expression was true */
X
X maybe:
X if (cmdflags & CF_INVERT)
X match = !match;
X if (!match && cmd->c_type != C_IF)
X goto next_cmd;
X }
X
X /* now to do the actual command, if any */
X
X switch (cmd->c_type) {
X case C_NULL:
X fatal("panic: cmd_exec");
X case C_EXPR: /* evaluated for side effects */
X if (cmd->ucmd.acmd.ac_expr) { /* more to do? */
X lastretstr = retstr;
X retstr = eval(cmd->ucmd.acmd.ac_expr,Null(STR***),-1);
X }
X break;
X case C_IF:
X oldspat = curspat;
X oldsave = savestack->ary_fill;
X#ifdef DEBUGGING
X olddlevel = dlevel;
X#endif
X if (match) {
X retstr = &str_yes;
X if (cmd->ucmd.ccmd.cc_true) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 't';
X debdelim[dlevel++] = '_';
X }
X#endif
X retstr = cmd_exec(cmd->ucmd.ccmd.cc_true);
X }
X }
X else {
X retstr = &str_no;
X if (cmd->ucmd.ccmd.cc_alt) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 'e';
X debdelim[dlevel++] = '_';
X }
X#endif
X retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt);
X }
X }
X curspat = oldspat;
X if (savestack->ary_fill > oldsave)
X restorelist(oldsave);
X#ifdef DEBUGGING
X dlevel = olddlevel;
X#endif
X break;
X case C_BLOCK:
X case C_WHILE:
X if (!(cmdflags & CF_ONCE)) { /* first time through here? */
X cmdflags |= CF_ONCE;
X loop_ptr++;
X loop_stack[loop_ptr].loop_label = cmd->c_label;
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Pushing label #%d %s)\n",
X loop_ptr,cmd->c_label);
X }
X#endif
X }
X switch (setjmp(loop_stack[loop_ptr].loop_env)) {
X case O_LAST:
X retstr = lastretstr;
X curspat = oldspat;
X if (savestack->ary_fill > oldsave)
X restorelist(oldsave);
X goto next_cmd;
X case O_NEXT:
X goto next_iter;
X case O_REDO:
X#ifdef DEBUGGING
X dlevel = olddlevel;
X#endif
X goto doit;
X }
X oldspat = curspat;
X oldsave = savestack->ary_fill;
X#ifdef DEBUGGING
X olddlevel = dlevel;
X#endif
X doit:
X if (cmd->ucmd.ccmd.cc_true) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 't';
X debdelim[dlevel++] = '_';
X }
X#endif
X cmd_exec(cmd->ucmd.ccmd.cc_true);
X }
X /* actually, this spot is rarely reached anymore since the above
X * cmd_exec() returns through longjmp(). Hooray for structure.
X */
X next_iter:
X#ifdef DEBUGGING
X dlevel = olddlevel;
X#endif
X if (cmd->ucmd.ccmd.cc_alt) {
X#ifdef DEBUGGING
X if (debug) {
X debname[dlevel] = 'a';
X debdelim[dlevel++] = '_';
X }
X#endif
X cmd_exec(cmd->ucmd.ccmd.cc_alt);
X }
X finish_while:
X curspat = oldspat;
X if (savestack->ary_fill > oldsave)
X restorelist(oldsave);
X#ifdef DEBUGGING
X dlevel = olddlevel - 1;
X#endif
X if (cmd->c_type != C_BLOCK)
X goto until_loop; /* go back and evaluate conditional again */
X }
X if (cmdflags & CF_LOOP) {
X cmdflags |= CF_COND; /* now test the condition */
X#ifdef DEBUGGING
X dlevel = entdlevel;
X#endif
X goto until_loop;
X }
X next_cmd:
X if (cmdflags & CF_ONCE) {
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Popping label #%d %s)\n",loop_ptr,
X loop_stack[loop_ptr].loop_label);
X }
X#endif
X loop_ptr--;
X if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY) {
X cmd->c_stab->stab_val = cmd->c_short;
X }
X }
X cmd = cmd->c_next;
X goto tail_recursion_entry;
X}
X
X#ifdef DEBUGGING
X/*VARARGS1*/
Xdeb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
Xchar *pat;
X{
X register int i;
X
X fprintf(stderr,"%-4ld",(long)line);
X for (i=0; i<dlevel; i++)
X fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
X fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
X}
X#endif
X
Xcopyopt(cmd,which)
Xregister CMD *cmd;
Xregister CMD *which;
X{
X cmd->c_flags &= CF_ONCE|CF_COND|CF_LOOP;
X cmd->c_flags |= which->c_flags;
X cmd->c_short = which->c_short;
X cmd->c_slen = which->c_slen;
X cmd->c_stab = which->c_stab;
X return cmd->c_flags;
X}
X
Xvoid
Xsavelist(sarg,maxsarg)
Xregister STR **sarg;
Xint maxsarg;
X{
X register STR *str;
X register int i;
X
X for (i = 1; i <= maxsarg; i++) {
X apush(savestack,sarg[i]); /* remember the pointer */
X str = str_new(0);
X str_sset(str,sarg[i]);
X apush(savestack,str); /* remember the value */
X }
X}
X
Xvoid
Xrestorelist(base)
Xint base;
X{
X register STR *str;
X register STR *value;
X
X while (savestack->ary_fill > base) {
X value = apop(savestack);
X str = apop(savestack);
X str_sset(str,value);
X STABSET(str);
X str_free(value);
X }
X}
!STUFFY!FUNK!
echo Extracting x2p/s2p
sed >x2p/s2p <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: s2p,v 2.0 88/06/05 00:15:55 root Exp $
X#
X# $Log: s2p,v $
X# Revision 2.0 88/06/05 00:15:55 root
X# Baseline version 2.0.
X#
X#
X
X$indent = 4;
X$shiftwidth = 4;
X$l = '{'; $r = '}';
X$tempvar = '1';
X
Xwhile ($ARGV[0] =~ '^-') {
X $_ = shift;
X last if /^--/;
X if (/^-D/) {
X $debug++;
X open(body,'>-');
X next;
X }
X if (/^-n/) {
X $assumen++;
X next;
X }
X if (/^-p/) {
X $assumep++;
X next;
X }
X die "I don't recognize this switch: $_\n";
X}
X
Xunless ($debug) {
X open(body,">/tmp/sperl$$") || do Die("Can't open temp file");
X}
X
Xif (!$assumen && !$assumep) {
X print body
X'while ($ARGV[0] =~ /^-/) {
X $_ = shift;
X last if /^--/;
X if (/^-n/) {
X $nflag++;
X next;
X }
X die "I don\'t recognize this switch: $_\\n";
X}
X
X';
X}
X
Xprint body '
X#ifdef PRINTIT
X#ifdef ASSUMEP
X$printit++;
X#else
X$printit++ unless $nflag;
X#endif
X#endif
Xline: while (<>) {
X';
X
Xline: while (<>) {
X s/[ \t]*(.*)\n$/$1/;
X if (/^:/) {
X s/^:[ \t]*//;
X $label = do make_label($_);
X if ($. == 1) {
X $toplabel = $label;
X }
X $_ = "$label:";
X if ($lastlinewaslabel++) {$_ .= "\t;";}
X if ($indent >= 2) {
X $indent -= 2;
X $indmod = 2;
X }
X next;
X } else {
X $lastlinewaslabel = '';
X }
X $addr1 = '';
X $addr2 = '';
X if (s/^([0-9]+)//) {
X $addr1 = "$1";
X }
X elsif (s/^\$//) {
X $addr1 = 'eof()';
X }
X elsif (s|^/||) {
X $addr1 = '/';
X delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
X $prefix = $1;
X $delim = $2;
X if ($delim eq '\\') {
X s/(.)(.*)/$2/;
X $ch = $1;
X $delim = '' if index("(|)",$ch) >= 0;
X $delim .= $1;
X }
X elsif ($delim ne '/') {
X $delim = '\\' . $delim;
X }
X $addr1 .= $prefix;
X $addr1 .= $delim;
X if ($delim eq '/') {
X last delim;
X }
X }
X }
X if (s/^,//) {
X if (s/^([0-9]+)//) {
X $addr2 = "$1";
X } elsif (s/^\$//) {
X $addr2 = "eof()";
X } elsif (s|^/||) {
X $addr2 = '/';
X delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
X $prefix = $1;
X $delim = $2;
X if ($delim eq '\\') {
X s/(.)(.*)/$2/;
X $ch = $1;
X $delim = '' if index("(|)",$ch) >= 0;
X $delim .= $1;
X }
X elsif ($delim ne '/') {
X $delim = '\\' . $delim;
X }
X $addr2 .= $prefix;
X $addr2 .= $delim;
X if ($delim eq '/') {
X last delim;
X }
X }
X } else {
X do Die("Invalid second address at line $.\n");
X }
X $addr1 .= " .. $addr2";
X }
X # a { to keep vi happy
X s/^[ \t]+//;
X if ($_ eq '}') {
X $indent -= 4;
X next;
X }
X if (s/^!//) {
X $if = 'unless';
X $else = "$r else $l\n";
X } else {
X $if = 'if';
X $else = '';
X }
X if (s/^{//) { # a } to keep vi happy
X $indmod = 4;
X $redo = $_;
X $_ = '';
X $rmaybe = '';
X } else {
X $rmaybe = "\n$r";
X if ($addr2 || $addr1) {
X $space = substr(' ',0,$shiftwidth);
X } else {
X $space = '';
X }
X $_ = do transmogrify();
X }
X
X if ($addr1) {
X if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
X $_ !~ / if / && $_ !~ / unless /) {
X s/;$/ $if $addr1;/;
X $_ = substr($_,$shiftwidth,1000);
X } else {
X $command = $_;
X $_ = "$if ($addr1) $l\n$change$command$rmaybe";
X }
X $change = '';
X next line;
X }
X} continue {
X @lines = split(/\n/,$_);
X while ($#lines >= 0) {
X $_ = shift(lines);
X unless (s/^ *<<--//) {
X print body substr("\t\t\t\t\t\t\t\t\t\t\t\t",0,$indent / 8),
X substr(' ',0,$indent % 8);
X }
X print body $_, "\n";
X }
X $indent += $indmod;
X $indmod = 0;
X if ($redo) {
X $_ = $redo;
X $redo = '';
X redo line;
X }
X}
X
Xprint body "}\n";
Xif ($appendseen || $tseen || !$assumen) {
X $printit++ if $dseen || (!$assumen && !$assumep);
X print body '
Xcontinue {
X#ifdef PRINTIT
X#ifdef DSEEN
X#ifdef ASSUMEP
X print if $printit++;
X#else
X if ($printit) { print;} else { $printit++ unless $nflag; }
X#endif
X#else
X print if $printit;
X#endif
X#else
X print;
X#endif
X#ifdef TSEEN
X $tflag = \'\';
X#endif
X#ifdef APPENDSEEN
X if ($atext) { print $atext; $atext = \'\'; }
X#endif
X}
X';
X}
X
Xclose body;
X
Xunless ($debug) {
X open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2");
X print head "#define PRINTIT\n" if ($printit);
X print head "#define APPENDSEEN\n" if ($appendseen);
X print head "#define TSEEN\n" if ($tseen);
X print head "#define DSEEN\n" if ($dseen);
X print head "#define ASSUMEN\n" if ($assumen);
X print head "#define ASSUMEP\n" if ($assumep);
X if ($opens) {print head "$opens\n";}
X open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file");
X while (<body>) {
X print head $_;
X }
X close head;
X
X print "#!/bin/perl\n\n";
X open(body,"cc -E /tmp/sperl2$$.c |") ||
X do Die("Can't reopen temp file");
X while (<body>) {
X /^# [0-9]/ && next;
X /^[ \t]*$/ && next;
X s/^<><>//;
X print;
X }
X}
X
Xunlink "/tmp/sperl$$", "/tmp/sperl2$$";
X
Xsub Die {
X unlink "/tmp/sperl$$", "/tmp/sperl2$$";
X die $_[0];
X}
Xsub make_filehandle {
X $fname = $_ = $_[0];
X s/[^a-zA-Z]/_/g;
X s/^_*//;
X if (/^([a-z])([a-z]*)$/) {
X $first = $1;
X $rest = $2;
X $first =~ y/a-z/A-Z/;
X $_ = $first . $rest;
X }
X if (!$seen{$_}) {
X $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n";
X }
X $seen{$_} = $_;
X}
X
Xsub make_label {
X $label = $_[0];
X $label =~ s/[^a-zA-Z0-9]/_/g;
X if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
X $label = substr($label,0,8);
X if ($label =~ /^([a-z])([a-z]*)$/) {
X $first = $1;
X $rest = $2;
X $first =~ y/a-z/A-Z/;
X $label = $first . $rest;
X }
X $label;
X}
X
Xsub transmogrify {
X { # case
X if (/^d/) {
X $dseen++;
X $_ = '
X<<--#ifdef PRINTIT
X$printit = \'\';
X<<--#endif
Xnext line;';
X next;
X }
X
X if (/^n/) {
X $_ =
X'<<--#ifdef PRINTIT
X<<--#ifdef DSEEN
X<<--#ifdef ASSUMEP
Xprint if $printit++;
X<<--#else
Xif ($printit) { print;} else { $printit++ unless $nflag; }
X<<--#endif
X<<--#else
Xprint if $printit;
X<<--#endif
X<<--#else
Xprint;
X<<--#endif
X<<--#ifdef APPENDSEEN
Xif ($atext) {print $atext; $atext = \'\';}
X<<--#endif
X$_ = <>;
X<<--#ifdef TSEEN
X$tflag = \'\';
X<<--#endif';
X next;
X }
X
X if (/^a/) {
X $appendseen++;
X $command = $space . '$atext .=' . "\n<<--'";
X $lastline = 0;
X while (<>) {
X s/^[ \t]*//;
X s/^[\\]//;
X unless (s|\\$||) { $lastline = 1;}
X s/'/\\'/g;
X s/^([ \t]*\n)/<><>$1/;
X $command .= $_;
X $command .= '<<--';
X last if $lastline;
X }
X $_ = $command . "';";
X last;
X }
X
X if (/^[ic]/) {
X if (/^c/) { $change = 1; }
X $addr1 = '$iter = (' . $addr1 . ')';
X $command = $space . 'if ($iter == 1) { print' . "\n<<--'";
X $lastline = 0;
X while (<>) {
X s/^[ \t]*//;
X s/^[\\]//;
X unless (s/\\$//) { $lastline = 1;}
X s/'/\\'/g;
X s/^([ \t]*\n)/<><>$1/;
X $command .= $_;
X $command .= '<<--';
X last if $lastline;
X }
X $_ = $command . "';}";
X if ($change) {
X $dseen++;
X $change = "$_\n";
X $_ = "
X<<--#ifdef PRINTIT
X$space\$printit = '';
X<<--#endif
X${space}next line;";
X }
X last;
X }
X
X if (/^s/) {
X $delim = substr($_,1,1);
X $len = length($_);
X $repl = $end = 0;
X for ($i = 2; $i < $len; $i++) {
X $c = substr($_,$i,1);
X if ($c eq '\\') {
X $i++;
X if ($i >= $len) {
X $_ .= 'n';
X $_ .= <>;
X $len = length($_);
X $_ = substr($_,0,--$len);
X }
X elsif (!$repl && index("(|)",substr($_,$i,1)) >= 0) {
X $i--;
X $len--;
X $_ = substr($_,0,$i) . substr($_,$i+1,10000);
X }
X }
X elsif ($c eq $delim) {
X if ($repl) {
X $end = $i;
X last;
X } else {
X $repl = $i;
X }
X }
X elsif (!$repl && index("(|)",$c) >= 0) {
X $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
X $i++;
X $len++;
X }
X }
X do Die("Malformed substitution at line $.\n") unless $end;
X $pat = substr($_, 0, $repl + 1);
X $repl = substr($_, $repl + 1, $end - $repl - 1);
X $end = substr($_, $end + 1, 1000);
X $dol = '$';
X $repl =~ s/\$/\\$/;
X $repl =~ s'&'$&'g;
X $repl =~ s/[\\]([0-9])/$dol$1/g;
X $subst = "$pat$repl$delim";
X $cmd = '';
X while ($end) {
X if ($end =~ s/^g//) { $subst .= 'g'; next; }
X if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; }
X if ($end =~ s/^w[ \t]*//) {
X $fh = do make_filehandle($end);
X $cmd .= " && (print $fh \$_)";
X $end = '';
X next;
X }
X do Die("Unrecognized substitution command ($end) at line $.\n");
X }
X $_ = $subst . $cmd . ';';
X next;
X }
X
X if (/^p/) {
X $_ = 'print;';
X next;
X }
X
X if (/^w/) {
X s/^w[ \t]*//;
X $fh = do make_filehandle($_);
X $_ = "print $fh \$_;";
X next;
X }
X
X if (/^r/) {
X $appendseen++;
X s/^r[ \t]*//;
X $file = $_;
X $_ = "\$atext .= `cat $file 2>/dev/null`;";
X next;
X }
X
X if (/^P/) {
X $_ =
X'if (/(^[^\n]*\n)/) {
X print $1;
X}';
X next;
X }
X
X if (/^D/) {
X $_ =
X's/^[^\n]*\n//;
Xif ($_) {redo line;}
Xnext line;';
X next;
X }
X
X if (/^N/) {
X $_ = '
X$_ .= <>;
X<<--#ifdef TSEEN
X$tflag = \'\';
X<<--#endif';
X next;
X }
X
X if (/^h/) {
X $_ = '$hold = $_;';
X next;
X }
X
X if (/^H/) {
X $_ = '$hold .= $_ ? $_ : "\n";';
X next;
X }
X
X if (/^g/) {
X $_ = '$_ = $hold;';
X next;
X }
X
X if (/^G/) {
X $_ = '$_ .= $hold ? $hold : "\n";';
X next;
X }
X
X if (/^x/) {
X $_ = '($_, $hold) = ($hold, $_);';
X next;
X }
X
X if (/^b$/) {
X $_ = 'next line;';
X next;
X }
X
X if (/^b/) {
X s/^b[ \t]*//;
X $lab = do make_label($_);
X if ($lab eq $toplabel) {
X $_ = 'redo line;';
X } else {
X $_ = "goto $lab;";
X }
X next;
X }
X
X if (/^t$/) {
X $_ = 'next line if $tflag;';
X $tseen++;
X next;
X }
X
X if (/^t/) {
X s/^t[ \t]*//;
X $lab = do make_label($_);
X if ($lab eq $toplabel) {
X $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
X } else {
X $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
X }
X $tseen++;
X next;
X }
X
X if (/^=/) {
X $_ = 'print "$.\n";';
X next;
X }
X
X if (/^q/) {
X $_ =
X'close(ARGV);
X@ARGV = ();
Xnext line;';
X next;
X }
X } continue {
X if ($space) {
X s/^/$space/;
X s/(\n)(.)/$1$space$2/g;
X }
X last;
X }
X $_;
X}
X
!STUFFY!FUNK!
echo Extracting eg/g/gsh
sed >eg/g/gsh <<'!STUFFY!FUNK!' -e 's/X//'
X#!/bin/perl
X
X# $Header: gsh,v 2.0 88/06/05 00:17:20 root Exp $
X
X# Do rsh globally--see man page
X
X$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT
X
Xsub getswitches {
X while ($ARGV[0] =~ /^-/) { # parse switches
X $ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift,next);
X $ARGV[0] =~ /^-s/ && ($silent++,shift,next);
X $ARGV[0] =~ /^-d/ && ($dodist++,shift,next);
X $ARGV[0] =~ /^-n/ && ($n=' -n',shift,next);
X $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift,shift,next);
X last;
X }
X}
X
Xdo getswitches(); # get any switches before class
X$systype = shift; # get name representing set of hosts
Xdo getswitches(); # same switches allowed after class
X
Xif ($dodist) { # distribute input over all rshes?
X `cat >/tmp/gsh$$`; # get input into a handy place
X $dist = " </tmp/gsh$$"; # each rsh takes input from there
X}
X
X$cmd = join(' ',@ARGV); # remaining args constitute the command
X$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes
X
X$one_of_these = ":$systype:"; # prepare to expand "macros"
X$one_of_these =~ s/\+/:/g; # we hope to end up with list of
X$one_of_these =~ s/-/:-/g; # colon separated attributes
X
X@ARGV = ();
Xpush(@ARGV,'.grem') if -f '.grem';
Xpush(@ARGV,'.ghosts') if -f '.ghosts';
Xpush(@ARGV,'/etc/ghosts');
X
X$remainder = '';
X
Xline: while (<>) { # for each line of ghosts
X
X s/[ \t]*\n//; # trim trailing whitespace
X if (!$_ || /^#/) { # skip blank line or comment
X next line;
X }
X
X if (/^(\w+)=(.+)/) { # a macro line?
X $name = $1; $repl = $2;
X $repl =~ s/\+/:/g;
X $repl =~ s/-/:-/g;
X $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list
X $repl =~ s/:/:-/g;
X $one_of_these =~ s/:-$name:/:-$repl:/;
X next line;
X }
X
X # we have a normal line
X
X @attr = split(' '); # a list of attributes to match against
X # which we put into an array
X $host = $attr[0]; # the first attribute is the host name
X if ($showhost) {
X $showhost = "$host:\t";
X }
X
X $wanted = 0;
X foreach $attr (@attr) { # iterate over attribute array
X $wanted++ if index($one_of_these,":$attr:") >= 0;
X $wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
X }
X if ($wanted > 0) {
X print "rsh $host$l$n '$cmd'\n" unless $silent;
X $SIG{'INT'} = 'DEFAULT';
X if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
X $SIG{'INT'} = 'cont';
X for ($iter=0; <pipe>; $iter++) {
X unless ($iter) {
X $remainder .= "$host+"
X if /Connection timed out|Permission denied/;
X }
X print $showhost,$_;
X }
X close(pipe);
X } else {
X $SIG{'INT'} = 'cont';
X print "(Can't execute rsh.)\n";
X }
X }
X}
X
Xunlink "/tmp/gsh$$" if $dodist;
X
Xif ($remainder) {
X chop($remainder);
X open(grem,">.grem") || (printf stderr "Can't make a .grem file\n");
X print grem 'rem=', $remainder, "\n";
X close(grem);
X print 'rem=', $remainder, "\n";
X}
X
X# here are a couple of subroutines that serve as signal handlers
X
Xsub cont {
X print "\rContinuing...\n";
X $remainder .= "$host+";
X}
X
Xsub quit {
X $| = 1;
X print "\r";
X $SIG{'INT'} = '';
X kill 2, $$;
X}
!STUFFY!FUNK!
echo ""
echo "End of kit 10 (of 15)"
cat /dev/null >kit10isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
--
Please send comp.sources.unix-related mail to rsalz@uunet.uu.net.