2
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4
This file is part of GNU Common Lisp, herein referred to as GCL
6
GCL is free software; you can redistribute it and/or modify it under
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
8
the Free Software Foundation; either version 2, or (at your option)
11
GCL is distributed in the hope that it will be useful, but WITHOUT
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
14
License for more details.
16
You should have received a copy of the GNU Library General Public License
17
along with GCL; see the file COPYING. If not, write to the Free Software
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
32
#define dcheck_type(a,b) check_type(a,b)
34
DEFUNO_NEW("SPECIALP",object,fSspecialp,SI
35
,1,1,NONE,OO,OO,OO,OO,void,siLspecialp,(object sym),"")
38
if (type_of(sym) == t_symbol &&
39
(enum stype)sym->s.s_stype == stp_special)
46
DEF_ORDINARY("DEBUG",sSdebug,SI,"");
48
DEFUN_NEW("DEFVAR1",object,fSdefvar1,SI
49
,2,3,NONE,OO,OO,OO,OO,(object sym,object val,...),"")
54
if (n>=3) doc=va_arg(ap,object);else goto LDEFAULT3;
56
LDEFAULT3: doc = Cnil;
57
LEND_VARARG: va_end(ap);}
60
if(sym->s.s_dbind==0 && n > 1)
62
sym->s.s_stype=(short)stp_special;
64
putprop(sym,doc,sSvariable_documentation);
69
DEFUN_NEW("DEBUG",object,fSdebug,SI
70
,2,2,NONE,OO,OO,OO,OO,(object sym,object val),"")
72
putprop(sym,val,sSdebug);
77
DEFUN_NEW("SETVV",object,fSsetvv,SI
78
,2,2,NONE,OO,OO,OO,OO,(object index,object val),"")
80
if(type_of(sSPmemory->s.s_dbind)==t_cfdata)
81
sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val;
82
else FEerror("setvv called outside %init",0);
86
DEF_ORDINARY("%MEMORY",sSPmemory,SI,"");
87
DEF_ORDINARY("%INIT",sSPinit,SI,"");
89
/* void Lidentity(void); */
95
/* real one defined in predlib.lsp, need this for bootstrap */
96
/* make_si_function("WARN-VERSION",Lidentity); */
101
/* Now inlined directly by optimizer */
103
/* ifloor(int x, int y) */
106
/* FEerror("Zero divizor", 0); */
113
/* FIXME, deal with possible overflow here*/
114
/* return(-((-x-1))/y-1); */
117
/* FIXME, deal with possible overflow here*/
118
/* return(-((x-1)/(-y))-1); */
120
/* return((-x)/(-y)); */
124
/* imod(int x, int y) */
126
/* return(x - ifloor(x, y)*y); */
130
/* set_VV(object *, int, object); */
133
/* set_VV_data(object *VV, int n, object data, char *start, int size) */
134
/* {set_VV(VV,n,data); */
135
/* data->cfd.cfd_start=start; */
136
/* data->cfd.cfd_size = size; */
140
/* set_VV(object *VV, int n, object data) */
145
/* q = data->v.v_self; */
146
/* while (n-- > 0) */
148
/* data->cfd.cfd_self = VV; */
156
object_to_char(object x)
159
switch (type_of(x)) {
163
{object *to = vs_top;
165
vs_push(small_fixnum(0xff));
173
c = char_code(x); break;
175
FEerror("~S cannot be coerce to a C char.", 1, x);
181
object_to_int(object x)
185
switch (type_of(x)) {
187
i = char_code(x); break;
191
i = number_to_double(x);
194
i = number_to_double(x); break;
200
FEerror("~S cannot be coerce to a C int.", 1, x);
206
object_to_float(object x)
210
switch (type_of(x)) {
212
f = char_code(x); break;
217
f = number_to_double(x); break;
223
FEerror("~S cannot be coerce to a C float.", 1, x);
229
object_to_double(object x)
233
switch (type_of(x)) {
235
d = char_code(x); break;
240
d = number_to_double(x); break;
246
FEerror("~S cannot be coerce to a C double.", 1, x);
251
/* this may allocate storage. The user can prevent this
252
by providing a string will fillpointer < length and
253
have a null character in the fillpointer position. */
256
object_to_string(object x)
258
if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);
259
leng= x->st.st_fillp;
260
/* user has thoughtfully provided a null terminated string ! */
261
if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
262
return x->st.st_self;
263
if (x->st.st_dim == leng
264
&& ( leng % sizeof(object))
266
{ x->st.st_self[leng] = 0;
267
return x->st.st_self;
270
{char *res=malloc(leng+1);
271
bcopy(x->st.st_self,res,leng);
277
/* typedef int (*FUNC)(); */
279
/* perform the actual invocation of the init function durint a fasload
280
init_address is the offset from the place in memory where the code is loaded
281
in. In most systems this will be 0.
282
The new style fasl vector MUST end with an entry (si::%init f1 f2 .....)
283
where f1 f2 are forms to be evaled.
286
/* #ifdef CLEAR_CACHE */
288
/* sigh(int sig,long code,void *scp, char *addr) { */
290
/* fprintf(stderr,"Received SIGILL at %p\n",((siginfo_t *)code)->si_addr); */
296
call_init(int init_address, object memory, object fasl_vec, FUNC fptr)
299
/* #ifdef CLEAR_CACHE */
301
/* static sigset_t ss; */
304
/* struct sigaction sa={{(void *)sigh},{{0}},SA_RESTART|SA_SIGINFO,NULL}; */
306
/* sigaction(SIGILL,&sa,NULL); */
307
/* sigemptyset(&ss); */
308
/* sigaddset(&ss,SIGILL); */
309
/* sigprocmask(SIG_BLOCK,&ss,NULL); */
315
check_type(fasl_vec,t_vector);
316
form=(fasl_vec->v.v_self[fasl_vec->v.v_fillp -1]);
320
at=(FUNC)(memory->cfd.cfd_start+ init_address );
326
if (type_of(form)==t_cons &&
327
form->c.c_car == sSPinit)
328
{bds_bind(sSPinit,fasl_vec);
329
bds_bind(sSPmemory,memory);
330
/* #ifdef CLEAR_CACHE */
331
/* sigprocmask(SIG_UNBLOCK,&ss,NULL); */
334
/* #ifdef CLEAR_CACHE */
335
/* sigprocmask(SIG_BLOCK,&ss,NULL); */
341
/* old style three arg init, with all init being done by C code. */
342
{memory->cfd.cfd_self = fasl_vec->v.v_self;
343
memory->cfd.cfd_fillp = fasl_vec->v.v_fillp;
344
/* #ifdef CLEAR_CACHE */
345
/* sigprocmask(SIG_UNBLOCK,&ss,NULL); */
347
(*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, memory);
348
/* #ifdef CLEAR_CACHE */
349
/* sigprocmask(SIG_BLOCK,&ss,NULL); */
353
/* statVV is the address of some static storage, which is used by the
354
cfunctions to refer to global variables,..
355
Initially it holds a number of addresses. We also have sSPmemory->s.s_dbind
356
which points to a vector of lisp constants. We switch the
357
fn addresses and lisp constants. We follow this convoluted path,
358
since we don't wish to have a separate block of data space allocated
359
in the object module simply to temporarily have access to the
360
actual function addresses during load.
365
do_init(object *statVV)
366
{object fasl_vec=sSPinit->s.s_dbind;
367
object data = sSPmemory->s.s_dbind;
369
int n=fasl_vec->v.v_fillp -1;
372
check_type(fasl_vec,t_vector);
373
form = fasl_vec->v.v_self[n];
374
dcheck_type(form,t_cons);
377
/* switch SPinit to point to a vector of function addresses */
379
fasl_vec->v.v_elttype = aet_fix;
380
fasl_vec->v.v_dim *= (sizeof(object)/sizeof(fixnum));
381
fasl_vec->v.v_fillp *= (sizeof(object)/sizeof(fixnum));
383
/* swap the entries */
384
p = fasl_vec->v.v_self;
387
for (i=0; i<=n ; i++)
393
data->cfd.cfd_self = statVV;
394
data->cfd.cfd_fillp= n+1;
398
/* So now the fasl_vec is a fixnum array, containing random addresses of c
399
functions and other stuff from the compiled code.
400
data is what it wants to be for the init
402
/* Now we can run the forms f1 f2 in form= (%init f1 f2 ...) */
407
for(i=0 ; i< form->v.v_fillp; i++)
409
eval(form->v.v_self[i]);
419
fix_path_string_dos(s)
426
if (IS_DIR_SEPARATOR(*p)) i=PATH_LIM;
427
else if (*p == '.') i = TYPE_LIM;
439
gcl_init_or_load1(void (*fn)(void),char *file)
444
file=FIX_PATH_STRING(file);
446
memory=alloc_object(t_cfdata);
447
memory->cfd.cfd_self=0;
448
memory->cfd.cfd_fillp=0;
449
memory->cfd.cfd_size = 0;
450
printf("Initializing %s\n",file); fflush(stdout);
451
fasl_data = read_fasl_data(file);
452
memory->cfd.cfd_start= (char *)fn;
453
call_init(0,memory,fasl_data,0);
456
{printf("loading %s\n",file); fflush(stdout); load(file);}
459
DEFUN_NEW("INIT-CMP-ANON", object, fSinit_cmp_anon, SI, 0, 0,
460
NONE, OO, OO, OO,OO,(void),
461
"Initialize previously compiled and linked anonymous function from the \
462
.text section of the running executable. This function is inherently \
463
dangerous, and is meant as a work-around to facilitate the production \
464
of an ansi GCL image on systems which must currently link using \
465
dlopen. On such systems, it is imposible to compile and load \
466
anonymous functions as part of the initialization sequence of the lisp \
467
image, as is done in pcl, and preserve that function across a \
468
save-system call. The approach here is to provide a flag to GCL's \
469
compile function which will direct the algorithm to forgo \
470
recompilation and loading in favor of initialization via this \
476
i=gcl_init_cmp_anon();
478
FEerror("No such anonymous function",0);
480
return i ? Cnil : Ct;
added
removed
o/cmpaux.c
