← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to o/eval.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/eval.c
 
1
/*
 
2
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
3
 
 
4
This file is part of GNU Common Lisp, herein referred to as GCL
 
5
 
 
6
GCL is free software; you can redistribute it and/or modify it under
 
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
8
the Free Software Foundation; either version 2, or (at your option)
 
9
any later version.
 
10
 
 
11
GCL is distributed in the hope that it will be useful, but WITHOUT
 
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
13
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
14
License for more details.
 
15
 
 
16
You should have received a copy of the GNU Library General Public License 
 
17
along with GCL; see the file COPYING.  If not, write to the Free Software
 
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
 
 
20
*/
 
21
 
 
22
/*
 
23
        eval.c
 
24
*/
 
25
 
 
26
#include "include.h"
 
27
#include "sfun_argd.h"
 
28
 
 
29
static void
 
30
call_applyhook(object);
 
31
 
 
32
 
 
33
struct nil3 { object nil3_self[3]; } three_nils;
 
34
 
 
35
#ifdef DEBUG_AVMA
 
36
#undef DEBUG_AVMA
 
37
unsigned long avma,bot;
 
38
#define DEBUG_AVMA unsigned long saved_avma =  avma;
 
39
warn_avma()
 
40
{ 
 
41
  print(list(2,make_simple_string("avma changed"),ihs_top_function_name(ihs_top)),
 
42
        sLAstandard_outputA->s.s_dbind);
 
43
}
 
44
#define CHECK_AVMA if(avma!= saved_avma) warn_avma();
 
45
#define DEBUGGING_AVMA  
 
46
#else
 
47
#define DEBUG_AVMA
 
48
#define CHECK_AVMA
 
49
#endif
 
50
 
 
51
 
 
52
 
 
53
/*  object c_apply_n(long int (*fn)(), int n, object *x); */
 
54
 
 
55
object sSAbreak_pointsA;
 
56
object sSAbreak_stepA;
 
57
 
 
58
 
 
59
/* This is a temporary workaround.  m68k cannot find the result 
 
60
   of a function returning long when invoked via a function pointer
 
61
   declared as a function returning a pointer, in this case, an 
 
62
   object.  A proper fix will require rewriting sections of the lisp
 
63
   compiler to separate the calling procedures for functions returning
 
64
   an object from functions returning a long.  CM  20020801 */
 
65
/*  #if defined(__mc68020__) */
 
66
/*  #define LCAST(a) (object)(*(long(*)())a) */
 
67
/*  #else */
 
68
#define LCAST(a) (*a)
 
69
/*  #endif */
 
70
 
 
71
#define SET_TO_APPLY(res,f,n,x) \
 
72
 switch(n) {\
 
73
 case 0:   res=LCAST(f)(); break;\
 
74
  case 1:  res=LCAST(f)(x[0]); break; \
 
75
  case 2:  res=LCAST(f)(x[0],x[1]);break; \
 
76
  case 3:  res=LCAST(f)(x[0],x[1],x[2]);break; \
 
77
  case 4:  res=LCAST(f)(x[0],x[1],x[2],x[3]);break; \
 
78
  case 5:  res=LCAST(f)(x[0],x[1],x[2],x[3],x[4]);break; \
 
79
  case 6:  res=LCAST(f)(x[0],x[1],x[2],x[3],x[4],x[5]);  break;\
 
80
  case 7:  res=LCAST(f)(x[0],x[1],x[2],x[3],x[4],x[5], x[6]); break;\
 
81
  case 8:  res=LCAST(f)(x[0],x[1],x[2],x[3],x[4],x[5], x[6],x[7]); break;\
 
82
  case 9:  res=LCAST(f)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8]);break;\
 
83
  case 10: res=LCAST(f)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9]);break;\
 
84
   default: res=c_apply_n(*f,n,x); break;}
 
85
 
 
86
/*
 
87
#undef SET_TO_APPLY
 
88
#define SET_TO_APPLY(res,f,n,x)  res=c_apply_n(f,n,x);
 
89
*/
 
90
 
 
91
/* for t_sfun,t_gfun with args on vs stack */
 
92
 
 
93
static void
 
94
quick_call_sfun(object fun)
 
95
{ DEBUG_AVMA
 
96
  int i=fun->sfn.sfn_argd,n=SFUN_NARGS(i);
 
97
  enum ftype restype;
 
98
  object *x,res,*base;
 
99
  object *temp_ar=alloca(n*sizeof(object));
 
100
/*   i=fun->sfn.sfn_argd; */
 
101
/*   n=SFUN_NARGS(i); */
 
102
  base = vs_base;
 
103
  if (n != vs_top - base)
 
104
    {check_arg_failed(n);}
 
105
  restype = SFUN_RETURN_TYPE(i);
 
106
  SFUN_START_ARG_TYPES(i);
 
107
  /* for moment just support object and int */
 
108
#define COERCE_ARG(a,type)  (type==f_object ? a : (object)(fix(a)))
 
109
  if (i==0)
 
110
    x=vs_base;
 
111
  else
 
112
    {int j;
 
113
     x=temp_ar;
 
114
     for (j=0; j<n ; j++)
 
115
       {enum ftype typ=SFUN_NEXT_TYPE(i);
 
116
        x[j]=COERCE_ARG(vs_base[j],typ);}}
 
117
  SET_TO_APPLY(res,fun->sfn.sfn_self,n,x);
 
118
  base[0]=
 
119
    (restype==f_object ?  res :
 
120
     restype==f_fixnum ? make_fixnum((long)res)
 
121
     :(object) (FEerror("Bad result type",0),Cnil));
 
122
  vs_base = base;
 
123
  vs_top=base+1;
 
124
  CHECK_AVMA;
 
125
  return;}
 
126
 
 
127
/* only for sfun not gfun !!  Does not check number of args */
 
128
static void
 
129
call_sfun_no_check(object fun)
 
130
{ DEBUG_AVMA
 
131
  int n;
 
132
  object *base=vs_base;
 
133
  n=vs_top - base;
 
134
  SET_TO_APPLY(base[0],fun->sfn.sfn_self,n,base);
 
135
  vs_top=(vs_base=base)+1;
 
136
  CHECK_AVMA;
 
137
  return;
 
138
}
 
139
static void
 
140
call_vfun(object fun)
 
141
{ DEBUG_AVMA
 
142
  int n;
 
143
  object *base=vs_base;
 
144
  n=vs_top - base;
 
145
  if (n < fun->vfn.vfn_minargs)
 
146
    {FEtoo_few_arguments(base,vs_top); return;}
 
147
  if (n > fun->vfn.vfn_maxargs)
 
148
    {FEtoo_many_arguments(base,vs_top); return;}
 
149
  VFUN_NARGS = n;
 
150
  SET_TO_APPLY(base[0],fun->sfn.sfn_self,n,base);
 
151
  vs_top=(vs_base=base)+1;
 
152
  CHECK_AVMA;
 
153
  return;
 
154
}
 
155
 
 
156
 
 
157
void
 
158
funcall(object fun)
 
159
{ 
 
160
        object temporary;
 
161
        object x;
 
162
         object * VOL top;
 
163
        object *lex;
 
164
        bds_ptr old_bds_top;
 
165
        VOL bool b;
 
166
        bool c;
 
167
        DEBUG_AVMA
 
168
      TOP:
 
169
        if (fun == OBJNULL)
 
170
                FEerror("Undefined function.", 0);
 
171
        switch (type_of(fun)) {
 
172
        case t_cfun:
 
173
                MMcall(fun);
 
174
                CHECK_AVMA; return;
 
175
        case t_gfun:    
 
176
        case t_sfun:
 
177
                ihs_check;ihs_push(fun);
 
178
                quick_call_sfun(fun);
 
179
                ihs_pop();
 
180
                return;
 
181
        case t_vfun:
 
182
                ihs_check;ihs_push(fun);
 
183
                call_vfun(fun);
 
184
                ihs_pop();
 
185
                return;
 
186
         case t_afun:
 
187
         case t_closure:
 
188
           { object res,*b = vs_base;
 
189
             int n = vs_top - b;
 
190
             res = (object)IapplyVector(fun,n,b);
 
191
             n = fcall.nvalues;
 
192
             vs_base = b;
 
193
             vs_top =  b+ n;
 
194
             while (--n> 0 ) b[n] = fcall.values[n];
 
195
             b[0] = res;
 
196
             return;}           
 
197
      case t_cclosure:
 
198
 
 
199
        {
 
200
                object *top, *base, l;
 
201
 
 
202
                if (fun->cc.cc_turbo != NULL) {
 
203
                        MMccall(fun, fun->cc.cc_turbo);
 
204
                        CHECK_AVMA; return;
 
205
                }
 
206
                top = vs_top;
 
207
                base = vs_base;
 
208
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
209
                        vs_push(l);
 
210
                vs_base = vs_top;
 
211
                while (base < top)
 
212
                        vs_push(*base++);
 
213
                MMccall(fun, top);
 
214
                CHECK_AVMA; return;
 
215
        }
 
216
                
 
217
        case t_symbol:
 
218
             {object x = fun->s.s_gfdef;
 
219
              if (x) { fun = x; goto TOP;}
 
220
              else
 
221
                FEundefined_function(fun);
 
222
              }
 
223
 
 
224
        case t_cons:
 
225
                break;
 
226
 
 
227
        default:
 
228
                FEinvalid_function(fun);
 
229
        }
 
230
 
 
231
        /*
 
232
                This part is the same as that of funcall_no_event.
 
233
        */
 
234
 
 
235
        /* we may have pushed the calling form if this is called invoked from 
 
236
           eval.   A lambda call requires vs_push's, so we can tell
 
237
           if we pushed by vs_base being the same.
 
238
           */
 
239
      { VOL int not_pushed = 0;
 
240
        if (vs_base !=  ihs_top->ihs_base){
 
241
          ihs_check;
 
242
          ihs_push(fun);
 
243
        }
 
244
        else
 
245
          not_pushed = 1;
 
246
 
 
247
        ihs_top->ihs_base = lex_env;
 
248
        x = MMcar(fun);
 
249
        top = vs_top;
 
250
        lex = lex_env;
 
251
        old_bds_top = bds_top;
 
252
 
 
253
        /* maybe digest this lambda expression
 
254
           (lambda-block-expand name ..) has already been
 
255
           expanded.    The value of lambda-block-expand may
 
256
           be a compiled function in which case we say expand
 
257
           with it)
 
258
         */
 
259
 
 
260
        if (x == sSlambda_block_expanded) {
 
261
 
 
262
          b = TRUE;
 
263
          c = FALSE;
 
264
          fun = fun->c.c_cdr;
 
265
 
 
266
        }else if (x == sLlambda_block) {
 
267
          b = TRUE;
 
268
          c = FALSE;
 
269
          if(sSlambda_block_expanded->s.s_dbind)
 
270
            fun = ifuncall1(sSlambda_block_expanded->s.s_dbind,fun);
 
271
 
 
272
          fun = fun->c.c_cdr;
 
273
 
 
274
 
 
275
        
 
276
        } else if (x == sLlambda_closure) {
 
277
                b = FALSE;
 
278
                c = TRUE;
 
279
                fun = fun->c.c_cdr;
 
280
        } else if (x == sLlambda) {
 
281
                b = c = FALSE;
 
282
                fun = fun->c.c_cdr;
 
283
        } else if (x == sLlambda_block_closure) {
 
284
                b = c = TRUE;
 
285
                fun = fun->c.c_cdr;
 
286
        } else
 
287
                b = c = TRUE;
 
288
        if (c) {
 
289
                vs_push(kar(fun));
 
290
                fun = fun->c.c_cdr;
 
291
                vs_push(kar(fun));
 
292
                fun = fun->c.c_cdr;
 
293
                vs_push(kar(fun));
 
294
                fun = fun->c.c_cdr;
 
295
        } else {
 
296
                *(struct nil3 *)vs_top = three_nils;
 
297
                vs_top += 3;
 
298
        }
 
299
        if (b) {
 
300
                x = kar(fun);  /* block name */
 
301
                fun = fun->c.c_cdr;
 
302
        }
 
303
        lex_env = top;
 
304
        vs_push(fun);
 
305
        lambda_bind(top);
 
306
        ihs_top->ihs_base = lex_env;
 
307
        if (b) {
 
308
                fun = temporary = alloc_frame_id();
 
309
                /*  lex_block_bind(x, temporary);  */
 
310
                temporary = MMcons(temporary, Cnil);
 
311
                temporary = MMcons(sLblock, temporary);
 
312
                temporary = MMcons(x, temporary);
 
313
                lex_env[2] = MMcons(temporary, lex_env[2]);
 
314
                frs_push(FRS_CATCH, fun);
 
315
                if (nlj_active) {
 
316
                        nlj_active = FALSE;
 
317
                        goto END;
 
318
                }
 
319
        }
 
320
        x = top[3];  /* body */
 
321
        if(endp(x)) {
 
322
                vs_base = vs_top;
 
323
                vs_push(Cnil);
 
324
        } else {
 
325
                top = vs_top;
 
326
                for (;;) {
 
327
                        eval(MMcar(x));
 
328
                        x = MMcdr(x);
 
329
                        if (endp(x))
 
330
                                break;
 
331
                        vs_top = top;
 
332
                }
 
333
        }
 
334
END:
 
335
        if (b)
 
336
                frs_pop();
 
337
        bds_unwind(old_bds_top);
 
338
        lex_env = lex;
 
339
        if (not_pushed == 0) {ihs_pop();}
 
340
        CHECK_AVMA;
 
341
}}
 
342
 
 
343
void
 
344
funcall_no_event(object fun)
 
345
{
 
346
 DEBUG_AVMA
 
347
        if (fun == OBJNULL)
 
348
                FEerror("Undefined function.", 0);
 
349
        switch (type_of(fun)) {
 
350
        case t_cfun:
 
351
                (*fun->cf.cf_self)();
 
352
                break;
 
353
 
 
354
        case t_cclosure:
 
355
        {
 
356
                object *top, *base, l;
 
357
 
 
358
                if (fun->cc.cc_turbo != NULL) {
 
359
                        (*fun->cc.cc_self)(fun->cc.cc_turbo);
 
360
                        break;
 
361
                }
 
362
                top = vs_top;
 
363
                base = vs_base;
 
364
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
365
                        vs_push(l);
 
366
                vs_base = vs_top;
 
367
                while (base < top)
 
368
                        vs_push(*base++);
 
369
                (*fun->cc.cc_self)(top);
 
370
                break;
 
371
        }
 
372
 
 
373
        case t_sfun:
 
374
/*              call_sfun_no_check(fun); return; */
 
375
        case t_gfun:
 
376
                quick_call_sfun(fun); return;
 
377
        case t_vfun:
 
378
                call_vfun(fun); return;
 
379
 
 
380
        default:
 
381
                funcall(fun);
 
382
                
 
383
        }
 
384
}
 
385
 
 
386
void
 
387
lispcall(object *funp, int narg)
 
388
{
 
389
        DEBUG_AVMA
 
390
        object fun = *funp;
 
391
 
 
392
        vs_base = funp + 1;
 
393
        vs_top = vs_base + narg;
 
394
 
 
395
        if (fun == OBJNULL)
 
396
                FEerror("Undefined function.", 0);
 
397
        switch (type_of(fun)) {
 
398
        case t_cfun:
 
399
                MMcall(fun);
 
400
                break;
 
401
 
 
402
        case t_cclosure:
 
403
        {
 
404
                object *top, *base, l;
 
405
 
 
406
                if (fun->cc.cc_turbo != NULL) {
 
407
                        MMccall(fun, fun->cc.cc_turbo);
 
408
                        break;
 
409
                }
 
410
                top = vs_top;
 
411
                base = vs_base;
 
412
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
413
                        vs_push(l);
 
414
                vs_base = vs_top;
 
415
                while (base < top)
 
416
                        vs_push(*base++);
 
417
                MMccall(fun, top);
 
418
                break;
 
419
        }
 
420
 
 
421
              default:
 
422
                funcall(fun);
 
423
 
 
424
        }
 
425
  CHECK_AVMA;
 
426
}
 
427
 
 
428
void
 
429
lispcall_no_event(object *funp, int narg)
 
430
{
 
431
        DEBUG_AVMA
 
432
        object fun = *funp;
 
433
 
 
434
        vs_base = funp + 1;
 
435
        vs_top = vs_base + narg;
 
436
 
 
437
        if (fun == OBJNULL)
 
438
                FEerror("Undefined function.", 0);
 
439
        switch (type_of(fun)) {
 
440
        case t_cfun:
 
441
                (*fun->cf.cf_self)();
 
442
                break;
 
443
 
 
444
        case t_cclosure:
 
445
        {
 
446
                object *top, *base, l;
 
447
 
 
448
                if (fun->cc.cc_turbo != NULL) {
 
449
                        (*fun->cc.cc_self)(fun->cc.cc_turbo);
 
450
                        break;
 
451
                }
 
452
                top = vs_top;
 
453
                base = vs_base;
 
454
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
455
                        vs_push(l);
 
456
                vs_base = vs_top;
 
457
                while (base < top)
 
458
                        vs_push(*base++);
 
459
                (*fun->cc.cc_self)(top);
 
460
                break;
 
461
        }
 
462
 
 
463
 
 
464
        default:
 
465
                funcall(fun);
 
466
 
 
467
        }
 
468
         CHECK_AVMA;
 
469
}
 
470
 
 
471
void
 
472
symlispcall(object sym, object *base, int narg)
 
473
{
 
474
        DEBUG_AVMA
 
475
        object fun = symbol_function(sym);
 
476
 
 
477
        vs_base = base;
 
478
        vs_top = vs_base + narg;
 
479
 
 
480
        if (fun == OBJNULL)
 
481
                FEerror("Undefined function.", 0);
 
482
        switch (type_of(fun)) {
 
483
        case t_cfun:
 
484
                MMcall(fun);
 
485
                break;
 
486
 
 
487
        case t_cclosure:
 
488
        {
 
489
                object *top, *base, l;
 
490
 
 
491
                if (fun->cc.cc_turbo != NULL) {
 
492
                        MMccall(fun, fun->cc.cc_turbo);
 
493
                        break;
 
494
                }
 
495
                top = vs_top;
 
496
                base = vs_base;
 
497
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
498
                        vs_push(l);
 
499
                vs_base = vs_top;
 
500
                while (base < top)
 
501
                        vs_push(*base++);
 
502
                MMccall(fun, top);
 
503
                break;
 
504
        }
 
505
 
 
506
        default:
 
507
                funcall(fun);
 
508
        }
 
509
        CHECK_AVMA;
 
510
}
 
511
 
 
512
void
 
513
symlispcall_no_event(object sym, object *base, int narg)
 
514
{
 
515
        DEBUG_AVMA
 
516
        object fun = symbol_function(sym);
 
517
 
 
518
        vs_base = base;
 
519
        vs_top = vs_base + narg;
 
520
 
 
521
        if (fun == OBJNULL)
 
522
                FEerror("Undefined function.", 0);
 
523
        switch (type_of(fun)) {
 
524
        case t_cfun:
 
525
                (*fun->cf.cf_self)();
 
526
                break;
 
527
 
 
528
        case t_cclosure:
 
529
        {
 
530
                object *top, *base, l;
 
531
 
 
532
                if (fun->cc.cc_turbo != NULL) {
 
533
                        (*fun->cc.cc_self)(fun->cc.cc_turbo);
 
534
                        break;
 
535
                }
 
536
                top = vs_top;
 
537
                base = vs_base;
 
538
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
539
                        vs_push(l);
 
540
                vs_base = vs_top;
 
541
                while (base < top)
 
542
                        vs_push(*base++);
 
543
                (*fun->cc.cc_self)(top);
 
544
                break;
 
545
        }
 
546
 
 
547
        default:
 
548
                funcall(fun);
 
549
 
 
550
        }
 
551
        CHECK_AVMA;
 
552
}
 
553
 
 
554
object
 
555
simple_lispcall(object *funp, int narg)
 
556
{
 
557
        DEBUG_AVMA
 
558
        object fun = *funp;
 
559
        object *sup = vs_top;
 
560
 
 
561
        vs_base = funp + 1;
 
562
        vs_top = vs_base + narg;
 
563
 
 
564
        if (fun == OBJNULL)
 
565
                FEerror("Undefined function.", 0);
 
566
        switch (type_of(fun)) {
 
567
        case t_cfun:
 
568
                MMcall(fun);
 
569
                break;
 
570
 
 
571
        case t_cclosure:
 
572
        {
 
573
                object *top, *base, l;
 
574
 
 
575
                if (fun->cc.cc_turbo != NULL) {
 
576
                        MMccall(fun, fun->cc.cc_turbo);
 
577
                        break;
 
578
                }
 
579
                top = vs_top;
 
580
                base = vs_base;
 
581
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
582
                        vs_push(l);
 
583
                vs_base = vs_top;
 
584
                while (base < top)
 
585
                        vs_push(*base++);
 
586
                MMccall(fun, top);
 
587
                break;
 
588
        }
 
589
 
 
590
        default:
 
591
                funcall(fun);
 
592
        }
 
593
        vs_top = sup;
 
594
        CHECK_AVMA;
 
595
        return(vs_base[0]);
 
596
        
 
597
}
 
598
 
 
599
/* static object */
 
600
/* simple_lispcall_no_event(object *funp, int narg) */
 
601
/* { */
 
602
/*         DEBUG_AVMA  */
 
603
/*      object fun = *funp; */
 
604
/*      object *sup = vs_top; */
 
605
 
 
606
/*      vs_base = funp + 1; */
 
607
/*      vs_top = vs_base + narg; */
 
608
 
 
609
/*      if (fun == OBJNULL) */
 
610
/*              FEerror("Undefined function.", 0); */
 
611
/*      switch (type_of(fun)) { */
 
612
/*      case t_cfun: */
 
613
/*              (*fun->cf.cf_self)(); */
 
614
/*              break; */
 
615
 
 
616
/*      case t_cclosure: */
 
617
/*      { */
 
618
/*              object *top, *base, l; */
 
619
 
 
620
/*              if (fun->cc.cc_turbo != NULL) { */
 
621
/*                      (*fun->cc.cc_self)(fun->cc.cc_turbo); */
 
622
/*                      break; */
 
623
/*              } */
 
624
/*              top = vs_top; */
 
625
/*              base = vs_base; */
 
626
/*              for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr) */
 
627
/*                      vs_push(l); */
 
628
/*              vs_base = vs_top; */
 
629
/*              while (base < top) */
 
630
/*                      vs_push(*base++); */
 
631
/*              (*fun->cc.cc_self)(top); */
 
632
/*              break; */
 
633
/*      } */
 
634
 
 
635
/*      default: */
 
636
/*              funcall(fun); */
 
637
 
 
638
/*      } */
 
639
/*      vs_top = sup; */
 
640
/*      CHECK_AVMA; */
 
641
/*      return(vs_base[0]); */
 
642
/* } */
 
643
 
 
644
object
 
645
simple_symlispcall(object sym, object *base, int narg)
 
646
{
 
647
        DEBUG_AVMA
 
648
        object fun = symbol_function(sym);
 
649
        object *sup = vs_top;
 
650
 
 
651
        vs_base = base;
 
652
        vs_top = vs_base + narg;
 
653
 
 
654
        if (fun == OBJNULL)
 
655
                FEerror("Undefined function.", 0);
 
656
        switch (type_of(fun)) {
 
657
        case t_cfun:
 
658
                MMcall(fun);
 
659
                break;
 
660
 
 
661
        case t_cclosure:
 
662
        {
 
663
                object *top, *base, l;
 
664
 
 
665
                if (fun->cc.cc_turbo != NULL) {
 
666
                        MMccall(fun, fun->cc.cc_turbo);
 
667
                        break;
 
668
                }
 
669
                top = vs_top;
 
670
                base = vs_base;
 
671
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
672
                        vs_push(l);
 
673
                vs_base = vs_top;
 
674
                while (base < top)
 
675
                        vs_push(*base++);
 
676
                MMccall(fun, top);
 
677
                break;
 
678
        }
 
679
 
 
680
        default:
 
681
                funcall(fun);
 
682
 
 
683
        }
 
684
        vs_top = sup;
 
685
        CHECK_AVMA;
 
686
        return(vs_base[0]);
 
687
}
 
688
 
 
689
/* static object */
 
690
/* simple_symlispcall_no_event(object sym, object *base, int narg) */
 
691
/* { */
 
692
/*         DEBUG_AVMA */
 
693
/*      object fun = symbol_function(sym); */
 
694
/*      object *sup = vs_top; */
 
695
 
 
696
/*      vs_base = base; */
 
697
/*      vs_top = vs_base + narg; */
 
698
 
 
699
/*      if (fun == OBJNULL) */
 
700
/*              FEerror("Undefined function.", 0); */
 
701
/*      switch (type_of(fun)) { */
 
702
/*      case t_cfun: */
 
703
/*              (*fun->cf.cf_self)(); */
 
704
/*              break; */
 
705
 
 
706
/*      case t_cclosure: */
 
707
/*      { */
 
708
/*              object *top, *base, l; */
 
709
 
 
710
/*              if (fun->cc.cc_turbo != NULL) { */
 
711
/*                      (*fun->cc.cc_self)(fun->cc.cc_turbo); */
 
712
/*                      break; */
 
713
/*              } */
 
714
/*              top = vs_top; */
 
715
/*              base = vs_base; */
 
716
/*              for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr) */
 
717
/*                      vs_push(l); */
 
718
/*              vs_base = vs_top; */
 
719
/*              while (base < top) */
 
720
/*                      vs_push(*base++); */
 
721
/*              (*fun->cc.cc_self)(top); */
 
722
/*              break; */
 
723
/*      } */
 
724
 
 
725
/*      default: */
 
726
/*              funcall(fun); */
 
727
/*      } */
 
728
/*      vs_top = sup; */
 
729
/*      CHECK_AVMA; */
 
730
/*      return(vs_base[0]); */
 
731
/* } */
 
732
 
 
733
void
 
734
super_funcall(object fun)
 
735
{
 
736
        if (type_of(fun) == t_symbol) {
 
737
                if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
 
738
                        FEinvalid_function(fun);
 
739
                if (fun->s.s_gfdef == OBJNULL)
 
740
                        FEundefined_function(fun);
 
741
                fun = fun->s.s_gfdef;
 
742
        }
 
743
        funcall(fun);
 
744
}
 
745
 
 
746
void
 
747
super_funcall_no_event(object fun)
 
748
{
 
749
#ifdef DEBUGGING_AVMA
 
750
  funcall_no_event(fun); return;
 
751
#endif 
 
752
   if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();return;}
 
753
   if (type_of(fun)==t_sfun){call_sfun_no_check(fun); return;}
 
754
   if (type_of(fun)==t_gfun)
 
755
       {quick_call_sfun(fun); return;}
 
756
   if (type_of(fun)==t_vfun)
 
757
       {call_vfun(fun); return;}
 
758
   if (type_of(fun) == t_symbol) {
 
759
          if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
 
760
                        FEinvalid_function(fun);
 
761
                if (fun->s.s_gfdef == OBJNULL)
 
762
                        FEundefined_function(fun);
 
763
                fun = fun->s.s_gfdef;
 
764
                if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();
 
765
                                          return;}
 
766
        }
 
767
        funcall_no_event(fun);
 
768
}
 
769
 
 
770
#ifdef USE_BROKEN_IEVAL
 
771
object
 
772
Ieval(form)
 
773
object form;
 
774
{
 
775
       DEBUG_AVMA
 
776
        object fun, x;
 
777
        object *top;
 
778
        object *base;
 
779
        object orig_form;
 
780
 
 
781
        cs_check(form);
 
782
 
 
783
EVAL:
 
784
 
 
785
        vs_check;
 
786
 
 
787
        if (Vevalhook->s.s_dbind != Cnil && eval1 == 0)
 
788
        {
 
789
                bds_ptr old_bds_top = bds_top;
 
790
                object hookfun = symbol_value(Vevalhook);
 
791
                /*  check if Vevalhook is unbound  */
 
792
 
 
793
                bds_bind(Vevalhook, Cnil);
 
794
                form = Ifuncall_n(hookfun,2,form,list(3,lex_env[0],lex_env[1],lex_env[2]));
 
795
                bds_unwind(old_bds_top);
 
796
                return form;
 
797
        } else
 
798
                eval1 = 0;
 
799
 
 
800
        if (type_of(form) == t_cons)
 
801
                goto APPLICATION;
 
802
 
 
803
        if (type_of(form) != t_symbol)  RETURN1(form);
 
804
 
 
805
        switch (form->s.s_stype) {
 
806
        case stp_constant:
 
807
          RETURN1((form->s.s_dbind));
 
808
 
 
809
        case stp_special:
 
810
                if(form->s.s_dbind == OBJNULL)
 
811
                        FEunbound_variable(form);
 
812
          RETURN1((form->s.s_dbind));
 
813
 
 
814
        default:
 
815
                /*  x = lex_var_sch(form);  */
 
816
                for (x = lex_env[0];  type_of(x) == t_cons;  x = x->c.c_cdr)
 
817
                        if (x->c.c_car->c.c_car == form) {
 
818
                                x = x->c.c_car->c.c_cdr;
 
819
                                if (endp(x))
 
820
                                        break;
 
821
                                RETURN1((x->c.c_car));
 
822
                        }
 
823
                if(form->s.s_dbind == OBJNULL)
 
824
                        FEunbound_variable(form);
 
825
          RETURN1((form->s.s_dbind));
 
826
        }
 
827
 
 
828
APPLICATION:
 
829
        /* Hook for possibly stopping at forms in the break point
 
830
           list.  Also for stepping.  We only want to check
 
831
           one form each time round, so we do *breakpoints*
 
832
           */
 
833
        if (sSAbreak_pointsA->s.s_dbind != Cnil)
 
834
          { if (sSAbreak_stepA->s.s_dbind == Cnil ||
 
835
                ifuncall2(sSAbreak_stepA->s.s_dbind,form,
 
836
                          list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil)
 
837
              {object* bpts = sSAbreak_pointsA->s.s_dbind->v.v_self;
 
838
               int i = sSAbreak_pointsA->s.s_dbind->v.v_fillp;
 
839
               while (--i >= 0)
 
840
                 { if((*bpts)->c.c_car == form)
 
841
                     {ifuncall2(sSAbreak_pointsA->s.s_gfdef,form,
 
842
                                list(3,lex_env[0],lex_env[1],lex_env[2]));
 
843
 
 
844
                      break;}
 
845
                   bpts++;}
 
846
             }}
 
847
        
 
848
        fun = MMcar(form);
 
849
        if (type_of(fun) != t_symbol)
 
850
                goto LAMBDA;
 
851
        if (fun->s.s_sfdef != NOT_SPECIAL) {
 
852
                ihs_check;
 
853
                ihs_push(form);
 
854
                ihs_top->ihs_base = lex_env;
 
855
                (*fun->s.s_sfdef)(MMcdr(form));
 
856
                CHECK_AVMA;
 
857
                ihs_pop();
 
858
                return Ivs_values();
 
859
        }
 
860
        /*  x = lex_fd_sch(fun);  */
 
861
        for (x = lex_env[1];  type_of(x) == t_cons;  x = x->c.c_cdr)
 
862
                if (x->c.c_car->c.c_car == fun) {
 
863
                        x = x->c.c_car;
 
864
                        if (MMcadr(x) == sLmacro) {
 
865
                                x = MMcaddr(x);
 
866
                                goto EVAL_MACRO;
 
867
                        }
 
868
                        x = MMcaddr(x);
 
869
                        goto EVAL_ARGS;
 
870
                }
 
871
 
 
872
        if ((x = fun->s.s_gfdef) == OBJNULL)
 
873
                FEundefined_function(fun);
 
874
 
 
875
        if (fun->s.s_mflag) {
 
876
        EVAL_MACRO:
 
877
 
 
878
                form = Imacro_expand1(x, form);
 
879
                goto EVAL;
 
880
        }
 
881
 
 
882
          
 
883
        
 
884
EVAL_ARGS:
 
885
        { int n ;
 
886
        ihs_check;
 
887
        ihs_push(form);
 
888
        ihs_top->ihs_base = lex_env;
 
889
        form = form->c.c_cdr;
 
890
        base = vs_top;
 
891
        top = base ;
 
892
        while(!endp(form)) {
 
893
          object ans = Ieval(MMcar(form));
 
894
          top[0] = ans;
 
895
          vs_top = ++top;
 
896
          form = MMcdr(form);}
 
897
          n =top - base; /* number of args */
 
898
        if (Vapplyhook->s.s_dbind != Cnil) {
 
899
          base[0]= (object)n;
 
900
          base[0] = c_apply_n(list,n+1,base);
 
901
          x = Ifuncall_n(Vapplyhook->s.s_dbind,3,
 
902
                         x, /* the function */
 
903
                         base[0], /* the arg list */
 
904
                         list(3,lex_env[0],lex_env[1],lex_env[2]));
 
905
          vs_top = base; return x;
 
906
        }
 
907
        ihs_top->ihs_function = x;
 
908
        ihs_top->ihs_base = vs_base;
 
909
        x=IapplyVector(x,n,base+1);
 
910
        CHECK_AVMA;
 
911
        ihs_pop();
 
912
        vs_top = base;  
 
913
        return x;
 
914
                 }
 
915
 
 
916
LAMBDA:
 
917
        if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) {
 
918
          x = listA(4,sLlambda_closure,lex_env[0],lex_env[1],lex_env[2],Mcdr(fun));
 
919
          goto EVAL_ARGS;
 
920
        }
 
921
        FEinvalid_function(fun);
 
922
}       
 
923
 
 
924
#else  
 
925
 
 
926
object
 
927
Ieval(object form)
 
928
{ eval(form);
 
929
  return Ivs_values();
 
930
}
 
931
#endif
 
932
  
 
933
void
 
934
eval(object form)
 
935
{ 
 
936
        object temporary;
 
937
        DEBUG_AVMA
 
938
        object fun, x;
 
939
        object *top;
 
940
        object *base;
 
941
 
 
942
        cs_check(form);
 
943
 
 
944
EVAL:
 
945
 
 
946
        vs_check;
 
947
 
 
948
        if (Vevalhook->s.s_dbind != Cnil && eval1 == 0)
 
949
        {
 
950
                bds_ptr old_bds_top = bds_top;
 
951
                object hookfun = symbol_value(Vevalhook);
 
952
                /*  check if Vevalhook is unbound  */
 
953
 
 
954
                bds_bind(Vevalhook, Cnil);
 
955
                vs_base = vs_top;
 
956
                vs_push(form);
 
957
                vs_push(lex_env[0]);
 
958
                vs_push(lex_env[1]);
 
959
                vs_push(lex_env[2]);
 
960
                vs_push(Cnil);
 
961
                stack_cons();
 
962
                stack_cons();
 
963
                stack_cons();
 
964
                super_funcall(hookfun);
 
965
                bds_unwind(old_bds_top);
 
966
                return;
 
967
        } else
 
968
                eval1 = 0;
 
969
 
 
970
        if (type_of(form) == t_cons)
 
971
                goto APPLICATION;
 
972
 
 
973
        if (type_of(form) != t_symbol) {
 
974
                vs_base = vs_top;
 
975
                vs_push(form);
 
976
                return;
 
977
        }
 
978
 
 
979
        switch (form->s.s_stype) {
 
980
        case stp_constant:
 
981
                vs_base = vs_top;
 
982
                vs_push(form->s.s_dbind);
 
983
                return;
 
984
 
 
985
        case stp_special:
 
986
                if(form->s.s_dbind == OBJNULL)
 
987
                        FEunbound_variable(form);
 
988
                vs_base = vs_top;
 
989
                vs_push(form->s.s_dbind);
 
990
                return;
 
991
 
 
992
        default:
 
993
                /*  x = lex_var_sch(form);  */
 
994
                for (x = lex_env[0];  type_of(x) == t_cons;  x = x->c.c_cdr)
 
995
                        if (x->c.c_car->c.c_car == form) {
 
996
                                x = x->c.c_car->c.c_cdr;
 
997
                                if (endp(x))
 
998
                                        break;
 
999
                                vs_base = vs_top;
 
1000
                                vs_push(x->c.c_car);
 
1001
                                return;
 
1002
                        }
 
1003
                if(form->s.s_dbind == OBJNULL)
 
1004
                        FEunbound_variable(form);
 
1005
                vs_base = vs_top;
 
1006
                vs_push(form->s.s_dbind);
 
1007
                return;
 
1008
        }
 
1009
 
 
1010
APPLICATION:
 
1011
        /* Hook for possibly stopping at forms in the break point
 
1012
           list.  Also for stepping.  We only want to check
 
1013
           one form each time round, so we do *breakpoints*
 
1014
           */
 
1015
        if (sSAbreak_pointsA->s.s_dbind != Cnil)
 
1016
          { if (sSAbreak_stepA->s.s_dbind == Cnil ||
 
1017
                ifuncall2(sSAbreak_stepA->s.s_dbind,form,
 
1018
                          list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil)
 
1019
              {object* bpts = sSAbreak_pointsA->s.s_dbind->v.v_self;
 
1020
               int i = sSAbreak_pointsA->s.s_dbind->v.v_fillp;
 
1021
               while (--i >= 0)
 
1022
                 { if((*bpts)->c.c_car == form)
 
1023
                     {ifuncall2(sSAbreak_pointsA->s.s_gfdef,form,
 
1024
                                list(3,lex_env[0],lex_env[1],lex_env[2]));
 
1025
 
 
1026
                      break;}
 
1027
                   bpts++;}
 
1028
             }}
 
1029
        
 
1030
        fun = MMcar(form);
 
1031
        if (type_of(fun) != t_symbol)
 
1032
                goto LAMBDA;
 
1033
        if (fun->s.s_sfdef != NOT_SPECIAL) {
 
1034
                ihs_check;
 
1035
                ihs_push(form);
 
1036
                ihs_top->ihs_base = lex_env;
 
1037
                (*fun->s.s_sfdef)(MMcdr(form));
 
1038
                CHECK_AVMA;
 
1039
                ihs_pop();
 
1040
                return;
 
1041
        }
 
1042
        /*  x = lex_fd_sch(fun);  */
 
1043
        for (x = lex_env[1];  type_of(x) == t_cons;  x = x->c.c_cdr)
 
1044
                if (x->c.c_car->c.c_car == fun) {
 
1045
                        x = x->c.c_car;
 
1046
                        if (MMcadr(x) == sLmacro) {
 
1047
                                x = MMcaddr(x);
 
1048
                                goto EVAL_MACRO;
 
1049
                        }
 
1050
                        x = MMcaddr(x);
 
1051
                        goto EVAL_ARGS;
 
1052
                }
 
1053
 
 
1054
        if ((x = fun->s.s_gfdef) == OBJNULL)
 
1055
                FEundefined_function(fun);
 
1056
 
 
1057
        if (fun->s.s_mflag) {
 
1058
        EVAL_MACRO:
 
1059
                top = vs_top;
 
1060
                form=Imacro_expand1(x, form);
 
1061
                vs_top = top;
 
1062
                vs_push(form);
 
1063
                goto EVAL;
 
1064
        }
 
1065
 
 
1066
          
 
1067
        
 
1068
EVAL_ARGS:
 
1069
        vs_push(x);
 
1070
        ihs_check;
 
1071
        ihs_push(form);
 
1072
        ihs_top->ihs_base = lex_env;
 
1073
        form = form->c.c_cdr;
 
1074
        base = vs_top;
 
1075
        top = vs_top;
 
1076
        while(!endp(form)) {
 
1077
                eval(MMcar(form));
 
1078
                top[0] = vs_base[0];
 
1079
                vs_top = ++top;
 
1080
                form = MMcdr(form);
 
1081
        }
 
1082
        vs_base = base;
 
1083
        if (Vapplyhook->s.s_dbind != Cnil) {
 
1084
                call_applyhook(fun);
 
1085
                return;
 
1086
        }
 
1087
        ihs_top->ihs_function = x;
 
1088
        ihs_top->ihs_base = vs_base;
 
1089
        if (type_of(x) == t_cfun) 
 
1090
          (*(x)->cf.cf_self)();
 
1091
        else
 
1092
          funcall_no_event(x);
 
1093
        CHECK_AVMA;
 
1094
        ihs_pop();
 
1095
        return;
 
1096
 
 
1097
LAMBDA:
 
1098
        if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) {
 
1099
                temporary = make_cons(lex_env[2], fun->c.c_cdr);
 
1100
                temporary = make_cons(lex_env[1], temporary);
 
1101
                temporary = make_cons(lex_env[0], temporary);
 
1102
                x = make_cons(sLlambda_closure, temporary);
 
1103
                vs_push(x);
 
1104
                goto EVAL_ARGS;
 
1105
        }
 
1106
        FEinvalid_function(fun);
 
1107
}       
 
1108
 
 
1109
static void
 
1110
call_applyhook(object fun)
 
1111
{
 
1112
        object ah;
 
1113
        object *v;
 
1114
 
 
1115
        ah = symbol_value(Vapplyhook);
 
1116
        v = vs_base + 1;
 
1117
        vs_push(Cnil);
 
1118
        while (vs_top > v)
 
1119
                stack_cons();
 
1120
        vs_push(vs_base[0]);
 
1121
        vs_base[0] = fun;
 
1122
        vs_push(lex_env[0]);
 
1123
        vs_push(lex_env[1]);
 
1124
        vs_push(lex_env[2]);
 
1125
        vs_push(Cnil);
 
1126
        stack_cons();
 
1127
        stack_cons();
 
1128
        stack_cons();
 
1129
        super_funcall(ah);
 
1130
}
 
1131
 
 
1132
 
 
1133
DEFUNO_NEW("FUNCALL",object,fLfuncall,LISP
 
1134
       ,1,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lfuncall,(object fun,...),"")
 
1135
{ va_list ap;
 
1136
  object *new;
 
1137
  int n = VFUN_NARGS;
 
1138
  va_start(ap,fun);
 
1139
  {COERCE_VA_LIST(new,ap,n);
 
1140
  return IapplyVector(fun,n-1,new);
 
1141
  va_end(ap);
 
1142
 }
 
1143
}
 
1144
 
 
1145
 
 
1146
DEFUNO_NEW("APPLY",object,fLapply,LISP
 
1147
       ,2,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lapply,(object fun,...),"")
 
1148
{       int m,n=VFUN_NARGS;
 
1149
        object list;
 
1150
        object buf[MAX_ARGS];
 
1151
        object *base=buf;
 
1152
        va_list ap;
 
1153
        va_start(ap,fun);
 
1154
        m = n-1;
 
1155
        while (--m >0)
 
1156
          {*base++ = va_arg(ap,object);
 
1157
         }
 
1158
        m = n-2;
 
1159
        list = va_arg(ap,object);
 
1160
        va_end(ap);
 
1161
        while (!endp(list))
 
1162
          { if (m >= MAX_ARGS) FEerror(" Lisps arglist maximum surpassed",0);
 
1163
            *base++ = Mcar(list);
 
1164
            list = Mcdr(list);
 
1165
            m++;}
 
1166
        return IapplyVector(fun,m,buf);
 
1167
      }
 
1168
        
 
1169
 
 
1170
DEFUNO_NEW("EVAL",object,fLeval,LISP
 
1171
       ,1,1,NONE,OO,OO,OO,OO,void,Leval,(object x0),"")
 
1172
{
 
1173
        object *lex = lex_env;
 
1174
 
 
1175
        /* 1 args */
 
1176
        lex_new();
 
1177
        /*      eval(vs_base[0]); */
 
1178
        eval(x0);
 
1179
        lex_env = lex;
 
1180
        return Ivs_values();
 
1181
}
 
1182
 
 
1183
LFD(Levalhook)(void)
 
1184
{
 
1185
        object env;
 
1186
        bds_ptr old_bds_top = bds_top;
 
1187
        object *lex = lex_env;
 
1188
        int n = vs_top - vs_base;
 
1189
 
 
1190
        lex_env = vs_top;
 
1191
        if (n < 3)
 
1192
                too_few_arguments();
 
1193
        else if (n == 3) {
 
1194
                *(struct nil3 *)vs_top = three_nils;
 
1195
                vs_top += 3;
 
1196
        } else if (n == 4) {
 
1197
                env = vs_base[3];
 
1198
                vs_push(car(env));
 
1199
                env = cdr(env);
 
1200
                vs_push(car(env));
 
1201
                env = cdr(env);
 
1202
                vs_push(car(env));
 
1203
        } else
 
1204
                too_many_arguments();
 
1205
        bds_bind(Vevalhook, vs_base[1]);
 
1206
        bds_bind(Vapplyhook, vs_base[2]);
 
1207
        eval1 = 1;
 
1208
        eval(vs_base[0]);
 
1209
        lex_env = lex;
 
1210
        bds_unwind(old_bds_top);
 
1211
}
 
1212
 
 
1213
LFD(Lapplyhook)(void)
 
1214
{
 
1215
 
 
1216
        object env;
 
1217
        bds_ptr old_bds_top = bds_top;
 
1218
        object *lex = lex_env;
 
1219
        int n = vs_top - vs_base;
 
1220
        object l, *z;
 
1221
 
 
1222
        lex_env = vs_top;
 
1223
        if (n < 4)
 
1224
                too_few_arguments();
 
1225
        else if (n == 4) {
 
1226
                *(struct nil3 *)vs_top = three_nils;
 
1227
                vs_top += 3;
 
1228
        } else if (n == 5) {
 
1229
                env = vs_base[4];
 
1230
                vs_push(car(env));
 
1231
                env = cdr(env);
 
1232
                vs_push(car(env));
 
1233
                env = cdr(env);
 
1234
                vs_push(car(env));
 
1235
        } else
 
1236
                too_many_arguments();
 
1237
        bds_bind(Vevalhook, vs_base[2]);
 
1238
        bds_bind(Vapplyhook, vs_base[3]);
 
1239
        z = vs_top;
 
1240
        for (l = vs_base[1];  !endp(l);  l = l->c.c_cdr)
 
1241
                vs_push(l->c.c_car);
 
1242
        l = vs_base[0];
 
1243
        vs_base = z;
 
1244
        super_funcall(l);
 
1245
        lex_env = lex;
 
1246
        bds_unwind(old_bds_top);
 
1247
}
 
1248
 
 
1249
DEFUNO_NEW("CONSTANTP",object,fLconstantp,LISP
 
1250
       ,1,1,NONE,OO,OO,OO,OO,void,Lconstantp,(object x0),"")
 
1251
{
 
1252
        enum type x;
 
1253
        /* 1 args */
 
1254
 
 
1255
        x = type_of(x0);
 
1256
        if(x == t_cons)
 
1257
                if(x0->c.c_car == sLquote)
 
1258
                        x0 = Ct;
 
1259
                else    x0 = Cnil;
 
1260
        else if(x == t_symbol)
 
1261
                if((enum stype)x0->s.s_stype == stp_constant)
 
1262
                        x0 = Ct;
 
1263
                else
 
1264
                        x0 = Cnil;
 
1265
        else
 
1266
                        x0 = Ct;
 
1267
        RETURN1(x0);
 
1268
}
 
1269
 
 
1270
object
 
1271
ieval(object x)
 
1272
{
 
1273
        object *old_vs_base;
 
1274
        object *old_vs_top;
 
1275
 
 
1276
        old_vs_base = vs_base;
 
1277
        old_vs_top = vs_top;
 
1278
        eval(x);
 
1279
        x = vs_base[0];
 
1280
        vs_base = old_vs_base;
 
1281
        vs_top = old_vs_top;
 
1282
        return(x);
 
1283
}
 
1284
 
 
1285
object
 
1286
ifuncall1(object fun, object arg1)
 
1287
{
 
1288
        object *old_vs_base;
 
1289
        object *old_vs_top;
 
1290
        object x;
 
1291
 
 
1292
        old_vs_base = vs_base;
 
1293
        old_vs_top = vs_top;
 
1294
        vs_base = vs_top;
 
1295
        vs_push(arg1);
 
1296
        super_funcall(fun);
 
1297
        x = vs_base[0];
 
1298
        vs_top = old_vs_top;
 
1299
        vs_base = old_vs_base;
 
1300
        return(x);
 
1301
}
 
1302
 
 
1303
object
 
1304
ifuncall2(object fun, object arg1, object arg2)
 
1305
{
 
1306
        object *old_vs_base;
 
1307
        object *old_vs_top;
 
1308
        object x;
 
1309
 
 
1310
        old_vs_base = vs_base;
 
1311
        old_vs_top = vs_top;
 
1312
        vs_base = vs_top;
 
1313
        vs_push(arg1);
 
1314
        vs_push(arg2);
 
1315
        super_funcall(fun);
 
1316
        x = vs_base[0];
 
1317
        vs_top = old_vs_top;
 
1318
        vs_base = old_vs_base;
 
1319
        return(x);
 
1320
}
 
1321
 
 
1322
object
 
1323
ifuncall3(object fun, object arg1, object arg2, object arg3)
 
1324
{
 
1325
        object *old_vs_base;
 
1326
        object *old_vs_top;
 
1327
        object x;
 
1328
 
 
1329
        old_vs_base = vs_base;
 
1330
        old_vs_top = vs_top;
 
1331
        vs_base = vs_top;
 
1332
        vs_push(arg1);
 
1333
        vs_push(arg2);
 
1334
        vs_push(arg3);
 
1335
        super_funcall(fun);
 
1336
        x = vs_base[0];
 
1337
        vs_top = old_vs_top;
 
1338
        vs_base = old_vs_base;
 
1339
        return(x);
 
1340
}
 
1341
 
 
1342
void
 
1343
funcall_with_catcher(object fname, object fun)
 
1344
{
 
1345
        int n = vs_top - vs_base;
 
1346
        if (n > 64) n = 64;
 
1347
        frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n)));
 
1348
        if (nlj_active)
 
1349
                nlj_active = FALSE;
 
1350
        else
 
1351
                funcall(fun);
 
1352
        frs_pop();
 
1353
}
 
1354
 
 
1355
static object 
 
1356
fcalln_cclosure(object first,va_list ap)
 
1357
{
 
1358
int i=fcall.argd;
 
1359
 {object *base=vs_top;
 
1360
  DEBUG_AVMA
 
1361
    vs_base=base;
 
1362
  if (i) {
 
1363
    *(base++)=first;
 
1364
    i--;
 
1365
  }
 
1366
    switch(i){
 
1367
    case 10: *(base++)=va_arg(ap,object);
 
1368
    case 9: *(base++)=va_arg(ap,object);
 
1369
    case 8: *(base++)=va_arg(ap,object);
 
1370
    case 7: *(base++)=va_arg(ap,object);
 
1371
    case 6: *(base++)=va_arg(ap,object);
 
1372
    case 5: *(base++)=va_arg(ap,object);
 
1373
    case 4: *(base++)=va_arg(ap,object);
 
1374
    case 3: *(base++)=va_arg(ap,object);
 
1375
    case 2: *(base++)=va_arg(ap,object);
 
1376
    case 1: *(base++)=va_arg(ap,object);
 
1377
    case 0: break;
 
1378
    default:
 
1379
      FEerror("bad args",0);
 
1380
    } vs_top=base;
 
1381
      base=base -i;
 
1382
        do{object fun=fcall.fun;
 
1383
                object *top, *base, l;
 
1384
 
 
1385
                if (fun->cc.cc_turbo != NULL) {
 
1386
                        (*fun->cc.cc_self)(fun->cc.cc_turbo);
 
1387
                        break;
 
1388
                }
 
1389
                top = vs_top;
 
1390
                base = vs_base;
 
1391
                for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
 
1392
                        vs_push(l);
 
1393
                vs_base = vs_top;
 
1394
                while (base < top)
 
1395
                        vs_push(*base++);
 
1396
                (*fcall.fun->cc.cc_self)(top);
 
1397
                break;
 
1398
        }while (0);
 
1399
       vs_top=base;
 
1400
       CHECK_AVMA;
 
1401
       return(vs_base[0]);
 
1402
}}
 
1403
 
 
1404
static object 
 
1405
fcalln_general(object first,va_list ap) {
 
1406
  int i=fcall.argd;
 
1407
 
 
1408
  {
 
1409
    int n= SFUN_NARGS(i);
 
1410
    /*  object *old_vs_base=vs_base; */
 
1411
    object *old_vs_top=vs_top;
 
1412
    object x;
 
1413
    enum ftype typ,restype=SFUN_RETURN_TYPE(i);
 
1414
    vs_top =  vs_base = old_vs_top;
 
1415
    SFUN_START_ARG_TYPES(i);
 
1416
    if (i==0) {
 
1417
      int jj=0;
 
1418
      while (n-- > 0) {
 
1419
        typ= SFUN_NEXT_TYPE(i);
 
1420
        x =
 
1421
          (typ==f_object ?      (jj ? va_arg(ap,object) : first):
 
1422
           typ==f_fixnum ? make_fixnum((jj ? va_arg(ap,fixnum) : (fixnum)first)):
 
1423
           (object) (FEerror("bad type",0),Cnil));
 
1424
        *(vs_top++) = x;
 
1425
        jj++;
 
1426
      }
 
1427
    } else {
 
1428
      object *base=vs_top;
 
1429
      *(base++)=first;
 
1430
      n--;
 
1431
      while (n-- > 0) 
 
1432
        *(base++) = va_arg(ap,object);
 
1433
     vs_top=base;
 
1434
    }
 
1435
    funcall(fcall.fun);
 
1436
    x= vs_base[0];
 
1437
    vs_top=old_vs_top;
 
1438
    /* vs_base=old_vs_base; */
 
1439
    return (restype== f_object ? x :
 
1440
            restype== f_fixnum ? (object) (fix(x)):
 
1441
            (object) (FEerror("bad type",0),Cnil));
 
1442
  }
 
1443
}
 
1444
 
 
1445
static object
 
1446
fcalln_vfun(object first,va_list vl)
 
1447
{object *new,res;
 
1448
 DEBUG_AVMA
 
1449
 COERCE_VA_LIST_NEW(new,first,vl,fcall.argd);
 
1450
 res = c_apply_n(fcall.fun->vfn.vfn_self,fcall.argd,new);
 
1451
 CHECK_AVMA;
 
1452
 return res;
 
1453
}
 
1454
 
 
1455
object 
 
1456
fcalln1(object first,...)
 
1457
{  va_list ap;
 
1458
   object fun=fcall.fun;
 
1459
   DEBUG_AVMA
 
1460
   va_start(ap,first);
 
1461
   if(type_of(fun)==t_cfun)
 
1462
     {object *base=vs_top;
 
1463
      int i=fcall.argd;
 
1464
      vs_base=base;
 
1465
      if (i) {
 
1466
        *(base++)=first;
 
1467
        i--;
 
1468
      }
 
1469
      switch(i){
 
1470
      case 10: *(base++)=va_arg(ap,object);
 
1471
      case 9: *(base++)=va_arg(ap,object);
 
1472
      case 8: *(base++)=va_arg(ap,object);
 
1473
      case 7: *(base++)=va_arg(ap,object);
 
1474
      case 6: *(base++)=va_arg(ap,object);
 
1475
      case 5: *(base++)=va_arg(ap,object);
 
1476
      case 4: *(base++)=va_arg(ap,object);
 
1477
      case 3: *(base++)=va_arg(ap,object);
 
1478
      case 2: *(base++)=va_arg(ap,object);
 
1479
      case 1: *(base++)=va_arg(ap,object);
 
1480
      case 0: break;
 
1481
      default:
 
1482
        FEerror("bad args",0);
 
1483
      }  vs_top=base;
 
1484
      base=base -i;
 
1485
      (*fcall.fun->cf.cf_self)();
 
1486
      vs_top=base;
 
1487
      CHECK_AVMA;
 
1488
      return(vs_base[0]);
 
1489
    }
 
1490
   if(type_of(fun)==t_cclosure)
 
1491
     return(fcalln_cclosure(first,ap));
 
1492
   if(type_of(fun)==t_vfun)
 
1493
     return(fcalln_vfun(first,ap));
 
1494
   return(fcalln_general(first,ap));
 
1495
  va_end(ap);
 
1496
 }
 
1497
 
 
1498
/* call a cfun eg funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) */
 
1499
/*  typedef void (*funcvoid)(); */
 
1500
 
 
1501
object
 
1502
funcall_cfun(funcvoid fn,int n,...)
 
1503
{object *old_top = vs_top;
 
1504
 object *old_base= vs_base;
 
1505
 object result;
 
1506
 va_list ap;
 
1507
 DEBUG_AVMA
 
1508
 vs_base=vs_top;
 
1509
 va_start(ap,n);
 
1510
 while(n-->0) vs_push(va_arg(ap,object));
 
1511
 va_end(ap);
 
1512
 (*fn)();
 
1513
 if(vs_top>vs_base) result=vs_base[0];
 
1514
 else result=Cnil;
 
1515
 vs_top=old_top;
 
1516
 vs_base=old_base;
 
1517
 CHECK_AVMA;
 
1518
 return result;}
 
1519
 
 
1520
DEF_ORDINARY("LAMBDA-BLOCK-EXPANDED",sSlambda_block_expanded,SI,"");
 
1521
DEFVAR("*BREAK-POINTS*",sSAbreak_pointsA,SI,Cnil,"");
 
1522
DEFVAR("*BREAK-STEP*",sSAbreak_stepA,SI,Cnil,"");
 
1523
 
 
1524
void
 
1525
gcl_init_eval(void)
 
1526
{
 
1527
 
 
1528
 
 
1529
 
 
1530
 
 
1531
        make_constant("CALL-ARGUMENTS-LIMIT", make_fixnum(64));
 
1532
 
 
1533
 
 
1534
        Vevalhook = make_special("*EVALHOOK*", Cnil);
 
1535
        Vapplyhook = make_special("*APPLYHOOK*", Cnil);
 
1536
 
 
1537
 
 
1538
        three_nils.nil3_self[0] = Cnil;
 
1539
        three_nils.nil3_self[1] = Cnil;
 
1540
        three_nils.nil3_self[2] = Cnil;
 
1541
 
 
1542
        make_function("EVALHOOK", Levalhook);
 
1543
        make_function("APPLYHOOK", Lapplyhook);
 
1544
 
 
1545
}