diff options
| -rwxr-xr-x | Configure | 53 | ||||
| -rw-r--r-- | Makefile.SH | 20 | ||||
| -rw-r--r-- | README | 1 | ||||
| -rw-r--r-- | arg.h | 16 | ||||
| -rw-r--r-- | cmd.c | 17 | ||||
| -rw-r--r-- | cons.c | 10 | ||||
| -rw-r--r-- | consarg.c | 16 | ||||
| -rw-r--r-- | doarg.c | 35 | ||||
| -rw-r--r-- | doio.c | 8 | ||||
| -rw-r--r-- | dolist.c | 231 | ||||
| -rw-r--r-- | patchlevel.h | 2 |
11 files changed, 330 insertions, 79 deletions
@@ -8,7 +8,7 @@ # 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 3.0.1.5 90/02/28 16:17:50 lwall Locked $ +# $Header: Configure,v 3.0.1.6 90/03/12 16:10:23 lwall Locked $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than @@ -257,7 +257,7 @@ attrlist="$attrlist i186 __m88k__ m88k DGUX __DGUX__" pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /usr/plx /usr/5bin /vol/local/bin /etc /usr/lib /lib /usr/local/lib /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/bin /bsd4.3/usr/ucb" d_newshome="/usr/NeWS" defvoidused=7 -libswanted="net_s net nsl_s nsl socket nm ndir ndbm dbm sun bsd BSD x c_s PW" +libswanted="net_s net nsl_s nsl socket nm ndir ndbm dbm sun bsd BSD x c_s" inclwanted='/usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan' : some greps do not return status, grrr. echo "grimblepritz" >grimble @@ -638,11 +638,11 @@ esac cont=true while $test "$cont" ; do echo " " - rp="Where do you want to put the public executables? [$dflt]" + rp="Where do you want to put the public executables? (~name ok) [$dflt]" $echo $n "$rp $c" . myread bin="$ans" - bin=`filexp $bin` + bin=`./filexp "$bin"` if test -d $bin; then cont='' else @@ -675,10 +675,10 @@ esac cont=true while $test "$cont" ; do echo " " - rp="Where do the manual pages (source) go? [$dflt]" + rp="Where do the manual pages (source) go? (~name ok) [$dflt]" $echo $n "$rp $c" . myread - mansrc=`filexp "$ans"` + mansrc=`./filexp "$ans"` if $test -d "$mansrc"; then cont='' else @@ -707,7 +707,7 @@ case "$mansrc" in manext=l ;; *p) - manext=n + manext=p ;; *C) manext=C @@ -1110,10 +1110,6 @@ rmlist="$rmlist pdp11" echo " " echo "Checking for optional libraries..." -case "$libs" in -'') dflt='';; -*) dflt="$libs";; -esac case "$libswanted" in '') libswanted='c_s';; esac @@ -1156,6 +1152,9 @@ done set X $dflt shift dflt="$*" +case "$libs" in +*) dflt="$libs";; +esac case "$dflt" in '') dflt='none';; esac @@ -1206,7 +1205,7 @@ main() } u; if (sizeof(long) > 4) - u.l = 0x0807060504030201; + u.l = (0x08070605<<32) | 0x04030201; else u.l = 0x04030201; for (i=0; i < sizeof(long); i++) @@ -1214,7 +1213,7 @@ main() printf("\n"); } EOCP - if $cc try.c -o try >/dev/null 2>&1 ; then + if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then dflt=`./try` case "$dflt" in ????|????????) echo "(The test program ran ok.)";; @@ -1513,6 +1512,7 @@ if $contains '^vprintf$' libc.list >/dev/null 2>&1; then echo 'vprintf() found.' d_vprintf="$define" cat >.ucbsprf.c <<'EOF' +#include <stdio.h> #include <varargs.h> main() { xxx("foo"); } @@ -1948,7 +1948,7 @@ main() foo = bar; } EOCP -if $cc -c try.c >/dev/null 2>&1 ; then +if $cc -c $ccflags try.c >/dev/null 2>&1 ; then d_strctcpy="$define" echo "Yup, it can." else @@ -2007,9 +2007,9 @@ for s_timeval in '-DS_TIMEVAL' ''; do for i_systime in '-DI_SYSTIME' ''; do case "$flags" in '') echo Trying $i_time $i_systime $d_systimekernel $s_timeval - if $cc try.c $ccflags \ + if $cc $ccflags \ $i_time $i_systime $d_systimekernel $s_timeval \ - -o try >/dev/null 2>&1 ; then + try.c -o try >/dev/null 2>&1 ; then set X $i_time $i_systime $d_systimekernel $s_timeval shift flags="$*" @@ -2067,11 +2067,12 @@ echo 'Checking to see if your C compiler knows about "volatile"...' $cat >try.c <<'EOCP' main() { - volatile int foo; + char *volatile foo; + volatile int bar; foo = foo; } EOCP -if $cc -c try.c >/dev/null 2>&1 ; then +if $cc -c $ccflags try.c >/dev/null 2>&1 ; then d_volatile="$define" echo "Yup, it does." else @@ -2117,7 +2118,7 @@ main() { exit(0); } EOCP - if $cc -S -DTRY=$defvoidused try.c >.out 2>&1 ; then + if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then voidflags=$defvoidused echo "It appears to support void." if $contains warning .out >/dev/null 2>&1; then @@ -2126,14 +2127,14 @@ EOCP fi else echo "Hmm, your compiler has some difficulty with void. Checking further..." - if $cc -S -DTRY=1 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1 ; then echo "It supports 1..." - if $cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1 ; then voidflags=3 echo "And it supports 2 but not 4." else echo "It doesn't support 2..." - if $cc -S -DTRY=5 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=5 try.c >/dev/null 2>&1 ; then voidflags=5 echo "But it supports 4." else @@ -2286,7 +2287,7 @@ main() printf("%d\n", sizeof(int)); } EOCP - if $cc try.c -o try >/dev/null 2>&1 ; then + if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then dflt=`./try` else dflt='4' @@ -2317,10 +2318,10 @@ $cat <<EOM The $package package has some auxiliary files that should be put in a library that is accessible by everyone. Where do you want to put these "private" EOM -$echo $n "but accessible files? [$dflt] $c" +$echo $n "but accessible files? (~name ok) [$dflt] $c" rp="Put private files where? [$dflt]" . myread -privlib="$ans" +privlib=`./filexp "$ans"` : check for size of random number generator echo " " @@ -2344,7 +2345,7 @@ main() printf("%d\n",i); } EOCP - if $cc try.c -o try >/dev/null 2>&1 ; then + if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then dflt=`./try` else dflt='?' diff --git a/Makefile.SH b/Makefile.SH index 63d326d301..b1c1eeb94b 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -25,9 +25,14 @@ esac echo "Extracting Makefile (with variable substitutions)" cat >Makefile <<!GROK!THIS! -# $Header: Makefile.SH,v 3.0.1.4 90/02/28 16:19:43 lwall Locked $ +# $Header: Makefile.SH,v 3.0.1.5 90/03/12 16:15:17 lwall Locked $ # # $Log: Makefile.SH,v $ +# Revision 3.0.1.5 90/03/12 16:15:17 lwall +# patch13: some dependencies missing on perly.h +# patch13: some relief for buggy parallel makes +# patch13: bison doesn't declare extern YYSTYPE yylval; +# # Revision 3.0.1.4 90/02/28 16:19:43 lwall # patch9: extraneous $ on suidperl in Makefile # @@ -167,7 +172,7 @@ tcmd.o: cmd.c $(h) $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tcmd.c /bin/rm -f tcmd.c -tcons.o: cons.c $(h) +tcons.o: cons.c $(h) perly.h /bin/rm -f tcons.c $(SLN) cons.c tcons.c $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tcons.c @@ -239,13 +244,13 @@ tstab.o: stab.c $(h) $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tstab.c /bin/rm -f tstab.c -tstr.o: str.c $(h) +tstr.o: str.c $(h) perly.h /bin/rm -f tstr.c $(SLN) str.c tstr.c $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tstr.c /bin/rm -f tstr.c -ttoke.o: toke.c $(h) +ttoke.o: toke.c $(h) perly.h /bin/rm -f ttoke.c $(SLN) toke.c ttoke.c $(CC) -c -DTAINT $(CFLAGS) $(LARGE) ttoke.c @@ -257,11 +262,16 @@ tutil.o: util.c $(h) $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tutil.c /bin/rm -f tutil.c -perl.c perly.h: perl.y +perly.h: perl.c + @ echo Dummy dependency for dumb parallel make + touch perly.h + +perl.c: perl.y @ echo Expect 25 shift/reduce errors... $(YACC) -d perl.y mv y.tab.c perl.c mv y.tab.h perly.h + echo 'extern YYSTYPE yylval;' >>perly.h perl.o: perl.c perly.h $(h) $(CC) -c $(CFLAGS) $(LARGE) perl.c @@ -80,6 +80,7 @@ Installation Ultrix (2.3) may need to hand assemble teval.s with a -J switch. Ultrix on MIPS machines may need -DLANGUAGE_C. SCO Xenix may need -m25000 for yacc. + Xenix 386 needs -Sm10000 for yacc. Genix needs to use libc rather than libc_s, or #undef VARARGS. NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR. Machines with half-implemented dbm routines will need to #undef ODBM & NDBM. @@ -1,4 +1,4 @@ -/* $Header: arg.h,v 3.0.1.3 90/02/28 16:21:55 lwall Locked $ +/* $Header: arg.h,v 3.0.1.4 90/03/12 16:18:21 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: arg.h,v $ + * Revision 3.0.1.4 90/03/12 16:18:21 lwall + * patch13: added list slice operator (LIST)[LIST] + * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) + * * Revision 3.0.1.3 90/02/28 16:21:55 lwall * patch9: added pipe function * @@ -261,7 +265,9 @@ #define O_SSOCKOPT 238 #define O_GETSOCKNAME 239 #define O_GETPEERNAME 240 -#define MAXO 241 +#define O_LSLICE 241 +#define O_SPLICE 242 +#define MAXO 243 #ifndef DOINIT extern char *opname[]; @@ -508,7 +514,9 @@ char *opname[] = { "SSOCKOPT", "GETSOCKNAME", "GETPEERNAME", - "241" + "LSLICE", + "SPLICE", + "243" }; #endif @@ -882,6 +890,8 @@ char opargs[MAXO+1] = { A(1,1,1), /* SSOCKOPT */ A(1,0,0), /* GETSOCKNAME */ A(1,0,0), /* GETPEERNAME */ + A(0,3,3), /* LSLICE */ + A(0,3,1), /* SPLICE */ 0 }; #undef A @@ -1,4 +1,4 @@ -/* $Header: cmd.c,v 3.0.1.5 90/02/28 16:38:31 lwall Locked $ +/* $Header: cmd.c,v 3.0.1.6 90/03/12 16:21:09 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cmd.c,v $ + * Revision 3.0.1.6 90/03/12 16:21:09 lwall + * patch13: fixed some backwards VOLATILE declarations + * patch13: while (s/x//) {} still caused some anomolies + * patch13: greater-than test of numeric switch structures did less-than action + * * Revision 3.0.1.5 90/02/28 16:38:31 lwall * patch9: volatilized some more variables for super-optimizing compilers * patch9: nested foreach loops didn't reset inner loop on next to outer loop @@ -77,8 +82,8 @@ VOLATILE int sp; register char *go_to = goto_targ; register int newsp = -2; register STR **st = stack->ary_array; - VOLATILE FILE *fp; - VOLATILE ARRAY *ar; + FILE *VOLATILE fp; + ARRAY *VOLATILE ar; lastsize = 0; #ifdef DEBUGGING @@ -461,9 +466,9 @@ until_loop: } } if (--cmd->c_short->str_u.str_useful < 0) { - cmdflags &= ~(CF_OPTIMIZE|CF_ONCE); + cmdflags &= ~CF_OPTIMIZE; cmdflags |= CFT_EVAL; /* never try this optimization again */ - cmd->c_flags = cmdflags; + cmd->c_flags = (cmdflags & ~CF_ONCE); } break; /* must evaluate */ @@ -681,7 +686,7 @@ until_loop: if (match < 0) match = 0; else if (match > cmd->ucmd.scmd.sc_max) - match = cmd->c_slen; + match = cmd->ucmd.scmd.sc_max; cmd = cmd->ucmd.scmd.sc_next[match]; goto tail_recursion_entry; case C_NEXT: @@ -1,4 +1,4 @@ -/* $Header: cons.c,v 3.0.1.4 90/02/28 16:44:00 lwall Locked $ +/* $Header: cons.c,v 3.0.1.5 90/03/12 16:23:10 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cons.c,v $ + * Revision 3.0.1.5 90/03/12 16:23:10 lwall + * patch13: perl -d coredumped on scripts with subs that did explicit return + * * Revision 3.0.1.4 90/02/28 16:44:00 lwall * patch9: subs which return by both mechanisms can clobber local return data * patch9: changed internal SUB label to _SUB_ @@ -74,10 +77,7 @@ CMD *cmd; mycompblock.comp_alt = Nullcmd; cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,Nullarg,mycompblock)); saw_return = FALSE; - if (perldb) - cmd->c_next->c_flags |= CF_TERM; - else - cmd->c_flags |= CF_TERM; + cmd->c_flags |= CF_TERM; } sub->cmd = cmd; stab_sub(stab) = sub; @@ -1,4 +1,4 @@ -/* $Header: consarg.c,v 3.0.1.3 90/02/28 16:47:54 lwall Locked $ +/* $Header: consarg.c,v 3.0.1.4 90/03/12 16:24:40 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: consarg.c,v $ + * Revision 3.0.1.4 90/03/12 16:24:40 lwall + * patch13: return (@array) did counter-intuitive things + * * Revision 3.0.1.3 90/02/28 16:47:54 lwall * patch9: the x operator is now up to 10 times faster * patch9: @_ clobbered by ($foo,$bar) = split @@ -905,7 +908,16 @@ maybelistish(optype, arg) int optype; ARG *arg; { - if (optype == O_PRTF || + ARG *tmparg = arg; + + if (optype == O_RETURN && arg->arg_type == O_ITEM && + arg[1].arg_type == A_EXPR && (tmparg = arg[1].arg_ptr.arg_arg) && + ((tmparg->arg_flags & AF_LISTISH) || (tmparg->arg_type == O_ARRAY) )) { + tmparg = listish(tmparg); + free_arg(arg); + arg = tmparg; + } + else if (optype == O_PRTF || (arg->arg_type == O_ASLICE || arg->arg_type == O_HSLICE || arg->arg_type == O_F_OR_R) ) arg = listish(arg); @@ -1,4 +1,4 @@ -/* $Header: doarg.c,v 3.0.1.3 90/02/28 16:56:58 lwall Locked $ +/* $Header: doarg.c,v 3.0.1.4 90/03/12 16:28:42 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: doarg.c,v $ + * Revision 3.0.1.4 90/03/12 16:28:42 lwall + * patch13: pack of ascii strings could call str_ncat() with negative length + * patch13: printf("%s", *foo) was busted + * * Revision 3.0.1.3 90/02/28 16:56:58 lwall * patch9: split now can split into more than 10000 elements * patch9: sped up pack and unpack @@ -395,22 +399,23 @@ int *arglast; aptr = str_get(fromstr); if (fromstr->str_cur > len) str_ncat(str,aptr,len); - else + else { str_ncat(str,aptr,fromstr->str_cur); - len -= fromstr->str_cur; - if (datumtype == 'A') { - while (len >= 10) { - str_ncat(str,space10,10); - len -= 10; + len -= fromstr->str_cur; + if (datumtype == 'A') { + while (len >= 10) { + str_ncat(str,space10,10); + len -= 10; + } + str_ncat(str,space10,len); } - str_ncat(str,space10,len); - } - else { - while (len >= 10) { - str_ncat(str,null10,10); - len -= 10; + else { + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); } - str_ncat(str,null10,len); } break; case 'C': @@ -601,7 +606,7 @@ register STR **sarg; *t = '\0'; xs = str_get(*sarg); xlen = (*sarg)->str_cur; - if (*xs == 'S' && xs[1] == 't' && xs[2] == 'a' && xs[3] == 'b' + if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xlen == sizeof(STBP) && strlen(xs) < xlen) { xs = stab_name(((STAB*)(*sarg))); /* a stab value! */ sprintf(tokenbuf,"*%s",xs); /* reformat to non-binary */ @@ -1,4 +1,4 @@ -/* $Header: doio.c,v 3.0.1.5 90/02/28 17:01:36 lwall Locked $ +/* $Header: doio.c,v 3.0.1.6 90/03/12 16:30:07 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: doio.c,v $ + * Revision 3.0.1.6 90/03/12 16:30:07 lwall + * patch13: system 'FOO=bar command' didn't invoke sh as it should + * * Revision 3.0.1.5 90/02/28 17:01:36 lwall * patch9: open(FOO,"$filename\0") will now protect trailing spaces in filename * patch9: removed obsolete checks to avoid opening block devices @@ -939,6 +942,9 @@ char *cmd; return FALSE; } } + for (s = cmd; *s && isalpha(*s); s++) ; /* catch VAR=val gizmo */ + if (*s == '=') + goto doshell; New(402,argv, (s - cmd) / 2 + 2, char*); a = argv; @@ -1,4 +1,4 @@ -/* $Header: dolist.c,v 3.0.1.5 90/02/28 17:09:44 lwall Locked $ +/* $Header: dolist.c,v 3.0.1.6 90/03/12 16:33:02 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: dolist.c,v $ + * Revision 3.0.1.6 90/03/12 16:33:02 lwall + * patch13: added list slice operator (LIST)[LIST] + * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) + * patch13: made split('') act like split(//) rather than split(' ') + * * Revision 3.0.1.5 90/02/28 17:09:44 lwall * patch9: split now can split into more than 10000 elements * patch9: @_ clobbered by ($foo,$bar) = split @@ -287,7 +292,7 @@ int *arglast; st = stack->ary_array; m = str_get(dstr = st[sp--]); nointrp = ""; - if (!dstr->str_cur || (*m == ' ' && dstr->str_cur == 1)) { + if (*m == ' ' && dstr->str_cur == 1) { str_set(dstr,"\\s+"); m = dstr->str_ptr; spat->spat_flags |= SPAT_SKIPWHITE; @@ -658,8 +663,9 @@ int *arglast; } int -do_slice(stab,numarray,lval,gimme,arglast) -register STAB *stab; +do_slice(stab,str,numarray,lval,gimme,arglast) +STAB *stab; +STR *str; int numarray; int lval; int gimme; @@ -671,23 +677,40 @@ int *arglast; register char *tmps; register int len; register int magic = 0; + register ARRAY *ary; + register HASH *hash; + int oldarybase = arybase; - if (lval && !numarray) { - if (stab == envstab) - magic = 'E'; - else if (stab == sigstab) - magic = 'S'; + if (numarray) { + if (numarray == 2) { /* a slice of a LIST */ + ary = stack; + ary->ary_fill = arglast[3]; + arybase -= max + 1; + st[sp] = str; /* make stack size available */ + str_numset(str,(double)(sp - 1)); + } + else + ary = stab_array(stab); /* a slice of an array */ + } + else { + if (lval) { + if (stab == envstab) + magic = 'E'; + else if (stab == sigstab) + magic = 'S'; #ifdef SOME_DBM - else if (stab_hash(stab)->tbl_dbm) - magic = 'D'; + else if (stab_hash(stab)->tbl_dbm) + magic = 'D'; #endif /* SOME_DBM */ + } + hash = stab_hash(stab); /* a slice of an associative array */ } if (gimme == G_ARRAY) { if (numarray) { while (sp < max) { if (st[++sp]) { - st[sp-1] = afetch(stab_array(stab), + st[sp-1] = afetch(ary, ((int)str_gnum(st[sp])) - arybase, lval); } else @@ -699,7 +722,7 @@ int *arglast; if (st[++sp]) { tmps = str_get(st[sp]); len = st[sp]->str_cur; - st[sp-1] = hfetch(stab_hash(stab),tmps,len, lval); + st[sp-1] = hfetch(hash,tmps,len, lval); if (magic) str_magic(st[sp-1],stab,magic,tmps,len); } @@ -712,7 +735,7 @@ int *arglast; else { if (numarray) { if (st[max]) - st[sp] = afetch(stab_array(stab), + st[sp] = afetch(ary, ((int)str_gnum(st[max])) - arybase, lval); else st[sp] = &str_undef; @@ -721,7 +744,7 @@ int *arglast; if (st[max]) { tmps = str_get(st[max]); len = st[max]->str_cur; - st[sp] = hfetch(stab_hash(stab),tmps,len, lval); + st[sp] = hfetch(hash,tmps,len, lval); if (magic) str_magic(st[sp],stab,magic,tmps,len); } @@ -729,6 +752,184 @@ int *arglast; st[sp] = &str_undef; } } + arybase = oldarybase; + return sp; +} + +int +do_splice(ary,str,gimme,arglast) +register ARRAY *ary; +STR *str; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + int max = arglast[2] + 1; + register STR **src; + register STR **dst; + register int i; + register int offset; + register int length; + int newlen; + int after; + int diff; + STR **tmparyval; + + if (++sp < max) { + offset = ((int)str_gnum(st[sp])) - arybase; + if (offset < 0) + offset += ary->ary_fill + 1; + if (++sp < max) { + length = (int)str_gnum(st[sp++]); + if (length < 0) + length = 0; + } + else + length = ary->ary_max; /* close enough to infinity */ + } + else { + offset = 0; + length = ary->ary_max; + } + if (offset < 0) { + length += offset; + offset = 0; + if (length < 0) + length = 0; + } + if (offset > ary->ary_fill + 1) + offset = ary->ary_fill + 1; + after = ary->ary_fill + 1 - (offset + length); + if (after < 0) { /* not that much array */ + length += after; /* offset+length now in array */ + after = 0; + } + + /* At this point, sp .. max-1 is our new LIST */ + + newlen = max - sp; + diff = newlen - length; + + if (diff < 0) { /* shrinking the area */ + if (newlen) { + New(451, tmparyval, newlen, STR*); /* so remember insertion */ + Copy(st+sp, tmparyval, newlen, STR*); + } + + sp = arglast[0] + 1; + if (gimme == G_ARRAY) { /* copy return vals to stack */ + if (sp + length >= stack->ary_max) { + astore(stack,sp + length, Nullstr); + st = stack->ary_array; + } + Copy(ary->ary_array+offset, st+sp, length, STR*); + if (ary->ary_flags & ARF_REAL) { + for (i = length, dst = st+sp; i; i--) + str_2static(*dst++); /* free them eventualy */ + } + sp += length - 1; + } + else { + st[sp] = ary->ary_array[offset+length-1]; + if (ary->ary_flags & ARF_REAL) + str_2static(st[sp]); + } + ary->ary_fill += diff; + + /* pull up or down? */ + + if (offset < after) { /* easier to pull up */ + if (offset) { /* esp. if nothing to pull */ + src = &ary->ary_array[offset-1]; + dst = src - diff; /* diff is negative */ + for (i = offset; i > 0; i--) /* can't trust Copy */ + *dst-- = *src--; + } + ary->ary_array -= diff; /* diff is negative */ + ary->ary_max += diff; + } + else { + if (after) { /* anything to pull down? */ + src = ary->ary_array + offset + length; + dst = src + diff; /* diff is negative */ + Copy(src, dst, after, STR*); + } + Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*); + /* avoid later double free */ + } + if (newlen) { + for (src = tmparyval, dst = ary->ary_array + offset; + newlen; newlen--) { + *dst = Str_new(46,0); + str_sset(*dst++,*src++); + } + Safefree(tmparyval); + } + } + else { /* no, expanding (or same) */ + if (length) { + New(452, tmparyval, length, STR*); /* so remember deletion */ + Copy(ary->ary_array+offset, tmparyval, length, STR*); + } + + if (diff > 0) { /* expanding */ + + /* push up or down? */ + + if (offset < after && diff <= ary->ary_array - ary->ary_alloc) { + if (offset) { + src = ary->ary_array; + dst = src - diff; + Copy(src, dst, offset, STR*); + } + ary->ary_array -= diff; /* diff is positive */ + ary->ary_max += diff; + ary->ary_fill += diff; + } + else { + if (ary->ary_fill + diff >= ary->ary_max) /* oh, well */ + astore(ary, ary->ary_fill + diff, Nullstr); + else + ary->ary_fill += diff; + if (after) { + dst = ary->ary_array + ary->ary_fill; + src = dst - diff; + for (i = after; i; i--) { + if (*dst) /* str was hanging around */ + str_free(*dst); /* after $#foo */ + *dst-- = *src; + *src-- = Nullstr; + } + } + } + } + + for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) { + *dst = Str_new(46,0); + str_sset(*dst++,*src++); + } + sp = arglast[0] + 1; + if (gimme == G_ARRAY) { /* copy return vals to stack */ + if (length) { + Copy(tmparyval, st+sp, length, STR*); + if (ary->ary_flags & ARF_REAL) { + for (i = length, dst = st+sp; i; i--) + str_2static(*dst++); /* free them eventualy */ + } + Safefree(tmparyval); + } + sp += length - 1; + } + else if (length) { + st[sp] = tmparyval[length-1]; + if (ary->ary_flags & ARF_REAL) + str_2static(st[sp]); + Safefree(tmparyval); + } + else + st[sp] = &str_undef; + } return sp; } diff --git a/patchlevel.h b/patchlevel.h index bc5f1c8250..910cae8f16 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 12 +#define PATCHLEVEL 13 |