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

Diff of /gcl/o/utils.c

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

revision 1.2 by camm, Thu Jun 13 00:00:46 2002 UTC revision 1.3 by camm, Sat Jul 20 07:10:56 2002 UTC
# Line 6  Line 6 
6     argument.   They may in future allow resetting the argument.     argument.   They may in future allow resetting the argument.
7  */  */
8    
9  object CEerror();  object CEerror(char *error_str, char *cont_str, int num, object arg1, object arg2, object arg3, object arg4);
10  object  object
11  IisSymbol(f)  IisSymbol(object f)
 object f;  
12  { if (type_of(f) != t_symbol)  { if (type_of(f) != t_symbol)
13     { FEerror("Not a symbol ~s",1,f); }     { FEerror("Not a symbol ~s",1,f); }
14    return f;    return f;
15  }  }
16    
17  object  object
18  IisFboundp(f)  IisFboundp(object f)
      object f;  
19  {  {
20    IisSymbol(f);    IisSymbol(f);
21    if (f->s.s_gfdef ==0)    if (f->s.s_gfdef ==0)
# Line 26  IisFboundp(f) Line 24  IisFboundp(f)
24  }  }
25    
26  object  object
27  IisArray(f)  IisArray(object f)
 object f;  
28  { if (TS_MEMBER(type_of(f),  { if (TS_MEMBER(type_of(f),
29                  TS(t_array)                  TS(t_array)
30                  |TS(t_vector)                  |TS(t_vector)
# Line 40  object f; Line 37  object f;
37  }  }
38    
39  object  object
40  Iis_fixnum(f)  Iis_fixnum(object f)
      object f;  
41  { if (type_of(f)==t_fixnum)  { if (type_of(f)==t_fixnum)
42      { return f;}      { return f;}
43    else    else
# Line 55  void Wrong_type_error(char *str,int n,.. Line 51  void Wrong_type_error(char *str,int n,..
51  }  }
52    
53  object  object
54  Iapply_ap(f,ap)  Iapply_ap(object (*f) (/* ??? */), va_list ap)
55  /* Apply f to the va_list ap, with an implicit number of args  /* Apply f to the va_list ap, with an implicit number of args
56     passed in VFUN_NARGS */     passed in VFUN_NARGS */
57  va_list ap;            
58  object (*f)();                
59  { int n = VFUN_NARGS;  { int n = VFUN_NARGS;
60    object *new;    object *new;
61    COERCE_VA_LIST(new,ap,n);    COERCE_VA_LIST(new,ap,n);
# Line 130  Iapply_fun_n1(object (*fun)(),int n,int Line 126  Iapply_fun_n1(object (*fun)(),int n,int
126    
127    va_end(ap);    va_end(ap);
128    
129   return IapplyVector(fun,i,b);   return IapplyVector(make_sfun(Cnil,fun,i,Cnil),i,b);
130  }  }
131    
132  /* For applying FUN to args in VA_LIST, where n are supplied directly  /* For applying FUN to args in VA_LIST, where n are supplied directly
133     and the last one is itself a va_list */     and the last one is itself a va_list */
134  object  /*  object */
135  Iapply_fun_n2(object fun,int n,int m,...) {  /*  Iapply_fun_n2(object fun,int n,int m,...) { */
136    
137    va_list ap,*app;  /*    va_list ap,*app; */
138    object b[F_ARG_LIMIT];  /*    object b[F_ARG_LIMIT]; */
139    int i = 0;  /*    int i = 0; */
140    
141    va_start(ap,m);  /*    va_start(ap,m); */
142    
143    while (--n >= 0) {  /*    while (--n >= 0) {  */
144      b[i++] = va_arg(ap,object);}  /*      b[i++] = va_arg(ap,object);} */
145    if (m > 0) {  /*    if (m > 0) { */
146      app = va_arg(ap,va_list *);  /*      app = va_arg(ap,va_list *); */
147      while (--m >= 0)  /*      while (--m >= 0) */
148        b[i++] = va_arg(*app,object);  /*        b[i++] = va_arg(*app,object); */
149    }  /*    } */
150    
151    va_end(ap);  /*    va_end(ap); */
152    
153   return IapplyVector(fun,i,b);  /*   return IapplyVector(fun,i,b); */
154  }  /*  } */
155    
156    
157  object  object
158  ImakeStructure(n,p)  ImakeStructure(int n, object *p)
159  /* p[0]= structure name , p[1] = 1'st elt,.... p[n-1] = last elt. */  /* p[0]= structure name , p[1] = 1'st elt,.... p[n-1] = last elt. */
160  int n;        
161  object *p;            
162  { object * r = vs_top;  { object * r = vs_top;
163    object res;    object res;
164    if (p+n != r) { FEerror("bad make struct",0);}    if (p+n != r) { FEerror("bad make struct",0);}
# Line 174  object *p; Line 170  object *p;
170  }  }
171    
172  object  object
173  Icheck_one_type(x,t)  Icheck_one_type(object x, enum type t)
 object x;  
 enum type t;  
174  { if (x->d.t != t)  { if (x->d.t != t)
175      { return CEerror("Expected a ~a ","Supply right type",1,type_name(t));      { return CEerror("Expected a ~a ","Supply right type",1,type_name(t),Cnil,Cnil,Cnil);
176      }      }
177    return x;    return x;
178  }  }
179    
180    
181  object  object
182  fSincorrect_type(val,type)  fSincorrect_type(object val, object type)
183       object val,type;  { return CEerror("Got ~a,Expected a ~a","Supply a new one",1,val,type,Cnil,Cnil);
 { return CEerror("Got ~a,Expected a ~a","Supply a new one",1,val,type);  
184  }  }
185    
186  void  void
187  Ineed_in_image(foo)  Ineed_in_image(object (*foo) (/* ??? */))
      object (*foo)();  
188  {;}  {;}
189    
190  /* Convert a value stack type return to an fcall multiple vaule return  /* Convert a value stack type return to an fcall multiple vaule return
191     and return the actual value (or nil if no values);  */     and return the actual value (or nil if no values);  */
192  object  object
193  Ivs_values()  Ivs_values(void)
194  { int n = fcall.nvalues = vs_top - vs_base;  { int n = fcall.nvalues = vs_top - vs_base;
195    object *b = vs_base,*p=&fcall.values[0];    object *b = vs_base,*p=&fcall.values[0];
196    object res = (n > 0 ? b[0] : sLnil);    object res = (n > 0 ? b[0] : sLnil);
# Line 209  Ivs_values() Line 201  Ivs_values()
201        
202                                                    
203  void  void
204  fatal(s,i1,i2)  fatal(char *s, int i1, int i2)
      char *s;  
      int i1;  
      int i2;  
205  {  {
206    fprintf(stderr,s,i1,i2);    fprintf(stderr,s,i1,i2);
207    exit(1);    exit(1);
# Line 223  fatal(s,i1,i2) Line 212  fatal(s,i1,i2)
212  /* Copy STRING to  BUF which has N bytes available.  /* Copy STRING to  BUF which has N bytes available.
213     If there is not enough space, malloc some */     If there is not enough space, malloc some */
214  char *  char *
215  lisp_copy_to_null_terminated(string,buf,n)  lisp_copy_to_null_terminated(object string, char *buf, int n)
      char *buf;  
      int n;  
      object string;  
216  { if(type_of(string) != t_string  { if(type_of(string) != t_string
217        && type_of(string) != t_symbol)        && type_of(string) != t_symbol)
218      FEerror("Need to give symbol or string",0);      FEerror("Need to give symbol or string",0);

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