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) |
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) |
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 |
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); |
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);} |
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); |
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); |
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); |