10 |
#include "sfun_argd.h" |
#include "sfun_argd.h" |
11 |
#include "page.h" |
#include "page.h" |
12 |
|
|
13 |
|
#undef DO_FUNLINK_DEBUG |
14 |
|
|
15 |
static int |
static int |
16 |
clean_link_array(object *,object *); |
clean_link_array(object *,object *); |
17 |
|
|
27 |
/* cleanup link */ |
/* cleanup link */ |
28 |
void |
void |
29 |
call_or_link(object sym, void **link ) |
call_or_link(object sym, void **link ) |
30 |
{object fun; |
{ |
31 |
fun = sym->s.s_gfdef; |
object fun; |
32 |
#if 0 |
fun = sym->s.s_gfdef; |
33 |
fprintf ( stderr, "call_or_link: fun %x\n", fun ); |
#ifdef DO_FUNLINK_DEBUG |
34 |
|
fprintf ( stderr, "call_or_link: fun %x START\n", fun ); |
35 |
#endif |
#endif |
36 |
if (fun == OBJNULL) {FEinvalid_function(sym); return;} |
if (fun == OBJNULL) { |
37 |
if (type_of(fun) == t_cclosure |
FEinvalid_function(sym); |
38 |
&& (fun->cc.cc_turbo)) |
#ifdef DO_FUNLINK_DEBUG |
39 |
{if (Rset==0) {MMccall(fun, fun->cc.cc_turbo);} |
fprintf ( stderr, "call_or_link: fun %x ERROR END\n", fun ); |
40 |
else (*(fun)->cf.cf_self)(fun->cc.cc_turbo); |
#endif |
41 |
return;} |
return; |
42 |
if (Rset==0) funcall(fun); |
} |
43 |
else |
if ( type_of ( fun ) == t_cclosure && (fun->cc.cc_turbo) ) { |
44 |
if (type_of(fun) == t_cfun) |
if ( Rset ==0 ) { |
45 |
{ (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind); |
MMccall ( fun, fun->cc.cc_turbo ); |
46 |
(void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind); |
} else { |
47 |
*link = (void *) (fun->cf.cf_self); |
(*(fun)->cf.cf_self)(fun->cc.cc_turbo); |
48 |
|
} |
49 |
|
#ifdef DO_FUNLINK_DEBUG |
50 |
|
fprintf ( stderr, "call_or_link: fun %x END 1\n", fun ); |
51 |
|
#endif |
52 |
|
return; |
53 |
|
} |
54 |
|
if ( Rset == 0 ) { |
55 |
|
funcall(fun); |
56 |
|
} else { |
57 |
|
if ( type_of(fun) == t_cfun ) { |
58 |
|
(void) vpush_extend ( link,sLAlink_arrayA->s.s_dbind ); |
59 |
|
(void) vpush_extend ( *link,sLAlink_arrayA->s.s_dbind ); |
60 |
|
*link = (void *) (fun->cf.cf_self); |
61 |
#if 0 |
#if 0 |
62 |
fprintf ( stderr, "call_or_link: cf %x\n", fun->cf ); |
fprintf ( stderr, "call_or_link: cf %x\n", fun->cf ); |
63 |
fprintf ( stderr, "call_or_link: cf_name %x\n", fun->cf.cf_name ); |
fprintf ( stderr, "call_or_link: cf_name %x\n", fun->cf.cf_name ); |
64 |
fprintf ( stderr, "call_or_link: cf_data %x\n", fun->cf.cf_data ); |
fprintf ( stderr, "call_or_link: cf_data %x\n", fun->cf.cf_data ); |
65 |
fprintf ( stderr, "call_or_link: cf_self %x\n", fun->cf.cf_self ); |
fprintf ( stderr, "call_or_link: cf_self %x\n", fun->cf.cf_self ); |
66 |
fflush ( stderr ); |
fflush ( stderr ); |
67 |
fprintf ( stderr, "call_or_link: staddr %x\n", fun->cf.cf_name->st.st_self ); |
fprintf ( stderr, "call_or_link: staddr %x\n", fun->cf.cf_name->st.st_self ); |
68 |
fprintf ( stderr, "call_or_link: ststring %s\n", fun->cf.cf_name->st.st_self ); |
fprintf ( stderr, "call_or_link: ststring %s\n", fun->cf.cf_name->st.st_self ); |
69 |
fflush ( stderr ); |
fflush ( stderr ); |
70 |
#endif |
#endif |
71 |
(*(void (*)())(fun->cf.cf_self))(); |
( *(void (*)()) (fun->cf.cf_self)) (); |
72 |
} |
} else { |
73 |
else funcall(fun);} |
funcall(fun); |
74 |
|
} |
75 |
|
} |
76 |
|
#ifdef DO_FUNLINK_DEBUG |
77 |
|
fprintf ( stderr, "call_or_link: fun %x END 2\n", fun ); |
78 |
|
#endif |
79 |
|
} |
80 |
|
|
81 |
void |
void |
82 |
call_or_link_closure(object sym, void **link, void **ptr) |
call_or_link_closure ( object sym, void **link, void **ptr ) |
83 |
{object fun; |
{ |
84 |
fun = sym->s.s_gfdef; |
object fun; |
85 |
if (fun == OBJNULL) {FEinvalid_function(sym); return;} |
#ifdef DO_FUNLINK_DEBUG |
86 |
if (type_of(fun) == t_cclosure |
fprintf ( stderr, "call_or_link_closure: fun %x START\n", fun ); |
87 |
&& (fun->cc.cc_turbo)) |
#endif |
88 |
{if (Rset) { |
fun = sym->s.s_gfdef; |
89 |
(void) vpush_extend( link,sLAlink_arrayA->s.s_dbind); |
if (fun == OBJNULL) { |
90 |
(void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind); |
#ifdef DO_FUNLINK_DEBUG |
91 |
*ptr = (void *)(fun->cc.cc_turbo); |
fprintf ( stderr, "call_or_link: fun %x ERROR END\n", fun ); |
92 |
*link = (void *) (fun->cf.cf_self); |
#endif |
93 |
MMccall(fun, fun->cc.cc_turbo);} |
FEinvalid_function(sym); |
94 |
else |
return; |
95 |
{MMccall(fun, fun->cc.cc_turbo);} |
} |
96 |
return;} |
if ( type_of ( fun ) == t_cclosure && ( fun->cc.cc_turbo ) ) { |
97 |
if (Rset==0) funcall(fun); |
if ( Rset ) { |
98 |
else |
(void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind ); |
99 |
/* can't do this if invoking foo(a) is illegal when foo is not defined |
(void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind ); |
100 |
to take any arguments. In the majority of C's this is legal */ |
*ptr = (void *) ( fun->cc.cc_turbo ); |
101 |
|
*link = (void *) ( fun->cf.cf_self ); |
102 |
if (type_of(fun) == t_cfun) |
MMccall (fun, fun->cc.cc_turbo); |
103 |
{ (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind); |
} else { |
104 |
(void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind); |
MMccall ( fun, fun->cc.cc_turbo ); |
105 |
*link = (void *) (fun->cf.cf_self); |
} |
106 |
(*(void (*)())(fun->cf.cf_self))(); |
#ifdef DO_FUNLINK_DEBUG |
107 |
} |
fprintf ( stderr, "call_or_link: fun %x END 1\n", fun ); |
108 |
else funcall(fun);} |
#endif |
109 |
|
return; |
110 |
|
} |
111 |
|
if ( Rset == 0 ) { |
112 |
|
funcall ( fun ); |
113 |
|
} else { |
114 |
|
/* can't do this if invoking foo(a) is illegal when foo is not defined |
115 |
|
to take any arguments. In the majority of C's this is legal */ |
116 |
|
|
117 |
|
if ( type_of ( fun ) == t_cfun ) { |
118 |
|
(void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind ); |
119 |
|
(void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind ); |
120 |
|
*link = (void *) (fun->cf.cf_self); |
121 |
|
( *(void (*)()) (fun->cf.cf_self) ) (); |
122 |
|
} else { |
123 |
|
funcall(fun); |
124 |
|
} |
125 |
|
} |
126 |
|
#ifdef DO_FUNLINK_DEBUG |
127 |
|
fprintf ( stderr, "call_or_link: fun %x END 2\n", fun ); |
128 |
|
#endif |
129 |
|
} |
130 |
|
|
131 |
/* for pushing item into an array, where item is an address if array-type = t |
/* for pushing item into an array, where item is an address if array-type = t |
132 |
or a fixnum if array-type = fixnum */ |
or a fixnum if array-type = fixnum */ |
134 |
#define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val |
#define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val |
135 |
static int |
static int |
136 |
vpush_extend(void *item, object ar) |
vpush_extend(void *item, object ar) |
137 |
{ register int ind = ar->ust.ust_fillp; |
{ register int ind; |
138 |
|
#ifdef DO_FUNLINK_DEBUG |
139 |
|
fprintf ( stderr, "vpush_extend: item %x, ar %x\n", item, ar ); |
140 |
|
#endif |
141 |
|
ind = ar->ust.ust_fillp; |
142 |
AGAIN: |
AGAIN: |
143 |
if (ind < ar->ust.ust_dim) |
if (ind < ar->ust.ust_dim) |
144 |
{SET_ITEM(ar,ind,item); |
{SET_ITEM(ar,ind,item); |
153 |
ar->ust.ust_dim=newdim; |
ar->ust.ust_dim=newdim; |
154 |
ar->ust.ust_self=newself; |
ar->ust.ust_self=newself; |
155 |
goto AGAIN; |
goto AGAIN; |
156 |
}} |
} |
157 |
|
#ifdef DO_FUNLINK_DEBUG |
158 |
|
fprintf ( stderr, "vpush_extend: item %x, ar %x END\n", item, ar ); |
159 |
|
#endif |
160 |
|
} |
161 |
|
|
162 |
|
|
163 |
/* if we unlink a bunch of functions, this will mean there are some |
/* if we unlink a bunch of functions, this will mean there are some |
168 |
static void |
static void |
169 |
delete_link(void *address, object link_ar) |
delete_link(void *address, object link_ar) |
170 |
{object *ar,*ar_end,*p; |
{object *ar,*ar_end,*p; |
171 |
|
#ifdef DO_FUNLINK_DEBUG |
172 |
|
fprintf ( stderr, "delete_link: address %x, link_ar %x START\n", address, link_ar ); |
173 |
|
#endif |
174 |
p=0; |
p=0; |
175 |
ar = link_ar->v.v_self; |
ar = link_ar->v.v_self; |
176 |
ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); |
ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); |
183 |
ar=ar+2;} |
ar=ar+2;} |
184 |
if (number_unlinked > 40) |
if (number_unlinked > 40) |
185 |
link_ar->v.v_fillp= |
link_ar->v.v_fillp= |
186 |
clean_link_array(link_ar->v.v_self,ar_end); } |
clean_link_array(link_ar->v.v_self,ar_end); |
187 |
|
#ifdef DO_FUNLINK_DEBUG |
188 |
|
fprintf ( stderr, "delete_link: address %x, link_ar %x END\n", address, link_ar ); |
189 |
|
#endif |
190 |
|
} |
191 |
|
|
192 |
|
|
193 |
DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...), |
DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...), |
277 |
clean_link_array(object *ar, object *ar_end) |
clean_link_array(object *ar, object *ar_end) |
278 |
{int i=0; |
{int i=0; |
279 |
object *orig; |
object *orig; |
280 |
|
#ifdef DO_FUNLINK_DEBUG |
281 |
|
fprintf ( stderr, "clean_link_array: ar %x, ar_end %x START\n", ar, ar_end ); |
282 |
|
#endif |
283 |
orig=ar; |
orig=ar; |
284 |
number_unlinked=0; |
number_unlinked=0; |
285 |
while( ar<ar_end) |
while( ar<ar_end) |
289 |
} |
} |
290 |
else ar=ar+2; |
else ar=ar+2; |
291 |
} |
} |
292 |
|
#ifdef DO_FUNLINK_DEBUG |
293 |
|
fprintf ( stderr, "clean_link_array: ar %x, ar_end %x END\n", ar, ar_end ); |
294 |
|
#endif |
295 |
return(i*sizeof(object *)); |
return(i*sizeof(object *)); |
296 |
} |
} |
297 |
|
|
310 |
object |
object |
311 |
c_apply_n(object (*fn)(), int n, object *x) |
c_apply_n(object (*fn)(), int n, object *x) |
312 |
{object res=Cnil; |
{object res=Cnil; |
313 |
|
#ifdef DO_FUNLINK_DEBUG |
314 |
|
fprintf ( stderr, "c_apply_n: n %d, x %x START\n", n, x ); |
315 |
|
#endif |
316 |
switch(n){ |
switch(n){ |
317 |
case 0: res=LCAST(fn)();break; |
case 0: res=LCAST(fn)();break; |
318 |
case 1: res=LCAST(fn)(x[0]);break; |
case 1: res=LCAST(fn)(x[0]);break; |
634 |
default: FEerror("Exceeded call-arguments-limit ",0); |
default: FEerror("Exceeded call-arguments-limit ",0); |
635 |
} |
} |
636 |
|
|
637 |
|
#ifdef DO_FUNLINK_DEBUG |
638 |
|
fprintf ( stderr, "c_apply_n: res %x END\n", n, res ); |
639 |
|
#endif |
640 |
return res; |
return res; |
641 |
} |
} |
642 |
|
|
648 |
call_proc(object sym, void **link, int argd, va_list ll) |
call_proc(object sym, void **link, int argd, va_list ll) |
649 |
{object fun; |
{object fun; |
650 |
int nargs; |
int nargs; |
651 |
|
#ifdef DO_FUNLINK_DEBUG |
652 |
|
fprintf ( stderr, "call_proc: sym %x START\n", sym ); |
653 |
|
#endif |
654 |
check_type_symbol(&sym); |
check_type_symbol(&sym); |
655 |
fun=sym->s.s_gfdef; |
fun=sym->s.s_gfdef; |
656 |
if (fun && (type_of(fun)==t_sfun |
if (fun && (type_of(fun)==t_sfun |
778 |
call_proc_new(object sym, void **link, int argd, object first, va_list ll) |
call_proc_new(object sym, void **link, int argd, object first, va_list ll) |
779 |
{object fun; |
{object fun; |
780 |
int nargs; |
int nargs; |
781 |
|
#ifdef DO_FUNLINK_DEBUG |
782 |
|
fprintf ( stderr, "call_proc_new: sym %x START\n", sym ); |
783 |
|
#endif |
784 |
check_type_symbol(&sym); |
check_type_symbol(&sym); |
785 |
fun=sym->s.s_gfdef; |
fun=sym->s.s_gfdef; |
786 |
if (fun && (type_of(fun)==t_sfun |
if (fun && (type_of(fun)==t_sfun |