home *** CD-ROM | disk | FTP | other *** search
/ Fish 'n' More 2 / fishmore-publicdomainlibraryvol.ii1991xetec.iso / fish / applications / xlispstat / src / src2.lzh / XLisp-Stat / objects.c < prev    next >
C/C++ Source or Header  |  1990-10-04  |  36KB  |  1,427 lines
  1. /* objects - Additional object functions                               */
  2. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  3. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  4. /* You may give out copies of this software; for conditions see the    */
  5. /* file COPYING included with this distribution.                       */
  6.  
  7. #include "xlisp.h"
  8. #include "osdef.h"
  9. #ifdef ANSI
  10. #include "xlproto.h"
  11. #include "xlsproto.h"
  12. #else
  13. #include "xlfun.h"
  14. #include "xlsfun.h"
  15. #endif ANSI
  16. #include "xlvar.h"
  17. #include "xlsvar.h"
  18.  
  19. #ifdef ANSI
  20. LVAL get_self(void),delete_duplicates(LVAL),append_list(LVAL,LVAL),
  21.      delete(LVAL,LVAL),check_object(LVAL),find_SC(LVAL),find_S(LVAL),
  22.      find_RC(LVAL),find_R(LVAL),find_no_predecessor_list(LVAL,LVAL),
  23.      next_object(LVAL,LVAL),trim_S(LVAL,LVAL),trim_R(LVAL,LVAL),
  24.      precedence_list(LVAL),calculate_preclist(LVAL),
  25.      make_object(LVAL,LVAL),find_own_slot(LVAL,LVAL),find_slot(LVAL,LVAL),
  26.      delete_slot(LVAL,LVAL),find_own_method(LVAL,LVAL),find_method(LVAL,LVAL),
  27.      delete_method(LVAL,LVAL),message_method(LVAL,LVAL),
  28.      set_message_method(LVAL,LVAL,LVAL),sendmsg(LVAL,LVAL),get_cars(LVAL),
  29.      find_documentation(LVAL,LVAL,int),get_documentation(LVAL,LVAL),
  30.      instance_slots(LVAL,LVAL),get_initial_slot_value(LVAL,LVAL),
  31.      callmethod(LVAL,LVAL,int,LVAL *);
  32. int equal(LVAL,LVAL),is_member(LVAL,LVAL),has_duplicates(LVAL),
  33.     has_predecessor(LVAL,LVAL),child_position(LVAL,LVAL);
  34. void check_parents(LVAL),add_slot(LVAL,LVAL,LVAL),add_method(LVAL,LVAL,LVAL),
  35.      add_documentation(LVAL,LVAL,LVAL),
  36.      make_prototype(LVAL,LVAL,LVAL,LVAL,LVAL,int);
  37. #else
  38. LVAL get_self(),delete_duplicates(),append_list(),
  39.      delete(),check_object(),find_SC(),find_S(),
  40.      find_RC(),find_R(),find_no_predecessor_list(),
  41.      next_object(),trim_S(),trim_R(),
  42.      precedence_list(),calculate_preclist(),
  43.      make_object(),find_own_slot(),find_slot(),
  44.      delete_slot(),find_own_method(),find_method(),
  45.      delete_method(),message_method(),
  46.      set_message_method(),sendmsg(),get_cars(),
  47.      find_documentation(,int),get_documentation(),
  48.      instance_slots(),get_initial_slot_value(),callmethod();
  49. int equal(),is_member(),has_duplicates(),
  50.     has_predecessor(),child_position();
  51. void check_parents(),add_slot(),add_method(),
  52.      add_documentation(),
  53.      make_prototype();
  54. #endif ANSI
  55.  
  56. /* macros to handle tracing */
  57. #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
  58. #define trexit(sym,val) {if (sym) doexit(sym,val);}
  59.  
  60. /***********************************************************************/
  61. /**                                                                   **/
  62. /**                          CLASS Definitions                        **/
  63. /**                                                                   **/
  64. /***********************************************************************/
  65.  
  66. /* instance variable numbers for the class 'CLASS' */
  67. # define CVARS          2 /* list of class variable names */
  68. # define CVALS          3 /* list of class variable values */
  69. # define SUPERCLASS   4
  70. # define IVARTOTAL      6
  71.  
  72. /* time stamp for determining validity of allocated objects */
  73. /* long time_stamp; moved to statinit.c  JKL */
  74.  
  75. /***********************************************************************/
  76. /**                                                                   **/
  77. /**                          Utility Functions                        **/
  78. /**                                                                   **/
  79. /***********************************************************************/
  80.  
  81. /* Built in KIND-OF-P function */
  82. LVAL xskind_of_p()
  83. {
  84.   LVAL x, y;
  85.   x = xlgetarg();
  86.   y = xlgetarg();
  87.   xllastarg();
  88.   
  89.   return((kind_of_p(x, y)) ? s_true : NIL);
  90. }
  91.  
  92. LVAL xsobject_null_method() { return(NIL); }
  93.  
  94. /***********************************************************************/
  95. /***********************************************************************/
  96. /***                                                                 ***/
  97. /***                         New Object System                       ***/
  98. /***                                                                 ***/
  99. /***********************************************************************/
  100. /***********************************************************************/
  101. #define OBJECT_SIZE 4
  102. #define getslots(x) getelement(x, 1)
  103. #define getmethods(x) getelement(x, 2)
  104. #define getparents(x) getelement(x, 3)
  105. #define getpreclist(x) getelement(x, 4)
  106. #define setslots(x, v) setelement(x, 1, v)
  107. #define setmethods(w, v) setelement(x, 2, v)
  108. #define setparents(x, v) setelement(x, 3, v)
  109. #define setpreclist(x, v) setelement(x, 4, v)
  110.  
  111. static LVAL object_class, root_object;
  112. int in_send = FALSE;
  113.  
  114. /***********************************************************************/
  115. /**                                                                   **/
  116. /**                          Utility Functions                        **/
  117. /**                                                                   **/
  118. /***********************************************************************/
  119.  
  120. /* get SELF for the current message; signal an error if not in a message */
  121. static LVAL get_self()
  122. {
  123.   LVAL p = xlxgetvalue(s_self);
  124.   
  125.   if (! mobject_p(p)) xlerror("bad object", p);
  126.   return(p);
  127. }
  128.  
  129. /* simple form of EQUAL test */
  130. static int equal(x, y)
  131.     LVAL x, y;
  132. {
  133.   if (x == y) return(TRUE);
  134.   else if (consp(x) && consp(y)
  135.            && equal(car(x), car(y)) && equal(cdr(x), cdr(y)))
  136.     return(TRUE);
  137.   else return(FALSE);
  138. }
  139.  
  140. /* check if x is a member of list; use simple equal test */
  141. static int is_member(x, list)
  142.     LVAL x, list;
  143. {
  144.   int result = FALSE;
  145.   
  146.   for (; ! result && consp(list); list = cdr(list))
  147.     if (equal(x, car(list))) result = TRUE;
  148.   return(result);
  149. }
  150.  
  151. /* check if list contains any duplicates */
  152. static int has_duplicates(list)
  153.     LVAL list;
  154. {
  155.   int result = FALSE;
  156.   
  157.   for (; ! result && consp(list); list = cdr(list))
  158.     if (is_member(car(list), cdr(list))) result = TRUE;
  159.   return(result);
  160. }
  161.  
  162. /* destructively delete duplicates from list x */
  163. static LVAL delete_duplicates(x)
  164.      LVAL x;
  165. {
  166.   LVAL last, result;
  167.  
  168.   if (x == NIL) return(NIL);
  169.   else if (consp(x)) {
  170.     for (; consp(x) && is_member(car(x), cdr(x)); x = cdr(x)) ;
  171.  
  172.     result = x;
  173.  
  174.     for (last = x, x = cdr(x); consp(x); x = cdr(x))
  175.       if (is_member(car(x), cdr(x))) rplacd(last, cdr(x));
  176.       else last = x;
  177.   }
  178.   else xlerror("not a list", x);
  179.   return(result);
  180. }
  181.  
  182. /* destructively append y to x */
  183. static LVAL append_list(x, y)
  184.     LVAL x, y;
  185. {
  186.   LVAL result;
  187.   
  188.   if (x == NIL) result = y;
  189.   else if (consp(x)) {
  190.     result = x;
  191.     for (; consp(cdr(x)); x = cdr(x)) ;
  192.     rplacd(x, y);
  193.   }
  194.   else xlerror("not a list", x);
  195.   return(result);
  196. }
  197.  
  198. /* destructively delete x from list */
  199. static LVAL delete(x, list)
  200.     LVAL x, list;
  201. {
  202.   return(xscallsubr2(xdelete, x, list));
  203. }
  204.  
  205. /***********************************************************************/
  206. /**                                                                   **/
  207. /**                Predicate and Stack Access Functions               **/
  208. /**                                                                   **/
  209. /***********************************************************************/
  210.  
  211. int mobject_p(x)
  212.     LVAL x;
  213. {
  214.   return(objectp(x) && getclass(x) == object_class && getsize(x) == 5);
  215. }
  216.  
  217. static LVAL check_object(object)
  218.     LVAL object;
  219. {
  220.   if (! mobject_p(object)) xlerror("bad object", object);
  221.   else return(object);
  222. }
  223.  
  224. int kind_of_p(x, y)
  225.     LVAL x, y;
  226. {
  227.   if (! mobject_p(x) || ! mobject_p(y)) return(FALSE);
  228.   return(is_member(y, getpreclist(x)));
  229. }
  230.  
  231. LVAL xsgetmobject() { return(check_object(xlgetarg())); }
  232.  
  233. /***********************************************************************/
  234. /**                                                                   **/
  235. /**                    Precedence List Functions                      **/
  236. /**                                                                   **/
  237. /***********************************************************************/
  238.  
  239. /* find set of object and ancestors */
  240. static LVAL find_SC(object)
  241.     LVAL object;
  242. {
  243.   return(copylist(getpreclist(check_object(object))));
  244. }
  245.  
  246. /* find set of object and ancestors */
  247. static LVAL find_S(object)
  248.     LVAL object;
  249. {
  250.   LVAL result, parents;
  251.   
  252.   xlstkcheck(2);
  253.   xlprotect(object);
  254.   xlsave(result);
  255.   parents = getparents(object); /* not needed: in macro JKL */
  256.   for (/*result = NIL*/; consp(parents); parents = cdr(parents))
  257.     result = append_list(find_SC(car(parents)), result);
  258.   result = cons(object, result);
  259.   result = delete_duplicates(result);
  260.   xlpopn(2);
  261.   return(result);
  262. }
  263.  
  264. /* find local precedence ordering */
  265. static LVAL find_RC(object)
  266.     LVAL object;
  267. {
  268.   LVAL list, next;
  269.   
  270.   xlstkcheck(2);
  271.   xlprotect(object);
  272.   xlsave(list);
  273.   list = copylist(getparents(check_object(object)));
  274.   for (next = list; consp(next); next = cdr(next)) {
  275.     rplaca(next, cons(object, car(next)));
  276.     object = cdr(car(next));
  277.   }
  278.   xlpopn(2);
  279.   return(list);
  280. }
  281.  
  282. /* find partial precedence ordering */
  283. static LVAL find_R(S)
  284.     LVAL S;
  285. {
  286.   LVAL result;
  287.   
  288.   xlstkcheck(2);
  289.   xlprotect(S);
  290.   xlsave(result);
  291.   for (/*result = NIL*/; consp(S); S = cdr(S)) /* not needed JKL */
  292.     result = append_list(result, find_RC(car(S)));
  293.   result = delete_duplicates(result);
  294.   xlpopn(2);
  295.   return(result);
  296. }
  297.  
  298. /* check if x has a predecessor according to R */
  299. static int has_predecessor(x, R)
  300.     LVAL x, R;
  301. {
  302.   int result = FALSE;
  303.   
  304.   for (; ! result && consp(R); R = cdr(R))
  305.     if (consp(car(R)) && x == cdr(car(R))) result = TRUE;
  306.   return(result);
  307. }
  308.  
  309. /* find list of objects in S without predecessors, by R */
  310. static LVAL find_no_predecessor_list(S, R)
  311.     LVAL S, R;
  312. {
  313.   LVAL result;
  314.   
  315.   xlstkcheck(3);
  316.   xlprotect(S);
  317.   xlprotect(R);
  318.   xlsave(result);
  319.   for (/*result = NIL*/; consp(S); S = cdr(S))/* not needed JKL */
  320.     if (! has_predecessor(car(S), R))
  321.       result = cons(car(S), result);
  322.   xlpopn(3);
  323.   return(result);
  324. }
  325.  
  326. /* find the position of child, if any, of x in P, the list found so far */
  327. static int child_position(x, P)
  328.     LVAL x, P;
  329. {
  330.   int count;
  331.   
  332.   for (count = 0; consp(P); P = cdr(P), count++)
  333.     if (is_member(x, getparents(car(P)))) return(count);
  334.   return(-1);
  335. }
  336.  
  337. /* find the next object in the precedence list from objects with no */
  338. /* predecessor and current list.                                    */
  339. static LVAL next_object(no_preds, P)
  340.     LVAL no_preds, P;
  341. {
  342.   LVAL result;
  343.   int count, tcount;
  344.  
  345.   if (! consp(no_preds)) result = NIL;
  346.   else if (! consp(cdr(no_preds))) result = car(no_preds);
  347.   else {
  348.     for (count = -1, result = NIL; consp(no_preds); no_preds = cdr(no_preds)) {
  349.       tcount = child_position(car(no_preds), P);
  350.       if (tcount > count) {
  351.         result = car(no_preds);
  352.         count = tcount;
  353.       }
  354.     }
  355.   }
  356.   return(result);
  357. }
  358.  
  359. /* remove object x from S */
  360. static LVAL trim_S(x, S)
  361.     LVAL x, S;
  362. {
  363.   LVAL next;
  364.   
  365.   while (consp(S) && x == car(S)) S = cdr(S);
  366.   for (next = S; consp(S) && consp(cdr(next));)
  367.     if (x == car(cdr(next))) rplacd(next, cdr(cdr(next)));
  368.     else next = cdr(next);
  369.   return(S);
  370. }
  371.  
  372. /* remove all pairs containing x from R. x is assumed to have no */
  373. /* predecessors, so only the first position is checked.          */
  374. static LVAL trim_R(x, R)
  375.     LVAL x, R;
  376. {
  377.   LVAL next;
  378.   
  379.   while (consp(R) && consp(car(R)) && x == car(car(R))) R = cdr(R);
  380.   for (next = R; consp(R) && consp(cdr(next));)
  381.     if (consp(car(next)) && x == car(car(cdr(next))))
  382.       rplacd(next, cdr(cdr(next)));
  383.     else next = cdr(next);
  384.   return(R);
  385. }
  386.  
  387. /* calculat the object's precedence list */
  388. static LVAL precedence_list(object)
  389.     LVAL object;
  390. {
  391.   LVAL R, S, P, no_preds, next;
  392.   
  393.   check_object(object);
  394.   xlstkcheck(5);
  395.   xlprotect(object);
  396.   xlsave(R);
  397.   xlsave(S);
  398.   xlsave(P);
  399.   xlsave(no_preds);
  400.   S = find_S(object);
  401.   R = find_R(S);
  402.   P = NIL;
  403.   while (consp(S)) {
  404.     no_preds = find_no_predecessor_list(S, R);
  405.     next = next_object(no_preds, P);
  406.     if (next == NIL) xlfail("inconsistent precedence order");
  407.     else {
  408.       P = append_list(P, consa(next));
  409.       S = trim_S(next, S);
  410.       R = trim_R(next, R);
  411.     }
  412.   }
  413.   xlpopn(5);
  414.   return(P);
  415. }
  416.  
  417. /***********************************************************************/
  418. /**                                                                   **/
  419. /**                  Object Construction Functions                    **/
  420. /**                                                                   **/
  421. /***********************************************************************/
  422.  
  423. static LVAL calculate_preclist(object)
  424.     LVAL object;
  425. {
  426.   LVAL result, parent, parents;
  427.   
  428.   parents = getparents(check_object(object));
  429.   if (consp(parents)) {
  430.     xlstkcheck(2);
  431.     xlprotect(object);
  432.     xlsave(result);
  433.     if (! consp(cdr(parents))) {
  434.       parent = check_object(car(parents));
  435.       result = getpreclist(parent);
  436.       result = cons(object, result);
  437.     }
  438.     else result = precedence_list(object);
  439.     xlpopn(2);
  440.   }
  441.   else xlerror("bad parent list", parents);
  442.   return(result);
  443. }
  444.  
  445. static void check_parents(parents)
  446.     LVAL parents;
  447. {
  448.   if (parents == NIL) return;
  449.   else if (mobject_p(parents)) return;
  450.   else if (consp(parents)) {
  451.     for (; consp(parents); parents = cdr(parents))
  452.       check_object(car(parents));
  453.   }
  454.   else xlerror("bad parents", parents);
  455.   if (consp(parents) && has_duplicates(parents))
  456.     xlfail("parents may not contain duplicates");
  457. }
  458.  
  459. static LVAL make_object(parents, object)
  460.     LVAL parents, object;
  461. {
  462.   check_parents(parents);
  463.   
  464.   xlstkcheck(2);
  465.   xlprotect(parents);
  466.   xlprotect(object);
  467.   
  468.   if (! mobject_p(object))
  469.     object = newobject(object_class, OBJECT_SIZE);
  470.  
  471.   setpreclist(object, getpreclist(root_object));
  472.   if (parents == NIL) setparents(object, consa(root_object));
  473.   else if (mobject_p(parents)) setparents(object, consa(parents));
  474.   else setparents(object, parents);
  475.   
  476.   setpreclist(object, calculate_preclist(object));
  477.   xlpopn(2);
  478.   return(object);
  479. }
  480.  
  481. LVAL xsmake_object()
  482. {
  483.   LVAL parents, object;
  484.   
  485.   xlsave1(parents);
  486.   parents = makearglist(xlargc, xlargv);
  487.   object = make_object(parents, NIL);
  488.   xlpop();
  489.   return(object);
  490. }
  491.  
  492. LVAL xsreparent_object()
  493. {
  494.   LVAL parents, object;
  495.   LVAL s_hardware_object = xlenter("HARDWARE-OBJECT-PROTO");
  496.   object = xsgetmobject();
  497.  
  498.   xlsave1(parents);
  499.   if (kind_of_p(object, getvalue(s_hardware_object)))
  500.     send_message(object, sk_dispose);
  501.   parents = makearglist(xlargc, xlargv);
  502.   object = make_object(parents, object);
  503.   xlpop();
  504.   return(object);
  505. }
  506.  
  507. /***********************************************************************/
  508. /**                                                                   **/
  509. /**                      Slot Access Functions                        **/
  510. /**                                                                   **/
  511. /***********************************************************************/
  512.  
  513. #define make_slot_entry(x, y) cons((x), (y))
  514. #define slot_entry_p(x) consp((x))
  515. #define slot_entry_key(x) car((x))
  516. #define slot_entry_value(x) cdr((x))
  517. #define set_slot_entry_value(x, v) rplacd((x), (v))
  518.  
  519. static LVAL find_own_slot(x, slot)
  520.     LVAL x, slot;
  521. {
  522.   LVAL slots;
  523.   
  524.   if (! mobject_p(x)) return(NIL);
  525.   for (slots = getslots(x); consp(slots); slots = cdr(slots))
  526.     if (slot_entry_p(car(slots)) && slot_entry_key(car(slots)) == slot) 
  527.       return(car(slots));
  528.   return(NIL);
  529. }
  530.  
  531. static LVAL find_slot(x, slot)
  532.     LVAL x, slot;
  533. {
  534.   LVAL slot_entry, preclist;
  535.  
  536.   if (! mobject_p(x)) slot_entry = NIL;
  537.   else {
  538.     for (slot_entry = NIL, preclist = getpreclist(x);
  539.          slot_entry == NIL && consp(preclist);
  540.          preclist = cdr(preclist))
  541.       slot_entry = find_own_slot(car(preclist), slot);
  542.   }    
  543.   return(slot_entry);
  544. }
  545.  
  546. static void add_slot(x, slot, value)
  547.     LVAL x, slot, value;
  548. {
  549.   LVAL slot_entry;
  550.   
  551.   xlstkcheck(3);
  552.   xlprotect(x);
  553.   xlprotect(slot);
  554.   xlprotect(value);
  555.   check_object(x);
  556.   
  557.   if (! symbolp(slot)) xlerror("not a symbol", slot);
  558.   slot_entry = find_own_slot(x, slot);
  559.   if (slot_entry != NIL) set_slot_entry_value(slot_entry, value);
  560.   else {
  561.     xlsave1(slot_entry);
  562.     slot_entry = make_slot_entry(slot, value);
  563.     setslots(x, cons(slot_entry, getslots(x)));
  564.     xlpop();
  565.   }
  566.   xlpopn(3);
  567. }
  568.  
  569. static LVAL delete_slot(x, slot)
  570.     LVAL x, slot;
  571. {
  572.   LVAL entry, slots;
  573.   
  574.   if (! mobject_p(x)) return(NIL);
  575.   else {
  576.     entry = find_own_slot(x, slot);
  577.     if (entry == NIL) return(NIL);
  578.     else {
  579.       slots = getslots(x);
  580.       setslots(x, delete(entry, slots));
  581.       return(s_true);
  582.     }
  583.   }
  584. }
  585.  
  586. LVAL slot_value(x, slot)
  587.     LVAL x, slot;
  588. {
  589.   LVAL slot_entry;
  590.   
  591.   check_object(x);
  592.   slot_entry = find_slot(x, slot);
  593.   if (slot_entry_p(slot_entry)) return(slot_entry_value(slot_entry));
  594.   else xlerror("no slot by this name", slot);
  595. }
  596.  
  597. #define CONSTRAINTHOOKS
  598.  
  599. void check_hooks(object, sym, slot)
  600.     LVAL object, sym;
  601.     int slot;
  602. {
  603. #ifdef CONSTRAINTHOOKS
  604.   LVAL hook, hooksym, olddenv;
  605.   
  606.   hooksym = (slot) ? s_set_slot_hook : s_message_hook;
  607.   hook = getvalue(hooksym);
  608.   if (hook != s_unbound && hook != NIL) {
  609.     /* rebind the hook function to nil */
  610.     olddenv = xldenv;
  611.     xldbind(hooksym,NIL);
  612.  
  613.     xsfuncall2(hook, object, sym);
  614.  
  615.     /* unbind the hook symbol */
  616.     xlunbind(olddenv);
  617.   }
  618. #endif CONSTRAINTHOOKS
  619. }
  620.  
  621. LVAL set_slot_value(x, slot, value)
  622.     LVAL x, slot, value;
  623. {
  624.   LVAL slot_entry;
  625.   
  626.   check_object(x);
  627.   slot_entry = find_own_slot(x, slot);
  628.   if (slot_entry_p(slot_entry)) {
  629.     set_slot_entry_value(slot_entry, value);
  630.     check_hooks(x, slot_entry_key(slot_entry), TRUE);
  631.   }
  632.   else {
  633.     if (find_slot(x, slot) != NIL)
  634.       xlerror("object does not own slot", slot);
  635.     else xlerror("no slot by this name", slot);
  636.   }
  637.   return(value);
  638. }
  639.  
  640. LVAL xshas_slot()
  641. {
  642.   LVAL x, slot, own, slot_entry;
  643.   
  644.   x = xsgetmobject();
  645.   slot = xlgasymbol();
  646.   if (! xlgetkeyarg(sk_own, &own)) own = NIL;
  647.   
  648.   slot_entry = (own == NIL) ? find_slot(x, slot) : find_own_slot(x, slot);
  649.   return((slot_entry != NIL) ? s_true : NIL);
  650. }
  651.  
  652. LVAL xsadd_slot()
  653. {
  654.   LVAL x, slot, value;
  655.   
  656.   x = xsgetmobject();
  657.   slot = xlgasymbol();
  658.   value = (moreargs()) ? xlgetarg() : NIL;
  659.   xllastarg();
  660.   
  661.   add_slot(x, slot, value);
  662.   return(value);
  663. }
  664.  
  665. LVAL xsdelete_slot()
  666. {
  667.   LVAL x, slot;
  668.   
  669.   x = xsgetmobject();
  670.   slot = xlgasymbol();
  671.   xllastarg();
  672.   
  673.   return(delete_slot(x, slot));
  674. }
  675.  
  676. LVAL xsslot_value()
  677. {
  678.   LVAL x, slot, value;
  679.   int set = FALSE;
  680.   
  681.   x = get_self(); /*xsgetmobject();*/
  682.   slot = xlgasymbol();
  683.   if (moreargs()) {
  684.     set = TRUE;
  685.     value = xlgetarg();
  686.   }
  687.   xllastarg();
  688.   
  689.   if (set) return(set_slot_value(x, slot, value));
  690.   else return(slot_value(x, slot));
  691. }
  692.  
  693. /***********************************************************************/
  694. /**                                                                   **/
  695. /**                    Method Access Functions                        **/
  696. /**                                                                   **/
  697. /***********************************************************************/
  698.  
  699. #define make_method_entry(x, y) cons((x), (y))
  700. #define method_entry_p(x) consp((x))
  701. #define method_entry_key(x) car((x))
  702. #define method_entry_method(x) cdr((x))
  703. #define set_method_entry_method(x, v) rplacd((x), (v))
  704.  
  705. static LVAL find_own_method(x, selector)
  706.     LVAL x, selector;
  707. {
  708.   LVAL methods;
  709.   
  710.   if (! mobject_p(x)) return(NIL);
  711.   for (methods = getmethods(x); consp(methods); methods = cdr(methods))
  712.     if (method_entry_p(car(methods)) 
  713.         && method_entry_key(car(methods)) == selector)
  714.       return(car(methods));
  715.   return(NIL);
  716. }
  717.  
  718. static LVAL find_method(x, selector)
  719.     LVAL x, selector;
  720. {
  721.   LVAL method_entry, preclist;
  722.   
  723.   if (! mobject_p(x)) method_entry = NIL;
  724.   else {
  725.     for (method_entry = NIL, preclist = getpreclist(x);
  726.          method_entry == NIL && consp(preclist);
  727.          preclist = cdr(preclist))
  728.       method_entry = find_own_method(car(preclist), selector);
  729.   }    
  730.   return(method_entry);
  731. }
  732.  
  733. static void add_method(x, selector, method)
  734.     LVAL x, selector, method;
  735. {
  736.   LVAL method_entry;
  737.   
  738.   xlstkcheck(3);
  739.   xlprotect(x);
  740.   xlprotect(selector);
  741.   xlprotect(method);
  742.   
  743.   check_object(x);
  744.   if (! symbolp(selector)) xlerror("not a symbol", selector);
  745.   method_entry = find_own_method(x, selector);
  746.   if (method_entry != NIL)
  747.     set_method_entry_method(method_entry, method);
  748.   else {
  749.     xlsave1(method_entry);
  750.     method_entry = make_method_entry(selector, method);
  751.     setmethods(x, cons(method_entry, getmethods(x)));
  752.     xlpop();
  753.   }
  754.   xlpopn(3);
  755. }
  756.  
  757. static LVAL delete_method(x, selector)
  758.     LVAL x, selector;
  759. {
  760.   LVAL entry, methods;
  761.   
  762.   if (! mobject_p(x)) return(NIL);
  763.   else {
  764.     entry = find_own_method(x, selector);
  765.     if (entry == NIL) return(NIL);
  766.     else {
  767.       methods = getmethods(x);
  768.       setmethods(x, delete(entry, methods));
  769.       return(s_true);
  770.     }
  771.   }
  772. }
  773.  
  774. static LVAL message_method(x, selector)
  775.     LVAL x, selector;
  776. {
  777.   LVAL method_entry;
  778.   
  779.   check_object(x);
  780.   method_entry = find_method(x, selector);
  781.   if (method_entry_p(method_entry)) 
  782.     return(method_entry_method(method_entry));
  783.   else xlfail("no method for this selector");
  784. }
  785.  
  786. #ifdef DODO
  787. static LVAL set_message_method(x, selector, method)
  788.     LVAL x, selector, method;
  789. {
  790.   LVAL method_entry;
  791.   
  792.   check_object(x);
  793.   method_entry = find_method(x, selector);
  794.   if (method_entry_p(method_entry))
  795.     set_method_entry_method(method_entry, method);
  796.   else xlfail("no method for this selector");
  797.   return(method);
  798. }
  799. #endif DODO
  800.   
  801. LVAL xshas_method()
  802. {
  803.   LVAL x, selector, own, method_entry;
  804.   
  805.   x = xsgetmobject();
  806.   selector = xlgasymbol();
  807.   if (! xlgetkeyarg(sk_own, &own)) own = NIL;
  808.   
  809.   method_entry = (own == NIL)
  810.                ? find_method(x, selector) : find_own_method(x, selector);
  811.   return((method_entry != NIL) ? s_true : NIL);
  812. }
  813.  
  814. LVAL xsadd_method()
  815. {
  816.   LVAL x, selector, method;
  817.   
  818.   x = xsgetmobject();
  819.   selector = xlgasymbol();
  820.   method = (moreargs()) ? xlgetarg() : NIL;
  821.   xllastarg();
  822.   
  823.   add_method(x, selector, method);
  824.   return(method);
  825. }
  826.  
  827. LVAL xsdelete_method()
  828. {
  829.   LVAL x, selector;
  830.   
  831.   x = xsgetmobject();
  832.   selector = xlgasymbol();
  833.   xllastarg();
  834.   
  835.   return(delete_method(x, selector));
  836. }
  837.  
  838. LVAL xsmessage_method()
  839. {
  840.   LVAL x, selector;
  841.   
  842.   x = xsgetmobject();
  843.   selector = xlgasymbol();
  844.   xllastarg();
  845.   
  846.   return(message_method(x, selector));
  847. }
  848.  
  849. /***********************************************************************/
  850. /**                                                                   **/
  851. /**                    Message Sending Functions                      **/
  852. /**                                                                   **/
  853. /***********************************************************************/
  854.  
  855. static LVAL current_preclist = NIL;
  856. static LVAL current_selector = NIL;
  857.  
  858. /*#define SAFEMESS*/
  859. #ifndef SAFEMESS
  860. static LVAL callmethod(method, object, argc, argv)
  861.     LVAL method, object, *argv;
  862.     int argc;
  863. {
  864.   LVAL *newfp;
  865.   int i;
  866.     
  867.   /* build a new argument stack frame */
  868.   newfp = xlsp;
  869.   pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  870.   pusharg(method);
  871.   pusharg(cvfixnum((FIXTYPE) (argc + 1)));
  872.  
  873.   /* push each argument */
  874.   pusharg(object);
  875.   for (i = 0; i < argc; i++) pusharg(argv[i]);
  876.  
  877.   /* establish the new stack frame */
  878.   xlfp = newfp;
  879.  
  880.   return(xlapply(argc + 1));
  881. }
  882. #endif /* SAFEMESS */
  883.  
  884. static LVAL sendmsg(object, selector)
  885.     LVAL object, selector;
  886. {
  887.   LVAL method_entry, method, old_preclist, preclist, val, old_selector;
  888.   LVAL tracing = NIL;
  889. #ifdef SAFEMESS
  890.   LVAL args;
  891. #endif
  892.  
  893.   old_selector = current_selector;
  894.   current_selector = selector;
  895.  
  896.   /* look for the message in the precedence list */
  897.   old_preclist = current_preclist;
  898.   for (method_entry = NIL, preclist = current_preclist;
  899.        method_entry == NIL && consp(preclist);
  900.        preclist = cdr(preclist)) {
  901.     method_entry = find_own_method(car(preclist), selector);
  902.     current_preclist = preclist;
  903.   }
  904.   if (method_entry == NIL)
  905.     xlerror("no method for this message", selector);
  906.   else if (! method_entry_p(method_entry)) xlfail("bad method entry");
  907.   else method = method_entry_method(method_entry);
  908.    
  909.   /* invoke the method */
  910.   if (getvalue(s_tracelist) && is_member(selector,getvalue(s_tracelist)))
  911.     tracing = selector;
  912.   trenter(tracing,xlargc,xlargv);
  913. #ifdef SAFEMESS
  914.   xlsave1(args);
  915.   args = makearglist(xlargc, xlargv);
  916.   args = cons(object, args);
  917.   val = xlapply(pushargs(method, args));
  918.   xlpop();
  919. #else
  920.   val = callmethod(method, object, xlargc, xlargv);
  921. #endif /* SAFEMESS */
  922.   trexit(tracing,val);
  923.   
  924.   current_preclist = old_preclist;
  925.   current_selector = old_selector;
  926.   check_hooks(object, method_entry_key(method_entry), FALSE);
  927.   return(val);
  928. }
  929.  
  930. /* send message with arguments on the stack */
  931. LVAL send_message_stk(object, selector)
  932.     LVAL object, selector;
  933. {
  934.   LVAL old_preclist, result;
  935.   int old_in_send = in_send;
  936.   
  937.   old_preclist = current_preclist;
  938.   current_preclist = getpreclist(object);
  939.   in_send = TRUE;
  940.   result = sendmsg(object, selector);
  941.   current_preclist = old_preclist;
  942.   in_send = old_in_send;
  943.   return(result);
  944. }
  945.  
  946.  
  947. /* xmsendsuper - send a message to the superobject of an object */
  948. LVAL xmsendsuper()
  949. {
  950.   LVAL old_preclist, object, result;
  951.   int old_in_send = in_send;
  952.   
  953.   object = get_self();
  954.   old_preclist = current_preclist;
  955.   if (! consp(current_preclist))
  956.     xlfail("no more objects in precedence list");
  957.   current_preclist = cdr(current_preclist);
  958.   in_send = TRUE;
  959.   result = sendmsg(object, xlgasymbol());
  960.   current_preclist = old_preclist;
  961.   in_send = old_in_send;
  962.   return(result);
  963. }
  964.  
  965. /* xscall_next - call inherited version of current method */
  966. LVAL xscall_next()
  967. {
  968.   LVAL old_preclist, object, result;
  969.   int old_in_send = in_send;
  970.   
  971.   object = get_self();
  972.   old_preclist = current_preclist;
  973.   if (! consp(current_preclist))
  974.     xlfail("no more objects in precedence list");
  975.   current_preclist = cdr(current_preclist);
  976.   in_send = TRUE;
  977.   result = sendmsg(object, current_selector);
  978.   current_preclist = old_preclist;
  979.   in_send = old_in_send;
  980.   return(result);
  981. }
  982.  
  983. LVAL xmsend()
  984. {
  985.   LVAL object, old_preclist, result;
  986.   int old_in_send = in_send;
  987.  
  988.   object = xlgaobject();
  989.   if (! mobject_p(object)) return(NIL);
  990.  
  991.   old_preclist = current_preclist;
  992.   current_preclist = getpreclist(object);
  993.   in_send = TRUE;
  994.   result = sendmsg(object, xlgasymbol());
  995.   current_preclist = old_preclist;
  996.   in_send = old_in_send;
  997.   return(result);
  998. }
  999.   
  1000. LVAL xscall_method() 
  1001. {
  1002.   LVAL object, self, old_preclist, result;
  1003.   int old_in_send = in_send;
  1004.   
  1005.   object = xlgaobject();
  1006.   self = get_self();
  1007.   old_preclist = current_preclist;
  1008.   current_preclist = getpreclist(object);
  1009.   in_send = TRUE;
  1010.   result = sendmsg(self, xlgasymbol());
  1011.   current_preclist = old_preclist;
  1012.   in_send = old_in_send;
  1013.   return(result);
  1014. }
  1015.   
  1016. void print_mobject(object, stream)
  1017.     LVAL object, stream;
  1018. {
  1019.   send_message_1L(object, sk_print, stream);
  1020. }
  1021.  
  1022. LVAL xsshow_object()
  1023. {
  1024.   LVAL x, fptr;
  1025.   
  1026.   x = xsgetmobject();
  1027.   fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  1028.   xllastarg();
  1029.   
  1030.   xlputstr(fptr, "Slots = "); xlprint(fptr, getslots(x), TRUE); xlterpri(fptr);
  1031.   xlputstr(fptr, "Methods = "); xlprint(fptr, getmethods(x), TRUE); xlterpri(fptr);
  1032.   xlputstr(fptr, "Parents = "); xlprint(fptr, getparents(x), TRUE); xlterpri(fptr);
  1033.   xlputstr(fptr, "Precedence List = "); xlprint(fptr, getpreclist(x), TRUE); xlterpri(fptr);
  1034.   return(NIL);
  1035. }
  1036.  
  1037. LVAL xsparents()
  1038. {
  1039.   LVAL x;
  1040.   
  1041.   x = xsgetmobject();
  1042.   xllastarg();
  1043.   
  1044.   return(copylist(getparents(x)));
  1045. }
  1046.  
  1047. LVAL xsprecedence_list()
  1048. {
  1049.   LVAL x;
  1050.   
  1051.   x = xsgetmobject();
  1052.   xllastarg();
  1053.   
  1054.   return(copylist(getpreclist(x)));
  1055. }
  1056.  
  1057. static LVAL get_cars(x)
  1058.     LVAL x;
  1059. {
  1060.   LVAL next;
  1061.   
  1062.   for (next = x; consp(next); next = cdr(next))
  1063.       if (consp(car(next)))
  1064.         rplaca(next, car(car(next)));
  1065.   return(x);
  1066. }
  1067.  
  1068. LVAL xsobject_methods()
  1069. {
  1070.   LVAL x;
  1071.   
  1072.   x = xsgetmobject();
  1073.   xllastarg();
  1074.   
  1075.   return(get_cars(copylist(getmethods(x))));
  1076. }
  1077.  
  1078. LVAL xsobject_slots()
  1079. {
  1080.   LVAL x;
  1081.   
  1082.   x = xsgetmobject();
  1083.   xllastarg();
  1084.   
  1085.   return(get_cars(copylist(getslots(x))));
  1086. }
  1087.  
  1088. void statobsymbols()
  1089. {
  1090.   object_class = getvalue(xlenter("OBJECT"));
  1091.   root_object = getvalue(xlenter("*OBJECT*"));
  1092. }
  1093.  
  1094. int lex_slot_value(object, sym, pval)
  1095.     LVAL object, sym, *pval;
  1096. {
  1097.   int has = (find_slot(object, sym) != NIL);
  1098.   if (has) *pval = slot_value(object, sym);
  1099.   return(has);
  1100. }
  1101.  
  1102. void object_isnew(object)
  1103.     LVAL object;
  1104. {
  1105.   LVAL slots, sym, ksym, value;
  1106.  
  1107.   for (slots = getslots(object); consp(slots); slots = cdr(slots)) {
  1108.     sym = car(car(slots));
  1109.     if (! symbolp(sym)) xlerror("bad slot entry", car(slots));
  1110.     sprintf(buf, ":%s", getstring(getpname(sym)));
  1111.     ksym = xlenter(buf);
  1112.     if (xlgetkeyarg(ksym, &value)) set_slot_value(object, sym, value);
  1113.   }
  1114. }
  1115.  
  1116. LVAL xsobject_isnew()
  1117. {
  1118.   LVAL object;
  1119.  
  1120.   object = xsgetmobject();
  1121.   object_isnew(object);
  1122.   return(object);
  1123. }
  1124.   
  1125. #define FIRST_METHOD_OFFSET 300
  1126.  
  1127. /* xsaddmsg - add a message to an object */
  1128. void xsaddmsg(object, str)
  1129.     LVAL object;
  1130.     char *str;
  1131. {
  1132.   LVAL fcn;
  1133.   extern FUNDEF funtab[];
  1134.   static offset = FIRST_METHOD_OFFSET; 
  1135.  
  1136.   xlsave1(fcn);
  1137.   fcn = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
  1138.   add_method(object, xlenter(str), fcn);
  1139.   xlpop();
  1140.   
  1141.   offset++;
  1142. }
  1143.  
  1144. void xsaddslot(object, str)
  1145.     LVAL object;
  1146.     char *str;
  1147. {
  1148.   add_slot(object, xlenter(str), NIL);
  1149. }
  1150.  
  1151. LVAL xsnewproto(str, parents)
  1152.     char *str;
  1153.     LVAL parents;
  1154. {
  1155.   LVAL sym = xlenter(str), object;
  1156.  
  1157.   xlsave1(object);
  1158.   object = make_object(parents, NIL);
  1159.   make_prototype(object, sym, NIL, NIL, NIL, TRUE);
  1160.   xlpop();
  1161.   
  1162.   return(object);
  1163. }
  1164.  
  1165. LVAL init_root_object()
  1166. {
  1167.   LVAL s__object_ = xlenter("*OBJECT*");
  1168.   
  1169.   object_class = getvalue(xlenter("OBJECT"));
  1170.   root_object = newobject(object_class, OBJECT_SIZE);
  1171.   setvalue(s__object_, root_object);
  1172.   setpreclist(root_object, consa(root_object));
  1173.   
  1174.   add_slot(root_object, s_instance_slots, NIL);
  1175.   add_slot(root_object, s_proto_name, s__object_);
  1176.   return(root_object);
  1177. }
  1178.  
  1179. static LVAL find_documentation(x, sym, add)
  1180.     LVAL x, sym;
  1181.     int add;
  1182. {
  1183.   LVAL doc;
  1184.   
  1185.   if (! mobject_p(x)) return(NIL);
  1186.   doc = find_own_slot(x, s_documentation);
  1187.   if (doc == NIL && add) add_slot(x, s_documentation, NIL);
  1188.   if (consp(doc)) doc = cdr(doc);
  1189.   for (; consp(doc); doc = cdr(doc))
  1190.     if (consp(car(doc)) && car(car(doc)) == sym) return(car(doc));
  1191.   return(NIL);
  1192. }
  1193.  
  1194. /* x should be protected from gc before calling add_slot */
  1195. static void add_documentation(x, sym, value)
  1196.     LVAL x, sym, value;
  1197. {
  1198.   LVAL doc_entry;
  1199.   
  1200.   xlstkcheck(3);
  1201.   xlprotect(x);
  1202.   xlprotect(sym);
  1203.   xlprotect(value);
  1204.   check_object(x);
  1205.   if (! symbolp(sym)) xlerror("not a symbol", sym);
  1206.   doc_entry = find_documentation(x, sym, TRUE);
  1207.   if (doc_entry != NIL) rplacd(doc_entry, value);
  1208.   else {
  1209.     xlsave1(doc_entry);
  1210.     doc_entry = cons(sym, value);
  1211.     set_slot_value(x,
  1212.                    s_documentation,
  1213.                    cons(doc_entry, slot_value(x, s_documentation)));
  1214.     xlpop();
  1215.   }
  1216.   xlpopn(3);
  1217. }
  1218.  
  1219. static LVAL get_documentation(x, sym)
  1220.     LVAL x, sym;
  1221. {
  1222.   LVAL doc_entry; /* changed JKL */
  1223. #ifdef DODO
  1224.   LVAL list;
  1225. #endif DODO
  1226.  
  1227.   check_object(x);
  1228. #ifdef DODO /* this only looks in the object itself! */
  1229.   for (list = getpreclist(x); consp(list); list = cdr(list)) {
  1230.     doc_entry = find_documentation(x, sym, FALSE);
  1231.     if (doc_entry != NIL) break;
  1232.   }
  1233. #endif DODO
  1234.   doc_entry = find_documentation(x, sym, FALSE);
  1235.   return (consp(doc_entry) ? cdr(doc_entry) : NIL);
  1236. }
  1237.  
  1238. LVAL xsobject_documentation()
  1239. {
  1240.   LVAL x, sym, val;
  1241.   
  1242.   x = xsgetmobject();
  1243.   sym = xlgasymbol();
  1244.   if (moreargs()) {
  1245.     val = xlgetarg();
  1246.     add_documentation(x, sym, val);
  1247.   }
  1248.   return(get_documentation(x, sym));
  1249. }
  1250.   
  1251.  
  1252. LVAL xsdefmeth()
  1253. {
  1254.   LVAL object, sym, fargs, arglist, fcn;
  1255.   
  1256.   xlstkcheck(3);
  1257.   xlsave(fargs);
  1258.   xlsave(arglist);
  1259.   xlsave(fcn);
  1260.   object = xleval(xlgetarg());
  1261.   sym = xlgasymbol();
  1262.   fargs = xlgalist();
  1263.   arglist = makearglist(xlargc,xlargv);
  1264.  
  1265.   if (! mobject_p(object)) xlerror("bad object", object);
  1266.  
  1267.   /* install documentation string */
  1268.   if (consp(arglist) && stringp(car(arglist)) && consp(cdr(arglist))) {
  1269.     add_documentation(object, sym, car(arglist));
  1270.     arglist = cdr(arglist);
  1271.   }
  1272.  
  1273.   /* create a new function definition */
  1274.   fargs = cons(s_self, fargs);
  1275.   fcn = xlclose(sym, s_lambda, fargs, arglist, xlenv, xlfenv);
  1276.  
  1277.   /* add the method to the object */
  1278.   add_method(object, sym, fcn);
  1279.   
  1280.   /* restore the stack and return the symbol */
  1281.   xlpopn(3);
  1282.   return (sym);
  1283. }
  1284.  
  1285. /***********************************************************************/
  1286. /**                                                                   **/
  1287. /**                  Prototype Construction Functions                 **/
  1288. /**                                                                   **/
  1289. /***********************************************************************/
  1290.  
  1291. static LVAL instance_slots(x, slots)
  1292.     LVAL x, slots;
  1293. {
  1294.   LVAL parents = getparents(x), result, sym, temp, tail;
  1295.   
  1296.   xlsave1(result);
  1297.   result = copylist(slots); /* redundant equation to NIL in macro JKL */
  1298.   result = delete_duplicates(result);
  1299.   for (tail = result; consp(tail) && consp(cdr(tail)); tail = cdr(tail));
  1300.  
  1301.   for (; consp(parents); parents = cdr(parents)) {
  1302.     for (temp = slot_value(car(parents), s_instance_slots);
  1303.          consp(temp);
  1304.          temp = cdr(temp)) {
  1305.       sym = car(temp);
  1306.       if (! is_member(sym, result)) {
  1307.         if (result == NIL) {
  1308.           result = consa(sym);
  1309.           tail = result;
  1310.         }
  1311.         else {
  1312.           rplacd(tail, consa(sym));
  1313.           tail = cdr(tail);
  1314.         }
  1315.       }
  1316.     }
  1317.   }
  1318.   xlpop();
  1319.   
  1320.   return(result);
  1321. }
  1322.  
  1323. static LVAL get_initial_slot_value(object, slot)
  1324.     LVAL object, slot;
  1325. {
  1326.   LVAL entry = find_slot(object, slot);
  1327.   return((entry != NIL) ? cdr(entry) : NIL);
  1328. }
  1329.  
  1330. static void make_prototype(object, name, ivars, cvars, doc, set)
  1331.     LVAL object, name, ivars, cvars, doc;
  1332.     int set;
  1333. {
  1334.   LVAL slot;
  1335.   
  1336.   xlprot1(ivars);
  1337.   
  1338.   ivars = instance_slots(object, ivars);
  1339.   add_slot(object, s_instance_slots, ivars);
  1340.   add_slot(object, s_proto_name, name);
  1341.   
  1342.   for (; consp(ivars); ivars = cdr(ivars)) {
  1343.     slot = car(ivars);
  1344.     add_slot(object, slot, get_initial_slot_value(object, slot));
  1345.   }
  1346.   
  1347.   for (; consp(cvars); cvars = cdr(cvars)) 
  1348.     add_slot(object, car(cvars), NIL);
  1349.     
  1350.   if (doc != NIL && stringp(doc))
  1351.     add_documentation(object, xlenter("PROTO"), doc);
  1352.     
  1353.   if (set) setvalue(name, object);
  1354.  
  1355.   xlpop();
  1356. }
  1357.  
  1358. void xsaddinstanceslot(x, s)
  1359.     LVAL x;
  1360.     char *s;
  1361. {
  1362.   LVAL sym = xlenter(s), ivars = slot_value(x, s_instance_slots);
  1363.   
  1364.   if (! is_member(sym, ivars)) {
  1365.     add_slot(x, sym, get_initial_slot_value(x, sym));
  1366.     set_slot_value(x, s_instance_slots, cons(sym, ivars));
  1367.   }
  1368. }
  1369.  
  1370. void xssetslotval(x, s, val)
  1371.     LVAL x, val;
  1372.     char *s;
  1373. {
  1374.   set_slot_value(x, xlenter(s), val);
  1375. }
  1376.  
  1377. LVAL xsdefproto()
  1378. {
  1379.   LVAL object, name, ivars, cvars, parents, doc;
  1380.   
  1381.   xlstkcheck(5);
  1382.   xlsave(object);
  1383.   xlsave(ivars);
  1384.   xlsave(cvars);
  1385.   xlsave(parents);
  1386.   xlsave(doc);
  1387.   
  1388.   name = xlgasymbol();
  1389.   ivars = (moreargs()) ? xleval(ivars = xlgetarg()) : NIL;
  1390.   cvars = (moreargs()) ? xleval(cvars = xlgetarg()) : NIL;
  1391.   parents = (moreargs()) ? xleval(parents = xlgetarg()) : NIL;
  1392.   doc = (moreargs()) ? xleval(doc = xlgetarg()) : NIL;
  1393.   
  1394.   if (! listp(parents)) parents = consa(parents);
  1395.   object = make_object(parents, NIL);
  1396.   make_prototype(object, name, ivars, cvars, doc, TRUE);
  1397.   
  1398.   xlpopn(5);
  1399.   return(name);
  1400. }
  1401.  
  1402. LVAL xsmakeproto()
  1403. {
  1404.   LVAL object, name, ivars;
  1405.   
  1406.   object = xsgetmobject();
  1407.   name = xlgasymbol();
  1408.   ivars = (moreargs()) ? xlgetarg() : NIL;
  1409.   
  1410.   make_prototype(object, name, ivars, NIL, NIL, TRUE);
  1411.   
  1412.   return(object);
  1413. }
  1414.  
  1415. LVAL clanswer () { return(NIL); }
  1416. LVAL clisnew () { return(NIL); }
  1417. LVAL clnew () { return(NIL); }
  1418. void obsymbols () {}
  1419. LVAL obclass () { return(NIL); }
  1420. LVAL obshow () { return(NIL); }
  1421. LVAL obisnew () { return(NIL); }
  1422. LVAL xsend () { return(NIL); }
  1423. int xlobgetvalue (a, b, c) LVAL a,b,*c; { return(FALSE); }
  1424. int xlobsetvalue (a, b, c) LVAL a,b,c;  { return(FALSE); }
  1425. LVAL xsendsuper () { return(NIL); }
  1426. void xloinit () {}
  1427.