/[gcl]/gcl/o/nfunlink.c
ViewVC logotype

Diff of /gcl/o/nfunlink.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by camm, Fri Jul 12 22:00:49 2002 UTC revision 1.3 by camm, Sat Jul 20 07:10:55 2002 UTC
# Line 57  union {int i; Line 57  union {int i;
57       } bill;       } bill;
58    
59    
60  static object coerce_df(x)  /*  static object coerce_df(object x) */
61  object x;  /*  {if (type_of(x)==t_longfloat) return x; */
62  {if (type_of(x)==t_longfloat) return x;  /*   if (type_of(x)==t_shortfloat) return make_longfloat(Msf(x)); */
63   if (type_of(x)==t_shortfloat) return make_longfloat(Msf(x));  /*   FEerror("Not of float type ~a" ,1,x); */
64   FEerror("Not of float type ~a" ,1,x);  /*   return Cnil; */
65   return Cnil;  /*  } */
 }  
66    
67    
68    
69  object  object
70  Icall_proc(fun_name,link_desk,link_loc,ap)  Icall_proc(object fun_name, int link_desk, object (**link_loc) (/* ??? */), va_list ap)
      object fun_name;  
      int link_desk;  
      object (**link_loc)();  
      va_list ap;  
71  { object fun,res;  { object fun,res;
72    object (*fn)();    object (*fn)();
73    int nargs;    int nargs;
# Line 98  Icall_proc(fun_name,link_desk,link_loc,a Line 93  Icall_proc(fun_name,link_desk,link_loc,a
93        && F_MAX_ARGS(fargd) >= F_MIN_ARGS(link_desk)        && F_MAX_ARGS(fargd) >= F_MIN_ARGS(link_desk)
94        && F_TYPES(fargd) == F_TYPES(link_desk))        && F_TYPES(fargd) == F_TYPES(link_desk))
95      {                           /* do the link */      {                           /* do the link */
96        (void) vpush_extend((long) link_loc,sLAlink_arrayA->s.s_dbind);        (void) vpush_extend(link_loc,sLAlink_arrayA->s.s_dbind);
97        (void) vpush_extend((long) *link_loc,sLAlink_arrayA->s.s_dbind);        (void) vpush_extend(*link_loc,sLAlink_arrayA->s.s_dbind);
98        *link_loc = fn;}        *link_loc = fn;}
99    /* make this call */    /* make this call */
100    
   call_nopush:  
101    /* figure out the true number of args passed */    /* figure out the true number of args passed */
102    nargs = (F_ARG_FLAGS_P(link_desk,F_requires_nargs) ?    nargs = (F_ARG_FLAGS_P(link_desk,F_requires_nargs) ?
103             F_NARGS(VFUN_NARGS) : F_NARGS(link_desk));             F_NARGS(VFUN_NARGS) : F_NARGS(link_desk));
# Line 172  Icall_proc(fun_name,link_desk,link_loc,a Line 166  Icall_proc(fun_name,link_desk,link_loc,a
166   */   */
167    
168  float  float
169  Icall_proc_float(fun_name,link_desk,link_loc,ap)  Icall_proc_float(object fun_name, int link_desk, object (**link_loc) (/* ??? */), va_list ap)
      object fun_name;  
      int link_desk;  
      object (**link_loc)();  
      va_list ap;  
170  { object val;  { object val;
171    val = Icall_proc(fun_name,link_desk,link_loc,ap);    val = Icall_proc(fun_name,link_desk,link_loc,ap);
172    { union { void *p;    { union { void *p;
# Line 186  Icall_proc_float(fun_name,link_desk,link Line 176  Icall_proc_float(fun_name,link_desk,link
176  }  }
177    
178  object  object
179  IapplyVector(fun,nargs,base)  IapplyVector(object fun, int nargs, object *base)
180       object fun,*base;                        
181       int nargs;                
182  /* Call FUN a lisp objectect on NARGS which are loaded into an array  /* Call FUN a lisp objectect on NARGS which are loaded into an array
183     starting at BASE.  This pushes on the CallHist, and puts the args onto     starting at BASE.  This pushes on the CallHist, and puts the args onto
184     the arg stack, so that debuggers may examine them.  It sets     the arg stack, so that debuggers may examine them.  It sets
# Line 265  Iinvoke_c_function_from_value_stack(fLar Line 255  Iinvoke_c_function_from_value_stack(fLar
255  }  }
256        
257  */    */  
258  Iinvoke_c_function_from_value_stack(f,fargd)  void
259  object (*f)();  Iinvoke_c_function_from_value_stack(object (*f)(), int fargd)
260  int fargd;  {
 { int restype = F_RESULT_TYPE(fargd);  
261    int atypes = F_TYPES(fargd)>> F_TYPE_WIDTH;    int atypes = F_TYPES(fargd)>> F_TYPE_WIDTH;
262    object *base = vs_base;    object *base = vs_base;
263    int i;    int i;
# Line 317  int fargd; Line 306  int fargd;
306    
307  #define TYPE_STRING(i) (i == F_object ? "object" : i == F_int ?  "int" : i == F_double_ptr ? "double ptr" : "unknown")  #define TYPE_STRING(i) (i == F_object ? "object" : i == F_int ?  "int" : i == F_double_ptr ? "double ptr" : "unknown")
308    
309  print_fargd(fargd)  int
310       int fargd;  print_fargd(int fargd)
311  { int m,i,ftyp;  { int i;
312    int nargs = 7;    int nargs = 7;
313    unsigned int  ftypes = (F_TYPES(fargd) >> F_TYPE_WIDTH);    unsigned int  ftypes = (F_TYPES(fargd) >> F_TYPE_WIDTH);
314    int fret_type = F_TYPES(fargd) & MASK_RANGE(0,F_TYPE_WIDTH);  
315    printf("minargs=%d,maxargs=%d, arg_types=(",F_MIN_ARGS(fargd),    printf("minargs=%d,maxargs=%d, arg_types=(",F_MIN_ARGS(fargd),
316           F_MAX_ARGS(fargd));           F_MAX_ARGS(fargd));
317    for (i = 0; i < F_MAX_ARGS(fargd) ; i++, ftypes >>= F_TYPE_WIDTH)    for (i = 0; i < F_MAX_ARGS(fargd) ; i++, ftypes >>= F_TYPE_WIDTH)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26