← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to o/makefun.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/makefun.c
 
1
#include "include.h"
 
2
#include "funlink.h"
 
3
 
 
4
#define PADDR(i) ((char *)(sSPinit->s.s_dbind->fixa.fixa_self[Mfix(i)]))
 
5
/* eg:
 
6
MakeAfun(addr,F_ARGD(min,max,flags,ARGTYPES(a,b,c,d)),0);
 
7
MakeAfun(addr,F_ARGD(2,3,NONE,ARGTYPES(OO,OO,OO,OO)),0);
 
8
*/
 
9
object MakeAfun(addr,argd,data)
 
10
object data, (*addr) ();
 
11
unsigned int argd;
 
12
{int type = (F_ARG_FLAGS_P(argd,F_requires_fun_passed) ? t_closure : t_afun);
 
13
  object x = alloc_object(type);
 
14
  x->sfn.sfn_name = Cnil;
 
15
  x->sfn.sfn_self = addr;
 
16
  x->sfn.sfn_argd = argd;
 
17
  if (type == t_closure)
 
18
    { x->cl.cl_env = 0;
 
19
      x->cl.cl_envdim=0;}
 
20
  x->sfn.sfn_data = data;
 
21
  return x;
 
22
}
 
23
 
 
24
 
 
25
object
 
26
fSmakefun(sym,addr,argd)
 
27
object sym, (*addr) ();
 
28
unsigned int argd;
 
29
{object ans = MakeAfun(addr,argd,
 
30
                      (sSPmemory && sSPmemory->s.s_dbind &&
 
31
                       type_of(sSPmemory->s.s_dbind)==t_cfdata) ?
 
32
                      sSPmemory->s.s_dbind : 0);
 
33
 ans->sfn.sfn_name = sym;
 
34
 return ans;
 
35
}
 
36
 
 
37
object
 
38
ImakeClosure(addr,argd,n,va_alist)
 
39
     object (*addr)();
 
40
     int n,argd;
 
41
     va_dcl
 
42
{ object x = fSmakefun(Cnil,addr,argd);
 
43
  va_list ap;
 
44
  va_start(ap);
 
45
  IsetClosure(x,n,ap);
 
46
  va_end(ap);
 
47
  return x;
 
48
}
 
49
     
 
50
IsetClosure(x,n,ap)
 
51
object x;
 
52
int n; va_list ap;
 
53
{  /* this will change so that we can allocate 'hunks' which will be little
 
54
   blocks the size of an array header say with only one header word.   This
 
55
   will be more economical. Because of gc, we can't allocate relblock, it
 
56
   might move while in the closure.  */
 
57
  object *p;
 
58
  if (type_of(x) != t_closure)
 
59
    { FEerror("Not a closure",0);}
 
60
  if (x->cl.cl_envdim < n)
 
61
    {BEGIN_NO_INTERRUPT; x->cl.cl_env = (object *)alloc_contblock(n);
 
62
     x->cl.cl_envdim = n;
 
63
     END_NO_INTERRUPT;
 
64
   }
 
65
  p = x->cl.cl_env;
 
66
  while (--n >= 0)
 
67
    { *p++ = va_arg(ap,object);
 
68
    }
 
69
}
 
70
 
 
71
DEFUN("INITFUN",object,fSinitfun,SI,3,ARG_LIMIT,NONE,OO,OO,OO,OO,
 
72
      "Store a compiled function on SYMBOL whose body is in the VV array at \
 
73
INDEX, and whose argd descriptor is ARGD.  If more arguments IND1, IND2,.. \
 
74
are supplied these are indices in the VV array for the environment of this \
 
75
closure.")
 
76
     (sym,addr_ind,argd,va_alist)
 
77
object sym,addr_ind,argd; va_dcl
 
78
{ int nargs = F_NARGS(VFUN_NARGS) -3;
 
79
  va_list ap;
 
80
  object fun = fSmakefun(IisSymbol(sym),PADDR(addr_ind),Mfix(argd));
 
81
  if (nargs > 0)
 
82
    { va_start(ap);
 
83
      IsetClosure(fun,nargs,ap);
 
84
      while (--nargs >= 0)
 
85
        /* the things put in by IsetClosure were only the indices
 
86
           of the closure variables not the actual variables */
 
87
        { fun->cl.cl_env[nargs]= (object) PADDR(fun->cl.cl_env[nargs]);}
 
88
      va_end(ap);
 
89
    }
 
90
  fSfset(sym,fun);
 
91
  return sym;
 
92
}
 
93
 
 
94
DEFUN("INITMACRO",object,fSinitmacro,SI,3,ARG_LIMIT,NONE,OO,OO,OO,OO,
 
95
      "Like INITFUN, but makes then sets the 'macro' flag on this symbol")
 
96
 (va_alist)
 
97
va_dcl     
 
98
{va_list ap;
 
99
 object res,name;
 
100
 va_start(ap);
 
101
 res = Iapply_ap(fSinitfun,ap);
 
102
 va_end(ap);
 
103
 res->s.s_mflag = 1;
 
104
 return res;
 
105
}
 
106
 
 
107
DEFUN("SET-KEY-STRUCT",object,fSset_key_struct,SI,1,1,NONE,OO,OO,OO,OO,
 
108
      "Called inside the loader.  The keystruct is set up in the file with \
 
109
   indexes rather than the actual entries.  We change these indices to \
 
110
   the objects")
 
111
     (key_struct_ind)
 
112
object key_struct_ind;
 
113
 
 
114
{ set_key_struct(PADDR(key_struct_ind),sSPmemory->s.s_dbind);
 
115
  return Cnil;
 
116
}
 
117
     
 
118
 
 
119
void
 
120
SI_makefun(strg,fn,argd)
 
121
     char *strg;
 
122
     unsigned int argd;
 
123
     object (*fn)();
 
124
{ object sym = make_si_ordinary(strg);
 
125
 fSfset(sym, fSmakefun(sym,fn,argd));
 
126
}
 
127
 
 
128
void
 
129
LISP_makefun(strg,fn,argd)
 
130
     char *strg;
 
131
     unsigned int argd;
 
132
     object (*fn)();
 
133
{ object sym = make_ordinary(strg);
 
134
 fSfset(sym, fSmakefun(sym,fn,argd));
 
135
}
 
136
 
 
137
 
 
138
object 
 
139
MakeClosure(n,argd,data,fn,va_alist)
 
140
int n;
 
141
object (*fn)();
 
142
object data;
 
143
va_dcl
 
144
{ object x;
 
145
  va_list ap;
 
146
  x = alloc_object(t_closure);
 
147
  x->cl.cl_name = Cnil;
 
148
  x->cl.cl_self = fn;
 
149
  x->cl.cl_data = data;
 
150
  x->cl.cl_argd = argd;
 
151
  x->cl.cl_env = 0;
 
152
  x->cl.cl_env = (object *)alloc_contblock(n*sizeof(object));
 
153
  x->cl.cl_envdim=n;
 
154
  va_start(ap);
 
155
  { object *p = x->cl.cl_env;
 
156
  while (--n>= 0)
 
157
    { *p++ = va_arg(ap,object);}
 
158
  va_end(ap);
 
159
  }
 
160
  return x;
 
161
}
 
162
      
 
163
DEFUN("INVOKE",object,fSinvoke,SI,1,ARG_LIMIT,NONE,OO,OO,OO,OO,
 
164
      "Invoke a C function whose body is at INDEX in the VV array")
 
165
 (x)
 
166
object x;
 
167
{ int (*fn)();
 
168
  fn = (void *) PADDR(x);
 
169
  (*fn)();
 
170
  return Cnil;
 
171
}
 
172