rsalz@uunet.uu.net (Rich Salz) (07/08/88)
Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Posting-number: Volume 15, Issue 93
Archive-name: perl2/part04
#! /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 4 (of 15). If kit 4 is complete, the line"
echo '"'"End of kit 4 (of 15)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir x2p 2>/dev/null
echo Extracting perly.c
sed >perly.c <<'!STUFFY!FUNK!' -e 's/X//'
Xchar rcsid[] = "$Header: perly.c,v 2.0 88/06/05 00:09:56 root Exp $";
X/*
X * $Log: perly.c,v $
X * Revision 2.0 88/06/05 00:09:56 root
X * Baseline version 2.0.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include "perly.h"
X
Xextern char *tokename[];
Xextern int yychar;
X
Xstatic int cmd_tosave();
Xstatic int arg_tosave();
Xstatic int spat_tosave();
X
Xmain(argc,argv,env)
Xregister int argc;
Xregister char **argv;
Xregister char **env;
X{
X register STR *str;
X register char *s;
X char *index(), *strcpy(), *getenv();
X bool dosearch = FALSE;
X
X uid = (int)getuid();
X euid = (int)geteuid();
X linestr = str_new(80);
X str_nset(linestr,"",0);
X str = str_make(""); /* first used for -I flags */
X incstab = aadd(stabent("INC",TRUE));
X for (argc--,argv++; argc; argc--,argv++) {
X if (argv[0][0] != '-' || !argv[0][1])
X break;
X reswitch:
X switch (argv[0][1]) {
X case 'a':
X minus_a = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X#ifdef DEBUGGING
X case 'D':
X debug = atoi(argv[0]+2);
X#ifdef YYDEBUG
X yydebug = (debug & 1);
X#endif
X break;
X#endif
X case 'e':
X if (!e_fp) {
X e_tmpname = strcpy(safemalloc(sizeof(TMPPATH)),TMPPATH);
X mktemp(e_tmpname);
X e_fp = fopen(e_tmpname,"w");
X }
X if (argv[1])
X fputs(argv[1],e_fp);
X putc('\n', e_fp);
X argc--,argv++;
X break;
X case 'i':
X inplace = savestr(argv[0]+2);
X argvoutstab = stabent("ARGVOUT",TRUE);
X break;
X case 'I':
X str_cat(str,argv[0]);
X str_cat(str," ");
X if (argv[0][2]) {
X apush(incstab->stab_array,str_make(argv[0]+2));
X }
X else {
X apush(incstab->stab_array,str_make(argv[1]));
X str_cat(str,argv[1]);
X argc--,argv++;
X str_cat(str," ");
X }
X break;
X case 'n':
X minus_n = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case 'p':
X minus_p = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case 'P':
X preprocess = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case 's':
X doswitches = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case 'S':
X dosearch = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case 'U':
X unsafe = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case 'v':
X version();
X exit(0);
X case 'w':
X dowarn = TRUE;
X strcpy(argv[0], argv[0]+1);
X goto reswitch;
X case '-':
X argc--,argv++;
X goto switch_end;
X case 0:
X break;
X default:
X fatal("Unrecognized switch: %s",argv[0]);
X }
X }
X switch_end:
X if (e_fp) {
X fclose(e_fp);
X argc++,argv--;
X argv[0] = e_tmpname;
X }
X#ifndef PRIVLIB
X#define PRIVLIB "/usr/local/lib/perl"
X#endif
X apush(incstab->stab_array,str_make(PRIVLIB));
X
X str_set(&str_no,No);
X str_set(&str_yes,Yes);
X init_eval();
X
X /* open script */
X
X if (argv[0] == Nullch)
X argv[0] = "-";
X if (dosearch && argv[0][0] != '/' && (s = getenv("PATH"))) {
X char *xfound = Nullch, *xfailed = Nullch;
X
X while (*s) {
X s = cpytill(tokenbuf,s,':');
X if (*s)
X s++;
X if (tokenbuf[0])
X strcat(tokenbuf,"/");
X strcat(tokenbuf,argv[0]);
X#ifdef DEBUGGING
X if (debug & 1)
X fprintf(stderr,"Looking for %s\n",tokenbuf);
X#endif
X if (stat(tokenbuf,&statbuf) < 0) /* not there? */
X continue;
X if ((statbuf.st_mode & S_IFMT) == S_IFREG
X && cando(S_IREAD,TRUE) && cando(S_IEXEC,TRUE)) {
X xfound = tokenbuf; /* bingo! */
X break;
X }
X if (!xfailed)
X xfailed = savestr(tokenbuf);
X }
X if (!xfound)
X fatal("Can't execute %s", xfailed);
X if (xfailed)
X safefree(xfailed);
X argv[0] = savestr(xfound);
X }
X filename = savestr(argv[0]);
X origfilename = savestr(filename);
X if (strEQ(filename,"-"))
X argv[0] = "";
X if (preprocess) {
X str_cat(str,"-I");
X str_cat(str,PRIVLIB);
X sprintf(buf, "\
X/bin/sed -e '/^[^#]/b' \
X -e '/^#[ ]*include[ ]/b' \
X -e '/^#[ ]*define[ ]/b' \
X -e '/^#[ ]*if[ ]/b' \
X -e '/^#[ ]*ifdef[ ]/b' \
X -e '/^#[ ]*ifndef[ ]/b' \
X -e '/^#[ ]*else/b' \
X -e '/^#[ ]*endif/b' \
X -e 's/^#.*//' \
X %s | %s -C %s %s",
X argv[0], CPPSTDIN, str_get(str), CPPMINUS);
X rsfp = popen(buf,"r");
X }
X else if (!*argv[0])
X rsfp = stdin;
X else
X rsfp = fopen(argv[0],"r");
X if (rsfp == Nullfp)
X fatal("Perl script \"%s\" doesn't seem to exist",filename);
X str_free(str); /* free -I directories */
X
X defstab = stabent("_",TRUE);
X
X /* init tokener */
X
X bufptr = str_get(linestr);
X
X /* now parse the report spec */
X
X if (yyparse())
X fatal("Execution aborted due to compilation errors.\n");
X
X if (dowarn) {
X stab_check('A','Z');
X stab_check('a','z');
X }
X
X preprocess = FALSE;
X if (e_fp) {
X e_fp = Nullfp;
X UNLINK(e_tmpname);
X }
X argc--,argv++; /* skip name of script */
X if (doswitches) {
X for (; argc > 0 && **argv == '-'; argc--,argv++) {
X if (argv[0][1] == '-') {
X argc--,argv++;
X break;
X }
X str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0);
X }
X }
X if (argvstab = stabent("ARGV",allstabs)) {
X aadd(argvstab);
X for (; argc > 0; argc--,argv++) {
X apush(argvstab->stab_array,str_make(argv[0]));
X }
X }
X if (envstab = stabent("ENV",allstabs)) {
X hadd(envstab);
X for (; *env; env++) {
X if (!(s = index(*env,'=')))
X continue;
X *s++ = '\0';
X str = str_make(s);
X str->str_link.str_magic = envstab;
X hstore(envstab->stab_hash,*env,str);
X *--s = '=';
X }
X }
X if (sigstab = stabent("SIG",allstabs))
X hadd(sigstab);
X
X magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|");
X
X sawampersand = (stabent("&",FALSE) != Nullstab);
X if (tmpstab = stabent("0",allstabs))
X str_set(STAB_STR(tmpstab),origfilename);
X if (tmpstab = stabent("$",allstabs))
X str_numset(STAB_STR(tmpstab),(double)getpid());
X
X tmpstab = stabent("stdin",TRUE);
X tmpstab->stab_io = stio_new();
X tmpstab->stab_io->fp = stdin;
X
X tmpstab = stabent("stdout",TRUE);
X tmpstab->stab_io = stio_new();
X tmpstab->stab_io->fp = stdout;
X defoutstab = tmpstab;
X curoutstab = tmpstab;
X
X tmpstab = stabent("stderr",TRUE);
X tmpstab->stab_io = stio_new();
X tmpstab->stab_io->fp = stderr;
X
X savestack = anew(Nullstab); /* for saving non-local values */
X
X setjmp(top_env); /* sets goto_targ on longjump */
X
X#ifdef DEBUGGING
X if (debug & 1024)
X dump_cmd(main_root,Nullcmd);
X if (debug)
X fprintf(stderr,"\nEXECUTING...\n\n");
X#endif
X
X /* do it */
X
X (void) cmd_exec(main_root);
X
X if (goto_targ)
X fatal("Can't find label \"%s\"--aborting",goto_targ);
X exit(0);
X /* NOTREACHED */
X}
X
Xmagicalize(list)
Xregister char *list;
X{
X register STAB *stab;
X char sym[2];
X
X sym[1] = '\0';
X while (*sym = *list++) {
X if (stab = stabent(sym,allstabs)) {
X stab->stab_flags = SF_VMAGIC;
X stab->stab_val->str_link.str_magic = stab;
X }
X }
X}
X
XARG *
Xmake_split(stab,arg)
Xregister STAB *stab;
Xregister ARG *arg;
X{
X register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
X
X if (arg->arg_type != O_MATCH) {
X spat = (SPAT *) safemalloc(sizeof (SPAT));
X bzero((char *)spat, sizeof(SPAT));
X spat->spat_next = spat_root; /* link into spat list */
X spat_root = spat;
X
X spat->spat_runtime = arg;
X arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
X }
X arg->arg_type = O_SPLIT;
X spat = arg[2].arg_ptr.arg_spat;
X spat->spat_repl = stab2arg(A_STAB,aadd(stab));
X if (spat->spat_short) { /* exact match can bypass regexec() */
X if (!((spat->spat_flags & SPAT_SCANFIRST) &&
X (spat->spat_flags & SPAT_ALL) )) {
X str_free(spat->spat_short);
X spat->spat_short = Nullstr;
X }
X }
X return arg;
X}
X
XSUBR *
Xmake_sub(name,cmd)
Xchar *name;
XCMD *cmd;
X{
X register SUBR *sub = (SUBR *) safemalloc(sizeof (SUBR));
X STAB *stab = stabent(name,TRUE);
X
X if (stab->stab_sub) {
X if (dowarn) {
X line_t oldline = line;
X
X if (cmd)
X line = cmd->c_line;
X warn("Subroutine %s redefined",name);
X line = oldline;
X }
X cmd_free(stab->stab_sub->cmd);
X afree(stab->stab_sub->tosave);
X safefree((char*)stab->stab_sub);
X }
X bzero((char *)sub, sizeof(SUBR));
X sub->cmd = cmd;
X sub->filename = filename;
X tosave = anew(Nullstab);
X tosave->ary_fill = 0; /* make 1 based */
X cmd_tosave(cmd); /* this builds the tosave array */
X sub->tosave = tosave;
X stab->stab_sub = sub;
X}
X
XCMD *
Xblock_head(tail)
Xregister CMD *tail;
X{
X if (tail == Nullcmd) {
X return tail;
X }
X return tail->c_head;
X}
X
XCMD *
Xappend_line(head,tail)
Xregister CMD *head;
Xregister CMD *tail;
X{
X if (tail == Nullcmd)
X return head;
X if (!tail->c_head) /* make sure tail is well formed */
X tail->c_head = tail;
X if (head != Nullcmd) {
X tail = tail->c_head; /* get to start of tail list */
X if (!head->c_head)
X head->c_head = head; /* start a new head list */
X while (head->c_next) {
X head->c_next->c_head = head->c_head;
X head = head->c_next; /* get to end of head list */
X }
X head->c_next = tail; /* link to end of old list */
X tail->c_head = head->c_head; /* propagate head pointer */
X }
X while (tail->c_next) {
X tail->c_next->c_head = tail->c_head;
X tail = tail->c_next;
X }
X return tail;
X}
X
XCMD *
Xmake_acmd(type,stab,cond,arg)
Xint type;
XSTAB *stab;
XARG *cond;
XARG *arg;
X{
X register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
X
X bzero((char *)cmd, sizeof(CMD));
X cmd->c_type = type;
X cmd->ucmd.acmd.ac_stab = stab;
X cmd->ucmd.acmd.ac_expr = arg;
X cmd->c_expr = cond;
X if (cond) {
X opt_arg(cmd,1,1);
X cmd->c_flags |= CF_COND;
X }
X if (cmdline != NOLINE) {
X cmd->c_line = cmdline;
X cmdline = NOLINE;
X }
X cmd->c_file = filename;
X return cmd;
X}
X
XCMD *
Xmake_ccmd(type,arg,cblock)
Xint type;
Xregister ARG *arg;
Xstruct compcmd cblock;
X{
X register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
X
X bzero((char *)cmd, sizeof(CMD));
X cmd->c_type = type;
X cmd->c_expr = arg;
X cmd->ucmd.ccmd.cc_true = cblock.comp_true;
X cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
X if (arg) {
X opt_arg(cmd,1,0);
X cmd->c_flags |= CF_COND;
X }
X if (cmdline != NOLINE) {
X cmd->c_line = cmdline;
X cmdline = NOLINE;
X }
X return cmd;
X}
X
Xvoid
Xopt_arg(cmd,fliporflop,acmd)
Xregister CMD *cmd;
Xint fliporflop;
Xint acmd;
X{
X register ARG *arg;
X int opt = CFT_EVAL;
X int sure = 0;
X ARG *arg2;
X char *tmps; /* for True macro */
X int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */
X int flp = fliporflop;
X
X if (!cmd)
X return;
X arg = cmd->c_expr;
X
X /* Can we turn && and || into if and unless? */
X
X if (acmd && !cmd->ucmd.acmd.ac_expr &&
X (arg->arg_type == O_AND || arg->arg_type == O_OR) ) {
X dehoist(arg,1);
X dehoist(arg,2);
X cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg;
X cmd->c_expr = arg[1].arg_ptr.arg_arg;
X if (arg->arg_type == O_OR)
X cmd->c_flags ^= CF_INVERT; /* || is like unless */
X arg->arg_len = 0;
X arg_free(arg);
X arg = cmd->c_expr;
X }
X
X /* Turn "if (!expr)" into "unless (expr)" */
X
X while (arg->arg_type == O_NOT) {
X dehoist(arg,1);
X cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */
X cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */
X free_arg(arg);
X arg = cmd->c_expr; /* here we go again */
X }
X
X if (!arg->arg_len) { /* sanity check */
X cmd->c_flags |= opt;
X return;
X }
X
X /* for "cond .. cond" we set up for the initial check */
X
X if (arg->arg_type == O_FLIP)
X context |= 4;
X
X /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */
X
X if (arg->arg_type == O_AND)
X context |= 1;
X else if (arg->arg_type == O_OR)
X context |= 2;
X if (context && arg[flp].arg_type == A_EXPR) {
X arg = arg[flp].arg_ptr.arg_arg;
X flp = 1;
X }
X
X if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
X cmd->c_flags |= opt;
X return; /* side effect, can't optimize */
X }
X
X if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP ||
X arg->arg_type == O_AND || arg->arg_type == O_OR) {
X if (arg[flp].arg_type == A_SINGLE) {
X opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
X cmd->c_short = arg[flp].arg_ptr.arg_str;
X goto literal;
X }
X else if (arg[flp].arg_type == A_STAB || arg[flp].arg_type == A_LVAL) {
X cmd->c_stab = arg[flp].arg_ptr.arg_stab;
X opt = CFT_REG;
X literal:
X if (!context) { /* no && or ||? */
X free_arg(arg);
X cmd->c_expr = Nullarg;
X }
X if (!(context & 1))
X cmd->c_flags |= CF_EQSURE;
X if (!(context & 2))
X cmd->c_flags |= CF_NESURE;
X }
X }
X else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
X arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
X if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
X arg[2].arg_type == A_SPAT &&
X arg[2].arg_ptr.arg_spat->spat_short ) {
X cmd->c_stab = arg[1].arg_ptr.arg_stab;
X cmd->c_short = arg[2].arg_ptr.arg_spat->spat_short;
X cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen;
X if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL &&
X !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) &&
X (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) )
X sure |= CF_EQSURE; /* (SUBST must be forced even */
X /* if we know it will work.) */
X arg[2].arg_ptr.arg_spat->spat_short = Nullstr;
X arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */
X sure |= CF_NESURE; /* normally only sure if it fails */
X if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST)
X cmd->c_flags |= CF_FIRSTNEG;
X if (context & 1) { /* only sure if thing is false */
X if (cmd->c_flags & CF_FIRSTNEG)
X sure &= ~CF_NESURE;
X else
X sure &= ~CF_EQSURE;
X }
X else if (context & 2) { /* only sure if thing is true */
X if (cmd->c_flags & CF_FIRSTNEG)
X sure &= ~CF_EQSURE;
X else
X sure &= ~CF_NESURE;
X }
X if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/
X if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST)
X opt = CFT_SCAN;
X else
X opt = CFT_ANCHOR;
X if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */
X && arg->arg_type == O_MATCH
X && context & 4
X && fliporflop == 1) {
X spat_free(arg[2].arg_ptr.arg_spat);
X arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */
X }
X cmd->c_flags |= sure;
X }
X }
X }
X else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE ||
X arg->arg_type == O_SLT || arg->arg_type == O_SGT) {
X if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
X if (arg[2].arg_type == A_SINGLE) {
X cmd->c_stab = arg[1].arg_ptr.arg_stab;
X cmd->c_short = arg[2].arg_ptr.arg_str;
X cmd->c_slen = 30000;
X switch (arg->arg_type) {
X case O_SLT: case O_SGT:
X sure |= CF_EQSURE;
X cmd->c_flags |= CF_FIRSTNEG;
X break;
X case O_SNE:
X cmd->c_flags |= CF_FIRSTNEG;
X /* FALL THROUGH */
X case O_SEQ:
X sure |= CF_NESURE|CF_EQSURE;
X break;
X }
X if (context & 1) { /* only sure if thing is false */
X if (cmd->c_flags & CF_FIRSTNEG)
X sure &= ~CF_NESURE;
X else
X sure &= ~CF_EQSURE;
X }
X else if (context & 2) { /* only sure if thing is true */
X if (cmd->c_flags & CF_FIRSTNEG)
X sure &= ~CF_EQSURE;
X else
X sure &= ~CF_NESURE;
X }
X if (sure & (CF_EQSURE|CF_NESURE)) {
X opt = CFT_STROP;
X cmd->c_flags |= sure;
X }
X }
X }
X }
X else if (arg->arg_type == O_EQ || arg->arg_type == O_NE ||
X arg->arg_type == O_LE || arg->arg_type == O_GE ||
X arg->arg_type == O_LT || arg->arg_type == O_GT) {
X if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
X if (arg[2].arg_type == A_SINGLE) {
X cmd->c_stab = arg[1].arg_ptr.arg_stab;
X cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str));
X cmd->c_slen = arg->arg_type;
X sure |= CF_NESURE|CF_EQSURE;
X if (context & 1) { /* only sure if thing is false */
X sure &= ~CF_EQSURE;
X }
X else if (context & 2) { /* only sure if thing is true */
X sure &= ~CF_NESURE;
X }
X if (sure & (CF_EQSURE|CF_NESURE)) {
X opt = CFT_NUMOP;
X cmd->c_flags |= sure;
X }
X }
X }
X }
X else if (arg->arg_type == O_ASSIGN &&
X (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
X arg[1].arg_ptr.arg_stab == defstab &&
X arg[2].arg_type == A_EXPR ) {
X arg2 = arg[2].arg_ptr.arg_arg;
X if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) {
X opt = CFT_GETS;
X cmd->c_stab = arg2[1].arg_ptr.arg_stab;
X if (!(arg2[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV)) {
X free_arg(arg2);
X free_arg(arg);
X cmd->c_expr = Nullarg;
X }
X }
X }
X else if (arg->arg_type == O_CHOP &&
X (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) {
X opt = CFT_CHOP;
X cmd->c_stab = arg[1].arg_ptr.arg_stab;
X free_arg(arg);
X cmd->c_expr = Nullarg;
X }
X if (context & 4)
X opt |= CF_FLIP;
X cmd->c_flags |= opt;
X
X if (cmd->c_flags & CF_FLIP) {
X if (fliporflop == 1) {
X arg = cmd->c_expr; /* get back to O_FLIP arg */
X arg[3].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
X bcopy((char *)cmd, (char *)arg[3].arg_ptr.arg_cmd, sizeof(CMD));
X arg[4].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
X bcopy((char *)cmd, (char *)arg[4].arg_ptr.arg_cmd, sizeof(CMD));
X opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd);
X arg->arg_len = 2; /* this is a lie */
X }
X else {
X if ((opt & CF_OPTIMIZE) == CFT_EVAL)
X cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP;
X }
X }
X}
X
XARG *
Xmod_match(type,left,pat)
Xregister ARG *left;
Xregister ARG *pat;
X{
X
X register SPAT *spat;
X register ARG *newarg;
X
X if ((pat->arg_type == O_MATCH ||
X pat->arg_type == O_SUBST ||
X pat->arg_type == O_TRANS ||
X pat->arg_type == O_SPLIT
X ) &&
X pat[1].arg_ptr.arg_stab == defstab ) {
X switch (pat->arg_type) {
X case O_MATCH:
X newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH,
X pat->arg_len,
X left,Nullarg,Nullarg,0);
X break;
X case O_SUBST:
X newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
X pat->arg_len,
X left,Nullarg,Nullarg,0));
X break;
X case O_TRANS:
X newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
X pat->arg_len,
X left,Nullarg,Nullarg,0));
X break;
X case O_SPLIT:
X newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
X pat->arg_len,
X left,Nullarg,Nullarg,0);
X break;
X }
X if (pat->arg_len >= 2) {
X newarg[2].arg_type = pat[2].arg_type;
X newarg[2].arg_ptr = pat[2].arg_ptr;
X newarg[2].arg_flags = pat[2].arg_flags;
X if (pat->arg_len >= 3) {
X newarg[3].arg_type = pat[3].arg_type;
X newarg[3].arg_ptr = pat[3].arg_ptr;
X newarg[3].arg_flags = pat[3].arg_flags;
X }
X }
X safefree((char*)pat);
X }
X else {
X spat = (SPAT *) safemalloc(sizeof (SPAT));
X bzero((char *)spat, sizeof(SPAT));
X spat->spat_next = spat_root; /* link into spat list */
X spat_root = spat;
X
X spat->spat_runtime = pat;
X newarg = make_op(type,2,left,Nullarg,Nullarg,0);
X newarg[2].arg_type = A_SPAT;
X newarg[2].arg_ptr.arg_spat = spat;
X newarg[2].arg_flags = AF_SPECIAL;
X }
X
X return newarg;
X}
X
XCMD *
Xadd_label(lbl,cmd)
Xchar *lbl;
Xregister CMD *cmd;
X{
X if (cmd)
X cmd->c_label = lbl;
X return cmd;
X}
X
XCMD *
Xaddcond(cmd, arg)
Xregister CMD *cmd;
Xregister ARG *arg;
X{
X cmd->c_expr = arg;
X opt_arg(cmd,1,0);
X cmd->c_flags |= CF_COND;
X return cmd;
X}
X
XCMD *
Xaddloop(cmd, arg)
Xregister CMD *cmd;
Xregister ARG *arg;
X{
X cmd->c_expr = arg;
X opt_arg(cmd,1,0);
X cmd->c_flags |= CF_COND|CF_LOOP;
X if (cmd->c_type == C_BLOCK)
X cmd->c_flags &= ~CF_COND;
X else {
X arg = cmd->ucmd.acmd.ac_expr;
X if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
X cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */
X if (arg && arg->arg_type == O_SUBR)
X cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */
X }
X return cmd;
X}
X
XCMD *
Xinvert(cmd)
Xregister CMD *cmd;
X{
X cmd->c_flags ^= CF_INVERT;
X return cmd;
X}
X
Xyyerror(s)
Xchar *s;
X{
X char tmpbuf[128];
X char *tname = tmpbuf;
X
X if (yychar > 256) {
X tname = tokename[yychar-256];
X if (strEQ(tname,"word"))
X strcpy(tname,tokenbuf);
X else if (strEQ(tname,"register"))
X sprintf(tname,"$%s",tokenbuf);
X else if (strEQ(tname,"array_length"))
X sprintf(tname,"$#%s",tokenbuf);
X }
X else if (!yychar)
X strcpy(tname,"EOF");
X else if (yychar < 32)
X sprintf(tname,"^%c",yychar+64);
X else if (yychar == 127)
X strcpy(tname,"^?");
X else
X sprintf(tname,"%c",yychar);
X sprintf(tokenbuf, "%s in file %s at line %d, next token \"%s\"\n",
X s,filename,line,tname);
X if (in_eval)
X str_set(stabent("@",TRUE)->stab_val,tokenbuf);
X else
X fputs(tokenbuf,stderr);
X}
X
XARG *
Xmake_op(type,newlen,arg1,arg2,arg3,dolist)
Xint type;
Xint newlen;
XARG *arg1;
XARG *arg2;
XARG *arg3;
Xint dolist;
X{
X register ARG *arg;
X register ARG *chld;
X register int doarg;
X
X arg = op_new(newlen);
X arg->arg_type = type;
X doarg = opargs[type];
X if (chld = arg1) {
X if (!(doarg & 1))
X arg[1].arg_flags |= AF_SPECIAL;
X if (doarg & 16)
X arg[1].arg_flags |= AF_NUMERIC;
X if (chld->arg_type == O_ITEM &&
X (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL) ) {
X arg[1].arg_type = chld[1].arg_type;
X arg[1].arg_ptr = chld[1].arg_ptr;
X arg[1].arg_flags |= chld[1].arg_flags;
X free_arg(chld);
X }
X else {
X arg[1].arg_type = A_EXPR;
X arg[1].arg_ptr.arg_arg = chld;
X if (dolist & 1) {
X if (chld->arg_type == O_LIST) {
X if (newlen == 1) { /* we can hoist entire list */
X chld->arg_type = type;
X free_arg(arg);
X arg = chld;
X }
X else {
X arg[1].arg_flags |= AF_SPECIAL;
X }
X }
X else {
X switch (chld->arg_type) {
X case O_ARRAY:
X if (chld->arg_len == 1)
X arg[1].arg_flags |= AF_SPECIAL;
X break;
X case O_ITEM:
X if (chld[1].arg_type == A_READ ||
X chld[1].arg_type == A_INDREAD ||
X chld[1].arg_type == A_GLOB)
X arg[1].arg_flags |= AF_SPECIAL;
X break;
X case O_SPLIT:
X case O_TMS:
X case O_EACH:
X case O_VALUES:
X case O_KEYS:
X case O_SORT:
X arg[1].arg_flags |= AF_SPECIAL;
X break;
X }
X }
X }
X }
X }
X if (chld = arg2) {
X if (!(doarg & 2))
X arg[2].arg_flags |= AF_SPECIAL;
X if (doarg & 32)
X arg[2].arg_flags |= AF_NUMERIC;
X if (chld->arg_type == O_ITEM &&
X (hoistable[chld[1].arg_type] ||
X (type == O_ASSIGN &&
X ((chld[1].arg_type == A_READ && !(arg[1].arg_flags & AF_SPECIAL))
X ||
X (chld[1].arg_type == A_INDREAD && !(arg[1].arg_flags & AF_SPECIAL))
X ||
X (chld[1].arg_type == A_GLOB && !(arg[1].arg_flags & AF_SPECIAL))
X ||
X chld[1].arg_type == A_BACKTICK ) ) ) ) {
X arg[2].arg_type = chld[1].arg_type;
X arg[2].arg_ptr = chld[1].arg_ptr;
X free_arg(chld);
X }
X else {
X arg[2].arg_type = A_EXPR;
X arg[2].arg_ptr.arg_arg = chld;
X if ((dolist & 2) &&
X (chld->arg_type == O_LIST ||
X (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
X arg[2].arg_flags |= AF_SPECIAL;
X }
X }
X if (chld = arg3) {
X if (!(doarg & 4))
X arg[3].arg_flags |= AF_SPECIAL;
X if (doarg & 64)
X arg[3].arg_flags |= AF_NUMERIC;
X if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
X arg[3].arg_type = chld[1].arg_type;
X arg[3].arg_ptr = chld[1].arg_ptr;
X free_arg(chld);
X }
X else {
X arg[3].arg_type = A_EXPR;
X arg[3].arg_ptr.arg_arg = chld;
X if ((dolist & 4) &&
X (chld->arg_type == O_LIST ||
X (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
X arg[3].arg_flags |= AF_SPECIAL;
X }
X }
X#ifdef DEBUGGING
X if (debug & 16) {
X fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
X if (arg1)
X fprintf(stderr,",%s=%lx",
X argname[arg[1].arg_type],arg[1].arg_ptr.arg_arg);
X if (arg2)
X fprintf(stderr,",%s=%lx",
X argname[arg[2].arg_type],arg[2].arg_ptr.arg_arg);
X if (arg3)
X fprintf(stderr,",%s=%lx",
X argname[arg[3].arg_type],arg[3].arg_ptr.arg_arg);
X fprintf(stderr,")\n");
X }
X#endif
X evalstatic(arg); /* see if we can consolidate anything */
X return arg;
X}
X
X/* turn 123 into 123 == $. */
X
XARG *
Xflipflip(arg)
Xregister ARG *arg;
X{
X if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_SINGLE) {
X arg = (ARG*)saferealloc((char*)arg,3*sizeof(ARG));
X arg->arg_type = O_EQ;
X arg->arg_len = 2;
X arg[2].arg_type = A_STAB;
X arg[2].arg_flags = 0;
X arg[2].arg_ptr.arg_stab = stabent(".",TRUE);
X }
X return arg;
X}
X
Xvoid
Xevalstatic(arg)
Xregister ARG *arg;
X{
X register STR *str;
X register STR *s1;
X register STR *s2;
X double value; /* must not be register */
X register char *tmps;
X int i;
X unsigned long tmplong;
X double exp(), log(), sqrt(), modf();
X char *crypt();
X
X if (!arg || !arg->arg_len)
X return;
X
X if (arg[1].arg_type == A_SINGLE &&
X (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
X str = str_new(0);
X s1 = arg[1].arg_ptr.arg_str;
X if (arg->arg_len > 1)
X s2 = arg[2].arg_ptr.arg_str;
X else
X s2 = Nullstr;
X switch (arg->arg_type) {
X default:
X str_free(str);
X str = Nullstr; /* can't be evaluated yet */
X break;
X case O_CONCAT:
X str_sset(str,s1);
X str_scat(str,s2);
X break;
X case O_REPEAT:
X i = (int)str_gnum(s2);
X while (i-- > 0)
X str_scat(str,s1);
X break;
X case O_MULTIPLY:
X value = str_gnum(s1);
X str_numset(str,value * str_gnum(s2));
X break;
X case O_DIVIDE:
X value = str_gnum(s2);
X if (value == 0.0)
X fatal("Illegal division by constant zero");
X str_numset(str,str_gnum(s1) / value);
X break;
X case O_MODULO:
X tmplong = (unsigned long)str_gnum(s2);
X if (tmplong == 0L)
X fatal("Illegal modulus of constant zero");
X str_numset(str,(double)(((unsigned long)str_gnum(s1)) % tmplong));
X break;
X case O_ADD:
X value = str_gnum(s1);
X str_numset(str,value + str_gnum(s2));
X break;
X case O_SUBTRACT:
X value = str_gnum(s1);
X str_numset(str,value - str_gnum(s2));
X break;
X case O_LEFT_SHIFT:
X value = str_gnum(s1);
X i = (int)str_gnum(s2);
X str_numset(str,(double)(((unsigned long)value) << i));
X break;
X case O_RIGHT_SHIFT:
X value = str_gnum(s1);
X i = (int)str_gnum(s2);
X str_numset(str,(double)(((unsigned long)value) >> i));
X break;
X case O_LT:
X value = str_gnum(s1);
X str_numset(str,(double)(value < str_gnum(s2)));
X break;
X case O_GT:
X value = str_gnum(s1);
X str_numset(str,(double)(value > str_gnum(s2)));
X break;
X case O_LE:
X value = str_gnum(s1);
X str_numset(str,(double)(value <= str_gnum(s2)));
X break;
X case O_GE:
X value = str_gnum(s1);
X str_numset(str,(double)(value >= str_gnum(s2)));
X break;
X case O_EQ:
X value = str_gnum(s1);
X str_numset(str,(double)(value == str_gnum(s2)));
X break;
X case O_NE:
X value = str_gnum(s1);
X str_numset(str,(double)(value != str_gnum(s2)));
X break;
X case O_BIT_AND:
X value = str_gnum(s1);
X str_numset(str,(double)(((unsigned long)value) &
X ((unsigned long)str_gnum(s2))));
X break;
X case O_XOR:
X value = str_gnum(s1);
X str_numset(str,(double)(((unsigned long)value) ^
X ((unsigned long)str_gnum(s2))));
X break;
X case O_BIT_OR:
X value = str_gnum(s1);
X str_numset(str,(double)(((unsigned long)value) |
X ((unsigned long)str_gnum(s2))));
X break;
X case O_AND:
X if (str_true(s1))
X str = str_make(str_get(s2));
X else
X str = str_make(str_get(s1));
X break;
X case O_OR:
X if (str_true(s1))
X str = str_make(str_get(s1));
X else
X str = str_make(str_get(s2));
X break;
X case O_COND_EXPR:
X if (arg[3].arg_type != A_SINGLE) {
X str_free(str);
X str = Nullstr;
X }
X else {
X str = str_make(str_get(str_true(s1) ? s2 : arg[3].arg_ptr.arg_str));
X str_free(arg[3].arg_ptr.arg_str);
X }
X break;
X case O_NEGATE:
X str_numset(str,(double)(-str_gnum(s1)));
X break;
X case O_NOT:
X str_numset(str,(double)(!str_true(s1)));
X break;
X case O_COMPLEMENT:
X str_numset(str,(double)(~(long)str_gnum(s1)));
X break;
X case O_LENGTH:
X str_numset(str, (double)str_len(s1));
X break;
X case O_SUBSTR:
X if (arg[3].arg_type != A_SINGLE || stabent("[",allstabs)) {
X str_free(str); /* making the fallacious assumption */
X str = Nullstr; /* that any $[ occurs before substr()*/
X }
X else {
X char *beg;
X int len = (int)str_gnum(s2);
X int tmp;
X
X for (beg = str_get(s1); *beg && len > 0; beg++,len--) ;
X len = (int)str_gnum(arg[3].arg_ptr.arg_str);
X str_free(arg[3].arg_ptr.arg_str);
X if (len > (tmp = strlen(beg)))
X len = tmp;
X str_nset(str,beg,len);
X }
X break;
X case O_SLT:
X tmps = str_get(s1);
X str_numset(str,(double)(strLT(tmps,str_get(s2))));
X break;
X case O_SGT:
X tmps = str_get(s1);
X str_numset(str,(double)(strGT(tmps,str_get(s2))));
X break;
X case O_SLE:
X tmps = str_get(s1);
X str_numset(str,(double)(strLE(tmps,str_get(s2))));
X break;
X case O_SGE:
X tmps = str_get(s1);
X str_numset(str,(double)(strGE(tmps,str_get(s2))));
X break;
X case O_SEQ:
X tmps = str_get(s1);
X str_numset(str,(double)(strEQ(tmps,str_get(s2))));
X break;
X case O_SNE:
X tmps = str_get(s1);
X str_numset(str,(double)(strNE(tmps,str_get(s2))));
X break;
X case O_CRYPT:
X#ifdef CRYPT
X tmps = str_get(s1);
X str_set(str,crypt(tmps,str_get(s2)));
X#else
X fatal(
X "The crypt() function is unimplemented due to excessive paranoia.");
X#endif
X break;
X case O_EXP:
X str_numset(str,exp(str_gnum(s1)));
X break;
X case O_LOG:
X str_numset(str,log(str_gnum(s1)));
X break;
X case O_SQRT:
X str_numset(str,sqrt(str_gnum(s1)));
X break;
X case O_INT:
X value = str_gnum(s1);
X if (value >= 0.0)
X modf(value,&value);
X else {
X modf(-value,&value);
X value = -value;
X }
X str_numset(str,value);
X break;
X case O_ORD:
X str_numset(str,(double)(*str_get(s1)));
X break;
X }
X if (str) {
X arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */
X str_free(s1);
X str_free(s2);
X arg[1].arg_ptr.arg_str = str;
X }
X }
X}
X
XARG *
Xl(arg)
Xregister ARG *arg;
X{
X register int i;
X register ARG *arg1;
X ARG *tmparg;
X
X arg->arg_flags |= AF_COMMON; /* XXX should cross-match */
X /* this does unnecessary copying */
X
X if (arg[1].arg_type == A_ARYLEN) {
X arg[1].arg_type = A_LARYLEN;
X return arg;
X }
X
X /* see if it's an array reference */
X
X if (arg[1].arg_type == A_EXPR) {
X arg1 = arg[1].arg_ptr.arg_arg;
X
X if (arg1->arg_type == O_LIST && arg->arg_type != O_ITEM) {
X /* assign to list */
X arg[1].arg_flags |= AF_SPECIAL;
X dehoist(arg,2);
X arg[2].arg_flags |= AF_SPECIAL;
X for (i = arg1->arg_len; i >= 1; i--) {
X switch (arg1[i].arg_type) {
X case A_STAB: case A_LVAL:
X arg1[i].arg_type = A_LVAL;
X break;
X case A_EXPR: case A_LEXPR:
X arg1[i].arg_type = A_LEXPR;
X if (arg1[i].arg_ptr.arg_arg->arg_type == O_ARRAY)
X arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
X else if (arg1[i].arg_ptr.arg_arg->arg_type == O_HASH)
X arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
X if (arg1[i].arg_ptr.arg_arg->arg_type == O_LARRAY)
X break;
X if (arg1[i].arg_ptr.arg_arg->arg_type == O_LHASH)
X break;
X /* FALL THROUGH */
X default:
X sprintf(tokenbuf,
X "Illegal item (%s) as lvalue",argname[arg1[i].arg_type]);
X yyerror(tokenbuf);
X }
X }
X }
X else if (arg1->arg_type == O_ARRAY) {
X if (arg1->arg_len == 1 && arg->arg_type != O_ITEM) {
X /* assign to array */
X arg[1].arg_flags |= AF_SPECIAL;
X dehoist(arg,2);
X arg[2].arg_flags |= AF_SPECIAL;
X }
X else
X arg1->arg_type = O_LARRAY; /* assign to array elem */
X }
X else if (arg1->arg_type == O_HASH)
X arg1->arg_type = O_LHASH;
X else if (arg1->arg_type != O_ASSIGN) {
X sprintf(tokenbuf,
X "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
X yyerror(tokenbuf);
X }
X arg[1].arg_type = A_LEXPR;
X#ifdef DEBUGGING
X if (debug & 16)
X fprintf(stderr,"lval LEXPR\n");
X#endif
X return arg;
X }
X
X /* not an array reference, should be a register name */
X
X if (arg[1].arg_type != A_STAB && arg[1].arg_type != A_LVAL) {
X sprintf(tokenbuf,
X "Illegal item (%s) as lvalue",argname[arg[1].arg_type]);
X yyerror(tokenbuf);
X }
X arg[1].arg_type = A_LVAL;
X#ifdef DEBUGGING
X if (debug & 16)
X fprintf(stderr,"lval LVAL\n");
X#endif
X return arg;
X}
X
Xdehoist(arg,i)
XARG *arg;
X{
X ARG *tmparg;
X
X if (arg[i].arg_type != A_EXPR) { /* dehoist */
X tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg,0);
X tmparg[1] = arg[i];
X arg[i].arg_ptr.arg_arg = tmparg;
X arg[i].arg_type = A_EXPR;
X }
X}
X
XARG *
Xaddflags(i,flags,arg)
Xregister ARG *arg;
X{
X arg[i].arg_flags |= flags;
X return arg;
X}
X
XARG *
Xhide_ary(arg)
XARG *arg;
X{
X if (arg->arg_type == O_ARRAY)
X return make_op(O_ITEM,1,arg,Nullarg,Nullarg,0);
X return arg;
X}
X
XARG *
Xmake_list(arg)
Xregister ARG *arg;
X{
X register int i;
X register ARG *node;
X register ARG *nxtnode;
X register int j;
X STR *tmpstr;
X
X if (!arg) {
X arg = op_new(0);
X arg->arg_type = O_LIST;
X }
X if (arg->arg_type != O_COMMA) {
X arg->arg_flags |= AF_LISTISH; /* see listish() below */
X return arg;
X }
X for (i = 2, node = arg; ; i++) {
X if (node->arg_len < 2)
X break;
X if (node[2].arg_type != A_EXPR)
X break;
X node = node[2].arg_ptr.arg_arg;
X if (node->arg_type != O_COMMA)
X break;
X }
X if (i > 2) {
X node = arg;
X arg = op_new(i);
X tmpstr = arg->arg_ptr.arg_str;
X *arg = *node; /* copy everything except the STR */
X arg->arg_ptr.arg_str = tmpstr;
X for (j = 1; ; ) {
X arg[j] = node[1];
X ++j; /* Bug in Xenix compiler */
X if (j >= i) {
X arg[j] = node[2];
X free_arg(node);
X break;
X }
X nxtnode = node[2].arg_ptr.arg_arg;
X free_arg(node);
X node = nxtnode;
X }
X }
X arg->arg_type = O_LIST;
X arg->arg_len = i;
X return arg;
X}
X
X/* turn a single item into a list */
X
XARG *
Xlistish(arg)
XARG *arg;
X{
X if (arg->arg_flags & AF_LISTISH) {
X arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0);
X arg[1].arg_flags &= ~AF_SPECIAL;
X }
X return arg;
X}
X
X/* mark list of local variables */
X
XARG *
Xlocalize(arg)
XARG *arg;
X{
X arg->arg_flags |= AF_LOCAL;
X return arg;
X}
X
XARG *
Xstab2arg(atype,stab)
Xint atype;
Xregister STAB *stab;
X{
X register ARG *arg;
X
X arg = op_new(1);
X arg->arg_type = O_ITEM;
X arg[1].arg_type = atype;
X arg[1].arg_ptr.arg_stab = stab;
X return arg;
X}
X
XARG *
Xcval_to_arg(cval)
Xregister char *cval;
X{
X register ARG *arg;
X
X arg = op_new(1);
X arg->arg_type = O_ITEM;
X arg[1].arg_type = A_SINGLE;
X arg[1].arg_ptr.arg_str = str_make(cval);
X safefree(cval);
X return arg;
X}
X
XARG *
Xop_new(numargs)
Xint numargs;
X{
X register ARG *arg;
X
X arg = (ARG*)safemalloc((numargs + 1) * sizeof (ARG));
X bzero((char *)arg, (numargs + 1) * sizeof (ARG));
X arg->arg_ptr.arg_str = str_new(0);
X arg->arg_len = numargs;
X return arg;
X}
X
Xvoid
Xfree_arg(arg)
XARG *arg;
X{
X str_free(arg->arg_ptr.arg_str);
X safefree((char*)arg);
X}
X
XARG *
Xmake_match(type,expr,spat)
Xint type;
XARG *expr;
XSPAT *spat;
X{
X register ARG *arg;
X
X arg = make_op(type,2,expr,Nullarg,Nullarg,0);
X
X arg[2].arg_type = A_SPAT;
X arg[2].arg_ptr.arg_spat = spat;
X#ifdef DEBUGGING
X if (debug & 16)
X fprintf(stderr,"make_match SPAT=%lx\n",(long)spat);
X#endif
X
X if (type == O_SUBST || type == O_NSUBST) {
X if (arg[1].arg_type != A_STAB)
X yyerror("Illegal lvalue");
X arg[1].arg_type = A_LVAL;
X }
X return arg;
X}
X
XARG *
Xcmd_to_arg(cmd)
XCMD *cmd;
X{
X register ARG *arg;
X
X arg = op_new(1);
X arg->arg_type = O_ITEM;
X arg[1].arg_type = A_CMD;
X arg[1].arg_ptr.arg_cmd = cmd;
X return arg;
X}
X
XCMD *
Xwopt(cmd)
Xregister CMD *cmd;
X{
X register CMD *tail;
X register ARG *arg = cmd->c_expr;
X STAB *asgnstab;
X
X /* hoist "while (<channel>)" up into command block */
X
X if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
X cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
X cmd->c_flags |= CFT_GETS; /* and set it to do the input */
X cmd->c_stab = arg[1].arg_ptr.arg_stab;
X if (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) {
X cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
X stab2arg(A_LVAL,defstab), arg, Nullarg,1 ));
X }
X else {
X free_arg(arg);
X cmd->c_expr = Nullarg;
X }
X }
X else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
X cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
X cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */
X cmd->c_stab = arg[1].arg_ptr.arg_stab;
X free_arg(arg);
X cmd->c_expr = Nullarg;
X }
X else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
X if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
X asgnstab = cmd->c_stab;
X else
X asgnstab = defstab;
X cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */
X stab2arg(A_LVAL,asgnstab), arg, Nullarg,1 ));
X cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
X }
X
X /* First find the end of the true list */
X
X if (cmd->ucmd.ccmd.cc_true == Nullcmd)
X return cmd;
X for (tail = cmd->ucmd.ccmd.cc_true; tail->c_next; tail = tail->c_next) ;
X
X /* if there's a continue block, link it to true block and find end */
X
X if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
X tail->c_next = cmd->ucmd.ccmd.cc_alt;
X for ( ; tail->c_next; tail = tail->c_next) ;
X }
X
X /* Here's the real trick: link the end of the list back to the beginning,
X * inserting a "last" block to break out of the loop. This saves one or
X * two procedure calls every time through the loop, because of how cmd_exec
X * does tail recursion.
X */
X
X tail->c_next = (CMD *) safemalloc(sizeof (CMD));
X tail = tail->c_next;
X if (!cmd->ucmd.ccmd.cc_alt)
X cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */
X
X bcopy((char *)cmd, (char *)tail, sizeof(CMD));
X tail->c_type = C_EXPR;
X tail->c_flags ^= CF_INVERT; /* turn into "last unless" */
X tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */
X tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg,0);
X tail->ucmd.acmd.ac_stab = Nullstab;
X return cmd;
X}
X
XCMD *
Xover(eachstab,cmd)
XSTAB *eachstab;
Xregister CMD *cmd;
X{
X /* hoist "for $foo (@bar)" up into command block */
X
X cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
X cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */
X cmd->c_stab = eachstab;
X
X return cmd;
X}
X
Xstatic int gensym = 0;
X
XSTAB *
Xgenstab()
X{
X sprintf(tokenbuf,"_GEN_%d",gensym++);
X return stabent(tokenbuf,TRUE);
X}
X
X/* this routine is in perly.c by virtue of being sort of an alternate main() */
X
XSTR *
Xdo_eval(str,optype)
XSTR *str;
Xint optype;
X{
X int retval;
X CMD *myroot;
X ARRAY *ar;
X int i;
X char *oldfile = filename;
X line_t oldline = line;
X int oldtmps_base = tmps_base;
X int oldsave = savestack->ary_fill;
X
X tmps_base = tmps_max;
X str_set(stabent("@",TRUE)->stab_val,"");
X if (optype != O_DOFILE) { /* normal eval */
X filename = "(eval)";
X line = 1;
X str_sset(linestr,str);
X }
X else {
X filename = savestr(str_get(str)); /* can't free this easily */
X str_set(linestr,"");
X rsfp = fopen(filename,"r");
X ar = incstab->stab_array;
X if (!rsfp && *filename != '/') {
X for (i = 0; i <= ar->ary_fill; i++) {
X sprintf(tokenbuf,"%s/%s",str_get(afetch(ar,i)),filename);
X rsfp = fopen(tokenbuf,"r");
X if (rsfp) {
X free(filename);
X filename = savestr(tokenbuf);
X break;
X }
X }
X }
X if (!rsfp) {
X filename = oldfile;
X tmps_base = oldtmps_base;
X return &str_no;
X }
X line = 0;
X }
X in_eval++;
X bufptr = str_get(linestr);
X if (setjmp(eval_env))
X retval = 1;
X else
X retval = yyparse();
X myroot = eval_root; /* in case cmd_exec does another eval! */
X if (retval)
X str = &str_no;
X else {
X str = str_static(cmd_exec(eval_root));
X /* if we don't save str, free zaps it */
X cmd_free(myroot); /* can't free on error, for some reason */
X }
X in_eval--;
X filename = oldfile;
X line = oldline;
X tmps_base = oldtmps_base;
X if (savestack->ary_fill > oldsave) /* let them use local() */
X restorelist(oldsave);
X return str;
X}
X
Xcmd_free(cmd)
Xregister CMD *cmd;
X{
X register CMD *tofree;
X register CMD *head = cmd;
X
X while (cmd) {
X if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */
X if (cmd->c_label)
X safefree(cmd->c_label);
X if (cmd->c_short)
X str_free(cmd->c_short);
X if (cmd->c_spat)
X spat_free(cmd->c_spat);
X if (cmd->c_expr)
X arg_free(cmd->c_expr);
X }
X switch (cmd->c_type) {
X case C_WHILE:
X case C_BLOCK:
X case C_IF:
X if (cmd->ucmd.ccmd.cc_true)
X cmd_free(cmd->ucmd.ccmd.cc_true);
X if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
X cmd_free(cmd->ucmd.ccmd.cc_alt);
X break;
X case C_EXPR:
X if (cmd->ucmd.acmd.ac_expr)
X arg_free(cmd->ucmd.acmd.ac_expr);
X break;
X }
X tofree = cmd;
X cmd = cmd->c_next;
X safefree((char*)tofree);
X if (cmd && cmd == head) /* reached end of while loop */
X break;
X }
X}
X
Xarg_free(arg)
Xregister ARG *arg;
X{
X register int i;
X
X for (i = 1; i <= arg->arg_len; i++) {
X switch (arg[i].arg_type) {
X case A_NULL:
X break;
X case A_LEXPR:
X case A_EXPR:
X arg_free(arg[i].arg_ptr.arg_arg);
X break;
X case A_CMD:
X cmd_free(arg[i].arg_ptr.arg_cmd);
X break;
X case A_WORD:
X case A_STAB:
X case A_LVAL:
X case A_READ:
X case A_GLOB:
X case A_ARYLEN:
X break;
X case A_SINGLE:
X case A_DOUBLE:
X case A_BACKTICK:
X str_free(arg[i].arg_ptr.arg_str);
X break;
X case A_SPAT:
X spat_free(arg[i].arg_ptr.arg_spat);
X break;
X case A_NUMBER:
X break;
X }
X }
X free_arg(arg);
X}
X
Xspat_free(spat)
Xregister SPAT *spat;
X{
X register SPAT *sp;
X
X if (spat->spat_runtime)
X arg_free(spat->spat_runtime);
X if (spat->spat_repl) {
X arg_free(spat->spat_repl);
X }
X if (spat->spat_short) {
X str_free(spat->spat_short);
X }
X if (spat->spat_regexp) {
X regfree(spat->spat_regexp);
X }
X
X /* now unlink from spat list */
X if (spat_root == spat)
X spat_root = spat->spat_next;
X else {
X for (sp = spat_root; sp->spat_next != spat; sp = sp->spat_next) ;
X sp->spat_next = spat->spat_next;
X }
X
X safefree((char*)spat);
X}
X
X/* Recursively descend a command sequence and push the address of any string
X * that needs saving on recursion onto the tosave array.
X */
X
Xstatic int
Xcmd_tosave(cmd)
Xregister CMD *cmd;
X{
X register CMD *head = cmd;
X
X while (cmd) {
X if (cmd->c_spat)
X spat_tosave(cmd->c_spat);
X if (cmd->c_expr)
X arg_tosave(cmd->c_expr);
X switch (cmd->c_type) {
X case C_WHILE:
X case C_BLOCK:
X case C_IF:
X if (cmd->ucmd.ccmd.cc_true)
X cmd_tosave(cmd->ucmd.ccmd.cc_true);
X if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
X cmd_tosave(cmd->ucmd.ccmd.cc_alt);
X break;
X case C_EXPR:
X if (cmd->ucmd.acmd.ac_expr)
X arg_tosave(cmd->ucmd.acmd.ac_expr);
X break;
X }
X cmd = cmd->c_next;
X if (cmd && cmd == head) /* reached end of while loop */
X break;
X }
X}
X
Xstatic int
Xarg_tosave(arg)
Xregister ARG *arg;
X{
X register int i;
X int saving = FALSE;
X
X for (i = 1; i <= arg->arg_len; i++) {
X switch (arg[i].arg_type) {
X case A_NULL:
X break;
X case A_LEXPR:
X case A_EXPR:
X saving |= arg_tosave(arg[i].arg_ptr.arg_arg);
X break;
X case A_CMD:
X cmd_tosave(arg[i].arg_ptr.arg_cmd);
X saving = TRUE; /* assume hanky panky */
X break;
X case A_WORD:
X case A_STAB:
X case A_LVAL:
X case A_READ:
X case A_GLOB:
X case A_ARYLEN:
X case A_SINGLE:
X case A_DOUBLE:
X case A_BACKTICK:
X break;
X case A_SPAT:
X saving |= spat_tosave(arg[i].arg_ptr.arg_spat);
X break;
X case A_NUMBER:
X break;
X }
X }
X switch (arg->arg_type) {
X case O_EVAL:
X case O_SUBR:
X saving = TRUE;
X }
X if (saving)
X apush(tosave,arg->arg_ptr.arg_str);
X return saving;
X}
X
Xstatic int
Xspat_tosave(spat)
Xregister SPAT *spat;
X{
X int saving = FALSE;
X
X if (spat->spat_runtime)
X saving |= arg_tosave(spat->spat_runtime);
X if (spat->spat_repl) {
X saving |= arg_tosave(spat->spat_repl);
X }
X
X return saving;
X}
!STUFFY!FUNK!
echo Extracting x2p/Makefile.SH
sed >x2p/Makefile.SH <<'!STUFFY!FUNK!' -e 's/X//'
Xcase $CONFIG in
X'')
X if test ! -f config.sh; then
X ln ../config.sh . || \
X ln ../../config.sh . || \
X ln ../../../config.sh . || \
X (echo "Can't find config.sh."; exit 1)
X fi
X . ./config.sh
X ;;
Xesac
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
Xcase "$mallocsrc" in
X'') ;;
X*) mallocsrc="../$mallocsrc";;
Xesac
Xecho "Extracting x2p/Makefile (with variable substitutions)"
Xcat >Makefile <<!GROK!THIS!
X# $Header: Makefile.SH,v 2.0 88/06/05 00:15:31 root Exp $
X#
X# $Log: Makefile.SH,v $
X# Revision 2.0 88/06/05 00:15:31 root
X# Baseline version 2.0.
X#
X#
X
XCC = $cc
Xbin = $bin
Xlib = $lib
Xmansrc = $mansrc
Xmanext = $manext
XCFLAGS = $ccflags -O
XLDFLAGS = $ldflags
XSMALL = $small
XLARGE = $large $split
Xmallocsrc = $mallocsrc
Xmallocobj = $mallocobj
X
Xlibs = $libnm -lm
X!GROK!THIS!
X
Xcat >>Makefile <<'!NO!SUBS!'
X
Xpublic = a2p s2p
X
Xprivate =
X
Xmanpages = a2p.man s2p.man
X
Xutil =
X
Xsh = Makefile.SH makedepend.SH
X
Xh = EXTERN.h INTERN.h config.h handy.h hash.h a2p.h str.h util.h
X
Xc = hash.c $(mallocsrc) str.c util.c walk.c
X
Xobj = hash.o $(mallocobj) str.o util.o walk.o
X
Xlintflags = -phbvxac
X
Xaddedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
X
X# grrr
XSHELL = /bin/sh
X
X.c.o:
X $(CC) -c $(CFLAGS) $(LARGE) $*.c
X
Xall: $(public) $(private) $(util)
X touch all
X
Xa2p: $(obj) a2p.o
X $(CC) $(LDFLAGS) $(LARGE) $(obj) a2p.o $(libs) -o a2p
X
Xa2p.c: a2p.y
X @ echo Expect 103 shift/reduce errors...
X yacc a2p.y
X mv y.tab.c a2p.c
X
Xa2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h
X $(CC) -c $(CFLAGS) $(LARGE) a2p.c
X
X# if a .h file depends on another .h file...
X$(h):
X touch $@
Xinstall: a2p s2p
X# won't work with csh
X export PATH || exit 1
X - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null
X - mv $(bin)/s2p $(bin)/s2p.old
X - if test `pwd` != $(bin); then cp $(public) $(bin); fi
X cd $(bin); \
Xfor pub in $(public); do \
Xchmod +x `basename $$pub`; \
Xdone
X# chmod +x makedir
X# - ./makedir `filexp $(lib)`
X# - \
X#if test `pwd` != `filexp $(lib)`; then \
X#cp $(private) `filexp $(lib)`; \
X#fi
X# cd `filexp $(lib)`; \
X#for priv in $(private); do \
X#chmod +x `basename $$priv`; \
X#done
X - if test `pwd` != $(mansrc); then \
Xfor page in $(manpages); do \
Xcp $$page $(mansrc)/`basename $$page .man`.$(manext); \
Xdone; \
Xfi
X
Xclean:
X rm -f *.o
X
Xrealclean:
X rm -f a2p *.orig */*.orig *.o core $(addedbyconf)
X
X# The following lint has practically everything turned on. Unfortunately,
X# you have to wade through a lot of mumbo jumbo that can't be suppressed.
X# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
X# for that spot.
X
Xlint:
X lint $(lintflags) $(defs) $(c) > a2p.fuzz
X
Xdepend: ../makedepend
X ../makedepend
X
Xclist:
X echo $(c) | tr ' ' '\012' >.clist
X
Xhlist:
X echo $(h) | tr ' ' '\012' >.hlist
X
Xshlist:
X echo $(sh) | tr ' ' '\012' >.shlist
X
X# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
X$(obj):
X @ echo "You haven't done a "'"make depend" yet!'; exit 1
Xmakedepend: makedepend.SH
X /bin/sh makedepend.SH
X!NO!SUBS!
X$eunicefix Makefile
Xcase `pwd` in
X*SH)
X $rm -f ../Makefile
X ln Makefile ../Makefile
X ;;
Xesac
!STUFFY!FUNK!
echo Extracting Wishlist
sed >Wishlist <<'!STUFFY!FUNK!' -e 's/X//'
Xdate support
Xcase statement
Xioctl() support
Xrandom numbers
!STUFFY!FUNK!
echo ""
echo "End of kit 4 (of 15)"
cat /dev/null >kit4isdone
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.