Path: utzoo!attcan!uunet!lll-winken!lll-tis!ames!elroy!jpl-devvax!lwall From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) Newsgroups: comp.sources.bugs Subject: perl 2.0 patch #15 Summary: This is an official patch for perl 2.0. Please apply it. Message-ID: <3439@jpl-devvax.JPL.NASA.GOV> Date: 1 Nov 88 01:26:52 GMT Organization: Jet Propulsion Laboratory, Pasadena, CA Lines: 1520 System: perl version 2.0 Patch #: 15 Priority: Subject: support for libc in more places Subject: some support for defective 286 compilers Subject: printf "%%" now works more consistently Subject: close $foo; didn't work right Subject: support for varargs and vprintf Subject: clarified location of array iterators. Subject: documented interpolation of variables into patterns. Subject: Documented that $a and $b are passed by reference in sort specs Subject: Documented that only one study is active at at time Subject: now suppresses -S if / is anywhere in script name. Subject: fix for signed/unsigned conflicts introduced in patch 14 Subject: in a2p, deleted some duplicate $ characters Description: Perl now makes use of varargs and vprintf where available. Configure checks whether they are. Configure also looks for libc (or clib) in more places (like /lib/large, /usr/lib/large, etc.). There's now some support for at least one broken 286 compiler. If this doesn't fix your 286 compiler's problems, lemme know. printf with a format containing "%%" sometimes make %% and sometime just %. It now makes % all the time. close $foo; (an indirect close) caused a core dump. This is now fixed. In the documentation I made some clarifications regarding array iterators, interpolation of variables into patterns, the way $a and $b are passed to a sort specification subroutine, and how study works. Previously -S (path search) was suppressed if the script name began with '/'. Now it is suppressed if there is a '/' anywhere in the script name. Patch 14 introduced some irritating but non-destructive warnings about conflicts between signed and unsigned characters. I put in some casts to suppress some of the chatter. No doubt somebody's compiler will now complain elsewhere. In a2p, certain symbols came out with an extra $ sign on the front. This has been remedied. Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source directory. Outside of rn, say "cd DIR; patch -p -N #define PATCHLEVEL 15 Index: Configure Prereq: 2.0.1.5 *** Configure.old Mon Oct 31 16:52:31 1988 --- Configure Mon Oct 31 16:52:35 1988 *************** *** 8,14 **** # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $Header: Configure,v 2.0.1.5 88/09/07 16:28:09 lwall Locked $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than --- 8,14 ---- # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $Header: Configure,v 2.0.1.6 88/10/31 16:21:11 lwall Locked $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than *************** *** 94,101 **** --- 94,103 ---- d_strctcpy='' d_symlink='' d_tminsys='' + d_varargs='' d_vfork='' d_voidsig='' + d_vprintf='' gidtype='' libc='' libnm='' *************** *** 137,143 **** define='define' undef='undef' ! libpth='/usr/lib /usr/local/lib /lib' smallmach='pdp11 i8086 z8000 i80286 iAPX286' rmlist='kit[1-9]isdone kit[1-9][0-9]isdone' trap 'echo " "; rm -f $rmlist; exit 1' 1 2 3 --- 139,145 ---- define='define' undef='undef' ! libpth='/usr/lib /usr/local/lib /lib /usr/lib/large /lib/large /usr/lib/small /lib/small' smallmach='pdp11 i8086 z8000 i80286 iAPX286' rmlist='kit[1-9]isdone kit[1-9][0-9]isdone' trap 'echo " "; rm -f $rmlist; exit 1' 1 2 3 *************** *** 445,454 **** else ans=`loc libc.a blurfl/dyick $libpth` if test ! -f $ans; then ! ans=`loc clib blurfl/dyick $libpth` fi if test ! -f $ans; then ! ans=`loc libc blurfl/dyick $libpth` fi if test -f $ans; then echo "Your C library is in $ans, of all places." --- 447,456 ---- else ans=`loc libc.a blurfl/dyick $libpth` if test ! -f $ans; then ! ans=`loc libc blurfl/dyick $libpth` fi if test ! -f $ans; then ! ans=`loc clib blurfl/dyick $libpth` fi if test -f $ans; then echo "Your C library is in $ans, of all places." *************** *** 1315,1320 **** --- 1317,1332 ---- d_tminsys="$define" fi + : see if this is a varargs system + echo " " + if $test -r /usr/include/varargs.h ; then + d_varargs="$define" + echo "varargs.h found." + else + d_varargs="$undef" + echo "No varargs.h found, but that's ok (I hope)." + fi + : see if there is a vfork echo " " if $contains '^vfork$' libc.list >/dev/null 2>&1 ; then *************** *** 1335,1340 **** --- 1347,1362 ---- d_voidsig="$undef" fi + : see if vprintf exists + echo " " + if $contains '^vprintf$' libc.list >/dev/null 2>&1; then + echo 'vprintf() found.' + d_vprintf="$define" + else + echo 'vprintf() not found.' + d_vprintf="$undef" + fi + : check for void type echo " " $cat < 0 && !*str_get(afetch(ary,iters-1))) iters--; + #else + char *zaps; + int zapb; + + zaps = str_get(afetch(ary,iters-1)); + zapb = (int) *zaps; + + while (iters > 0 && (!zapb)) { + iters--; + if (iters > 0) { + zaps = str_get(afetch(ary,iters-1)); + zapb = (int) *zaps; + } + } + #endif } if (retary) { #ifndef M_I386 *************** *** 1187,1194 **** } str_cat(str,buf); } ! if (*s) ! str_cat(str,s); STABSET(str); } --- 1208,1217 ---- } str_cat(str,buf); } ! if (*s) { ! sprintf(buf,s,0,0,0,0); ! str_cat(str,buf); ! } STABSET(str); } *************** *** 1879,1885 **** opargs[O_OPEN] = A(1,1,0); opargs[O_TRANS] = A(1,0,0); opargs[O_NTRANS] = A(1,0,0); ! opargs[O_CLOSE] = A(0,0,0); opargs[O_ARRAY] = A(1,0,0); opargs[O_HASH] = A(1,0,0); opargs[O_LARRAY] = A(1,0,0); --- 1902,1908 ---- opargs[O_OPEN] = A(1,1,0); opargs[O_TRANS] = A(1,0,0); opargs[O_NTRANS] = A(1,0,0); ! opargs[O_CLOSE] = A(1,0,0); opargs[O_ARRAY] = A(1,0,0); opargs[O_HASH] = A(1,0,0); opargs[O_LARRAY] = A(1,0,0); Index: cmd.c Prereq: 2.0.1.2 *** cmd.c.old Mon Oct 31 16:53:04 1988 --- cmd.c Mon Oct 31 16:53:06 1988 *************** *** 1,6 **** ! /* $Header: cmd.c,v 2.0.1.2 88/08/03 22:11:09 root Exp $ * * $Log: cmd.c,v $ * Revision 2.0.1.2 88/08/03 22:11:09 root * patch11: fixed some possible null dereferences in debugging code * patch11: couldn't mix two ways of returning values from subroutines --- 1,10 ---- ! /* $Header: cmd.c,v 2.0.1.3 88/10/31 16:26:07 lwall Locked $ * * $Log: cmd.c,v $ + * Revision 2.0.1.3 88/10/31 16:26:07 lwall + * patch15: varargs supported + * patch15: some support for defective 286 compilers + * * Revision 2.0.1.2 88/08/03 22:11:09 root * patch11: fixed some possible null dereferences in debugging code * patch11: couldn't mix two ways of returning values from subroutines *************** *** 17,22 **** --- 21,30 ---- #include "EXTERN.h" #include "perl.h" + #ifdef VARARGS + # include + #endif + static STR str_chop; /* This is the main command loop. We try to spend as much time in this loop *************** *** 241,246 **** --- 249,255 ---- /* FALL THROUGH */ case CFT_STROP: /* string op optimization */ retstr = STAB_STR(cmd->c_stab); + #ifndef I286 if (*cmd->c_short->str_ptr == *str_get(retstr) && strnEQ(cmd->c_short->str_ptr, str_get(retstr), cmd->c_slen) ) { *************** *** 266,271 **** --- 275,315 ---- retstr = &str_no; goto flipmaybe; } + #else + { + char *zap1, *zap2, zap1c, zap2c; + int zaplen; + + zap1 = cmd->c_short->str_ptr; + zap2 = str_get(retstr); + zap1c = *zap1; + zap2c = *zap2; + zaplen = cmd->c_slen; + if ((zap1c == zap2c) && (strnEQ(zap1, zap2, zaplen))) { + if (cmdflags & CF_EQSURE) { + if (sawampersand && cmd->c_slen < 30000) { + curspat = Nullspat; + if (leftstab) + str_nset(leftstab->stab_val,"",0); + if (amperstab) + str_sset(amperstab->stab_val,cmd->c_short); + if (rightstab) + str_nset(rightstab->stab_val, + retstr->str_ptr + cmd->c_slen, + retstr->str_cur - cmd->c_slen); + } + match = !(cmdflags & CF_FIRSTNEG); + retstr = &str_yes; + goto flipmaybe; + } + } + else if (cmdflags & CF_NESURE) { + match = cmdflags & CF_FIRSTNEG; + retstr = &str_no; + goto flipmaybe; + } + } + #endif break; /* must evaluate */ case CFT_SCAN: /* non-anchored search */ *************** *** 599,604 **** --- 643,649 ---- } #ifdef DEBUGGING + # ifndef VARARGS /*VARARGS1*/ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) char *pat; *************** *** 610,615 **** --- 655,679 ---- fprintf(stderr,"%c%c ",debname[i],debdelim[i]); fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8); } + # else + /*VARARGS1*/ + deb(va_alist) + va_dcl + { + va_list args; + char *pat; + register int i; + + va_start(args); + fprintf(stderr,"%-4ld",(long)line); + for (i=0; i 0x10000000) + #ifndef I286 fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p); + #else + fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p); + #endif nextf[bucket] = nextf[bucket]->ov_next; p->ov_magic = MAGIC; p->ov_index= bucket; *************** *** 168,177 **** --- 175,195 ---- * make getpageize call? */ op = (union overhead *)sbrk(0); + #ifndef I286 if ((int)op & 0x3ff) sbrk(1024 - ((int)op & 0x3ff)); + #else + /* The sbrk(0) call on the I286 always returns the next segment */ + #endif + + #ifndef I286 /* take 2k unless the block is bigger than that */ rnu = (bucket <= 8) ? 11 : bucket + 3; + #else + /* take 16k unless the block is bigger than that + (80286s like large segments!) */ + rnu = (bucket <= 11) ? 14 : bucket + 3; + #endif nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ if (rnu < bucket) rnu = bucket; *************** *** 183,192 **** --- 201,214 ---- * Round up to minimum allocation size boundary * and deduct from block count to reflect. */ + #ifndef I286 if ((int)op & 7) { op = (union overhead *)(((int)op + 8) &~ 7); nblks--; } + #else + /* Again, this should always be ok on an 80286 */ + #endif /* * Add new memory allocated to that on * free list for this hash bucket. Index: perl.h Prereq: 2.0.1.3 *** perl.h.old Mon Oct 31 16:53:43 1988 --- perl.h Mon Oct 31 16:53:45 1988 *************** *** 1,6 **** ! /* $Header: perl.h,v 2.0.1.3 88/09/07 16:51:18 lwall Exp $ * * $Log: perl.h,v $ * Revision 2.0.1.3 88/09/07 16:51:18 lwall * patch14: added sawi variable to optimize study when no //i found * --- 1,9 ---- ! /* $Header: perl.h,v 2.0.1.4 88/10/31 16:30:40 lwall Locked $ * * $Log: perl.h,v $ + * Revision 2.0.1.4 88/10/31 16:30:40 lwall + * patch15: some support for defective 286 compilers + * * Revision 2.0.1.3 88/09/07 16:51:18 lwall * patch14: added sawi variable to optimize study when no //i found * *************** *** 75,80 **** --- 78,87 ---- #include "array.h" #include "hash.h" + #if defined(iAPX286) || defined(M_I286) || defined(I80286) + # define I286 + #endif + #ifdef CHARSPRINTF char *sprintf(); #else *************** *** 127,132 **** --- 134,140 ---- ARG *make_split(); ARG *flipflip(); ARG *listish(); + ARG *maybelistish(); ARG *localize(); ARG *j(); ARG *l(); Index: perl.man.1 Prereq: 2.0.1.5 *** perl.man.1.old Mon Oct 31 16:53:55 1988 --- perl.man.1 Mon Oct 31 16:53:59 1988 *************** *** 1,7 **** .rn '' }` ! ''' $Header: perl.man.1,v 2.0.1.5 88/09/07 16:52:04 lwall Locked $ ''' ''' $Log: perl.man.1,v $ ''' Revision 2.0.1.5 88/09/07 16:52:04 lwall ''' patch14: documented setting $? by closing pipe ''' --- 1,11 ---- .rn '' }` ! ''' $Header: perl.man.1,v 2.0.1.6 88/10/31 16:33:00 lwall Locked $ ''' ''' $Log: perl.man.1,v $ + ''' Revision 2.0.1.6 88/10/31 16:33:00 lwall + ''' patch15: clarified location of array iterators. + ''' patch15: documented interpolation of variables into patterns. + ''' ''' Revision 2.0.1.5 88/09/07 16:52:04 lwall ''' patch14: documented setting $? by closing pipe ''' *************** *** 816,822 **** --- 820,829 ---- foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'}) { print "Item: $item\en"; } + .fi + (NB: there is only one iterator for each array, so you can't nest + iterators on the same array currently.) .PP The BLOCK by itself (labeled or not) is equivalent to a loop that executes once. *************** *** 1138,1143 **** --- 1145,1152 ---- This is particularly useful for matching Unix path names that contain \*(L'/\*(R'. If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is done in a case-insensitive manner. + PATTERN may contain references to scalar variables, which will be interpolated + (and the pattern recompiled) every time the pattern search is evaluated. .Sp If used in a context that requires an array value, a pattern match returns an array consisting of the subexpressions matched by the parentheses in pattern, Index: perl.man.2 Prereq: 2.0.1.6 *** perl.man.2.old Mon Oct 31 16:54:13 1988 --- perl.man.2 Mon Oct 31 16:54:19 1988 *************** *** 1,7 **** ''' Beginning of part 2 ! ''' $Header: perl.man.2,v 2.0.1.6 88/09/07 16:54:49 lwall Locked $ ''' ''' $Log: perl.man.2,v $ ''' Revision 2.0.1.6 88/09/07 16:54:49 lwall ''' patch14: spelled caesar right ''' patch14: generalized $? slightly --- 1,11 ---- ''' Beginning of part 2 ! ''' $Header: perl.man.2,v 2.0.1.7 88/10/31 16:41:21 lwall Locked $ ''' ''' $Log: perl.man.2,v $ + ''' Revision 2.0.1.7 88/10/31 16:41:21 lwall + ''' patch15: Documented that $a and $b are passed by reference in sort specs + ''' patch15: Documented that only one study is active at at time + ''' ''' Revision 2.0.1.6 88/09/07 16:54:49 lwall ''' patch14: spelled caesar right ''' patch14: generalized $? slightly *************** *** 541,546 **** --- 545,551 ---- is bypassed, with the following effects: the subroutine may not be a recursive subroutine, and the two elements to be compared are passed into the subroutine not via @_ but as $a and $b (see example below). + They are passed by reference so don't modify $a and $b. SUBROUTINE may be a scalar variable name, in which case the value provides the name of the subroutine to use. Examples: *************** *** 650,655 **** --- 655,662 ---- without it to see which runs faster. Those loops which scan for many short constant strings (including the constant parts of more complex patterns) will benefit most. + You may have only one study active at a time\*(--if you study a different + scalar the first is \*(L"unstudied\*(R". (The way study works is this: a linked list of every character in the string to be searched is made, so we know, for example, where all the \*(L'k\*(R' characters are. *************** *** 886,895 **** --- 893,904 ---- either very high or very low depending on whether you look at the left side of operator or the right side of it. For example, in + .nf @ary = (1, 3, sort 4, 2); print @ary; # prints 1324 + .fi the commas on the right of the sort are evaluated before the sort, but the commas on the left are evaluated after. In other words, list operators tend to gobble up all the arguments that *************** *** 982,990 **** Alternatives may be separated by |. The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e matches the digit'th substring, where digit can range from 1 to 9. ! (Outside of patterns, use $ instead of \e in front of the digit. The scope of $ extends to the end of the enclosing BLOCK, or to ! the next pattern match with subexpressions.) $+ returns whatever the last bracket match matched. $& returns the entire matched string. ($0 normally returns the same thing, but don't depend on it.) --- 991,1001 ---- Alternatives may be separated by |. The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e matches the digit'th substring, where digit can range from 1 to 9. ! (Outside of the pattern, always use $ instead of \e in front of the digit. The scope of $ extends to the end of the enclosing BLOCK, or to ! the next pattern match with subexpressions. ! The \e notation sometimes works outside the current pattern, but should ! be relied upon.) $+ returns whatever the last bracket match matched. $& returns the entire matched string. ($0 normally returns the same thing, but don't depend on it.) *************** *** 1299,1305 **** .ne 3 $_ = \'abcdefghi\'; /def/; ! print "$\`:$&:$\'\n"; # prints abc:def:ghi .fi .Ip $+ 8 4 --- 1310,1316 ---- .ne 3 $_ = \'abcdefghi\'; /def/; ! print "$\`:$&:$\'\en"; # prints abc:def:ghi .fi .Ip $+ 8 4 *************** *** 1635,1642 **** Associative arrays really ought to be first class objects. .PP .I Perl ! is at the mercy of the C compiler's definitions of various operations ! such atof(). .PP If your stdio requires an seek or eof between reads and writes on a particular stream, so does --- 1646,1653 ---- Associative arrays really ought to be first class objects. .PP .I Perl ! is at the mercy of your machine's definitions of various operations ! such as type casting, atof() and sprintf(). .PP If your stdio requires an seek or eof between reads and writes on a particular stream, so does Index: perl.y Prereq: 2.0.1.4 *** perl.y.old Mon Oct 31 16:54:29 1988 --- perl.y Mon Oct 31 16:54:31 1988 *************** *** 1,6 **** ! /* $Header: perl.y,v 2.0.1.4 88/09/07 16:55:41 lwall Exp $ * * $Log: perl.y,v $ * Revision 2.0.1.4 88/09/07 16:55:41 lwall * patch14: case insensitive search speedup * --- 1,9 ---- ! /* $Header: perl.y,v 2.0.1.5 88/10/31 16:42:23 lwall Locked $ * * $Log: perl.y,v $ + * Revision 2.0.1.5 88/10/31 16:42:23 lwall + * patch15: printf "%%" is now more consistent + * * Revision 2.0.1.4 88/09/07 16:55:41 lwall * patch14: case insensitive search speedup * *************** *** 676,682 **** stab2arg(A_WORD,Nullstab), Nullarg,0); } | LISTOP expr ! { $$ = make_op($1,2,make_list($2), stab2arg(A_WORD,Nullstab), Nullarg,1); } | LISTOP WORD --- 679,685 ---- stab2arg(A_WORD,Nullstab), Nullarg,0); } | LISTOP expr ! { $$ = make_op($1,2,maybelistish($1,make_list($2)), stab2arg(A_WORD,Nullstab), Nullarg,1); } | LISTOP WORD *************** *** 685,695 **** stab2arg(A_WORD,stabent($2,TRUE)), Nullarg,1); } | LISTOP WORD expr ! { $$ = make_op($1,2,make_list($3), stab2arg(A_WORD,stabent($2,TRUE)), Nullarg,1); } | LISTOP REG expr ! { $$ = make_op($1,2,make_list($3), stab2arg(A_STAB,$2), Nullarg,1); } ; --- 688,698 ---- stab2arg(A_WORD,stabent($2,TRUE)), Nullarg,1); } | LISTOP WORD expr ! { $$ = make_op($1,2,maybelistish($1,make_list($3)), stab2arg(A_WORD,stabent($2,TRUE)), Nullarg,1); } | LISTOP REG expr ! { $$ = make_op($1,2,maybelistish($1,make_list($3)), stab2arg(A_STAB,$2), Nullarg,1); } ; Index: perly.c Prereq: 2.0.1.7 *** perly.c.old Mon Oct 31 16:54:45 1988 --- perly.c Mon Oct 31 16:54:52 1988 *************** *** 1,6 **** ! char rcsid[] = "$Header: perly.c,v 2.0.1.7 88/09/07 16:57:47 lwall Exp $"; /* * $Log: perly.c,v $ * Revision 2.0.1.7 88/09/07 16:57:47 lwall * patch14: $foo = `echo $foo` now works right * patch14: % should now work with a negative left argument --- 1,11 ---- ! char rcsid[] = "$Header: perly.c,v 2.0.1.8 88/10/31 16:44:49 lwall Locked $"; /* * $Log: perly.c,v $ + * Revision 2.0.1.8 88/10/31 16:44:49 lwall + * patch15: now suppresses -S if / is anywhere in script name. + * patch15: some support for defective 286 compilers + * patch15: printf "%%" is now more consistent + * * Revision 2.0.1.7 88/09/07 16:57:47 lwall * patch14: $foo = `echo $foo` now works right * patch14: % should now work with a negative left argument *************** *** 203,209 **** if (argv[0] == Nullch) argv[0] = "-"; ! if (dosearch && argv[0][0] != '/' && (s = getenv("PATH"))) { char *xfound = Nullch, *xfailed = Nullch; while (*s) { --- 208,214 ---- if (argv[0] == Nullch) argv[0] = "-"; ! if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) { char *xfound = Nullch, *xfailed = Nullch; while (*s) { *************** *** 1410,1416 **** --- 1415,1432 ---- str_numset(str,value); break; case O_ORD: + #ifndef I286 str_numset(str,(double)(*str_get(s1))); + #else + { + int zapc; + char *zaps; + + zaps = str_get(s1); + zapc = (int) *zaps; + str_numset(str,(double)(zapc)); + } + #endif break; } if (str) { *************** *** 1631,1636 **** --- 1647,1662 ---- arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0); arg[1].arg_flags &= ~AF_SPECIAL; } + return arg; + } + + ARG * + maybelistish(optype, arg) + unsigned int optype; + ARG *arg; + { + if (optype == O_PRTF) + arg = listish(arg); return arg; } Index: util.c Prereq: 2.0.1.4 *** util.c.old Mon Oct 31 16:55:06 1988 --- util.c Mon Oct 31 16:55:08 1988 *************** *** 1,6 **** ! /* $Header: util.c,v 2.0.1.4 88/09/07 17:12:49 lwall Exp $ * * $Log: util.c,v $ * Revision 2.0.1.4 88/09/07 17:12:49 lwall * patch14: case insensitive search speedup * patch14: searches should now work on chars with the 128 bit set --- 1,11 ---- ! /* $Header: util.c,v 2.0.1.5 88/10/31 16:51:04 lwall Locked $ * * $Log: util.c,v $ + * Revision 2.0.1.5 88/10/31 16:51:04 lwall + * patch15: some support for defective 286 compilers + * patch15: support for varargs and vprintf + * patch15: fix for signed/unsigned conflicts introduced in patch 14 + * * Revision 2.0.1.4 88/09/07 17:12:49 lwall * patch14: case insensitive search speedup * patch14: searches should now work on chars with the 128 bit set *************** *** 22,27 **** --- 27,36 ---- #include "EXTERN.h" #include "perl.h" + #ifdef VARARGS + # include + #endif + #define FLUSH static char nomem[] = "Out of memory!\n"; *************** *** 41,48 **** --- 50,62 ---- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #ifdef DEBUGGING + # ifndef I286 if (debug & 128) fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); + # else + if (debug & 128) + fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",ptr,an++,size); + # endif #endif if (ptr != Nullch) return ptr; *************** *** 67,76 **** --- 81,97 ---- fatal("Null realloc"); ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ #ifdef DEBUGGING + # ifndef I286 if (debug & 128) { fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); } + # else + if (debug & 128) { + fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++); + fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",ptr,an++,size); + } + # endif #endif if (ptr != Nullch) return ptr; *************** *** 87,94 **** --- 108,120 ---- char *where; { #ifdef DEBUGGING + # ifndef I286 if (debug & 128) fprintf(stderr,"0x%x: (%05d) free\n",where,an++); + # else + if (debug & 128) + fprintf(stderr,"0x%lx: (%05d) free\n",where,an++); + # endif #endif if (where) { free(where); *************** *** 306,323 **** int frequency = 256; str_grow(str,len+256); ! table = str->str_ptr + len; /* actually points at final '\0' */ s = table - 1; for (i = 1; i < 256; i++) { table[i] = len; } i = 0; ! while (s >= str->str_ptr) { if (!isascii(*s)) return; if (table[*s] == len) { if (iflag) table[*s] = table[fold[*s]] = i; else table[*s] = i; } --- 332,358 ---- int frequency = 256; str_grow(str,len+256); ! table = (unsigned char*)str->str_ptr + len; /* really points at final '\0'*/ s = table - 1; for (i = 1; i < 256; i++) { table[i] = len; } i = 0; ! while (s >= (unsigned char*)str->str_ptr) { if (!isascii(*s)) return; if (table[*s] == len) { + #ifndef pdp11 if (iflag) table[*s] = table[fold[*s]] = i; + #else + if (iflag) { + int j; + j = fold[*s]; + table[j] = i; + table[*s] = i; + } + #endif /* pdp11 */ else table[*s] = i; } *************** *** 325,331 **** } str->str_pok |= 2; /* deep magic */ ! s = str->str_ptr; /* deeper magic */ if (iflag) { register int tmp, foldtmp; str->str_pok |= 8; --- 360,366 ---- } str->str_pok |= 2; /* deep magic */ ! s = (unsigned char*)str->str_ptr; /* deeper magic */ if (iflag) { register int tmp, foldtmp; str->str_pok |= 8; *************** *** 366,372 **** register int tmp; register char *little = littlestr->str_ptr; int littlelen = littlestr->str_cur; ! register char *table = little + littlelen; s = big + biglen - littlelen; while (s >= big) { --- 401,407 ---- register int tmp; register char *little = littlestr->str_ptr; int littlelen = littlestr->str_cur; ! register char *table = (unsigned char*)little + littlelen; s = big + biglen - littlelen; while (s >= big) { *************** *** 385,392 **** char * fbminstr(big, bigend, littlestr) ! char *big; ! register char *bigend; STR *littlestr; { register unsigned char *s; --- 420,427 ---- char * fbminstr(big, bigend, littlestr) ! unsigned char *big; ! register unsigned char *bigend; STR *littlestr; { register unsigned char *s; *************** *** 402,408 **** return instr(big,littlestr->str_ptr); littlelen = littlestr->str_cur; ! table = littlestr->str_ptr + littlelen; s = big + --littlelen; oldlittle = little = table - 1; if (littlestr->str_pok & 8) { /* case insensitive? */ --- 437,443 ---- return instr(big,littlestr->str_ptr); littlelen = littlestr->str_cur; ! table = (unsigned char*)littlestr->str_ptr + littlelen; s = big + --littlelen; oldlittle = little = table - 1; if (littlestr->str_pok & 8) { /* case insensitive? */ *************** *** 423,429 **** goto top1; return Nullch; } ! return s; } } } --- 458,464 ---- goto top1; return Nullch; } ! return (char *)s; } } } *************** *** 445,451 **** goto top2; return Nullch; } ! return s; } } } --- 480,486 ---- goto top2; return Nullch; } ! return (char *)s; } } } *************** *** 458,464 **** STR *littlestr; { register unsigned char *s, *x; ! register unsigned char *big = bigstr->str_ptr; register int pos; register int previous; register int first; --- 493,499 ---- STR *littlestr; { register unsigned char *s, *x; ! register unsigned char *big = (unsigned char *)bigstr->str_ptr; register int pos; register int previous; register int first; *************** *** 466,472 **** if ((pos = screamfirst[littlestr->str_rare]) < 0) return Nullch; ! little = littlestr->str_ptr; first = *little++; previous = littlestr->str_prev; big -= previous; --- 501,507 ---- if ((pos = screamfirst[littlestr->str_rare]) < 0) return Nullch; ! little = (unsigned char *)littlestr->str_ptr; first = *little++; previous = littlestr->str_prev; big -= previous; *************** *** 487,493 **** } } if (!*s) ! return big+pos; } while (pos += screamnext[pos]); } else { --- 522,528 ---- } } if (!*s) ! return (char *)big+pos; } while (pos += screamnext[pos]); } else { *************** *** 503,509 **** } } if (!*s) ! return big+pos; } while (pos += screamnext[pos]); } return Nullch; --- 538,544 ---- } } if (!*s) ! return (char *)big+pos; } while (pos += screamnext[pos]); } return Nullch; *************** *** 540,545 **** --- 575,581 ---- extern int errno; + #ifndef VARARGS /*VARARGS1*/ mess(pat,a1,a2,a3,a4) char *pat; *************** *** 598,604 **** --- 634,709 ---- fputs(buf,stderr); fflush(stderr); } + #else + /*VARARGS1*/ + mess(args) + va_list args; + { + char *pat; + char *s; + char *vsprintf(); + s = buf; + pat = va_arg(args, char *); + (void) vsprintf(s,pat,args); + + s += strlen(s); + if (s[-1] != '\n') { + if (line) { + sprintf(s," at %s line %ld", + in_eval?filename:origfilename, (long)line); + s += strlen(s); + } + if (last_in_stab && + last_in_stab->stab_io && + last_in_stab->stab_io->lines ) { + sprintf(s,", <%s> line %ld", + last_in_stab == argvstab ? "" : last_in_stab->stab_name, + (long)last_in_stab->stab_io->lines); + s += strlen(s); + } + strcpy(s,".\n"); + } + } + + /*VARARGS1*/ + fatal(va_alist) + va_dcl + { + va_list args; + extern FILE *e_fp; + extern char *e_tmpname; + + va_start(args); + mess(args); + va_end(args); + if (in_eval) { + str_set(stabent("@",TRUE)->stab_val,buf); + longjmp(eval_env,1); + } + fputs(buf,stderr); + fflush(stderr); + if (e_fp) + UNLINK(e_tmpname); + statusvalue >>= 8; + exit(errno?errno:(statusvalue?statusvalue:255)); + } + + /*VARARGS1*/ + warn(va_alist) + va_dcl + { + va_list args; + + va_start(args); + mess(args); + va_end(args); + + fputs(buf,stderr); + fflush(stderr); + } + #endif + static bool firstsetenv = TRUE; extern char **environ; *************** *** 696,698 **** --- 801,831 ---- } #endif #endif + + #ifdef VARARGS + #ifndef VPRINTF + + char * + vsprintf(dest, pat, args) + char *dest, *pat, *args; + { + FILE fakebuf; + + fakebuf._ptr = dest; + fakebuf._cnt = 32767; + fakebuf._flag = _IOWRT|_IOSTRG; + _doprnt(pat, args, &fakebuf); /* what a kludge */ + putc('\0', &fakebuf); + return(dest); + } + + int + vfprintf(fd, pat, args) + FILE *fd; + char *pat, *args; + { + _doprnt(pat, args, fd); + return 0; /* wrong, but perl doesn't use the return value */ + } + #endif /* VPRINTF */ + #endif /* VARARGS */