File: fnctn.c

package info (click to toggle)
yorick 1.4-14
  • links: PTS
  • area: main
  • in suites: potato
  • size: 5,948 kB
  • ctags: 6,609
  • sloc: ansic: 63,898; yacc: 889; makefile: 605; sh: 65; lisp: 60; fortran: 19
file content (589 lines) | stat: -rw-r--r-- 19,676 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
/*
    FNCTN.C

    $Id: fnctn.c,v 1.1 1993/08/27 18:32:09 munro Exp $

    EvalFN evaluates a Yorick interpretive function.  This is one half
    of the Yorick Eval instruction.  The other half is array indexing,
    which is handled in the array.c file.

    The most general Yorick function has 3 distinct kinds of dummy
    parameters:
       func sample(p1, p2, p3, .., pA=, pB=, pC=, pD=)

       where p1, p2, and p3 are ordinary positional parameters,
            .. means that more positional parameters are accessible
               by this function-- the function NextArg() returns
	       these additional positional parameters one at a time,
	    pA, PB, pC, and pD are keyword parameters,
      Both positional and keyword parameters are optional; if no
      corresponding actual parameter is provided, EvalFN must initialize
      them to nil.

    On entry to EvalFN, the Yorick program stack might look as follows:

    .. sample  p1  kB  pB  p2  p3  kA  pA  p4  kD  pD  p5
         *     *   pB  *   *   *   pA  *   *   pD  *   *  

    where 3 keywords and 2 extra positional parameters have been supplied.
    The second line shows where the Symbol->index pointers point; on input
    only the keyword markers kA, kB, and kD are significant.
    On exit from EvalFN, the stack would read:

    .. sample  p1' kB  pB' p2' p3' kA  pA' p4' kD  pD' p4  p5 (locals)  R
         -1    p1  -1  pB  p2  p3  -1  pA  p4  -1  pD  -1  -1    -1    -2

    The R entry contains the return address.
    In addition to what is shown above, the keyword markers
    now have meaningful offset pointers, namely:

       kL -> kA -> kB -> kD
       k4 -> p4

 */
/*    Copyright (c) 1994.  The Regents of the University of California.
                    All rights reserved.  */

#include "ydata.h"

/*--------------------------------------------------------------------------*/

extern UnaryOp EvalFN, EvalBI;

extern VMaction Return;
extern VMaction NextArg, MoreArgs;

/* YRecoverExterns must be called after an asynchronous interrupt
   of either EvalFN or Return in order to recover from the "partial"
   function call or return sequence.  */
extern void YRecoverExterns(void);

/* ClearStack and AbortReturn are a higher level interface than
   YRecoverExterns.  ClearStack positions the stack to the topmost
   returnSym (if any), returning the associated return pc (or 0).
   AbortReturn clears the stack with ClearStack, then returns to the
   caller WITHOUT leaving any result on the stack.  This is useful
   only during debugging (see task.c).  */
extern Instruction *ClearStack(void);
extern Instruction *AbortReturn(void);

extern void YCatchDrop(long isp);        /* in task.c */
extern long ispCatch;                    /* in task.c */

static void Swap(Symbol *sp, long index);
static Symbol *ExtractKey(int index);

/*--------------------------------------------------------------------------*/

/*
   EvalFN uses Swap to swap the external values of the dummy parameters
   with the values of the actual parameters found on the stack.  This is
   complicated by the possibility of a referenceSym in the actual
   parameter list on the stack.  Any referenceSyms have been copied in a
   first pass through the actual parameters to avoid a possible prior
   swap by a dummy parameter of the same name.
   Swap then does the actual swapping.

   Return uses YRecoverExterns to restore the external values of local
   variables.  YRecoverExterns must also be called after an asynchronous
   interrupt of either EvalFN or Return in order to recover from the
   "partial" function call or return sequence.
 */

/* The code must ensure that the external values can be recovered even
   if the program is interrupted asynchronously in mid-swap.  */
static Symbol *spRecover= 0;

/* YRecoverExterns is usually called by Return, which needs the
   beginning of the referenceSym list, and the beginning of the
   function call list.  */
static Symbol *spFunction= 0;
static Symbol *spReference= 0;
static int nReferences;

static void Swap(Symbol *stack, long index)
{
  Symbol *dummy= &globTab[index];      /* dummy parameter */

  /* The order of the following operations assures that the external
     value can be restored, even if the program is asynchronously
     interrupted during the swapping process (see RecoverExterns).  */

  /* There is a simpler, faster implementation, which takes advantage of
     the fact that dummy->value.db->references does not actually change
     here (the Unref undoes the Ref above).  However, for a very brief
     time, the better algorithm either leaves two references to
     dummy->value.db without incrementing its reference counter, or
     leaves the external value of dummy "unprotected" by spRecover.
     As a first cut, I take the bomb-proof but less efficient solution.
     If this routine proves to be a significant bottleneck for code
     timing, I would consider switching back to the faster, riskier
     algorithm...  */

  /* copy stack value to temporary */
  OpTable *opsX= stack->ops;
  SymbolValue valueX= stack->value;
  OpTable *opsD= dummy->ops;
  int isDB= (opsD==&dataBlockSym);

  /* for bomb-proof safety, "dud" the stack entry */
  stack->ops= &intScalar;   /* value now does NOT reference a pointer */

  /* copy external value to stack */
  if (isDB) stack->value.db= Ref(dummy->value.db);  /* more bomb-proofing */
  else stack->value= dummy->value;
  stack->ops= opsD;

  /* update pointer for YRecoverExterns */
  stack->index= index;  /* mark where to put it back */
  spRecover= stack;

  /* now it is OK to "dud" globTab entry and delete the temporary use */
  if (isDB) {
    dummy->ops= &intScalar;
    Unref(stack->value.db);
  }

  /* copy original stack value into globTab */
  dummy->value= valueX;
  dummy->ops= opsX;

  if (opsX==&dataBlockSym) {
    DataBlock *db= dummy->value.db;
    if (db->ops==&lvalueOps) {
      /* fetch LValue now to avoid repeated fetches during execution */
      Array *array= FetchLValue(db, dummy);
      if (!array->type.dims) {
	if (array->ops==&doubleOps) {
	  dummy->ops= &doubleScalar;
	  dummy->value.d= array->value.d[0];
	  Unref(array);
	} else if (array->ops==&longOps) {
	  dummy->ops= &longScalar;
	  dummy->value.l= array->value.l[0];
	  Unref(array);
	} else if (array->ops==&intOps) {
	  dummy->ops= &intScalar;
	  dummy->value.i= array->value.i[0];
	  Unref(array);
	}
      }
    }
  }
}

void YRecoverExterns(void)
{
  if (spRecover) {
    int index;
    Symbol *local, *spnow;
    OpTable *opsX, *ops;
    SymbolValue valueX;
    int isDB;

    /* Same remark about implementation as for Swap function above.  */

    nReferences= 0;

    for (index=spRecover->index ; index!=-2 ; index=spRecover->index) {
      if (index==-1) { spRecover--; continue; }
      ops= spRecover->ops;
      if (ops==&referenceSym) {
	nReferences++;
	spReference= spRecover--;
	continue;
      }
      isDB= (ops==&dataBlockSym);

      local= &globTab[index];

      /* copy local value to temporary */
      opsX= local->ops;
      valueX= local->value;

      /* temporarily "dud" local value for bomb-proofing */
      local->ops= &intScalar;

      /* copy external value back to globTab */
      if (isDB) local->value.db= Ref(spRecover->value.db);
      else local->value= spRecover->value;
      local->ops= ops;

      /* update pointer for YRecoverExterns */
      spnow= spRecover--;

      /* now it is OK to "dud" stack entry and delete the temporary use */
      if (isDB) {
	(spRecover+1)->ops= &intScalar;
	Unref((spRecover+1)->value.db);
      }

      /* copy local value back to stack */
      spnow->value= valueX;
      spnow->ops= opsX;
    }

    spFunction= spRecover;
    spRecover= 0;
  }
}

/*--------------------------------------------------------------------------*/

static Symbol *actualKeys;

static Symbol *ExtractKey(int index)
{
  Symbol *key= actualKeys, *prev= 0;
  while (key!=prev && (key+1)->index!=index) {
    prev= key;
    key-= key->value.offset;
  }
  if (key!=prev) {
    /* key found, unlink from actualKeys list */
    int offset= key->value.offset;
    if (prev) prev->value.offset= offset? prev-(key-offset) : 0;
    else actualKeys= offset? key-offset : 0;
  } else {
    /* no key corresponds to index in actualKeys list */
    key= 0;
  }
  return key;
}

/*--------------------------------------------------------------------------*/

void EvalFN(Operand *op)
{
  Symbol *stack= op->owner;
  int n= op->references;       /* (sic) # of actual parameters supplied */
  Function *func= op->value;
  Instruction *code= &func->code[1];  /* (code[0] is index to function) */
  int nReq= func->nReq;        /* (see CheckStack call below) */
  int nPos= func->nPos;        /* number of dummy positional parameters */
  int nKey= func->nKey;        /* number of dummy keyword parameters */
  int nLoc= func->nLocal;      /* number of local variables */
  long hasPosList= func->hasPosList;
  long posList;

  int actual, dummy, index, nExtra;
  Symbol *spnow, *extraPos, *key;

  /* Be sure the stack is long enough for a worst-case invocation of this
     function.  nReq= nPos + (hasPosList&1) + nKey + nLoc + (deepest stack
                      required for expression evaluation) + 2
		      + 1 for return address for this function
     The nPos and nKey terms must be present because they may not be
     actual arguments, and because even if they are supplied they may
     be referenceSyms which must be copied for use during return.
     The extra 2 is so that builtin procedures are always guaranteed
     two free stack slots without calling CheckStack.  */
  if (CheckStack(nReq)) stack= sp-n;

  /* Handle all actual parameters.
     This must be done in two passes to avoid accidental collisions
     between dummy parameters and indirect references on the stack
     to external variables of the same name.  All of this could be
     avoided if function parameters were always passed by value,
     never by reference.  But I can't bring myself to disallow the
     FORTRAN-like function which uses its parameters to return values.  */

  /* First pass copies any indirect references.
     The parser has guaranteed that index (dummy) will not be repeated,
     since there may not be 2 dummy parameters with the same name.
     However, nothing prevents the one or more of the actual parameters
     (stack) from being referenceSyms to the same name as a dummy
     parameter.  This possibility requires copying all referenceSym
     actual parameters onto the stack (possibly multiple times).
     Also, note that a globTab entry may NEVER be a referenceSym, so
     if return is to affect external values of parameters, any
     referenceSym parameters must remain on the stack.  */
  posList= hasPosList>>1;
  hasPosList&= 1;
  nExtra= -nPos;
  spnow= stack;
  for (actual=0 ; actual<n ; actual++) {
    spnow++;
    if (spnow->ops) {
      if (spnow->ops==&referenceSym) {
	if (posList) {
	  if (nExtra<0 && (posList&1)) {
	    /* this is an output parameter */
	    extraPos= sp+1;                   /* push copy of referenceSym */
	    extraPos->ops= &referenceSym;
	    extraPos->index= spnow->index;
	    extraPos->value.offset= extraPos-spnow;  /* install ref offset */
	    sp= extraPos;
	  }
	  posList>>= 1;
	}
	ReplaceRef(spnow);       /* replace original reference by object */
      } else if (posList) {
	posList>>= 1;
      }
      nExtra++;
    } else {
      /* skip over keyword arguments */
      spnow++;
      actual++;
    }
  }

  /* Mark beginning of function call for YRecoverExterns.  This MUST
     be done before spRecover has been set (by Swap).  */
  stack->index= -2;

  /* Second pass swaps the external values onto the stack and local
     values into the global symbol table.  */
  posList= -1;
  dummy= 0;
  extraPos= actualKeys= 0;
  spnow= stack;
  for (actual=0 ; actual<n ; actual++) {
    spnow++;
    if (spnow->ops!=0) {        /* actual parameter is positional */
      if (dummy<nPos) {
	dummy++;
	index= (code++)->index;
	Swap(spnow, index);
      } else {
	if (!extraPos) {
	  if (!hasPosList) {
	    YRecoverExterns();
	    YError("too many actual parameters in function call");
	  }
	  dummy++;
	  posList= (code++)->index;
	  extraPos= spnow;
	}
	spnow->index= -1;  /* extras cannot be swapped back on return */
      }

    } else {                                /* actual parameter is keyword */
      index= spnow->index;
      spnow->index= -1;  /* keywords must not be swapped back on return */
      spnow->value.offset= actualKeys? spnow-actualKeys : 0;
      actualKeys= spnow++;
      actual++;   /* increment actual, spnow to keyword parameter */
      Swap(spnow, index);
    }
  }

  /* initialize non-actual dummy positionals to nil */
  while (dummy<nPos) {
    dummy++;
    PushDataBlock(Ref(&nilDB));
    Swap(sp, (code++)->index);
  }
  if (hasPosList && posList<0) posList= (code++)->index;

  /* initialize non-actual dummy keywords to nil */
  for (dummy=0 ; dummy<nKey ; dummy++) {
    index= (code++)->index;
    key= ExtractKey(index);  /* unlinks key (index) from list */
    if (!key) {
      /* missing dummy keywords initialized to nil */
      PushDataBlock(Ref(&nilDB));
      Swap(sp, index);
    }
  }
  if (actualKeys) {
    YRecoverExterns();
    YError("unrecognized keyword parameter(s) in function call");
  }

  /* handle NextArg() parameter -- this is an entry in the global
     symbol table with the illegal name "*va*" */
  /* NOTE-- assumes fewer than 2048 actual parameters, and that the
            stack depth is less than a million Symbols... */
  if (posList>=0) {
    spnow= sp+1;
    spnow->ops= &longScalar;
    spnow->value.l= extraPos? ((extraPos-spBottom)<<11 | nExtra) : 0;
    sp++;
    Swap(sp, posList);
  }

  /* initialize all local variables to nil */
  for (dummy=0 ; dummy<nLoc ; dummy++) {
    PushDataBlock(Ref(&nilDB));
    Swap(sp, (code++)->index);
  }

  /* push return address marker */
  spnow= sp+1;
  spnow->ops= &returnSym;
  spnow->value.pc= pc;
  sp++;

  /* stack is again intact, YRecoverExterns can be a no-op */
  spRecover= 0;

  /* set stack and branch into this function */
  pc= code;
}

void EvalBI(Operand *op)
{
  Symbol *stack= op->owner;
  long stackIndex= stack-spBottom;  /* see comment after function call */
  int n= op->references;         /* interpret misuse in FormEvalOp */
  BIFunction *bif= op->value;

  /* Invoke built-in function */
  bif->function(n);

  /* Adjust remembered stack to allow for the stack being moved -- this
     can happen in Y_require and Y_include, and there is no other way
     to handle the problem.  The efficiency loss from this instruction
     and the stackIndex definition above is regrettable... */
  stack= spBottom+stackIndex;

  /* Move return value to what will be the top of the stack, and
     discard the reference to the function which is returning.  */
  if (sp>stack) {
    Symbol *spnow= sp--;
    stack->ops= &intScalar;      /* "dud" BIFunction reference */
    stack->value= spnow->value;  /* move final value into place (dudded) */
    Unref(bif);
    stack->ops= spnow->ops;      /* "arm" final value */
    /* discard the input parameters and scratch space */
    if (sp>stack) Drop((int)(sp-stack));
  }
}

/*--------------------------------------------------------------------------*/

void Return(void)
{
  Symbol *spnow, *extrn;
  OpTable *opsX;
  SymbolValue valueX;

  /* Pop off any pending catch calls.  */
  if ((sp-spBottom)<=ispCatch) YCatchDrop(sp-spBottom);

  /* Set pc to caller.  Must do this BEFORE the return PC stack element
     is stripped away-- otherwise, there is no way to get back to the
     caller if this routine is asynchronously interrupted.  */
  pc= (sp-1)->value.pc;

  /* Restore external values of local variables in a way that is
     protected against asynchronous interruption.  */
  spRecover= sp-2;
  YRecoverExterns();

  /* Move return value to what will be the top of the stack, and
     discard the reference to the function which is returning.  */
  spnow= sp--;
  spFunction->ops= &intScalar; /* "dud" this stack entry */
  valueX= spFunction->value;   /* (know that ops is dataBlockSym) */
  spFunction->value= spnow->value;
  Unref(valueX.db);
  spFunction->ops= spnow->ops; /* "arm" the returned value */

  /* Redefine any actual parameters which were referenceSyms.  */
  while (nReferences--) {
    spnow= spReference - spReference->value.offset;
    extrn= &globTab[spReference->index];
    spReference++;

    /* YRecoverExterns has moved the local value of the dummy argument
       ont onto the stack.  Delete the external value which is about to
       be replaced, then "dud" the stack value before moving it into
       the external location.  */
    opsX= extrn->ops;
    valueX= extrn->value;
    if (opsX==&dataBlockSym) {
      extrn->ops= &intScalar;
      Unref(valueX.db);
    }
    opsX= spnow->ops;
    spnow->ops= &intScalar;
    extrn->value= spnow->value;
    extrn->ops= opsX;
  }

  /* Clean local variables off stack (where YRecoverExterns put them).  */
  if (sp>spFunction) Drop((int)(sp-spFunction));
}

Instruction *ClearStack(void)
{
  DataBlock *db;
  YRecoverExterns();
  while (sp>spBottom) {
    if (sp->ops==&returnSym) return sp->value.pc;
    db= (sp->ops==&dataBlockSym)? sp->value.db : 0;
    sp--;
    Unref(db);
  }
  return 0;
}

Instruction *AbortReturn(void)
{
  Instruction *pcRet= ClearStack();

  /* Pop off any pending catch calls.  */
  if ((sp-spBottom)<=ispCatch) YCatchDrop(sp-spBottom);

  /* Set pc to caller.  Must do this BEFORE the return PC stack element
     is stripped away-- otherwise, there is no way to get back to the
     caller if this routine is asynchronously interrupted.  */
  if ((pc= pcRet)) {
    /* Restore external values of local variables in a way that is
       protected against asynchronous interruption.  */
    spRecover= sp-1;
    YRecoverExterns();
    Drop((int)(sp-spFunction+1));
  }

  return pcRet;
}

/*--------------------------------------------------------------------------*/

/* If a Yorick function definition includes a ".." dummy parameter, then
   the parser will allow calls to the pseudo-function NextArg(), which
   successively returns positional parameters beyond the named dummy
   parameters.  The MoreArgs() function returns true if there are any
   more positional parameters available with NextArg() (which returns
   nil if there are no more).  */

void MoreArgs(void)
{
  /* this function returns the number of remaining positional parameters */
  long va= globTab[(pc++)->index].value.l;
  PushIntValue(va & 0x7ff);
}

void NextArg(void)
{
  long vaIndex= (pc++)->index;
  long va= globTab[vaIndex].value.l;
  int nExtra= (va & 0x7ff);
  if (nExtra--) {
    Symbol *extraPos= spBottom + (va>>11);
    /* push copy of actual parameter to top of stack */
    (sp+1)->ops= extraPos->ops;
    (sp+1)->value= extraPos->value;
    /* since you only get one crack at this parameter with NextArg, may
       as well trash the original variable to avoid having to increment
       a possible DataBlock reference counter */
    extraPos->ops= &intScalar;
    sp++;
    /* update *va* in globTab for next call to NextArg() or MoreArgs() */
    if (nExtra) {
      /* skip over keywordSym pairs to find next positional parameter */
      while ((++extraPos)->ops==0) extraPos++;
      globTab[vaIndex].value.l= ((extraPos-spBottom)<<11 | nExtra);
    } else {
      globTab[vaIndex].value.l= 0;
    }
  } else {
    PushDataBlock(Ref(&nilDB));
  }
}

/*--------------------------------------------------------------------------*/