← Back to branch summary

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

« back to all changes in this revision

Viewing changes to o/funlink.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/funlink.c
 
1
/*  Copyright William Schelter. All rights reserved.
 
2
Fast linking method for kcl by W. Schelter University of Texas
 
3
   Note there are also changes to 
 
4
 cmpcall.lsp and cmptop.lsp */
 
5
 
 
6
 
 
7
#include <stdlib.h>
 
8
#include <string.h>
 
9
#include "include.h"
 
10
#include "sfun_argd.h"
 
11
#include "page.h"
 
12
 
 
13
#if 0
 
14
#define DO_FUNLINK_DEBUG
 
15
#endif
 
16
 
 
17
#ifdef DO_FUNLINK_DEBUG
 
18
void print_lisp_string ( char *boilerplate, object s )
 
19
{
 
20
    if ( s && s->st.s_fillp && s->st.st_self ) {
 
21
        int last = s->st.s_fillp;
 
22
        int i;
 
23
        fprintf ( stderr, "%s", boilerplate ); 
 
24
        for (i = 0;  (i < last) && (i < 30);  i++) {
 
25
            fputc ( s->st.st_self[i], stderr );
 
26
        }
 
27
        fputc ( '\n', stderr );
 
28
    } else {
 
29
        fprintf ( stderr, "Object %x not a string or empty\n", s );
 
30
    }
 
31
}
 
32
#endif
 
33
 
 
34
static int
 
35
clean_link_array(object *,object *);
 
36
 
 
37
object sScdefn;
 
38
typedef object (*object_func)();
 
39
 
 
40
static int     
 
41
vpush_extend(void *,object);
 
42
 
 
43
object sLAlink_arrayA;
 
44
int Rset = 0;
 
45
 
 
46
/* cleanup link */
 
47
void
 
48
call_or_link(object sym, void **link )
 
49
{
 
50
    object fun;
 
51
    fun = sym->s.s_gfdef;
 
52
#ifdef DO_FUNLINK_DEBUG
 
53
    fprintf ( stderr, "call_or_link: fun %x START for function ", fun );
 
54
    print_lisp_string ( "name: ", fun->cf.cf_name );
 
55
#endif 
 
56
    if (fun == OBJNULL) {
 
57
        FEinvalid_function(sym);
 
58
#ifdef DO_FUNLINK_DEBUG
 
59
        fprintf ( stderr, "call_or_link: fun %x Invalid function EXIT\n", fun );
 
60
#endif 
 
61
        return;
 
62
    }
 
63
    if ( type_of ( fun ) == t_cclosure && (fun->cc.cc_turbo) ) {
 
64
        if ( Rset ==0 ) {
 
65
            MMccall ( fun, fun->cc.cc_turbo );
 
66
        } else {
 
67
            (*(fun)->cf.cf_self)(fun->cc.cc_turbo);
 
68
        }
 
69
#ifdef DO_FUNLINK_DEBUG
 
70
        fprintf ( stderr, "call_or_link: fun %x EXIT POINT 1 closure and turbo branch\n", fun );
 
71
#endif 
 
72
    return;
 
73
    }
 
74
    if ( Rset == 0 ) {
 
75
        funcall(fun);
 
76
    } else {
 
77
        if ( type_of(fun) == t_cfun ) {
 
78
            (void) vpush_extend ( link,sLAlink_arrayA->s.s_dbind );
 
79
            (void) vpush_extend ( *link,sLAlink_arrayA->s.s_dbind );     
 
80
            *link = (void *) (fun->cf.cf_self);
 
81
#ifdef DO_FUNLINK_DEBUG
 
82
            fprintf ( stderr, "call_or_link: fun %x, fun->cf %x (cf_name %x, cf_data %x, cf_self %x), ",
 
83
                      fun, fun->cf, fun->cf.cf_name, fun->cf.cf_data, fun->cf.cf_self );
 
84
            fflush ( stderr );
 
85
            print_lisp_string ( "name: ", fun->cf.cf_name );
 
86
            fflush ( stderr );
 
87
#endif         
 
88
            ( *(void (*)()) (fun->cf.cf_self)) ();
 
89
        } else {
 
90
            funcall(fun);
 
91
        }
 
92
    }
 
93
#ifdef DO_FUNLINK_DEBUG
 
94
    fprintf ( stderr, "call_or_link: fun %x EXIT POINT 2\n", fun );
 
95
#endif 
 
96
}
 
97
 
 
98
void
 
99
call_or_link_closure ( object sym, void **link, void **ptr )
 
100
{
 
101
    object fun;
 
102
    fun = sym->s.s_gfdef;
 
103
#ifdef DO_FUNLINK_DEBUG
 
104
    fprintf ( stderr, "call_or_link_closure: START sym %x, link %x, *link %x, ptr %x, *ptr %x, sym->s.s_gfdef (fun) %x ",
 
105
              sym, link, *link, ptr, *ptr, fun );
 
106
    print_lisp_string ( "Function name: ", fun->cf.cf_name );
 
107
#endif 
 
108
    if (fun == OBJNULL) {
 
109
#ifdef DO_FUNLINK_DEBUG
 
110
        fprintf ( stderr, "call_or_link_closure: fun %x ERROR END\n", fun );
 
111
#endif 
 
112
        FEinvalid_function(sym);
 
113
        return;
 
114
    }
 
115
    if ( type_of ( fun ) == t_cclosure && ( fun->cc.cc_turbo ) ) {
 
116
        if ( Rset ) {
 
117
            (void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind );
 
118
            (void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind );
 
119
#ifdef DO_FUNLINK_DEBUG
 
120
            fprintf ( stderr, "call_or_link_closure: About to change %x to %x at ptr %x, %x to %x at %x, then MMccall fun (after t_cclosure vpush_extend)", *ptr, fun->cc.cc_turbo, ptr, *link, fun->cf.cf_self, link );
 
121
            print_lisp_string ( ": ", fun->cf.cf_name );
 
122
#endif 
 
123
            *ptr = (void *) ( fun->cc.cc_turbo );
 
124
            *link = (void *) ( fun->cf.cf_self );
 
125
            MMccall (fun, fun->cc.cc_turbo);
 
126
        } else {
 
127
            MMccall ( fun, fun->cc.cc_turbo );
 
128
        }
 
129
#ifdef DO_FUNLINK_DEBUG
 
130
        fprintf ( stderr, "call_or_link_closure: fun %x END 1\n", fun );
 
131
#endif 
 
132
        return;
 
133
    }
 
134
    if ( Rset == 0 ) {
 
135
        funcall ( fun );
 
136
    } else {
 
137
        /* can't do this if invoking foo(a) is illegal when foo is not defined
 
138
           to take any arguments.   In the majority of C's this is legal */
 
139
        
 
140
        if ( type_of ( fun ) == t_cfun ) {
 
141
            (void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind );
 
142
            (void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind );    
 
143
#ifdef DO_FUNLINK_DEBUG
 
144
            fprintf ( stderr, "call_or_link_closure: About to change *link %x to %x at link %x and execute it (after t_cfun vpush_extend), sym->s %x, sym->s.s_self %s (%d chars long)\n", *link, fun->cf.cf_self, link, sym->s, sym->s.s_self, sym->s.s_fillp );
 
145
#endif 
 
146
            *link = (void *) (fun->cf.cf_self);
 
147
            ( *(void (*)()) (fun->cf.cf_self) ) ();
 
148
        } else {
 
149
            funcall(fun);
 
150
        }
 
151
    }
 
152
#ifdef DO_FUNLINK_DEBUG
 
153
    fprintf ( stderr, "call_or_link_closure: fun %x END 2\n", fun );
 
154
#endif 
 
155
}
 
156
 
 
157
/* for pushing item into an array, where item is an address if array-type = t
 
158
or a fixnum if array-type = fixnum */
 
159
 
 
160
#define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val
 
161
static int     
 
162
vpush_extend(void *item, object ar)
 
163
{ register int ind;
 
164
#ifdef DO_FUNLINK_DEBUG
 
165
 fprintf ( stderr, "vpush_extend: item %x, ar %x\n", item, ar );
 
166
#endif 
 
167
 ind = ar->ust.ust_fillp;  
 
168
 AGAIN:
 
169
  if (ind < ar->ust.ust_dim)
 
170
   {SET_ITEM(ar,ind,item);
 
171
    ind += sizeof(void *); 
 
172
    return(ar->v.v_fillp = ind);}
 
173
       else
 
174
    { 
 
175
      int newdim= ROUND_UP_PTR((2 + (int) (1.3 * ind)));
 
176
      unsigned char *newself;
 
177
      newself = (void *)alloc_relblock(newdim);
 
178
      bcopy(ar->ust.ust_self,newself,ind);
 
179
      ar->ust.ust_dim=newdim;
 
180
      ar->ust.ust_self=newself;
 
181
      goto AGAIN;
 
182
    }
 
183
#ifdef DO_FUNLINK_DEBUG_1
 
184
 fprintf ( stderr, "vpush_extend: item %x, ar %x END\n", item, ar );
 
185
#endif 
 
186
}
 
187
 
 
188
 
 
189
/* if we unlink a bunch of functions, this will mean there are some
 
190
   holes in the link array, and we should probably go through it and
 
191
   push them back  */
 
192
static int number_unlinked=0;
 
193
 
 
194
static void
 
195
delete_link(void *address, object link_ar)
 
196
{object *ar,*ar_end,*p;
 
197
#ifdef DO_FUNLINK_DEBUG
 
198
 fprintf ( stderr, "delete_link: address %x, link_ar %x START\n", address, link_ar );
 
199
#endif 
 
200
 p=0;
 
201
 ar = link_ar->v.v_self;
 
202
 ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]);
 
203
 while (ar < ar_end)
 
204
   { if (*ar && *((void **)*ar)==address)
 
205
       { p = (object *) *ar;
 
206
         *ar=0;
 
207
         *p = *(ar+1);
 
208
         number_unlinked++;}
 
209
     ar=ar+2;}
 
210
 if (number_unlinked > 40)
 
211
   link_ar->v.v_fillp=
 
212
     clean_link_array(link_ar->v.v_self,ar_end);
 
213
#ifdef DO_FUNLINK_DEBUG
 
214
 fprintf ( stderr, "delete_link: address %x, link_ar %x END\n", address, link_ar );
 
215
#endif 
 
216
}
 
217
 
 
218
 
 
219
DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...),
 
220
      "Usage: (use-fast-links {nil,t} &optional fun) turns on or off \
 
221
the fast linking depending on FLAG, so that things will either go \
 
222
faster, or turns it off so that stack information is kept.  If SYMBOL \
 
223
is supplied and FLAG is nil, then this function is deleted from the fast links")
 
224
{int n = VFUN_NARGS;
 
225
 object sym;
 
226
 va_list ap;
 
227
 object *p,*ar,*ar_end;
 
228
 object link_ar;
 
229
 object fun=Cnil;
 
230
 
 
231
{ va_start(ap,flag);
 
232
 if (n>=2) sym=va_arg(ap,object);else goto LDEFAULT2;
 
233
 goto LEND_VARARG;
 
234
 LDEFAULT2: sym = Cnil ;
 
235
 LEND_VARARG: va_end(ap);}
 
236
 
 
237
  if (sLAlink_arrayA ==0)    RETURN1(Cnil);
 
238
  link_ar = sLAlink_arrayA->s.s_dbind;
 
239
  if (link_ar==Cnil && flag==Cnil) RETURN1(Cnil);
 
240
  check_type_array(&link_ar);
 
241
  if (type_of(link_ar) != t_string)
 
242
  { FEerror("*LINK-ARRAY* must be a string",0);}
 
243
  ar = link_ar->v.v_self;
 
244
  ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]);
 
245
 switch (n)
 
246
      {
 
247
  case 1:
 
248
   if (flag==Cnil)
 
249
    { Rset=0;
 
250
     while ( ar < ar_end)
 
251
      /* set the link variables back to initial state */
 
252
         { 
 
253
            p = (object *) *ar;
 
254
            if (p) *p = (ar++, *ar); else ar++;
 
255
           ar++;
 
256
         }
 
257
    link_ar->v.v_fillp = 0;
 
258
    }
 
259
  else
 
260
    { Rset=1;}
 
261
    break;
 
262
  case 2:
 
263
 
 
264
   if ((type_of(sym)==t_symbol))
 
265
     fun = sym->s.s_gfdef;
 
266
   else
 
267
     if (type_of(sym)==t_cclosure)
 
268
       fun = sym;
 
269
   else {FEerror("Second arg: ~a must be symbol or closure",0,sym);
 
270
       }
 
271
   if(Rset)
 
272
     {
 
273
      if(!fun) RETURN1(Cnil);
 
274
      switch(type_of(fun)){
 
275
      case t_cfun:
 
276
      case t_sfun:
 
277
      case t_vfun:      
 
278
      case t_gfun:
 
279
      case t_cclosure:
 
280
      case t_closure:
 
281
      case t_afun:
 
282
        delete_link(fun->cf.cf_self,link_ar);
 
283
        /* becoming obsolete 
 
284
         y=getf(sym->s.s_plist,sScdefn,Cnil);
 
285
         if (y!=Cnil)
 
286
           delete_link(fix(y),link_ar);
 
287
           */
 
288
 
 
289
      break;
 
290
       default: 
 
291
        /* no link for uncompiled functions*/
 
292
        break;  
 
293
    }
 
294
  }
 
295
    break;
 
296
  default:
 
297
    FEerror("Usage: (use-fast-links {nil,t} &optional fun)",0);
 
298
}
 
299
  RETURN1(Cnil);
 
300
}
 
301
object
 
302
fSuse_fast_links_2(object flag,object res) {
 
303
  VFUN_NARGS=2;
 
304
  return FFN(fSuse_fast_links)(flag,res);
 
305
}
 
306
 
 
307
object
 
308
clear_compiler_properties(object sym, object code)
 
309
{ object tem;
 
310
  extern object sSclear_compiler_properties;  
 
311
  VFUN_NARGS=2; FFN(fSuse_fast_links)(Cnil,sym);
 
312
  tem = getf(sym->s.s_plist,sStraced,Cnil);
 
313
  if (sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind != Cnil)
 
314
    (void)ifuncall2(sSclear_compiler_properties, sym,code);
 
315
  if (tem != Cnil) return tem;
 
316
  return sym;
 
317
  
 
318
}
 
319
 
 
320
 
 
321
static int
 
322
clean_link_array(object *ar, object *ar_end)
 
323
{int i=0;
 
324
 object *orig;
 
325
#ifdef DO_FUNLINK_DEBUG
 
326
 fprintf ( stderr, "clean_link_array: ar %x, ar_end %x START\n", ar, ar_end );
 
327
#endif 
 
328
 orig=ar;
 
329
 number_unlinked=0;
 
330
  while( ar<ar_end)
 
331
   {if(*ar)
 
332
      {orig[i++]= *ar++ ;
 
333
         orig[i++]= *ar++;
 
334
       }
 
335
   else ar=ar+2;       
 
336
    }
 
337
#ifdef DO_FUNLINK_DEBUG
 
338
 fprintf ( stderr, "clean_link_array: ar %x, ar_end %x END\n", ar, ar_end );
 
339
#endif 
 
340
 return(i*sizeof(object *));
 
341
 }
 
342
 
 
343
/* This is a temporary workaround.  m68k cannot find the result 
 
344
   of a function returning long when invoked via a function pointer
 
345
   declared as a function returning a pointer, in this case, an 
 
346
   object.  A proper fix will require rewriting sections of the lisp
 
347
   compiler to separate the calling procedures for functions returning
 
348
   an object from functions returning a long.  CM  20020801 */
 
349
/*  #if defined(__mc68020__) */
 
350
/*  #define LCAST(a) (object)(*(long(*)())a) */
 
351
/*  #else */
 
352
#define LCAST(a) (*a)
 
353
/*  #endif */
 
354
 
 
355
object
 
356
c_apply_n(object (*fn)(), int n, object *x)
 
357
{object res=Cnil;
 
358
#ifdef DO_FUNLINK_DEBUG_1
 
359
    fprintf ( stderr, "c_apply_n: n %d, x %x START\n", n, x );
 
360
#endif 
 
361
 switch(n){
 
362
    case 0:  res=LCAST(fn)();break;
 
363
    case 1:  res=LCAST(fn)(x[0]);break;
 
364
    case 2:  res=LCAST(fn)(x[0],x[1]);break;
 
365
    case 3:  res=LCAST(fn)(x[0],x[1],x[2]);break;
 
366
    case 4:  res=LCAST(fn)(x[0],x[1],x[2],x[3]);break;
 
367
    case 5:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4]);break;
 
368
    case 6:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5]);break;
 
369
    case 7:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6]);break;
 
370
    case 8:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]);break;
 
371
    case 9:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
372
         x[8]);break;
 
373
    case 10:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
374
         x[8],x[9]);break;
 
375
    case 11:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
376
         x[8],x[9],x[10]);break;
 
377
    case 12:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
378
         x[8],x[9],x[10],x[11]);break;
 
379
    case 13:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
380
         x[8],x[9],x[10],x[11],x[12]);break;
 
381
    case 14:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
382
         x[8],x[9],x[10],x[11],x[12],x[13]);break;
 
383
    case 15:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
384
         x[8],x[9],x[10],x[11],x[12],x[13],x[14]);break;
 
385
    case 16:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
386
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
387
         x[15]);break;
 
388
    case 17:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
389
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
390
         x[15],x[16]);break;
 
391
    case 18:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
392
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
393
         x[15],x[16],x[17]);break;
 
394
    case 19:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
395
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
396
         x[15],x[16],x[17],x[18]);break;
 
397
    case 20:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
398
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
399
         x[15],x[16],x[17],x[18],x[19]);break;
 
400
    case 21:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
401
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
402
         x[15],x[16],x[17],x[18],x[19],x[20]);break;
 
403
    case 22:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
404
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
405
         x[15],x[16],x[17],x[18],x[19],x[20],x[21]);break;
 
406
    case 23:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
407
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
408
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
409
         x[22]);break;
 
410
    case 24:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
411
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
412
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
413
         x[22],x[23]);break;
 
414
    case 25:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
415
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
416
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
417
         x[22],x[23],x[24]);break;
 
418
    case 26:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
419
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
420
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
421
         x[22],x[23],x[24],x[25]);break;
 
422
    case 27:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
423
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
424
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
425
         x[22],x[23],x[24],x[25],x[26]);break;
 
426
    case 28:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
427
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
428
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
429
         x[22],x[23],x[24],x[25],x[26],x[27]);break;
 
430
    case 29:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
431
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
432
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
433
         x[22],x[23],x[24],x[25],x[26],x[27],x[28]);break;
 
434
    case 30:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
435
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
436
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
437
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
438
         x[29]);break;
 
439
    case 31:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
440
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
441
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
442
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
443
         x[29],x[30]);break;
 
444
    case 32:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
445
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
446
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
447
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
448
         x[29],x[30],x[31]);break;
 
449
    case 33:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
450
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
451
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
452
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
453
         x[29],x[30],x[31],x[32]);break;
 
454
    case 34:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
455
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
456
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
457
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
458
         x[29],x[30],x[31],x[32],x[33]);break;
 
459
    case 35:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
460
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
461
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
462
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
463
         x[29],x[30],x[31],x[32],x[33],x[34]);break;
 
464
    case 36:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
465
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
466
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
467
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
468
         x[29],x[30],x[31],x[32],x[33],x[34],x[35]);break;
 
469
    case 37:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
470
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
471
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
472
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
473
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
474
         x[36]);break;
 
475
    case 38:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
476
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
477
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
478
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
479
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
480
         x[36],x[37]);break;
 
481
    case 39:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
482
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
483
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
484
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
485
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
486
         x[36],x[37],x[38]);break;
 
487
    case 40:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
488
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
489
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
490
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
491
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
492
         x[36],x[37],x[38],x[39]);break;
 
493
    case 41:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
494
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
495
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
496
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
497
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
498
         x[36],x[37],x[38],x[39],x[40]);break;
 
499
    case 42:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
500
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
501
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
502
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
503
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
504
         x[36],x[37],x[38],x[39],x[40],x[41]);break;
 
505
    case 43:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
506
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
507
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
508
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
509
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
510
         x[36],x[37],x[38],x[39],x[40],x[41],x[42]);break;
 
511
    case 44:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
512
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
513
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
514
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
515
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
516
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
517
         x[43]);break;
 
518
    case 45:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
519
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
520
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
521
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
522
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
523
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
524
         x[43],x[44]);break;
 
525
    case 46:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
526
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
527
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
528
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
529
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
530
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
531
         x[43],x[44],x[45]);break;
 
532
    case 47:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
533
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
534
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
535
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
536
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
537
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
538
         x[43],x[44],x[45],x[46]);break;
 
539
    case 48:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
540
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
541
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
542
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
543
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
544
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
545
         x[43],x[44],x[45],x[46],x[47]);break;
 
546
    case 49:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
547
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
548
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
549
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
550
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
551
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
552
         x[43],x[44],x[45],x[46],x[47],x[48]);break;
 
553
    case 50:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
554
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
555
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
556
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
557
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
558
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
559
         x[43],x[44],x[45],x[46],x[47],x[48],x[49]);break;
 
560
    case 51:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
561
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
562
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
563
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
564
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
565
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
566
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
567
         x[50]);break;
 
568
    case 52:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
569
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
570
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
571
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
572
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
573
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
574
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
575
         x[50],x[51]);break;
 
576
    case 53:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
577
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
578
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
579
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
580
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
581
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
582
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
583
         x[50],x[51],x[52]);break;
 
584
    case 54:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
585
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
586
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
587
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
588
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
589
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
590
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
591
         x[50],x[51],x[52],x[53]);break;
 
592
    case 55:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
593
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
594
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
595
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
596
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
597
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
598
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
599
         x[50],x[51],x[52],x[53],x[54]);break;
 
600
    case 56:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
601
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
602
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
603
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
604
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
605
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
606
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
607
         x[50],x[51],x[52],x[53],x[54],x[55]);break;
 
608
    case 57:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
609
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
610
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
611
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
612
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
613
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
614
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
615
         x[50],x[51],x[52],x[53],x[54],x[55],x[56]);break;
 
616
    case 58:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
617
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
618
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
619
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
620
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
621
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
622
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
623
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
624
         x[57]);break;
 
625
    case 59:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
626
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
627
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
628
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
629
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
630
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
631
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
632
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
633
         x[57],x[58]);break;
 
634
    case 60:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
635
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
636
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
637
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
638
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
639
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
640
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
641
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
642
         x[57],x[58],x[59]);break;
 
643
    case 61:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
644
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
645
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
646
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
647
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
648
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
649
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
650
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
651
         x[57],x[58],x[59],x[60]);break;
 
652
    case 62:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
653
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
654
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
655
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
656
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
657
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
658
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
659
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
660
         x[57],x[58],x[59],x[60],x[61]);break;
 
661
    case 63:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
662
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
663
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
664
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
665
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
666
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
667
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
668
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
669
         x[57],x[58],x[59],x[60],x[61],x[62]);break;
 
670
    case 64:  res=LCAST(fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
 
671
         x[8],x[9],x[10],x[11],x[12],x[13],x[14],
 
672
         x[15],x[16],x[17],x[18],x[19],x[20],x[21],
 
673
         x[22],x[23],x[24],x[25],x[26],x[27],x[28],
 
674
         x[29],x[30],x[31],x[32],x[33],x[34],x[35],
 
675
         x[36],x[37],x[38],x[39],x[40],x[41],x[42],
 
676
         x[43],x[44],x[45],x[46],x[47],x[48],x[49],
 
677
         x[50],x[51],x[52],x[53],x[54],x[55],x[56],
 
678
         x[57],x[58],x[59],x[60],x[61],x[62],x[63]);break;
 
679
  default: FEerror("Exceeded call-arguments-limit ",0);
 
680
  } 
 
681
 
 
682
#ifdef DO_FUNLINK_DEBUG_1
 
683
    fprintf ( stderr, "c_apply_n: res %x END\n", n, res );
 
684
#endif 
 
685
 return res;
 
686
}
 
687
  
 
688
/* Used for calling cfunctions which take object args, and return object 
 
689
value.  This function is called by the static lnk function in the reference
 
690
file */
 
691
 
 
692
static object
 
693
call_proc(object sym, void **link, int argd, va_list ll)
 
694
{object fun;
 
695
 int nargs;
 
696
#ifdef DO_FUNLINK_DEBUG_1
 
697
    fprintf ( stderr, "call_proc: sym %x START\n", sym );
 
698
#endif 
 
699
 check_type_symbol(&sym);
 
700
 fun=sym->s.s_gfdef;
 
701
 if (fun && (type_of(fun)==t_sfun
 
702
             || type_of(fun)==t_gfun
 
703
             || type_of(fun)== t_vfun)
 
704
             && Rset) /* the && Rset is to allow tracing */
 
705
   {object (*fn)();
 
706
    fn = fun->sfn.sfn_self;
 
707
    if (type_of(fun)==t_vfun)
 
708
      { /* argd=VFUN_NARGS; */ /*remove this! */
 
709
        nargs=SFUN_NARGS(argd);
 
710
        if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs
 
711
            || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK)))
 
712
         goto WRONG_ARGS;
 
713
        if ((VFUN_NARG_BIT & argd) == 0)
 
714
         /* don't link */
 
715
         { 
 
716
           VFUN_NARGS = nargs;
 
717
           goto   AFTER_LINK;
 
718
         }
 
719
      }
 
720
    else /* t_gfun,t_sfun */
 
721
      { nargs= SFUN_NARGS(argd);
 
722
        if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) 
 
723
        WRONG_ARGS:    
 
724
          FEerror("Arg or result mismatch in call to  ~s",1,sym);
 
725
      }
 
726
   
 
727
    (void) vpush_extend(link,sLAlink_arrayA->s.s_dbind);
 
728
    (void) vpush_extend(*link,sLAlink_arrayA->s.s_dbind);        
 
729
    *link = (void *)fn;
 
730
  AFTER_LINK:   
 
731
 
 
732
    if (nargs < 10) 
 
733
    /* code below presumes sizeof(int) == sizeof(object)
 
734
       Should probably not bother special casing the < 10 args
 
735
     */
 
736
      {object x0,x1,x2,x3,x4,x5,x6,x7,x8,x9;    
 
737
       if (nargs-- > 0)
 
738
         x0=va_arg(ll,object);
 
739
       else
 
740
         {return(LCAST(fn)());}
 
741
       if (nargs-- > 0)
 
742
         x1=va_arg(ll,object);
 
743
       else
 
744
         { return(LCAST(fn)(x0));}
 
745
       if (nargs-- > 0)
 
746
         x2=va_arg(ll,object);
 
747
       else
 
748
         {return(LCAST(fn)(x0,x1));}
 
749
       if (nargs-- > 0)  x3=va_arg(ll,object);
 
750
       else
 
751
         return(LCAST(fn)(x0,x1,x2));
 
752
       if (nargs-- > 0)  x4=va_arg(ll,object);
 
753
       else
 
754
         return(LCAST(fn)(x0,x1,x2,x3));
 
755
       if (nargs-- > 0)  x5=va_arg(ll,object);
 
756
       else
 
757
         return(LCAST(fn)(x0,x1,x2,x3,x4));
 
758
       if (nargs-- > 0)  x6=va_arg(ll,object);
 
759
       else
 
760
         return(LCAST(fn)(x0,x1,x2,x3,x4,x5));
 
761
       if (nargs-- > 0)  x7=va_arg(ll,object);
 
762
       else
 
763
         return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6));
 
764
       if (nargs-- > 0)  x8=va_arg(ll,object);
 
765
       else
 
766
         return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6,x7));
 
767
       if (nargs-- > 0)  x9=va_arg(ll,object);
 
768
       else
 
769
         return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6,x7,x8));
 
770
       return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6,x7,x8,x9));
 
771
 
 
772
     }
 
773
  else {object *new;
 
774
        COERCE_VA_LIST(new,ll,nargs);
 
775
        return(c_apply_n(fn,nargs,new));}
 
776
  }
 
777
 else                           /* there is no cdefn property */
 
778
/* regular_call: */
 
779
   { 
 
780
     object fun;
 
781
     register object *base;
 
782
     enum ftype result_type;
 
783
     /* we check they are valid functions before calling this */
 
784
     if(type_of(sym)==t_symbol) fun = symbol_function(sym);
 
785
     else fun = sym;
 
786
     vs_base= (base =   vs_top);
 
787
     if (fun == OBJNULL) FEinvalid_function(sym);
 
788
     /* push the args */
 
789
/*     if (type_of(fun)==t_vfun) argd=fcall.argd; */ /*remove this! */
 
790
     nargs=SFUN_NARGS(argd);
 
791
     result_type=SFUN_RETURN_TYPE(argd);
 
792
     SFUN_START_ARG_TYPES(argd);
 
793
     {int i=0;
 
794
      if (argd==0)
 
795
        {while(i < nargs)
 
796
            {vs_push(va_arg(ll,object));
 
797
             i++;}}
 
798
      else
 
799
        {while(i < nargs)
 
800
            {enum ftype typ=SFUN_NEXT_TYPE(argd);
 
801
              vs_push((typ==f_object? va_arg(ll,object):
 
802
                       make_fixnum(va_arg(ll,fixnum))));
 
803
             i++;}}
 
804
    }
 
805
 
 
806
     vs_check;
 
807
     
 
808
     funcall(fun);
 
809
      vs_top=base;
 
810
        /* vs_base=oldbase;
 
811
      The caller won't expect us to restore these.  */
 
812
     return((result_type==f_object? vs_base[0] : (object)fix(vs_base[0])));
 
813
   }
 
814
}
 
815
 
 
816
 
 
817
/* static object call_vproc(object sym, void *link, va_list ll) */
 
818
/* {return call_proc(sym,link,VFUN_NARGS | VFUN_NARG_BIT,ll);} */
 
819
 
 
820
/* For ANSI C stdarg */
 
821
 
 
822
object
 
823
call_proc_new(object sym, void **link, int argd, object first, va_list ll)
 
824
{object fun;
 
825
 int nargs;
 
826
#ifdef DO_FUNLINK_DEBUG_1
 
827
    fprintf ( stderr, "call_proc_new: sym %x START\n", sym );
 
828
#endif 
 
829
 check_type_symbol(&sym);
 
830
 fun=sym->s.s_gfdef;
 
831
 if (fun && (type_of(fun)==t_sfun
 
832
             || type_of(fun)==t_gfun
 
833
             || type_of(fun)== t_vfun)
 
834
     && Rset) /* the && Rset is to allow tracing */
 
835
   {object (*fn)();
 
836
   fn = fun->sfn.sfn_self;
 
837
   if (type_of(fun)==t_vfun)
 
838
     { /* argd=VFUN_NARGS; */ /*remove this! */
 
839
       nargs=SFUN_NARGS(argd);
 
840
       if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs
 
841
           || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK)))
 
842
         goto WRONG_ARGS;
 
843
       if ((VFUN_NARG_BIT & argd) == 0)
 
844
         /* don't link */
 
845
         { 
 
846
           VFUN_NARGS = nargs;
 
847
           goto   AFTER_LINK;
 
848
         }
 
849
     }
 
850
   else /* t_gfun,t_sfun */
 
851
     { nargs= SFUN_NARGS(argd);
 
852
     if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) 
 
853
       WRONG_ARGS:    
 
854
     FEerror("Arg or result mismatch in call to  ~s",1,sym);
 
855
     }
 
856
   
 
857
   (void) vpush_extend(link,sLAlink_arrayA->s.s_dbind);
 
858
   (void) vpush_extend(*link,sLAlink_arrayA->s.s_dbind);         
 
859
   *link = (void *)fn;
 
860
   AFTER_LINK:  
 
861
   
 
862
   if (nargs < 10) 
 
863
     /* code below presumes sizeof(int) == sizeof(object)
 
864
        Should probably not bother special casing the < 10 args
 
865
     */
 
866
     {object x0,x1,x2,x3,x4,x5,x6,x7,x8,x9;    
 
867
     if (nargs-- > 0)
 
868
       /*        x0=va_arg(ll,object); */
 
869
       x0=first;
 
870
     else
 
871
       {return(LCAST(fn)());}
 
872
     if (nargs-- > 0)
 
873
       x1=va_arg(ll,object);
 
874
     else
 
875
       { return(LCAST(fn)(x0));}
 
876
     if (nargs-- > 0)
 
877
       x2=va_arg(ll,object);
 
878
     else
 
879
       {return(LCAST(fn)(x0,x1));}
 
880
     if (nargs-- > 0)  x3=va_arg(ll,object);
 
881
     else
 
882
       return(LCAST(fn)(x0,x1,x2));
 
883
     if (nargs-- > 0)  x4=va_arg(ll,object);
 
884
     else
 
885
       return(LCAST(fn)(x0,x1,x2,x3));
 
886
     if (nargs-- > 0)  x5=va_arg(ll,object);
 
887
     else
 
888
       return(LCAST(fn)(x0,x1,x2,x3,x4));
 
889
     if (nargs-- > 0)  x6=va_arg(ll,object);
 
890
     else
 
891
       return(LCAST(fn)(x0,x1,x2,x3,x4,x5));
 
892
     if (nargs-- > 0)  x7=va_arg(ll,object);
 
893
     else
 
894
       return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6));
 
895
     if (nargs-- > 0)  x8=va_arg(ll,object);
 
896
     else
 
897
       return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6,x7));
 
898
     if (nargs-- > 0)  x9=va_arg(ll,object);
 
899
     else
 
900
       return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6,x7,x8));
 
901
     return(LCAST(fn)(x0,x1,x2,x3,x4,x5,x6,x7,x8,x9));
 
902
     
 
903
     }
 
904
   else {
 
905
     object *new;
 
906
     COERCE_VA_LIST_NEW(new,first,ll,nargs);
 
907
     return(c_apply_n(fn,nargs,new));}
 
908
   }
 
909
 else                           /* there is no cdefn property */
 
910
   /* regular_call: */
 
911
   { 
 
912
     object fun;
 
913
     register object *base;
 
914
     enum ftype result_type;
 
915
     /* we check they are valid functions before calling this */
 
916
     if(type_of(sym)==t_symbol) fun = symbol_function(sym);
 
917
     else fun = sym;
 
918
     vs_base= (base =   vs_top);
 
919
     if (fun == OBJNULL) FEinvalid_function(sym);
 
920
     /* push the args */
 
921
/*     if (type_of(fun)==t_vfun) argd=fcall.argd; */ /*remove this! */
 
922
     nargs=SFUN_NARGS(argd);
 
923
     result_type=SFUN_RETURN_TYPE(argd);
 
924
     SFUN_START_ARG_TYPES(argd);
 
925
     {int i=0;
 
926
      if (argd==0)
 
927
        {while(i < nargs)
 
928
            {vs_push(i ? va_arg(ll,object) : first);
 
929
             i++;}}
 
930
      else
 
931
        {
 
932
          while(i < nargs) {
 
933
            enum ftype typ=SFUN_NEXT_TYPE(argd);
 
934
            object _xx;
 
935
            if (typ==f_object)
 
936
              _xx=i ? va_arg(ll,object) : first;
 
937
            else {
 
938
              long _yy;
 
939
              _yy=i ? va_arg(ll,fixnum) : (fixnum)first;
 
940
              _xx=make_fixnum(_yy);
 
941
            }
 
942
            vs_push(_xx);
 
943
            i++;
 
944
          }
 
945
        }
 
946
    }
 
947
 
 
948
     vs_check;
 
949
     
 
950
     funcall(fun);
 
951
     vs_top=base;
 
952
     /* vs_base=oldbase;
 
953
        The caller won't expect us to restore these.  */
 
954
     return((result_type==f_object? vs_base[0] : (object)fix(vs_base[0])));
 
955
   }
 
956
}
 
957
 
 
958
 
 
959
object call_vproc_new(object sym, void *link, object first,va_list ll)
 
960
{return call_proc_new(sym,link,VFUN_NARGS | VFUN_NARG_BIT,first,ll);}
 
961
 
 
962
static object
 
963
mcall_proc0(object sym,void *link,int argd,...) 
 
964
{
 
965
  object res;
 
966
  va_list ap;
 
967
 
 
968
  va_start(ap,argd);
 
969
  res=call_proc(sym,link,argd,ap);
 
970
  va_end(ap);
 
971
 
 
972
  return res;
 
973
 
 
974
}
 
975
 
 
976
object
 
977
call_proc0(object sym, void *link)
 
978
{return mcall_proc0(sym,link,0);}
 
979
 
 
980
#if 0
 
981
object
 
982
call_proc1(object sym,void *link,...)
 
983
{  va_list ll;
 
984
   va_start(ll,link);
 
985
return (call_proc(sym,link,1,ll));
 
986
    va_end(ll);
 
987
}
 
988
 
 
989
object
 
990
call_proc2(object sym,object link,...)
 
991
{ va_list ll;
 
992
   va_start(ll,link);
 
993
   return (call_proc(sym,link,2,ll));
 
994
    va_end(ll);
 
995
}
 
996
  
 
997
#endif
 
998
 
 
999
   
 
1000
 
 
1001
object
 
1002
ifuncall(object sym,int n,...)
 
1003
{ va_list ap;
 
1004
  int i;
 
1005
  object *old_vs_base;
 
1006
  object *old_vs_top;
 
1007
  object x;
 
1008
  old_vs_base = vs_base;
 
1009
  old_vs_top = vs_top;
 
1010
  vs_base = old_vs_top;
 
1011
  vs_top=old_vs_top+n;
 
1012
  vs_check;
 
1013
  va_start(ap,n);
 
1014
  for(i=0;i<n;i++)
 
1015
    old_vs_top[i]= va_arg(ap,object);
 
1016
  va_end(ap);
 
1017
  if (type_of(sym->s.s_gfdef)==t_cfun)
 
1018
    (*(sym->s.s_gfdef)->cf.cf_self)();
 
1019
  else  super_funcall(sym);
 
1020
  x = vs_base[0];
 
1021
  vs_top = old_vs_top;
 
1022
  vs_base = old_vs_base;
 
1023
  return(x);
 
1024
}
 
1025
 
 
1026
 
 
1027
/* static object */
 
1028
/* imfuncall(object sym,int n,...) */
 
1029
/* { va_list ap; */
 
1030
/*   int i; */
 
1031
/*   object *old_vs_top; */
 
1032
/*   old_vs_top = vs_top; */
 
1033
/*   vs_base = old_vs_top; */
 
1034
/*   vs_top=old_vs_top+n; */
 
1035
/*   vs_check; */
 
1036
/*   va_start(ap,n); */
 
1037
/*   for(i=0;i<n;i++) */
 
1038
/*     old_vs_top[i]= va_arg(ap,object); */
 
1039
/*   va_end(ap); */
 
1040
/*   if (type_of(sym->s.s_gfdef)==t_cfun) */
 
1041
/*     (*(sym->s.s_gfdef)->cf.cf_self)(); */
 
1042
/*   else  super_funcall(sym); */
 
1043
/*   return(vs_base[0]); */
 
1044
/* } */
 
1045
 
 
1046
/* go from beg+1 below limit setting entries equal to 0 until you
 
1047
   come to FRESH 0's . */
 
1048
 
 
1049
#define FRESH 40
 
1050
 
 
1051
int
 
1052
clear_stack(object *beg, object *limit)
 
1053
{int i=0;
 
1054
 while (++beg < limit)
 
1055
  {if (*beg==0) i++;
 
1056
   if (i > FRESH) return 0;
 
1057
   ;*beg=0;} return 0;}
 
1058
 
 
1059
static object
 
1060
FFN(set_mv)(int i, object val)
 
1061
{ if (i >= (sizeof(MVloc)/sizeof(object)))
 
1062
     FEerror("Bad mv index",0);
 
1063
  return(MVloc[i]=val);
 
1064
}
 
1065
 
 
1066
 
 
1067
static object
 
1068
FFN(mv_ref)(unsigned int i)
 
1069
{ object x;
 
1070
  if (i >= (sizeof(MVloc)/sizeof(object)))
 
1071
     FEerror("Bad mv index",0);
 
1072
  x = MVloc[i];
 
1073
  if (x == 0)
 
1074
      FEerror("Null value",0);
 
1075
  return x;
 
1076
}
 
1077
 
 
1078
 
 
1079
#include "xdrfuns.c"
 
1080
 
 
1081
DEF_ORDINARY("CDEFN",sScdefn,SI,"");
 
1082
DEFVAR("*LINK-ARRAY*",sLAlink_arrayA,LISP,Cnil,"");
 
1083
 
 
1084
void
 
1085
gcl_init_links(void)
 
1086
{       
 
1087
 
 
1088
        make_si_sfun("SET-MV",set_mv, ARGTYPE2(f_fixnum,f_object) |
 
1089
                     RESTYPE(f_object));
 
1090
        make_si_sfun("MV-REF",mv_ref, ARGTYPE1(f_fixnum) | RESTYPE(f_object));
 
1091
        gcl_init_xdrfuns();
 
1092
              }
 
1093