This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.002gamma: hints/sunos_4_1.sh
[perl5.git] / scope.c
1 /*    scope.c
2  *
3  *    Copyright (c) 1991-1994, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "For the fashion of Minas Tirith was such that it was built on seven
12  * levels..."
13  */
14
15 #include "EXTERN.h"
16 #include "perl.h"
17
18 SV**
19 stack_grow(sp, p, n)
20 SV** sp;
21 SV** p;
22 int n;
23 {
24     stack_sp = sp;
25     av_extend(stack, (p - stack_base) + (n) + 128);
26     return stack_sp;
27 }
28
29 I32
30 cxinc()
31 {
32     cxstack_max = cxstack_max * 3 / 2;
33     Renew(cxstack, cxstack_max, CONTEXT);
34     return cxstack_ix + 1;
35 }
36
37 void
38 push_return(retop)
39 OP *retop;
40 {
41     if (retstack_ix == retstack_max) {
42         retstack_max = retstack_max * 3 / 2;
43         Renew(retstack, retstack_max, OP*);
44     }
45     retstack[retstack_ix++] = retop;
46 }
47
48 OP *
49 pop_return()
50 {
51     if (retstack_ix > 0)
52         return retstack[--retstack_ix];
53     else
54         return Nullop;
55 }
56
57 void
58 push_scope()
59 {
60     if (scopestack_ix == scopestack_max) {
61         scopestack_max = scopestack_max * 3 / 2;
62         Renew(scopestack, scopestack_max, I32);
63     }
64     scopestack[scopestack_ix++] = savestack_ix;
65
66 }
67
68 void
69 pop_scope()
70 {
71     I32 oldsave = scopestack[--scopestack_ix];
72     LEAVE_SCOPE(oldsave);
73 }
74
75 void
76 markstack_grow()
77 {
78     I32 oldmax = markstack_max - markstack;
79     I32 newmax = oldmax * 3 / 2;
80
81     Renew(markstack, newmax, I32);
82     markstack_ptr = markstack + oldmax;
83     markstack_max = markstack + newmax;
84 }
85
86 void
87 savestack_grow()
88 {
89     savestack_max = savestack_max * 3 / 2;
90     Renew(savestack, savestack_max, ANY);
91 }
92
93 void
94 free_tmps()
95 {
96     /* XXX should tmps_floor live in cxstack? */
97     I32 myfloor = tmps_floor;
98     while (tmps_ix > myfloor) {      /* clean up after last statement */
99         SV* sv = tmps_stack[tmps_ix];
100         tmps_stack[tmps_ix--] = Nullsv;
101         if (sv) {
102 #ifdef DEBUGGING
103             SvTEMP_off(sv);
104 #endif
105             SvREFCNT_dec(sv);           /* note, can modify tmps_ix!!! */
106         }
107     }
108 }
109
110 SV *
111 save_scalar(gv)
112 GV *gv;
113 {
114     register SV *sv;
115     SV *osv = GvSV(gv);
116
117     SSCHECK(3);
118     SSPUSHPTR(gv);
119     SSPUSHPTR(osv);
120     SSPUSHINT(SAVEt_SV);
121
122     sv = GvSV(gv) = NEWSV(0,0);
123     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
124         sv_upgrade(sv, SvTYPE(osv));
125         if (SvGMAGICAL(osv)) {
126             MAGIC* mg;
127             bool oldtainted = tainted;
128             mg_get(osv);
129             if (tainting && tainted && (mg = mg_find(osv, 't'))) {
130                 SAVESPTR(mg->mg_obj);
131                 mg->mg_obj = osv;
132             }
133             SvFLAGS(osv) |= (SvFLAGS(osv) &
134                 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
135             tainted = oldtainted;
136         }
137         SvMAGIC(sv) = SvMAGIC(osv);
138         SvFLAGS(sv) |= SvMAGICAL(osv);
139         localizing = 1;
140         SvSETMAGIC(sv);
141         localizing = 0;
142     }
143     return sv;
144 }
145
146 #ifdef INLINED_ELSEWHERE
147 void
148 save_gp(gv)
149 GV *gv;
150 {
151     register GP *gp;
152     GP *ogp = GvGP(gv);
153
154     SSCHECK(3);
155     SSPUSHPTR(SvREFCNT_inc(gv));
156     SSPUSHPTR(ogp);
157     SSPUSHINT(SAVEt_GP);
158
159     Newz(602,gp, 1, GP);
160     GvGP(gv) = gp;
161     GvREFCNT(gv) = 1;
162     GvSV(gv) = NEWSV(72,0);
163     GvLINE(gv) = curcop->cop_line;
164     GvEGV(gv) = gv;
165 }
166 #endif
167
168 SV*
169 save_svref(sptr)
170 SV **sptr;
171 {
172     register SV *sv;
173     SV *osv = *sptr;
174
175     SSCHECK(3);
176     SSPUSHPTR(*sptr);
177     SSPUSHPTR(sptr);
178     SSPUSHINT(SAVEt_SVREF);
179
180     sv = *sptr = NEWSV(0,0);
181     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
182         sv_upgrade(sv, SvTYPE(osv));
183         if (SvGMAGICAL(osv)) {
184             MAGIC* mg;
185             bool oldtainted = tainted;
186             mg_get(osv);
187             if (tainting && tainted && (mg = mg_find(osv, 't'))) {
188                 SAVESPTR(mg->mg_obj);
189                 mg->mg_obj = osv;
190             }
191             SvFLAGS(osv) |= (SvFLAGS(osv) &
192                 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
193             tainted = oldtainted;
194         }
195         SvMAGIC(sv) = SvMAGIC(osv);
196         SvFLAGS(sv) |= SvMAGICAL(osv);
197         localizing = 1;
198         SvSETMAGIC(sv);
199         localizing = 0;
200     }
201     return sv;
202 }
203
204 AV *
205 save_ary(gv)
206 GV *gv;
207 {
208     SSCHECK(3);
209     SSPUSHPTR(gv);
210     SSPUSHPTR(GvAVn(gv));
211     SSPUSHINT(SAVEt_AV);
212
213     GvAV(gv) = Null(AV*);
214     return GvAVn(gv);
215 }
216
217 HV *
218 save_hash(gv)
219 GV *gv;
220 {
221     SSCHECK(3);
222     SSPUSHPTR(gv);
223     SSPUSHPTR(GvHVn(gv));
224     SSPUSHINT(SAVEt_HV);
225
226     GvHV(gv) = Null(HV*);
227     return GvHVn(gv);
228 }
229
230 void
231 save_item(item)
232 register SV *item;
233 {
234     register SV *sv;
235
236     SSCHECK(3);
237     SSPUSHPTR(item);            /* remember the pointer */
238     sv = NEWSV(0,0);
239     sv_setsv(sv,item);
240     SSPUSHPTR(sv);              /* remember the value */
241     SSPUSHINT(SAVEt_ITEM);
242 }
243
244 void
245 save_int(intp)
246 int *intp;
247 {
248     SSCHECK(3);
249     SSPUSHINT(*intp);
250     SSPUSHPTR(intp);
251     SSPUSHINT(SAVEt_INT);
252 }
253
254 void
255 save_long(longp)
256 long *longp;
257 {
258     SSCHECK(3);
259     SSPUSHLONG(*longp);
260     SSPUSHPTR(longp);
261     SSPUSHINT(SAVEt_LONG);
262 }
263
264 void
265 save_I32(intp)
266 I32 *intp;
267 {
268     SSCHECK(3);
269     SSPUSHINT(*intp);
270     SSPUSHPTR(intp);
271     SSPUSHINT(SAVEt_I32);
272 }
273
274 void
275 save_iv(ivp)
276 IV *ivp;
277 {
278     SSCHECK(3);
279     SSPUSHIV(*ivp);
280     SSPUSHPTR(ivp);
281     SSPUSHINT(SAVEt_IV);
282 }
283
284 /* Cannot use save_sptr() to store a char* since the SV** cast will
285  * force word-alignment and we'll miss the pointer.
286  */
287 void
288 save_pptr(pptr)
289 char **pptr;
290 {
291     SSCHECK(3);
292     SSPUSHPTR(*pptr);
293     SSPUSHPTR(pptr);
294     SSPUSHINT(SAVEt_PPTR);
295 }
296
297 void
298 save_sptr(sptr)
299 SV **sptr;
300 {
301     SSCHECK(3);
302     SSPUSHPTR(*sptr);
303     SSPUSHPTR(sptr);
304     SSPUSHINT(SAVEt_SPTR);
305 }
306
307 void
308 save_nogv(gv)
309 GV *gv;
310 {
311     SSCHECK(2);
312     SSPUSHPTR(gv);
313     SSPUSHINT(SAVEt_NSTAB);
314 }
315
316 void
317 save_hptr(hptr)
318 HV **hptr;
319 {
320     SSCHECK(3);
321     SSPUSHPTR(*hptr);
322     SSPUSHPTR(hptr);
323     SSPUSHINT(SAVEt_HPTR);
324 }
325
326 void
327 save_aptr(aptr)
328 AV **aptr;
329 {
330     SSCHECK(3);
331     SSPUSHPTR(*aptr);
332     SSPUSHPTR(aptr);
333     SSPUSHINT(SAVEt_APTR);
334 }
335
336 void
337 save_freesv(sv)
338 SV *sv;
339 {
340     SSCHECK(2);
341     SSPUSHPTR(sv);
342     SSPUSHINT(SAVEt_FREESV);
343 }
344
345 void
346 save_freeop(op)
347 OP *op;
348 {
349     SSCHECK(2);
350     SSPUSHPTR(op);
351     SSPUSHINT(SAVEt_FREEOP);
352 }
353
354 void
355 save_freepv(pv)
356 char *pv;
357 {
358     SSCHECK(2);
359     SSPUSHPTR(pv);
360     SSPUSHINT(SAVEt_FREEPV);
361 }
362
363 void
364 save_clearsv(svp)
365 SV** svp;
366 {
367     SSCHECK(2);
368     SSPUSHLONG((long)(svp-curpad));
369     SSPUSHINT(SAVEt_CLEARSV);
370 }
371
372 void
373 save_delete(hv,key,klen)
374 HV *hv;
375 char *key;
376 I32 klen;
377 {
378     SSCHECK(4);
379     SSPUSHINT(klen);
380     SSPUSHPTR(key);
381     SSPUSHPTR(hv);
382     SSPUSHINT(SAVEt_DELETE);
383 }
384
385 void
386 save_list(sarg,maxsarg)
387 register SV **sarg;
388 I32 maxsarg;
389 {
390     register SV *sv;
391     register I32 i;
392
393     SSCHECK(3 * maxsarg);
394     for (i = 1; i <= maxsarg; i++) {
395         SSPUSHPTR(sarg[i]);             /* remember the pointer */
396         sv = NEWSV(0,0);
397         sv_setsv(sv,sarg[i]);
398         SSPUSHPTR(sv);                  /* remember the value */
399         SSPUSHINT(SAVEt_ITEM);
400     }
401 }
402
403 void
404 save_destructor(f,p)
405 void (*f) _((void*));
406 void* p;
407 {
408     SSCHECK(3);
409     SSPUSHDPTR(f);
410     SSPUSHPTR(p);
411     SSPUSHINT(SAVEt_DESTRUCTOR);
412 }
413
414 void
415 leave_scope(base)
416 I32 base;
417 {
418     register SV *sv;
419     register SV *value;
420     register GV *gv;
421     register AV *av;
422     register HV *hv;
423     register void* ptr;
424
425     if (base < -1)
426         croak("panic: corrupt saved stack index");
427     while (savestack_ix > base) {
428         switch (SSPOPINT) {
429         case SAVEt_ITEM:                        /* normal string */
430             value = (SV*)SSPOPPTR;
431             sv = (SV*)SSPOPPTR;
432             sv_replace(sv,value);
433             localizing = 2;
434             SvSETMAGIC(sv);
435             localizing = 0;
436             break;
437         case SAVEt_SV:                          /* scalar reference */
438             value = (SV*)SSPOPPTR;
439             gv = (GV*)SSPOPPTR;
440             sv = GvSV(gv);
441             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
442                 SvTYPE(sv) != SVt_PVGV)
443             {
444                 (void)SvUPGRADE(value, SvTYPE(sv));
445                 SvMAGIC(value) = SvMAGIC(sv);
446                 SvFLAGS(value) |= SvMAGICAL(sv);
447                 SvMAGICAL_off(sv);
448                 SvMAGIC(sv) = 0;
449             }
450             SvREFCNT_dec(sv);
451             GvSV(gv) = value;
452             localizing = 2;
453             SvSETMAGIC(value);
454             localizing = 0;
455             break;
456         case SAVEt_SVREF:                       /* scalar reference */
457             ptr = SSPOPPTR;
458             sv = *(SV**)ptr;
459             value = (SV*)SSPOPPTR;
460             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
461                 SvTYPE(sv) != SVt_PVGV)
462             {
463                 (void)SvUPGRADE(value, SvTYPE(sv));
464                 SvMAGIC(value) = SvMAGIC(sv);
465                 SvFLAGS(value) |= SvMAGICAL(sv);
466                 SvMAGICAL_off(sv);
467                 SvMAGIC(sv) = 0;
468             }
469             SvREFCNT_dec(sv);
470             *(SV**)ptr = value;
471             localizing = 2;
472             SvSETMAGIC(value);
473             localizing = 0;
474             break;
475         case SAVEt_AV:                          /* array reference */
476             av = (AV*)SSPOPPTR;
477             gv = (GV*)SSPOPPTR;
478             SvREFCNT_dec(GvAV(gv));
479             GvAV(gv) = av;
480             break;
481         case SAVEt_HV:                          /* hash reference */
482             hv = (HV*)SSPOPPTR;
483             gv = (GV*)SSPOPPTR;
484             SvREFCNT_dec(GvHV(gv));
485             GvHV(gv) = hv;
486             break;
487         case SAVEt_INT:                         /* int reference */
488             ptr = SSPOPPTR;
489             *(int*)ptr = (int)SSPOPINT;
490             break;
491         case SAVEt_LONG:                        /* long reference */
492             ptr = SSPOPPTR;
493             *(long*)ptr = (long)SSPOPLONG;
494             break;
495         case SAVEt_I32:                         /* I32 reference */
496             ptr = SSPOPPTR;
497             *(I32*)ptr = (I32)SSPOPINT;
498             break;
499         case SAVEt_IV:                          /* IV reference */
500             ptr = SSPOPPTR;
501             *(IV*)ptr = (IV)SSPOPIV;
502             break;
503         case SAVEt_SPTR:                        /* SV* reference */
504             ptr = SSPOPPTR;
505             *(SV**)ptr = (SV*)SSPOPPTR;
506             break;
507         case SAVEt_PPTR:                        /* char* reference */
508             ptr = SSPOPPTR;
509             *(char**)ptr = (char*)SSPOPPTR;
510             break;
511         case SAVEt_HPTR:                        /* HV* reference */
512             ptr = SSPOPPTR;
513             *(HV**)ptr = (HV*)SSPOPPTR;
514             break;
515         case SAVEt_APTR:                        /* AV* reference */
516             ptr = SSPOPPTR;
517             *(AV**)ptr = (AV*)SSPOPPTR;
518             break;
519         case SAVEt_NSTAB:
520             gv = (GV*)SSPOPPTR;
521             (void)sv_clear(gv);
522             break;
523         case SAVEt_GP:                          /* scalar reference */
524             ptr = SSPOPPTR;
525             gv = (GV*)SSPOPPTR;
526             gp_free(gv);
527             GvGP(gv) = (GP*)ptr;
528             SvREFCNT_dec(gv);
529             break;
530         case SAVEt_FREESV:
531             ptr = SSPOPPTR;
532             SvREFCNT_dec((SV*)ptr);
533             break;
534         case SAVEt_FREEOP:
535             ptr = SSPOPPTR;
536             curpad = AvARRAY(comppad);
537             op_free((OP*)ptr);
538             break;
539         case SAVEt_FREEPV:
540             ptr = SSPOPPTR;
541             Safefree((char*)ptr);
542             break;
543         case SAVEt_CLEARSV:
544             ptr = (void*)&curpad[SSPOPLONG];
545             sv = *(SV**)ptr;
546             if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */
547                 if (SvTHINKFIRST(sv)) {
548                     if (SvREADONLY(sv))
549                         croak("panic: leave_scope clearsv");
550                     if (SvROK(sv))
551                         sv_unref(sv);
552                 }
553                 if (SvMAGICAL(sv))
554                     mg_free(sv);
555
556                 switch (SvTYPE(sv)) {
557                 case SVt_NULL:
558                     break;
559                 case SVt_PVAV:
560                     av_clear((AV*)sv);
561                     break;
562                 case SVt_PVHV:
563                     hv_clear((HV*)sv);
564                     break;
565                 case SVt_PVCV:
566                     sub_generation++;
567                     cv_undef((CV*)sv);
568                     break;
569                 default:
570                     if (SvPOK(sv) && SvLEN(sv))
571                         (void)SvOOK_off(sv);
572                     (void)SvOK_off(sv);
573                     break;
574                 }
575             }
576             else {      /* Someone has a claim on this, so abandon it. */
577                 U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
578                 SvREFCNT_dec(sv);       /* Cast current value to the winds. */
579                 switch (SvTYPE(sv)) {   /* Console ourselves with a new value */
580                 case SVt_PVAV:  *(SV**)ptr = (SV*)newAV();      break;
581                 case SVt_PVHV:  *(SV**)ptr = (SV*)newHV();      break;
582                 default:        *(SV**)ptr = NEWSV(0,0);        break;
583                 }
584                 SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
585             }
586             break;
587         case SAVEt_DELETE:
588             ptr = SSPOPPTR;
589             hv = (HV*)ptr;
590             ptr = SSPOPPTR;
591             (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
592             Safefree(ptr);
593             break;
594         case SAVEt_DESTRUCTOR:
595             ptr = SSPOPPTR;
596             (*SSPOPDPTR)(ptr);
597             break;
598         case SAVEt_REGCONTEXT:
599             {
600                 I32 delta = SSPOPINT;
601                 savestack_ix -= delta;  /* regexp must have croaked */
602             }
603             break;
604         default:
605             croak("panic: leave_scope inconsistency");
606         }
607     }
608 }
609
610 #ifdef DEBUGGING
611 void
612 cx_dump(cx)
613 CONTEXT* cx;
614 {
615     fprintf(stderr, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]);
616     if (cx->cx_type != CXt_SUBST) {
617         fprintf(stderr, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
618         fprintf(stderr, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
619         fprintf(stderr, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
620         fprintf(stderr, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
621         fprintf(stderr, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
622         fprintf(stderr, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
623         fprintf(stderr, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
624     }
625     switch (cx->cx_type) {
626     case CXt_NULL:
627     case CXt_BLOCK:
628         break;
629     case CXt_SUB:
630         fprintf(stderr, "BLK_SUB.CV = 0x%lx\n",
631                 (long)cx->blk_sub.cv);
632         fprintf(stderr, "BLK_SUB.GV = 0x%lx\n",
633                 (long)cx->blk_sub.gv);
634         fprintf(stderr, "BLK_SUB.DFOUTGV = 0x%lx\n",
635                 (long)cx->blk_sub.dfoutgv);
636         fprintf(stderr, "BLK_SUB.OLDDEPTH = %ld\n",
637                 (long)cx->blk_sub.olddepth);
638         fprintf(stderr, "BLK_SUB.HASARGS = %d\n",
639                 (int)cx->blk_sub.hasargs);
640         break;
641     case CXt_EVAL:
642         fprintf(stderr, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
643                 (long)cx->blk_eval.old_in_eval);
644         fprintf(stderr, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
645                 op_name[cx->blk_eval.old_op_type],
646                 op_desc[cx->blk_eval.old_op_type]);
647         fprintf(stderr, "BLK_EVAL.OLD_NAME = %s\n",
648                 cx->blk_eval.old_name);
649         fprintf(stderr, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
650                 (long)cx->blk_eval.old_eval_root);
651         break;
652
653     case CXt_LOOP:
654         fprintf(stderr, "BLK_LOOP.LABEL = %s\n",
655                 cx->blk_loop.label);
656         fprintf(stderr, "BLK_LOOP.RESETSP = %ld\n",
657                 (long)cx->blk_loop.resetsp);
658         fprintf(stderr, "BLK_LOOP.REDO_OP = 0x%lx\n",
659                 (long)cx->blk_loop.redo_op);
660         fprintf(stderr, "BLK_LOOP.NEXT_OP = 0x%lx\n",
661                 (long)cx->blk_loop.next_op);
662         fprintf(stderr, "BLK_LOOP.LAST_OP = 0x%lx\n",
663                 (long)cx->blk_loop.last_op);
664         fprintf(stderr, "BLK_LOOP.ITERIX = %ld\n",
665                 (long)cx->blk_loop.iterix);
666         fprintf(stderr, "BLK_LOOP.ITERARY = 0x%lx\n",
667                 (long)cx->blk_loop.iterary);
668         fprintf(stderr, "BLK_LOOP.ITERVAR = 0x%lx\n",
669                 (long)cx->blk_loop.itervar);
670         if (cx->blk_loop.itervar)
671             fprintf(stderr, "BLK_LOOP.ITERSAVE = 0x%lx\n",
672                 (long)cx->blk_loop.itersave);
673         break;
674
675     case CXt_SUBST:
676         fprintf(stderr, "SB_ITERS = %ld\n",
677                 (long)cx->sb_iters);
678         fprintf(stderr, "SB_MAXITERS = %ld\n",
679                 (long)cx->sb_maxiters);
680         fprintf(stderr, "SB_SAFEBASE = %ld\n",
681                 (long)cx->sb_safebase);
682         fprintf(stderr, "SB_ONCE = %ld\n",
683                 (long)cx->sb_once);
684         fprintf(stderr, "SB_ORIG = %s\n",
685                 cx->sb_orig);
686         fprintf(stderr, "SB_DSTR = 0x%lx\n",
687                 (long)cx->sb_dstr);
688         fprintf(stderr, "SB_TARG = 0x%lx\n",
689                 (long)cx->sb_targ);
690         fprintf(stderr, "SB_S = 0x%lx\n",
691                 (long)cx->sb_s);
692         fprintf(stderr, "SB_M = 0x%lx\n",
693                 (long)cx->sb_m);
694         fprintf(stderr, "SB_STREND = 0x%lx\n",
695                 (long)cx->sb_strend);
696         fprintf(stderr, "SB_SUBBASE = 0x%lx\n",
697                 (long)cx->sb_subbase);
698         break;
699     }
700 }
701 #endif