PageRenderTime 71ms CodeModel.GetById 37ms RepoModel.GetById 1ms app.codeStats 0ms

/gcl-2.6.8/o/cmpaux.c

#
C | 579 lines | 350 code | 92 blank | 137 comment | 47 complexity | 149379a93d74d00e102ce6b6a58d63d0 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-3.0, LGPL-3.0, AGPL-1.0
  1. /*
  2. Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3. This file is part of GNU Common Lisp, herein referred to as GCL
  4. GCL is free software; you can redistribute it and/or modify it under
  5. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  6. the Free Software Foundation; either version 2, or (at your option)
  7. any later version.
  8. GCL is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
  11. License for more details.
  12. You should have received a copy of the GNU Library General Public License
  13. along with GCL; see the file COPYING. If not, write to the Free Software
  14. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  15. */
  16. /*
  17. cmpaux.c
  18. */
  19. #include <sys/types.h>
  20. #include <sys/stat.h>
  21. #include <string.h>
  22. #include <signal.h>
  23. #include <stdlib.h>
  24. #define NEED_MP_H
  25. #include "include.h"
  26. #define dcheck_type(a,b) check_type(a,b)
  27. #include "page.h"
  28. DEFUNO_NEW("SPECIALP",object,fSspecialp,SI
  29. ,1,1,NONE,OO,OO,OO,OO,void,siLspecialp,(object sym),"")
  30. {
  31. /* 1 args */
  32. if (type_of(sym) == t_symbol &&
  33. (enum stype)sym->s.s_stype == stp_special)
  34. sym = Ct;
  35. else
  36. sym = Cnil;
  37. RETURN1(sym);
  38. }
  39. DEF_ORDINARY("DEBUG",sSdebug,SI,"");
  40. DEFUN_NEW("DEFVAR1",object,fSdefvar1,SI
  41. ,2,3,NONE,OO,OO,OO,OO,(object sym,object val,...),"")
  42. { int n=VFUN_NARGS;
  43. object doc;
  44. va_list ap;
  45. { va_start(ap,val);
  46. if (n>=3) doc=va_arg(ap,object);else goto LDEFAULT3;
  47. goto LEND_VARARG;
  48. LDEFAULT3: doc = Cnil;
  49. LEND_VARARG: va_end(ap);}
  50. CHECK_ARG_RANGE(2,3);
  51. if(sym->s.s_dbind==0 && n > 1)
  52. sym->s.s_dbind= val;
  53. sym->s.s_stype=(short)stp_special;
  54. if(n > 2)
  55. putprop(sym,doc,sSvariable_documentation);
  56. RETURN1(sym);
  57. }
  58. DEFUN_NEW("DEBUG",object,fSdebug,SI
  59. ,2,2,NONE,OO,OO,OO,OO,(object sym,object val),"")
  60. { /* 2 args */
  61. putprop(sym,val,sSdebug);
  62. RETURN1(sym);
  63. }
  64. DEFUN_NEW("SETVV",object,fSsetvv,SI
  65. ,2,2,NONE,OO,OO,OO,OO,(object index,object val),"")
  66. { /* 2 args */
  67. if(type_of(sSPmemory->s.s_dbind)==t_cfdata)
  68. sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val;
  69. else FEerror("setvv called outside %init",0);
  70. RETURN1(index);
  71. }
  72. DEF_ORDINARY("%MEMORY",sSPmemory,SI,"");
  73. DEF_ORDINARY("%INIT",sSPinit,SI,"");
  74. /* void Lidentity(void); */
  75. void
  76. gcl_init_cmpaux(void)
  77. {
  78. /* real one defined in predlib.lsp, need this for bootstrap */
  79. /* make_si_function("WARN-VERSION",Lidentity); */
  80. }
  81. /* Now inlined directly by optimizer */
  82. /* int */
  83. /* ifloor(int x, int y) */
  84. /* { */
  85. /* if (y == 0) { */
  86. /* FEerror("Zero divizor", 0); */
  87. /* return 0; */
  88. /* } */
  89. /* if (y > 0) { */
  90. /* if (x >= 0) */
  91. /* return(x/y); */
  92. /* else */
  93. /* FIXME, deal with possible overflow here*/
  94. /* return(-((-x-1))/y-1); */
  95. /* } */
  96. /* if (x >= 0) */
  97. /* FIXME, deal with possible overflow here*/
  98. /* return(-((x-1)/(-y))-1); */
  99. /* else */
  100. /* return((-x)/(-y)); */
  101. /* } */
  102. /* int */
  103. /* imod(int x, int y) */
  104. /* { */
  105. /* return(x - ifloor(x, y)*y); */
  106. /* } */
  107. /* static void */
  108. /* set_VV(object *, int, object); */
  109. /* static void */
  110. /* set_VV_data(object *VV, int n, object data, char *start, int size) */
  111. /* {set_VV(VV,n,data); */
  112. /* data->cfd.cfd_start=start; */
  113. /* data->cfd.cfd_size = size; */
  114. /* } */
  115. /* static void */
  116. /* set_VV(object *VV, int n, object data) */
  117. /* { */
  118. /* object *p, *q; */
  119. /* p = VV; */
  120. /* q = data->v.v_self; */
  121. /* while (n-- > 0) */
  122. /* *p++ = *q++; */
  123. /* data->cfd.cfd_self = VV; */
  124. /* } */
  125. /*
  126. Conversions to C
  127. */
  128. char
  129. object_to_char(object x)
  130. {
  131. int c=0;
  132. switch (type_of(x)) {
  133. case t_fixnum:
  134. c = fix(x); break;
  135. case t_bignum:
  136. {object *to = vs_top;
  137. vs_push(x);
  138. vs_push(small_fixnum(0xff));
  139. Llogand();
  140. x = vs_base[0];
  141. vs_top = to;
  142. c = (char) fix(x);
  143. break;
  144. }
  145. case t_character:
  146. c = char_code(x); break;
  147. default:
  148. FEerror("~S cannot be coerce to a C char.", 1, x);
  149. }
  150. return(c);
  151. }
  152. int
  153. object_to_int(object x)
  154. {
  155. int i=0;
  156. switch (type_of(x)) {
  157. case t_character:
  158. i = char_code(x); break;
  159. case t_fixnum:
  160. i = fix(x); break;
  161. case t_bignum:
  162. i = number_to_double(x);
  163. break;
  164. case t_ratio:
  165. i = number_to_double(x); break;
  166. case t_shortfloat:
  167. i = sf(x); break;
  168. case t_longfloat:
  169. i = lf(x); break;
  170. default:
  171. FEerror("~S cannot be coerce to a C int.", 1, x);
  172. }
  173. return(i);
  174. }
  175. fixnum
  176. object_to_fixnum(object x)
  177. {
  178. fixnum i=0;
  179. switch (type_of(x)) {
  180. case t_character:
  181. i = char_code(x); break;
  182. case t_fixnum:
  183. i = fix(x); break;
  184. case t_bignum:
  185. i = number_to_double(x);
  186. break;
  187. case t_ratio:
  188. i = number_to_double(x); break;
  189. case t_shortfloat:
  190. i = sf(x); break;
  191. case t_longfloat:
  192. i = lf(x); break;
  193. default:
  194. FEerror("~S cannot be coerce to a C int.", 1, x);
  195. }
  196. return(i);
  197. }
  198. float
  199. object_to_float(object x)
  200. {
  201. float f=0.0;
  202. switch (type_of(x)) {
  203. case t_character:
  204. f = char_code(x); break;
  205. case t_fixnum:
  206. f = fix(x); break;
  207. case t_bignum:
  208. case t_ratio:
  209. f = number_to_double(x); break;
  210. case t_shortfloat:
  211. f = sf(x); break;
  212. case t_longfloat:
  213. f = lf(x); break;
  214. default:
  215. FEerror("~S cannot be coerce to a C float.", 1, x);
  216. }
  217. return(f);
  218. }
  219. double
  220. object_to_double(object x)
  221. {
  222. double d=0.0;
  223. switch (type_of(x)) {
  224. case t_character:
  225. d = char_code(x); break;
  226. case t_fixnum:
  227. d = fix(x); break;
  228. case t_bignum:
  229. case t_ratio:
  230. d = number_to_double(x); break;
  231. case t_shortfloat:
  232. d = sf(x); break;
  233. case t_longfloat:
  234. d = lf(x); break;
  235. default:
  236. FEerror("~S cannot be coerce to a C double.", 1, x);
  237. }
  238. return(d);
  239. }
  240. /* this may allocate storage. The user can prevent this
  241. by providing a string will fillpointer < length and
  242. have a null character in the fillpointer position. */
  243. char *
  244. object_to_string(object x) {
  245. unsigned int leng;
  246. long np;
  247. char *res;
  248. if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);
  249. leng= x->st.st_fillp;
  250. /* user has thoughtfully provided a null terminated string ! */
  251. if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
  252. return x->st.st_self;
  253. np=page(x->st.st_self);
  254. if (x->st.st_dim == leng && leng % sizeof(object)
  255. && np<MAXPAGE && (type_map[np]==t_relocatable || type_map[np]==t_contiguous)) {
  256. x->st.st_self[leng] = 0;
  257. return x->st.st_self;
  258. }
  259. res=malloc(leng+1);
  260. bcopy(x->st.st_self,res,leng);
  261. res[leng]=0;
  262. return res;
  263. }
  264. /* typedef int (*FUNC)(); */
  265. /* perform the actual invocation of the init function durint a fasload
  266. init_address is the offset from the place in memory where the code is loaded
  267. in. In most systems this will be 0.
  268. The new style fasl vector MUST end with an entry (si::%init f1 f2 .....)
  269. where f1 f2 are forms to be evaled.
  270. */
  271. /* #ifdef CLEAR_CACHE */
  272. /* static int */
  273. /* sigh(int sig,long code,void *scp, char *addr) { */
  274. /* fprintf(stderr,"Received SIGILL at %p\n",((siginfo_t *)code)->si_addr); */
  275. /* exit(1); */
  276. /* } */
  277. /* #endif */
  278. void
  279. call_init(int init_address, object memory, object fasl_vec, FUNC fptr)
  280. {object form;
  281. FUNC at;
  282. /* #ifdef CLEAR_CACHE */
  283. /* static int n; */
  284. /* static sigset_t ss; */
  285. /* if (!n) { */
  286. /* struct sigaction sa={{(void *)sigh},{{0}},SA_RESTART|SA_SIGINFO,NULL}; */
  287. /* sigaction(SIGILL,&sa,NULL); */
  288. /* sigemptyset(&ss); */
  289. /* sigaddset(&ss,SIGILL); */
  290. /* sigprocmask(SIG_BLOCK,&ss,NULL); */
  291. /* n=1; */
  292. /* } */
  293. /* #endif */
  294. check_type(fasl_vec,t_vector);
  295. form=(fasl_vec->v.v_self[fasl_vec->v.v_fillp -1]);
  296. if (fptr) at = fptr;
  297. else
  298. at=(FUNC)(memory->cfd.cfd_start+ init_address );
  299. #ifdef VERIFY_INIT
  300. VERIFY_INIT
  301. #endif
  302. if (type_of(form)==t_cons &&
  303. form->c.c_car == sSPinit)
  304. {bds_bind(sSPinit,fasl_vec);
  305. bds_bind(sSPmemory,memory);
  306. /* #ifdef CLEAR_CACHE */
  307. /* sigprocmask(SIG_UNBLOCK,&ss,NULL); */
  308. /* #endif */
  309. (*at)();
  310. /* #ifdef CLEAR_CACHE */
  311. /* sigprocmask(SIG_BLOCK,&ss,NULL); */
  312. /* #endif */
  313. bds_unwind1;
  314. bds_unwind1;
  315. }
  316. else
  317. /* old style three arg init, with all init being done by C code. */
  318. {memory->cfd.cfd_self = fasl_vec->v.v_self;
  319. memory->cfd.cfd_fillp = fasl_vec->v.v_fillp;
  320. /* #ifdef CLEAR_CACHE */
  321. /* sigprocmask(SIG_UNBLOCK,&ss,NULL); */
  322. /* #endif */
  323. (*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, memory);
  324. /* #ifdef CLEAR_CACHE */
  325. /* sigprocmask(SIG_BLOCK,&ss,NULL); */
  326. /* #endif */
  327. }}
  328. /* statVV is the address of some static storage, which is used by the
  329. cfunctions to refer to global variables,..
  330. Initially it holds a number of addresses. We also have sSPmemory->s.s_dbind
  331. which points to a vector of lisp constants. We switch the
  332. fn addresses and lisp constants. We follow this convoluted path,
  333. since we don't wish to have a separate block of data space allocated
  334. in the object module simply to temporarily have access to the
  335. actual function addresses during load.
  336. */
  337. void
  338. do_init(object *statVV)
  339. {object fasl_vec=sSPinit->s.s_dbind;
  340. object data = sSPmemory->s.s_dbind;
  341. {object *p,*q,y;
  342. int n=fasl_vec->v.v_fillp -1;
  343. int i;
  344. object form;
  345. check_type(fasl_vec,t_vector);
  346. form = fasl_vec->v.v_self[n];
  347. dcheck_type(form,t_cons);
  348. /* switch SPinit to point to a vector of function addresses */
  349. fasl_vec->v.v_elttype = aet_fix;
  350. fasl_vec->v.v_dim *= (sizeof(object)/sizeof(fixnum));
  351. fasl_vec->v.v_fillp *= (sizeof(object)/sizeof(fixnum));
  352. /* swap the entries */
  353. p = fasl_vec->v.v_self;
  354. q = statVV;
  355. for (i=0; i<=n ; i++)
  356. { y = *p;
  357. *p++ = *q;
  358. *q++ = y;
  359. }
  360. data->cfd.cfd_self = statVV;
  361. data->cfd.cfd_fillp= n+1;
  362. statVV[n] = data;
  363. /* So now the fasl_vec is a fixnum array, containing random addresses of c
  364. functions and other stuff from the compiled code.
  365. data is what it wants to be for the init
  366. */
  367. /* Now we can run the forms f1 f2 in form= (%init f1 f2 ...) */
  368. form=form->c.c_cdr;
  369. {object *top=vs_top;
  370. for(i=0 ; i< form->v.v_fillp; i++)
  371. {
  372. eval(form->v.v_self[i]);
  373. vs_top=top;
  374. }
  375. }
  376. }}
  377. #ifdef DOS
  378. #define PATH_LIM 8
  379. #define TYPE_LIM 3
  380. char *
  381. fix_path_string_dos(s)
  382. char *s;
  383. {char buf[200];
  384. char *p=s,*q=buf;
  385. int i=PATH_LIM;
  386. while(*p)
  387. {
  388. if (IS_DIR_SEPARATOR(*p)) i=PATH_LIM;
  389. else if (*p == '.') i = TYPE_LIM;
  390. else i--;
  391. if (i>=0) *q++ = *p;
  392. p++;}
  393. *q = 0;
  394. strcpy(s,buf);
  395. return s;
  396. }
  397. #endif
  398. void
  399. gcl_init_or_load1(void (*fn)(void),const char *file) {
  400. if (file[strlen(file)-1]=='o') {
  401. object memory;
  402. object fasl_data;
  403. file=FIX_PATH_STRING(file);
  404. memory=alloc_object(t_cfdata);
  405. memory->cfd.cfd_self=0;
  406. memory->cfd.cfd_fillp=0;
  407. memory->cfd.cfd_size = 0;
  408. printf("Initializing %s\n",file); fflush(stdout);
  409. fasl_data = read_fasl_data(file);
  410. memory->cfd.cfd_start= (char *)fn;
  411. call_init(0,memory,fasl_data,0);
  412. } else {
  413. printf("loading %s\n",file);
  414. fflush(stdout);
  415. load(file);
  416. }
  417. }
  418. DEFUN_NEW("INIT-CMP-ANON", object, fSinit_cmp_anon, SI, 0, 0,
  419. NONE, OO, OO, OO,OO,(void),
  420. "Initialize previously compiled and linked anonymous function from the \
  421. .text section of the running executable. This function is inherently \
  422. dangerous, and is meant as a work-around to facilitate the production \
  423. of an ansi GCL image on systems which must currently link using \
  424. dlopen. On such systems, it is imposible to compile and load \
  425. anonymous functions as part of the initialization sequence of the lisp \
  426. image, as is done in pcl, and preserve that function across a \
  427. save-system call. The approach here is to provide a flag to GCL's \
  428. compile function which will direct the algorithm to forgo \
  429. recompilation and loading in favor of initialization via this \
  430. function.")
  431. {
  432. int i;
  433. i=gcl_init_cmp_anon();
  434. if (i<0)
  435. FEerror("No such anonymous function",0);
  436. return i ? Cnil : Ct;
  437. }
  438. object
  439. find_init_name1(char *s,unsigned len) {
  440. #ifdef _WIN32
  441. char *tmp;
  442. if (len) {
  443. tmp=alloca(len+1);
  444. memcpy(tmp,s,len);
  445. tmp[len]=0;
  446. } else
  447. tmp=s;
  448. return find_init_string(tmp);
  449. #else
  450. /* These functions have no relevance on Windows
  451. * as dlopen and friends don't exist in that part of Cyberspace. */
  452. struct stat ss;
  453. char *tmp,*q;
  454. FILE *f;
  455. if (len) {
  456. tmp=alloca(len+1);
  457. memcpy(tmp,s,len);
  458. tmp[len]=0;
  459. } else
  460. tmp=s;
  461. if (stat(tmp,&ss))
  462. FEerror("File ~a does not exist",1,make_simple_string(tmp));
  463. if (!(f=fopen(tmp,"rb")))
  464. FEerror("Cannot open ~a for binary reading",1,make_simple_string(tmp));
  465. tmp=alloca(ss.st_size+1);
  466. if (fread(tmp,1,ss.st_size,f)!=ss.st_size)
  467. FEerror("Error reading binary file",0);
  468. fclose(f);
  469. for (s=tmp;s<tmp+ss.st_size && strncmp(s,"init_",5);q=strstr(s+1,"init_"),s=q ? q : s+strlen(s)+1);
  470. if (strncmp(s,"init_",5))
  471. FEerror("Init name not found",0);
  472. return make_simple_string(s);
  473. #endif /* _WIN32 */
  474. }
  475. DEFUN_NEW("FIND-INIT-NAME", object, fSfind_init_name, SI, 1, 1,
  476. NONE, OO, OO, OO,OO,(object namestring),"")
  477. {
  478. check_type_string(&namestring);
  479. return find_init_name1(namestring->st.st_self,namestring->st.st_dim);
  480. }