home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / c / structure.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  5.5 KB  |  249 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.     structure.c
  9.  
  10.     structure interface
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. object siSstructure_print_function;
  16. object siSstructure_slot_descriptions;
  17. object siSstructure_include;
  18.  
  19. bool
  20. structure_subtypep(x, y)
  21. object x, y;
  22. {
  23.     do {
  24.         if (type_of(x) != t_symbol)
  25.             return(FALSE);
  26.         if (x == y)
  27.             return(TRUE);
  28.         x = get(x, siSstructure_include, Cnil);
  29.     } while (x != Cnil);
  30.     return(FALSE);
  31. }
  32.  
  33. object
  34. structure_ref(x, name, n)
  35. object x, name;
  36. int n;
  37. {
  38.     int i;
  39.  
  40.     if (type_of(x) != t_structure ||
  41.         !structure_subtypep(x->str.str_name, name))
  42.         FEwrong_type_argument(name, x);
  43.     return(x->str.str_self[n]);
  44. }
  45.  
  46. object
  47. structure_set(x, name, n, v)
  48. object x, name, v;
  49. int n;
  50. {
  51.     int i;
  52.  
  53.     if (type_of(x) != t_structure ||
  54.         !structure_subtypep(x->str.str_name, name))
  55.         FEwrong_type_argument(name, x);
  56.     x->str.str_self[n] = v;
  57.     return(v);
  58. }
  59.  
  60. object
  61. structure_to_list(x)
  62. object x;
  63. {
  64.     object *p, s;
  65.     int i, n;
  66.  
  67.     s = getf(x->str.str_name->s.s_plist,
  68.              siSstructure_slot_descriptions, Cnil);
  69.     vs_push(x->str.str_name);
  70.     vs_push(Cnil);
  71.     p = &vs_head;
  72.     for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
  73.         *p = make_cons(car(s->c.c_car), Cnil);
  74.         p = &((*p)->c.c_cdr);
  75.         *p = make_cons(x->str.str_self[i], Cnil);
  76.         p = &((*p)->c.c_cdr);
  77.     }
  78.     stack_cons();
  79.     return(vs_pop);
  80. }
  81.  
  82. siLmake_structure()
  83. {
  84.     object x;
  85.     int narg, i;
  86.  
  87.     if ((narg = vs_top - vs_base) == 0)
  88.         too_few_arguments();
  89.     x = alloc_object(t_structure);
  90.     x->str.str_name = vs_base[0];
  91.     x->str.str_self = NULL;
  92.     x->str.str_length = --narg;
  93.     vs_base[0] = x;
  94.     x->str.str_self = (object *)alloc_relblock(sizeof(object)*narg);
  95.     vs_top = vs_base+1;
  96.     for (i = 0;  i < narg;  i++)
  97.         x->str.str_self[i] = vs_top[i];
  98. }
  99.  
  100. siLcopy_structure()
  101. {
  102.     object x, y;
  103.     int i, j;
  104.  
  105.     check_arg(2);
  106.     x = vs_base[0];
  107.     if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
  108.         FEwrong_type_argument(vs_base[1], x);
  109.     vs_base[1] = y = alloc_object(t_structure);
  110.     y->str.str_name = x->str.str_name;
  111.     y->str.str_self = NULL;
  112.     y->str.str_length = j = x->str.str_length;
  113.     y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
  114.     for (i = 0;  i < j;  i++)
  115.         y->str.str_self[i] = x->str.str_self[i];
  116.     vs_base++;
  117. }
  118.  
  119. siLstructure_name()
  120. {
  121.     check_arg(1);
  122.     if (type_of(vs_base[0]) != t_structure)
  123.         FEwrong_type_argument(Sstructure, vs_base[0]);
  124.     vs_base[0] = vs_base[0]->str.str_name;
  125. }
  126.  
  127. siLstructure_ref()
  128. {
  129.     object x;
  130.     int i;
  131.     check_arg(3);
  132.  
  133.     x = vs_base[0];
  134.     if (type_of(x) != t_structure ||
  135.         !structure_subtypep(x->str.str_name, vs_base[1]))
  136.         FEwrong_type_argument(vs_base[1], x);
  137. /*
  138.     if (type_of(vs_base[2]) != t_fixnum ||
  139.         (i = fix(vs_base[2])) < 0 || i >= x->str.str_length)
  140.         FEerror("~S is an illegal structure index.", 1, vs_base[2]);
  141. */
  142.     i = fix(vs_base[2]);
  143.     vs_base[0] = x->str.str_self[i];
  144.     vs_top = vs_base+1;
  145. }
  146.  
  147. siLstructure_set()
  148. {
  149.     object x;
  150.     int i;
  151.     check_arg(4);
  152.  
  153.     x = vs_base[0];
  154.     if (type_of(x) != t_structure ||
  155.         !structure_subtypep(x->str.str_name, vs_base[1]))
  156.         FEwrong_type_argument(vs_base[1], x);
  157. /*
  158.     if (type_of(vs_base[2]) != t_fixnum ||
  159.         (i = fix(vs_base[2])) >= x->str.str_length)
  160.         FEerror("~S is an illegal structure index.", 1, vs_base[2]);
  161. */
  162.     i = fix(vs_base[2]);
  163.     x->str.str_self[i] = vs_base[3];
  164.     vs_base = vs_top-1;
  165. }
  166.  
  167. siLstructurep()
  168. {
  169.     check_arg(1);
  170.     if (type_of(vs_base[0]) == t_structure)
  171.         vs_base[0] = Ct;
  172.     else
  173.         vs_base[0] = Cnil;
  174. }
  175.  
  176. siLrplaca_nthcdr()
  177. {
  178. /*
  179.     Used in DEFSETF forms generated by DEFSTRUCT.
  180.     (si:rplaca-nthcdr x i v) is equivalent to 
  181.     (progn (rplaca (nthcdr i x) v) v).
  182. */
  183.     int i;
  184.     object l;
  185.  
  186.     check_arg(3);
  187.     if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0)
  188.         FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]);
  189.     if (type_of(vs_base[0]) != t_cons)
  190.         FEerror("~S is not a cons.", 1, vs_base[0]);
  191.  
  192.     for (i = fix(vs_base[1]), l = vs_base[0];  i > 0; --i) {
  193.         l = l->c.c_cdr;
  194.         if (endp(l))
  195.             FEerror("The offset ~S is too big.", 1, vs_base[1]);
  196.     }
  197.     take_care(vs_base[2]);
  198.     l->c.c_car = vs_base[2];
  199.     vs_base = vs_base + 2;
  200. }
  201.  
  202. siLlist_nth()
  203. {
  204. /*
  205.     Used in structure access functions generated by DEFSTRUCT.
  206.     si:list-nth is similar to nth except that
  207.     (si:list-nth i x) is error if the length of the list x is less than i.
  208. */
  209.     int i;
  210.     object l;
  211.  
  212.     check_arg(2);
  213.     if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0)
  214.         FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]);
  215.     if (type_of(vs_base[1]) != t_cons)
  216.         FEerror("~S is not a cons.", 1, vs_base[1]);
  217.  
  218.     for (i = fix(vs_base[0]), l = vs_base[1];  i > 0; --i) {
  219.         l = l->c.c_cdr;
  220.         if (endp(l))
  221.             FEerror("The offset ~S is too big.", 1, vs_base[0]);
  222.     }
  223.  
  224.     vs_base[0] = l->c.c_car;
  225.     vs_pop;
  226. }
  227.  
  228. init_structure_function()
  229. {
  230.     siSstructure_print_function
  231.     = make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
  232.     enter_mark_origin(&siSstructure_print_function);
  233.     siSstructure_slot_descriptions
  234.     = make_si_ordinary("STRUCTURE-SLOT-DESCRIPTIONS");
  235.     enter_mark_origin(&siSstructure_slot_descriptions);
  236.     siSstructure_include = make_si_ordinary("STRUCTURE-INCLUDE");
  237.     enter_mark_origin(&siSstructure_include);
  238.  
  239.     make_si_function("MAKE-STRUCTURE", siLmake_structure);
  240.     make_si_function("COPY-STRUCTURE", siLcopy_structure);
  241.     make_si_function("STRUCTURE-NAME", siLstructure_name);
  242.     make_si_function("STRUCTURE-REF", siLstructure_ref);
  243.     make_si_function("STRUCTURE-SET", siLstructure_set);
  244.     make_si_function("STRUCTUREP", siLstructurep);
  245.  
  246.     make_si_function("RPLACA-NTHCDR", siLrplaca_nthcdr);
  247.     make_si_function("LIST-NTH", siLlist_nth);
  248. }
  249.