home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / cmpaux.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  8.3 KB  |  417 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  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)
  9. any later version.
  10.  
  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.
  15.  
  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.
  19.  
  20. */
  21.  
  22. /*
  23.  
  24.     cmpaux.c
  25. */
  26.  
  27. #include "include.h"
  28. #include "mp.h"
  29. #define dcheck_type(a,b) check_type(a,b)
  30.  
  31. siLspecialp()
  32. {
  33.     object sym;
  34.  
  35.     check_arg(1);
  36.     sym = vs_base[0];
  37.     if (type_of(sym) == t_symbol &&
  38.         (enum stype)sym->s.s_stype == stp_special)
  39.         vs_base[0] = Ct;
  40.     else
  41.         vs_base[0] = Cnil;
  42. }
  43.  
  44.  
  45.  
  46. object siSPinit;
  47. object siSPmemory;
  48. object siSdebug;
  49. void
  50. siLdefvar1()
  51. {int n=vs_top-vs_base;
  52.  if(vs_base[0]->s.s_dbind==0 && n > 1)
  53.    vs_base[0]->s.s_dbind= vs_base[1];
  54.  vs_base[0]->s.s_stype=(short)stp_special;
  55.  if(n > 2)
  56.  putprop(vs_base[0],vs_base[2],siSvariable_documentation);
  57.  vs_top=vs_base+1;
  58. }
  59.  
  60. void
  61. siLdebug()
  62. {putprop(vs_base[0],vs_base[1],siSdebug);}
  63.  
  64. void
  65. siLsetvv()
  66. { if(type_of(siSPmemory->s.s_dbind)==t_cfdata)
  67.   siSPmemory->s.s_dbind->cfd.cfd_self[fix(vs_base[0])]=vs_base[1];
  68.   else FEerror("setvv called outside %init");
  69. }
  70.  
  71.  
  72. void Lidentity();
  73. init_cmpaux()
  74. {
  75.         siSPmemory=make_si_special("%MEMORY",Cnil);
  76.         siSPinit=make_si_special("%INIT",Cnil);
  77.     make_si_function("SPECIALP",siLspecialp);
  78.     make_si_function("DEFVAR1",siLdefvar1);
  79.     /* real one defined in predlib.lsp, need this for bootstrap */
  80.     make_si_function("WARN-VERSION",Lidentity);
  81.     siSdebug=make_si_function("DEBUG",siLdebug);
  82.     make_si_function("SETVV",siLsetvv);
  83.     
  84. }
  85.  
  86.   
  87. int
  88. ifloor(x, y)
  89. int x, y;
  90. {
  91.     if (y == 0)
  92.         FEerror("Zero divizor", 0);
  93.     else if (y > 0)
  94.         if (x >= 0)
  95.             return(x/y);
  96.         else
  97.             return(-((-x+y-1))/y);
  98.     else
  99.         if (x >= 0)
  100.             return(-((x-y-1)/(-y)));
  101.         else
  102.             return((-x)/(-y));
  103. }
  104.  
  105. int
  106. imod(x, y)
  107. int x, y;
  108. {
  109.     return(x - ifloor(x, y)*y);
  110. }
  111.  
  112. set_VV_data(VV,n,data,start,size)
  113. object VV[],data;
  114. int size,n;
  115. char *start;
  116. {set_VV(VV,n,data);
  117.  data->cfd.cfd_start=start;
  118.  data->cfd.cfd_size = size;
  119. }
  120.  
  121. set_VV(VV, n, data)
  122. object VV[];
  123. int n;
  124. object data;
  125. {
  126.     object *p, *q;
  127.  
  128.     p = VV;
  129.     q = data->v.v_self;
  130.     while (n-- > 0)
  131.         *p++ = *q++;
  132.     data->cfd.cfd_self = VV;
  133. }
  134.  
  135. /*
  136.     Conversions to C
  137. */
  138.  
  139. char
  140. object_to_char(x)
  141. object x;
  142. {
  143.     int c;
  144.  
  145.     switch (type_of(x)) {
  146.     case t_fixnum:
  147.         c = fix(x);  break;
  148.     case t_bignum:
  149.         c = (char)MP_LOW(MP(x),lgef(MP(x)));  break;
  150.     case t_character:
  151.         c = char_code(x);  break;
  152.     default:
  153.         FEerror("~S cannot be coerce to a C char.", 1, x);
  154.     }
  155.     return(c);
  156. }
  157.  
  158. int
  159. object_to_int(x)
  160. object x;
  161. {
  162.     int i;
  163.  
  164.     switch (type_of(x)) {
  165.     case t_character:
  166.         i = char_code(x);  break;
  167.     case t_fixnum:
  168.         i = fix(x);  break;
  169.     case t_bignum:
  170.         i = MP_LOW(MP(x),lgef(MP(x))) * big_sign(x);  break;
  171.     case t_ratio:
  172.         i = number_to_double(x);  break;
  173.     case t_shortfloat:
  174.         i = sf(x);  break;
  175.     case t_longfloat:
  176.         i = lf(x);  break;
  177.     default:
  178.         FEerror("~S cannot be coerce to a C int.", 1, x);
  179.     }
  180.     return(i);
  181. }
  182.  
  183. float
  184. object_to_float(x)
  185. object x;
  186. {
  187.     float f;
  188.  
  189.     switch (type_of(x)) {
  190.     case t_character:
  191.         f = char_code(x);  break;
  192.     case t_fixnum:
  193.         f = fix(x);  break;
  194.     case t_bignum:
  195.     case t_ratio:
  196.         f = number_to_double(x);  break;
  197.     case t_shortfloat:
  198.         f = sf(x);  break;
  199.     case t_longfloat:
  200.         f = lf(x);  break;
  201.     default:
  202.         FEerror("~S cannot be coerce to a C float.", 1, x);
  203.     }
  204.     return(f);
  205. }
  206.  
  207. double
  208. object_to_double(x)
  209. object x;
  210. {
  211.     double d;
  212.  
  213.     switch (type_of(x)) {
  214.     case t_character:
  215.         d = char_code(x);  break;
  216.     case t_fixnum:
  217.         d = fix(x);  break;
  218.     case t_bignum:
  219.     case t_ratio:
  220.         d = number_to_double(x);  break;
  221.     case t_shortfloat:
  222.         d = sf(x);  break;
  223.     case t_longfloat:
  224.         d = lf(x);  break;
  225.     default:
  226.         FEerror("~S cannot be coerce to a C double.", 1, x);
  227.     }
  228.     return(d);
  229. }
  230.  
  231. /* this may allocate storage.  The user can prevent this
  232.    by providing a string will fillpointer < length and
  233.    have a null character in the fillpointer position. */
  234.  
  235. char *malloc();
  236.  
  237. char *
  238. object_to_string(x)
  239.      object x;
  240. { unsigned int leng;
  241.   if (type_of(x)!=t_string) FEwrong_type_argument(Sstring,x);
  242.   leng= x->st.st_fillp;
  243.   /* user has thoughtfully provided a null terminated string ! */
  244.     if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
  245.     return x->st.st_self;
  246.   if (x->st.st_dim == leng
  247.       && ( leng % sizeof(object))
  248.      )
  249.     { x->st.st_self[leng] = 0;
  250.       return x->st.st_self;
  251.     }
  252.   else
  253.     {char *res=malloc(leng+1);
  254.      bcopy(x->st.st_self,res,leng);
  255.      res[leng]=0;
  256.      return res;
  257.    }}
  258.  
  259.  
  260. typedef int (*FUNC)();
  261.  
  262. /* perform the actual invocation of the init function durint a fasload
  263.    init_address is the offset from the place in memory where the code is loaded
  264.    in.  In most systems this will be 0.
  265.    The new style fasl vector MUST end with an entry (si::%init f1 f2 .....)
  266.    where f1 f2 are forms to be evaled.
  267. */
  268.  
  269. call_init(init_address,memory,fasl_vec)
  270.      int init_address;
  271.      object memory,fasl_vec;
  272.        
  273. {object form;
  274.  FUNC at;
  275.  
  276.   check_type(fasl_vec,t_vector);
  277.   form=(fasl_vec->v.v_self[fasl_vec->v.v_fillp -1]);
  278.  at=(FUNC)(memory->cfd.cfd_start+ init_address );
  279.  
  280. #ifdef VERIFY_INIT
  281.  VERIFY_INIT
  282. #endif
  283.    
  284.  if (type_of(form)==t_cons &&
  285.      form->c.c_car == siSPinit)
  286.    {bds_bind(siSPinit,fasl_vec);
  287.     bds_bind(siSPmemory,memory);
  288.     (*at)();
  289.     bds_unwind1;
  290.     bds_unwind1;
  291.   }
  292.  else
  293.    /* old style three arg init, with all init being done by C code. */
  294.    {memory->cfd.cfd_self = fasl_vec->v.v_self;
  295.     memory->cfd.cfd_fillp = fasl_vec->v.v_fillp;
  296.     (*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, memory);
  297. }}
  298.  
  299. /* statVV is the address of some static storage, which is used by the
  300.    cfunctions to refer to global variables,..
  301.    Initially it holds a number of addresses.   We also have siSPmemory->s.s_dbind
  302.    which points to a vector  of lisp constants.   We switch the
  303.    fn addresses and lisp constants.   We follow this convoluted path,
  304.    since we don't wish to have a separate block of data space allocated
  305.    in the object module simply to temporarily have access to the
  306.    actual function addresses during load. 
  307.  
  308.    */
  309.  
  310. do_init(statVV)
  311.      object *statVV;
  312.      
  313. {object fasl_vec=siSPinit->s.s_dbind;
  314.  object data = siSPmemory->s.s_dbind;
  315.  {object *p,*q,x,y;
  316.   int n=fasl_vec->v.v_fillp -1;
  317.   int i;
  318.   object form;
  319.   check_type(fasl_vec,t_vector);
  320.   form = fasl_vec->v.v_self[n];
  321.   dcheck_type(form,t_cons);  
  322.  
  323.  
  324.   /* switch SPinit to point to a vector of function addresses */
  325.      
  326.   fasl_vec->v.v_elttype = aet_fix;
  327.   
  328.   /* swap the entries */
  329.   p = fasl_vec->v.v_self;
  330.   q = statVV;
  331.   for (i=0; i<=n ; i++)
  332.     {  y = *p;
  333.      *p++ = *q;
  334.      *q++ = y;
  335.      }
  336.   
  337.   data->cfd.cfd_self = statVV;
  338.   data->cfd.cfd_fillp= n+1;
  339.   statVV[n] = data;
  340.   
  341.  
  342.   /* So now the fasl_vec is a fixnum array, containing random addresses of c
  343.      functions and other stuff from the compiled code.
  344.      data is what it wants to be for the init
  345.   */
  346.   /* Now we can run the forms f1 f2 in form= (%init f1 f2 ...) */
  347.  
  348.   form=form->c.c_cdr;
  349.   {object *top=vs_top;
  350.    
  351.    for(i=0 ; i< form->v.v_fillp; i++)
  352.      { 
  353.        eval(form->v.v_self[i]);
  354.        vs_top=top;
  355.      }
  356.  }
  357. }}
  358.  
  359. #ifdef DOS
  360. #define PATH_LIM 8
  361. #define TYPE_LIM 3
  362. char *
  363. fix_path_string_dos(s)
  364. char *s;
  365. {char buf[200];
  366.  char *p=s,*q=buf;
  367.  int i=PATH_LIM;    
  368.  while(*p)
  369.   {
  370.    if (IS_DIR_SEPARATOR(*p)) i=PATH_LIM;
  371.     else if (*p == '.') i = TYPE_LIM;
  372.     else i--;
  373.    if (i>=0) *q++ = *p;
  374.    p++;}
  375.  *q = 0;
  376.  strcpy(s,buf);
  377.  return s;
  378. }
  379.     
  380. #endif
  381.  
  382. void
  383. init_or_load1(fn,file)
  384.      int (*fn)();
  385.      char *file;
  386. {int n=strlen(file);
  387.  if (file[n-1]=='o')
  388.    { object memory;
  389.      object fasl_data;
  390.      file=FIX_PATH_STRING(file);
  391.  
  392.      memory=alloc_object(t_cfdata);
  393.      memory->cfd.cfd_self=0;
  394.      memory->cfd.cfd_fillp=0;
  395.      memory->cfd.cfd_size = 0;
  396.      printf("Initializing %s\n",file); fflush(stdout);
  397.      fasl_data = read_fasl_data(file);
  398.      memory->cfd.cfd_start= (char *)fn;
  399.      call_init(0,memory,fasl_data);
  400.   }
  401.  else
  402.   {printf("loading %s\n",file); fflush(stdout);  load(file);}
  403. }
  404.  
  405.   
  406.  
  407.   
  408.   
  409.      
  410.   
  411.   
  412.  
  413.  
  414.     
  415.     
  416.    
  417.