home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / c / cfun.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  3.1 KB  |  182 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     cfun.c
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. object
  14. make_cfun(self, name, data, start, size)
  15. int (*self)();
  16. object name, data;
  17. char *start;
  18. int size;
  19. {
  20.     object cf;
  21.  
  22.     cf = alloc_object(t_cfun);
  23.     cf->cf.cf_self = self;
  24.     cf->cf.cf_name = name;
  25.     cf->cf.cf_data = data;
  26.     cf->cf.cf_start = start;
  27.     cf->cf.cf_size = size;
  28.     return(cf);
  29. }
  30.  
  31. object
  32. make_cclosure(self, name, env, data, start, size)
  33. int (*self)();
  34. object name, env, data;
  35. char *start;
  36. int size;
  37. {
  38.     object cc;
  39.  
  40.     cc = alloc_object(t_cclosure);
  41.     cc->cc.cc_self = self;
  42.     cc->cc.cc_name = name;
  43.     cc->cc.cc_env = env;
  44.     cc->cc.cc_data = data;
  45.     cc->cc.cc_start = start;
  46.     cc->cc.cc_size = size;
  47.     cc->cc.cc_turbo = NULL;
  48.     return(cc);
  49. }
  50.  
  51. object
  52. MF(sym, self, start, size, data)
  53. object sym;
  54. int (*self)();
  55. char *start;
  56. int size;
  57. object data;
  58. {
  59.     object cf;
  60.  
  61.     if (type_of(sym) != t_symbol)
  62.         not_a_symbol(sym);
  63.     if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
  64.         sym->s.s_sfdef = NOT_SPECIAL;
  65.     clear_compiler_properties(sym);
  66.     cf = alloc_object(t_cfun);
  67.     cf->cf.cf_self = self;
  68.     cf->cf.cf_name = sym;
  69.     cf->cf.cf_data = data;
  70.     cf->cf.cf_start = start;
  71.     cf->cf.cf_size = size;
  72.     sym->s.s_gfdef = cf;
  73.     sym->s.s_mflag = FALSE;
  74. }
  75.  
  76. object
  77. MM(sym, self, start, size, data)
  78. object sym;
  79. int (*self)();
  80. char *start;
  81. int size;
  82. object data;
  83. {
  84.     object cf;
  85.  
  86.     if (type_of(sym) != t_symbol)
  87.         not_a_symbol(sym);
  88.     if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
  89.         sym->s.s_sfdef = NOT_SPECIAL;
  90.     clear_compiler_properties(sym);
  91.     cf = alloc_object(t_cfun);
  92.     cf->cf.cf_self = self;
  93.     cf->cf.cf_name = sym;
  94.     cf->cf.cf_data = data;
  95.     cf->cf.cf_start = start;
  96.     cf->cf.cf_size = size;
  97.     sym->s.s_gfdef = cf;
  98.     sym->s.s_mflag = TRUE;
  99. }
  100.  
  101. object
  102. make_function(s, f)
  103. char *s;
  104. int (*f)();
  105. {
  106.     object x;
  107.     vs_mark;
  108.  
  109.     x = make_ordinary(s);
  110.     vs_push(x);
  111.     x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0);
  112.     x->s.s_mflag = FALSE;
  113.     vs_reset;
  114.     return(x);
  115. }
  116.  
  117. object
  118. make_si_function(s, f)
  119. char *s;
  120. int (*f)();
  121. {
  122.     object x;
  123.     vs_mark;
  124.  
  125.     x = make_si_ordinary(s);
  126.     vs_push(x);
  127.     x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0);
  128.     x->s.s_mflag = FALSE;
  129.     vs_reset;
  130.     return(x);
  131. }
  132.  
  133. object
  134. make_special_form(s, f)
  135. char *s;
  136. int (*f)();
  137. {
  138.     object x;
  139.     x = make_ordinary(s);
  140.     x->s.s_sfdef = f;
  141.     return(x);
  142. }
  143.  
  144. siLcompiled_function_name()
  145. {
  146.     check_arg(1);
  147.  
  148.     if (type_of(vs_base[0]) == t_cfun)
  149.         vs_base[0] = vs_base[0]->cf.cf_name;
  150.     else if (type_of(vs_base[0]) == t_cclosure)
  151.         vs_base[0] = vs_base[0]->cc.cc_name;
  152.     else
  153.         FEerror("~S is not a compiled-function.", 1, vs_base[0]);
  154. }
  155.  
  156. turbo_closure(fun)
  157. object fun;
  158. {
  159.     object l;
  160.     int n;
  161.  
  162.     for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
  163.         ;
  164.     fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object));
  165.     for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
  166.         fun->cc.cc_turbo[n] = l;
  167. }
  168.  
  169. siLturbo_closure()
  170. {
  171.     check_arg(1);
  172.     if (type_of(vs_base[0]) == t_cclosure)
  173.         turbo_closure(vs_base[0]);
  174. }
  175.  
  176. init_cfun()
  177. {
  178.     make_si_function("COMPILED-FUNCTION-NAME",
  179.              siLcompiled_function_name);
  180.     make_si_function("TURBO-CLOSURE", siLturbo_closure);
  181. }
  182.