home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLSTRUCT.C < prev    next >
Text File  |  1989-04-23  |  11KB  |  436 lines
  1. /* xlstruct.c - the defstruct facility */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv;
  10. extern LVAL s_lambda,s_quote,lk_key,true;
  11. extern char buf[];
  12.  
  13. /* local variables */
  14. static prefix[STRMAX+1];
  15.  
  16. /* xmkstruct - the '%make-struct' function */
  17. LVAL xmkstruct()
  18. {
  19.     LVAL type,val;
  20.     int i;
  21.  
  22.     /* get the structure type */
  23.     type = xlgasymbol();
  24.  
  25.     /* make the structure */
  26.     val = newstruct(type,xlargc);
  27.  
  28.     /* store each argument */
  29.     for (i = 1; moreargs(); ++i)
  30.     setelement(val,i,nextarg());
  31.     xllastarg();
  32.  
  33.     /* return the structure */
  34.     return (val);
  35. }
  36.  
  37. /* xcpystruct - the '%copy-struct' function */
  38. LVAL xcpystruct()
  39. {
  40.     LVAL str,val;
  41.     int size,i;
  42.     str = xlgastruct();
  43.     xllastarg();
  44.     size = getsize(str);
  45.     val = newstruct(getelement(str,0),size-1);
  46.     for (i = 1; i < size; ++i)
  47.     setelement(val,i,getelement(str,i));
  48.     return (val);
  49. }
  50.  
  51. /* xstrref - the '%struct-ref' function */
  52. LVAL xstrref()
  53. {
  54.     LVAL str,val;
  55.     int i;
  56.     str = xlgastruct();
  57.     val = xlgafixnum(); i = (int)getfixnum(val);
  58.     xllastarg();
  59.     return (getelement(str,i));
  60. }
  61.  
  62. /* xstrset - the '%struct-set' function */
  63. LVAL xstrset()
  64. {
  65.     LVAL str,val;
  66.     int i;
  67.     str = xlgastruct();
  68.     val = xlgafixnum(); i = (int)getfixnum(val);
  69.     val = xlgetarg();
  70.     xllastarg();
  71.     setelement(str,i,val);
  72.     return (val);
  73. }
  74.  
  75. /* xstrtypep - the '%struct-type-p' function */
  76. LVAL xstrtypep()
  77. {
  78.     LVAL type,val;
  79.     type = xlgasymbol();
  80.     val = xlgetarg();
  81.     xllastarg();
  82.     return (structp(val) && getelement(val,0) == type ? true : NIL);
  83. }
  84.  
  85. /* xdefstruct - the 'defstruct' special form */
  86. LVAL xdefstruct()
  87. {
  88.     LVAL structname,slotname,defexpr,sym,tmp,args,body;
  89.     LVAL options,oargs,slots;
  90.     char *pname;
  91.     int slotn;
  92.     
  93.     /* protect some pointers */
  94.     xlstkcheck(6);
  95.     xlsave(structname);
  96.     xlsave(slotname);
  97.     xlsave(defexpr);
  98.     xlsave(args);
  99.     xlsave(body);
  100.     xlsave(tmp);
  101.     
  102.     /* initialize */
  103.     args = body = NIL;
  104.     slotn = 0;
  105.  
  106.     /* get the structure name */
  107.     tmp = xlgetarg();
  108.     if (symbolp(tmp)) {
  109.     structname = tmp;
  110.     strcpy(prefix,getstring(getpname(structname)));
  111.     strcat(prefix,"-");
  112.     }
  113.  
  114.     /* get the structure name and options */
  115.     else if (consp(tmp) && symbolp(car(tmp))) {
  116.     structname = car(tmp);
  117.     strcpy(prefix,getstring(getpname(structname)));
  118.     strcat(prefix,"-");
  119.  
  120.     /* handle the list of options */
  121.     for (options = cdr(tmp); consp(options); options = cdr(options)) {
  122.  
  123.         /* get the next argument */
  124.         tmp = car(options);
  125.         
  126.         /* handle options that don't take arguments */
  127.         if (symbolp(tmp)) {
  128.         pname = getstring(getpname(tmp));
  129.         xlerror("unknown option",tmp);
  130.         }
  131.  
  132.         /* handle options that take arguments */
  133.         else if (consp(tmp) && symbolp(car(tmp))) {
  134.         pname = getstring(getpname(car(tmp)));
  135.         oargs = cdr(tmp);
  136.  
  137.         /* check for the :CONC-NAME keyword */
  138.         if (strcmp(pname,":CONC-NAME") == 0) {
  139.  
  140.             /* get the name of the structure to include */
  141.             if (!consp(oargs) || !symbolp(car(oargs)))
  142.             xlerror("expecting a symbol",oargs);
  143.  
  144.             /* save the prefix */
  145.             strcpy(prefix,getstring(getpname(car(oargs))));
  146.         }
  147.  
  148.         /* check for the :INCLUDE keyword */
  149.         else if (strcmp(pname,":INCLUDE") == 0) {
  150.  
  151.             /* get the name of the structure to include */
  152.             if (!consp(oargs) || !symbolp(car(oargs)))
  153.             xlerror("expecting a structure name",oargs);
  154.             tmp = car(oargs);
  155.             oargs = cdr(oargs);
  156.  
  157.             /* add each slot from the included structure */
  158.             slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
  159.             for (; consp(slots); slots = cdr(slots)) {
  160.             if (consp(car(slots)) && consp(cdr(car(slots)))) {
  161.  
  162.                 /* get the next slot description */
  163.                 tmp = car(slots);
  164.  
  165.                 /* create the slot access functions */
  166.                 addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
  167.             }
  168.             }
  169.  
  170.             /* handle slot initialization overrides */
  171.             for (; consp(oargs); oargs = cdr(oargs)) {
  172.             tmp = car(oargs);
  173.             if (symbolp(tmp)) {
  174.                 slotname = tmp;
  175.                 defexpr = NIL;
  176.             }
  177.             else if (consp(tmp) && symbolp(car(tmp))) {
  178.                 slotname = car(tmp);
  179.                 defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  180.             }
  181.             else
  182.                 xlerror("bad slot description",tmp);
  183.             updateslot(args,slotname,defexpr);
  184.             }
  185.         }
  186.         else
  187.             xlerror("unknown option",tmp);
  188.         }
  189.         else
  190.         xlerror("bad option syntax",tmp);
  191.     }
  192.     }
  193.  
  194.     /* get each of the structure members */
  195.     while (moreargs()) {
  196.     
  197.     /* get the slot name and default value expression */
  198.     tmp = xlgetarg();
  199.     if (symbolp(tmp)) {
  200.         slotname = tmp;
  201.         defexpr = NIL;
  202.     }
  203.     else if (consp(tmp) && symbolp(car(tmp))) {
  204.         slotname = car(tmp);
  205.         defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  206.     }
  207.     else
  208.         xlerror("bad slot description",tmp);
  209.     
  210.     /* create a closure for non-trival default expressions */
  211.     if (defexpr != NIL) {
  212.         tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  213.         setbody(tmp,cons(defexpr,NIL));
  214.         tmp = cons(tmp,NIL);
  215.         defexpr = tmp;
  216.     }
  217.  
  218.     /* create the slot access functions */
  219.     addslot(slotname,defexpr,++slotn,&args,&body);
  220.     }
  221.     
  222.     /* store the slotnames and default expressions */
  223.     xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
  224.  
  225.     /* enter the MAKE-xxx symbol */
  226.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  227.     sym = xlenter(buf);
  228.  
  229.     /* make the MAKE-xxx function */
  230.     args = cons(lk_key,args);
  231.     tmp = cons(structname,NIL);
  232.     tmp = cons(s_quote,tmp);
  233.     body = cons(tmp,body);
  234.     body = cons(xlenter("%MAKE-STRUCT"),body);
  235.     body = cons(body,NIL);
  236.     setfunction(sym,
  237.         xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
  238.  
  239.     /* enter the xxx-P symbol */
  240.     sprintf(buf,"%s-P",getstring(getpname(structname)));
  241.     sym = xlenter(buf);
  242.  
  243.     /* make the xxx-P function */
  244.     args = cons(xlenter("X"),NIL);
  245.     body = cons(xlenter("X"),NIL);
  246.     tmp = cons(structname,NIL);
  247.     tmp = cons(s_quote,tmp);
  248.     body = cons(tmp,body);
  249.     body = cons(xlenter("%STRUCT-TYPE-P"),body);
  250.     body = cons(body,NIL);
  251.     setfunction(sym,
  252.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  253.  
  254.     /* enter the COPY-xxx symbol */
  255.     sprintf(buf,"COPY-%s",getstring(getpname(structname)));
  256.     sym = xlenter(buf);
  257.  
  258.     /* make the COPY-xxx function */
  259.     args = cons(xlenter("X"),NIL);
  260.     body = cons(xlenter("X"),NIL);
  261.     body = cons(xlenter("%COPY-STRUCT"),body);
  262.     body = cons(body,NIL);
  263.     setfunction(sym,
  264.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  265.  
  266.     /* restore the stack */
  267.     xlpopn(6);
  268.  
  269.     /* return the structure name */
  270.     return (structname);
  271. }
  272.  
  273. /* xlrdstruct - convert a list to a structure (used by the reader) */
  274. LVAL xlrdstruct(list)
  275.   LVAL list;
  276. {
  277.     LVAL structname,sym,slotname,expr,last,val;
  278.  
  279.     /* protect the new structure */
  280.     xlsave1(expr);
  281.  
  282.     /* get the structure name */
  283.     if (!consp(list) || !symbolp(car(list)))
  284.     xlerror("bad structure initialization list",list);
  285.     structname = car(list);
  286.     list = cdr(list);
  287.  
  288.     /* enter the MAKE-xxx symbol */
  289.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  290.  
  291.     /* initialize the MAKE-xxx function call expression */
  292.     expr = cons(xlenter(buf),NIL);
  293.     last = expr;
  294.  
  295.     /* turn the rest of the initialization list into keyword arguments */
  296.     while (consp(list) && consp(cdr(list))) {
  297.  
  298.     /* get the slot keyword name */
  299.     slotname = car(list);
  300.     if (!symbolp(slotname))
  301.         xlerror("expecting a slot name",slotname);
  302.     sprintf(buf,":%s",getstring(getpname(slotname)));
  303.  
  304.     /* add the slot keyword */
  305.     rplacd(last,cons(xlenter(buf),NIL));
  306.     last = cdr(last);
  307.     list = cdr(list);
  308.  
  309.     /* add the value expression */
  310.     rplacd(last,cons(car(list),NIL));
  311.     last = cdr(last);
  312.     list = cdr(list);
  313.     }
  314.  
  315.     /* make sure all of the initializers were used */
  316.     if (consp(list))
  317.     xlerror("bad structure initialization list",list);
  318.  
  319.     /* invoke the creation function */
  320.     val = xleval(expr);
  321.  
  322.     /* restore the stack */
  323.     xlpop();
  324.  
  325.     /* return the new structure */
  326.     return (val);
  327. }
  328.  
  329. /* xlprstruct - print a structure (used by printer) */
  330. xlprstruct(fptr,vptr,flag)
  331.   LVAL fptr,vptr; int flag;
  332. {
  333.     LVAL next;
  334.     int i,n;
  335.     xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'(');
  336.     xlprint(fptr,getelement(vptr,0),flag);
  337.     next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
  338.     for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
  339.     if (consp(car(next))) { /* should always succeed */
  340.         xlputc(fptr,' ');
  341.         xlprint(fptr,car(car(next)),flag);
  342.         xlputc(fptr,' ');
  343.         xlprint(fptr,getelement(vptr,i),flag);
  344.     }
  345.     next = cdr(next);
  346.     }
  347.     xlputc(fptr,')');
  348. }
  349.  
  350. /* addslot - make the slot access functions */
  351. LOCAL addslot(slotname,defexpr,slotn,pargs,pbody)
  352.   LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
  353. {
  354.     LVAL sym,args,body,tmp;
  355.     
  356.     /* protect some pointers */
  357.     xlstkcheck(4);
  358.     xlsave(sym);
  359.     xlsave(args);
  360.     xlsave(body);
  361.     xlsave(tmp);
  362.     
  363.     /* construct the update function name */
  364.     sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
  365.     sym = xlenter(buf);
  366.     
  367.     /* make the access function */
  368.     args = cons(xlenter("S"),NIL);
  369.     body = cons(cvfixnum((FIXTYPE)slotn),NIL);
  370.     body = cons(xlenter("S"),body);
  371.     body = cons(xlenter("%STRUCT-REF"),body);
  372.     body = cons(body,NIL);
  373.     setfunction(sym,
  374.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  375.  
  376.     /* make the update function */
  377.     args = cons(xlenter("V"),NIL);
  378.     args = cons(xlenter("S"),args);
  379.     body = cons(xlenter("V"),NIL);
  380.     body = cons(cvfixnum((FIXTYPE)slotn),body);
  381.     body = cons(xlenter("S"),body);
  382.     body = cons(xlenter("%STRUCT-SET"),body);
  383.     body = cons(body,NIL);
  384.     xlputprop(sym,
  385.           xlclose(NIL,s_lambda,args,body,NIL,NIL),
  386.           xlenter("*SETF*"));
  387.  
  388.     /* add the slotname to the make-xxx keyword list */
  389.     tmp = cons(defexpr,NIL);
  390.     tmp = cons(slotname,tmp);
  391.     tmp = cons(tmp,NIL);
  392.     if ((args = *pargs) == NIL)
  393.     *pargs = tmp;
  394.     else {
  395.     while (cdr(args) != NIL)
  396.         args = cdr(args);
  397.     rplacd(args,tmp);
  398.     }
  399.     
  400.     /* add the slotname to the %make-xxx argument list */
  401.     tmp = cons(slotname,NIL);
  402.     if ((body = *pbody) == NIL)
  403.     *pbody = tmp;
  404.     else {
  405.     while (cdr(body) != NIL)
  406.         body = cdr(body);
  407.     rplacd(body,tmp);
  408.     }
  409.  
  410.     /* restore the stack */
  411.     xlpopn(4);
  412. }
  413.  
  414. /* updateslot - update a slot definition */
  415. LOCAL updateslot(args,slotname,defexpr)
  416.   LVAL args,slotname,defexpr;
  417. {
  418.     LVAL tmp;
  419.     for (; consp(args); args = cdr(args))
  420.     if (slotname == car(car(args))) {
  421.         if (defexpr != NIL) {
  422.         xlsave1(tmp);
  423.         tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  424.         setbody(tmp,cons(defexpr,NIL));
  425.         tmp = cons(tmp,NIL);
  426.         defexpr = tmp;
  427.         xlpop();
  428.         }
  429.         rplaca(cdr(car(args)),defexpr);
  430.         break;
  431.     }
  432.     if (args == NIL)
  433.     xlerror("unknown slot name",slotname);
  434. }
  435.  
  436.