home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / sources / xlstruct.c < prev    next >
C/C++ Source or Header  |  1992-02-03  |  14KB  |  502 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 LVAL s_strtypep, s_mkstruct, s_cpystruct, s_strref, s_strset;
  12. extern LVAL s_x, s_s, s_sslots, s_setf;
  13. extern LVAL k_concname, k_include;
  14.  
  15. /* forward declarations */
  16. #ifdef ANSI
  17. void NEAR addslot(LVAL slotname,LVAL defexpr,int slotn,LVAL *pargs, LVAL *pbody);
  18. void NEAR updateslot(LVAL args,LVAL slotname,LVAL defexpr);
  19. #else
  20. FORWARD void addslot();
  21. FORWARD void updateslot();
  22. #endif
  23.  
  24.  
  25. /* local variables */
  26. static  char prefix[STRMAX+1];
  27. #ifndef MEDMEM
  28. static char makestr[] = "MAKE-%s";
  29. #endif
  30.  
  31. /* xmkstruct - the '%make-struct' function */
  32. LVAL xmkstruct()
  33. {
  34.     LVAL type,val;
  35.     int i;
  36.  
  37.     /* get the structure type */
  38.     type = xlgasymbol();
  39.  
  40.     /* make the structure */
  41.     val = newstruct(type,xlargc);
  42.  
  43.     /* store each argument */
  44.     for (i = 1; moreargs(); ++i)
  45.         setelement(val,i,nextarg());
  46.     xllastarg();
  47.  
  48.     /* return the structure */
  49.     return (val);
  50. }
  51.  
  52. /* xcpystruct - the '%copy-struct' function */
  53. LVAL xcpystruct()
  54. {
  55.     LVAL str,val;
  56.     int size,i;
  57.     str = xlgastruct();
  58.     xllastarg();
  59.     size = getsize(str);
  60.     val = newstruct(getelement(str,0),size-1);
  61.     for (i = 1; i < size; ++i)
  62.         setelement(val,i,getelement(str,i));
  63.     return (val);
  64. }
  65.  
  66. /* xstrref - the '%struct-ref' function */
  67. LVAL xstrref()
  68. {
  69.     LVAL str,val;
  70.     int i;
  71.     str = xlgastruct();
  72.     val = xlgafixnum(); i = (int)getfixnum(val);
  73.     xllastarg();
  74.     if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
  75.         xlerror("bad structure reference",str);
  76.     return (getelement(str,i));
  77. }
  78.  
  79. /* xstrset - the '%struct-set' function */
  80. LVAL xstrset()
  81. {
  82.     LVAL str,val;
  83.     int i;
  84.     str = xlgastruct();
  85.     val = xlgafixnum(); i = (int)getfixnum(val);
  86.     val = xlgetarg();
  87.     xllastarg();
  88.     if (i >= getsize(str)) /* wrong structure TAA MOD fix*/
  89.         xlerror("bad structure reference",str);
  90.     setelement(str,i,val);
  91.     return (val);
  92. }
  93.  
  94. /* xstrtypep - the '%struct-type-p' function */
  95. LVAL xstrtypep()
  96. {
  97.     LVAL type,val;
  98.     type = xlgasymbol();
  99.     val = xlgetarg();
  100.     xllastarg();
  101.     return (structp(val) && getelement(val,0) == type ? true : NIL);
  102. }
  103.  
  104. /* xdefstruct - the 'defstruct' special form */
  105. LVAL xdefstruct()
  106. {
  107.     LVAL structname,slotname,defexpr,sym,tmp,args,body;
  108.     LVAL options,oargs,slots;
  109.     char FAR *pname;
  110.     int slotn;
  111.  
  112.     /* protect some pointers */
  113.     xlstkcheck(6);
  114.     xlsave(structname);
  115.     xlsave(slotname);
  116.     xlsave(defexpr);
  117.     xlsave(args);
  118.     xlsave(body);
  119.     xlsave(tmp);
  120.  
  121.     /* initialize */
  122.     args = body = NIL;
  123.     slotn = 0;
  124.  
  125.     /* get the structure name */
  126.     tmp = xlgetarg();
  127.     if (symbolp(tmp)) {
  128.         structname = tmp;
  129.         pname = getstring(getpname(structname));
  130. #ifdef MEDMEM
  131.         STRCPY(prefix, pname);
  132.         strcat(prefix, "-");
  133. #else
  134.         sprintf(prefix, "%s-", pname);
  135. #endif
  136.     }
  137.  
  138.     /* get the structure name and options */
  139.     else if (consp(tmp) && symbolp(car(tmp))) {
  140.         structname = car(tmp);
  141.         pname = getstring(getpname(structname));
  142. #ifdef MEDMEM
  143.         STRCPY(prefix, pname);
  144.         strcat(prefix, "-");
  145. #else
  146.         sprintf(prefix, "%s-", pname);
  147. #endif
  148.  
  149.         /* handle the list of options */
  150.         for (options = cdr(tmp); consp(options); options = cdr(options)) {
  151.  
  152.             /* get the next argument */
  153.             tmp = car(options);
  154.  
  155.             /* handle options that don't take arguments */
  156.             if (symbolp(tmp)) {
  157.                 xlerror("unknown option",tmp);
  158.             }
  159.  
  160.             /* handle options that take arguments */
  161.             else if (consp(tmp) && symbolp(car(tmp))) {
  162.                 oargs = cdr(tmp);
  163.  
  164.                 /* check for the :CONC-NAME keyword */
  165.                 if (car(tmp) == k_concname) {
  166.  
  167.                     /* get the name of the structure to include */
  168.                     if (!consp(oargs) || !symbolp(car(oargs)))
  169.                         xlerror("expecting a symbol",oargs);
  170.  
  171.                     /* save the prefix */
  172.                     STRCPY(prefix,getstring(getpname(car(oargs))));
  173.                 }
  174.  
  175.                 /* check for the :INCLUDE keyword */
  176.                 else if (car(tmp) == k_include) {
  177.  
  178.                     /* get the name of the structure to include */
  179.                     if (!consp(oargs) || !symbolp(car(oargs)))
  180.                         xlerror("expecting a structure name",oargs);
  181.                     tmp = car(oargs);
  182.                     oargs = cdr(oargs);
  183.  
  184.                     /* add each slot from the included structure */
  185.                     slots = xlgetprop(tmp,s_sslots);
  186.                     for (; consp(slots); slots = cdr(slots)) {
  187.                         if (consp(car(slots)) && consp(cdr(car(slots)))) {
  188.  
  189.                             /* get the next slot description */
  190.                             tmp = car(slots);
  191.  
  192.                             /* create the slot access functions */
  193.                             addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
  194.                         }
  195.                     }
  196.  
  197.                     /* handle slot initialization overrides */
  198.                     for (; consp(oargs); oargs = cdr(oargs)) {
  199.                         tmp = car(oargs);
  200.                         if (symbolp(tmp)) {
  201.                             slotname = tmp;
  202.                             defexpr = NIL;
  203.                         }
  204.                         else if (consp(tmp) && symbolp(car(tmp))) {
  205.                             slotname = car(tmp);
  206.                             defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  207.                         }
  208.                         else
  209.                             xlerror("bad slot description",tmp);
  210.                         updateslot(args,slotname,defexpr);
  211.                     }
  212.                 }
  213.                 else
  214.                     xlerror("unknown option",tmp);
  215.             }
  216.             else
  217.                 xlerror("bad option syntax",tmp);
  218.         }
  219.     }
  220.  
  221.     /* get each of the structure members */
  222.     while (moreargs()) {
  223.  
  224.         /* get the slot name and default value expression */
  225.         tmp = xlgetarg();
  226.         if (symbolp(tmp)) {
  227.             slotname = tmp;
  228.             defexpr = NIL;
  229.         }
  230.         else if (consp(tmp) && symbolp(car(tmp))) {
  231.             slotname = car(tmp);
  232.             defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  233.         }
  234.         else
  235.             xlerror("bad slot description",tmp);
  236.  
  237.         /* create a closure for non-trival default expressions */
  238.         if (defexpr != NIL) {
  239.             tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  240.             setbody(tmp,cons(defexpr,NIL));
  241.             tmp = cons(tmp,NIL);
  242.             defexpr = tmp;
  243.         }
  244.  
  245.         /* create the slot access functions */
  246.         addslot(slotname,defexpr,++slotn,&args,&body);
  247.     }
  248.  
  249.     /* store the slotnames and default expressions */
  250.     xlputprop(structname,args,s_sslots);
  251.  
  252.     /* enter the MAKE-xxx symbol */
  253. #ifdef MEDMEM
  254.     strcpy(buf, "MAKE-");
  255.     STRCAT(buf, pname);
  256. #else
  257.     sprintf(buf, makestr, pname);
  258. #endif
  259.     sym = xlenter(buf);
  260.  
  261.     /* make the MAKE-xxx function */
  262.     args = cons(lk_key,args);
  263.     tmp = cons(structname,NIL);
  264.     tmp = cons(s_quote,tmp);
  265.     body = cons(tmp,body);
  266.     body = cons(s_mkstruct,body);
  267.     body = cons(body,NIL);
  268.     setfunction(sym,
  269.                 xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
  270.  
  271.     /* enter the xxx-P symbol */
  272. #ifdef MEDMEM
  273.     STRCPY(buf, pname);
  274.     strcat(buf, "-P");
  275. #else
  276.     sprintf(buf,"%s-P", pname);
  277. #endif
  278.     sym = xlenter(buf);
  279.  
  280.     /* make the xxx-P function */
  281.     args = cons(s_x,NIL);
  282.     body = cons(s_x,NIL);
  283.     tmp = cons(structname,NIL);
  284.     tmp = cons(s_quote,tmp);
  285.     body = cons(tmp,body);
  286.     body = cons(s_strtypep,body);
  287.     body = cons(body,NIL);
  288.     setfunction(sym,
  289.                 xlclose(sym,s_lambda,args,body,NIL,NIL));
  290.  
  291.     /* enter the COPY-xxx symbol */
  292. #ifdef MEDMEM
  293.     strcpy(buf, "COPY-");
  294.     STRCAT(buf, pname);
  295. #else
  296.     sprintf(buf,"COPY-%s", pname);
  297. #endif
  298.     sym = xlenter(buf);
  299.  
  300.     /* make the COPY-xxx function */
  301.     args = cons(s_x,NIL);
  302.     body = cons(s_x,NIL);
  303.     body = cons(s_cpystruct,body);
  304.     body = cons(body,NIL);
  305.     setfunction(sym,
  306.                 xlclose(sym,s_lambda,args,body,NIL,NIL));
  307.  
  308.     /* restore the stack */
  309.     xlpopn(6);
  310.  
  311.     /* return the structure name */
  312.     return (structname);
  313. }
  314.  
  315. /* xlrdstruct - convert a list to a structure (used by the reader) */
  316. /* Modified by TAA to quote arguments and accept leading colons on keys */
  317. LVAL xlrdstruct(list)
  318.   LVAL list;
  319. {
  320.     LVAL structname,slotname,expr,last,val;
  321.  
  322.     /* protect the new structure */
  323.     xlsave1(expr);
  324.  
  325.     /* get the structure name */
  326.     if (!consp(list) || !symbolp(car(list)))
  327.     xlerror("bad structure initialization list",list);
  328.     structname = car(list);
  329.     list = cdr(list);
  330.  
  331.     /* enter the MAKE-xxx symbol */
  332. #ifdef MEDMEM
  333.     strcpy(buf, "MAKE-");
  334.     STRCAT(buf, getstring(getpname(structname)));
  335. #else
  336.     sprintf(buf, makestr, getstring(getpname(structname)));
  337. #endif
  338.  
  339.     /* initialize the MAKE-xxx function call expression */
  340.     expr = cons(xlenter(buf),NIL);
  341.     last = expr;
  342.  
  343.     /* turn the rest of the initialization list into keyword arguments */
  344.     while (consp(list) && consp(cdr(list))) {
  345.  
  346.     /* get the slot keyword name */
  347.     slotname = car(list);
  348.     if (!symbolp(slotname))
  349.         xlerror("expecting a slot name",slotname);
  350.  
  351.  
  352.     /* add the slot keyword */
  353.     if (*(getstring(getpname(slotname))) != ':') { /* add colon */
  354. #ifdef MEDMEM
  355.         strcpy(buf, ":");
  356.         STRCAT(buf, getstring(getpname(slotname)));
  357. #else
  358.         sprintf(buf,":%s",getstring(getpname(slotname)));
  359. #endif
  360.         rplacd(last,cons(xlenter(buf),NIL));
  361.     }
  362.     else {
  363.         rplacd(last,cons(slotname,NIL));
  364.     }
  365.     last = cdr(last);
  366.     list = cdr(list);
  367.  
  368.     /* add the value expression  -- QUOTED (TAA MOD) */
  369.     rplacd(last,cons(NIL,NIL));
  370.     last = cdr(last);
  371.     rplaca(last, (slotname = cons(s_quote,NIL)));
  372.     rplacd(slotname, cons(car(list), NIL));
  373.     list = cdr(list);
  374.     }
  375.  
  376.     /* make sure all of the initializers were used */
  377.     if (consp(list))
  378.     xlerror("bad structure initialization list",list);
  379.  
  380.     /* invoke the creation function */
  381.     val = xleval(expr);
  382.  
  383.     /* restore the stack */
  384.     xlpop();
  385.  
  386.     /* return the new structure */
  387.     return (val);
  388. }
  389.  
  390. /* xlprstruct - print a structure (used by printer) */
  391. void xlprstruct(fptr,vptr,flag)
  392.  LVAL fptr,vptr; int flag;
  393. {
  394.     LVAL next;
  395.     int i,n;
  396.     xlputstr(fptr,"#S(");   /* TAA MOD */
  397.     xlprint(fptr,getelement(vptr,0),flag);
  398.     next = xlgetprop(getelement(vptr,0),s_sslots);
  399.     for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
  400.         if (consp(car(next))) { /* should always succeed */
  401.             xlputc(fptr,' ');   /* Alternate, could print " :" */
  402.             xlprint(fptr,car(car(next)),flag);
  403.             xlputc(fptr,' ');
  404.             xlprint(fptr,getelement(vptr,i),flag);
  405.         }
  406.         next = cdr(next);
  407.     }
  408.     xlputc(fptr,')');
  409. }
  410.  
  411. /* addslot - make the slot access functions */
  412. LOCAL void NEAR addslot(slotname,defexpr,slotn,pargs,pbody)
  413.  LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
  414. {
  415.     LVAL sym,args,body,tmp;
  416.  
  417.     /* protect some pointers */
  418.     xlstkcheck(4);
  419.     xlsave(sym);
  420.     xlsave(args);
  421.     xlsave(body);
  422.     xlsave(tmp);
  423.  
  424.     /* construct the update function name */
  425. #ifdef MEDMEM
  426.     strcpy(buf, prefix);
  427.     STRCAT(buf, getstring(getpname(slotname)));
  428. #else
  429.     sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
  430. #endif
  431.     sym = xlenter(buf);
  432.  
  433.     /* make the access function */
  434.     args = cons(s_s,NIL);
  435.     body = cons(cvfixnum((FIXTYPE)slotn),NIL);
  436.     body = cons(s_s,body);
  437.     body = cons(s_strref,body);
  438.     body = cons(body,NIL);
  439.     setfunction(sym,
  440.                 xlclose(sym,s_lambda,args,body,NIL,NIL));
  441.  
  442.     /* make the update function */
  443.     args = cons(s_x,NIL);
  444.     args = cons(s_s,args);
  445.     body = cons(s_x,NIL);
  446.     body = cons(cvfixnum((FIXTYPE)slotn),body);
  447.     body = cons(s_s,body);
  448.     body = cons(s_strset,body);
  449.     body = cons(body,NIL);
  450.     xlputprop(sym,
  451.               xlclose(NIL,s_lambda,args,body,NIL,NIL),
  452.               s_setf);
  453.  
  454.     /* add the slotname to the make-xxx keyword list */
  455.     tmp = cons(defexpr,NIL);
  456.     tmp = cons(slotname,tmp);
  457.     tmp = cons(tmp,NIL);
  458.     if ((args = *pargs) == NIL)
  459.         *pargs = tmp;
  460.     else {
  461.         while (cdr(args) != NIL)
  462.             args = cdr(args);
  463.         rplacd(args,tmp);
  464.     }
  465.  
  466.     /* add the slotname to the %make-xxx argument list */
  467.     tmp = cons(slotname,NIL);
  468.     if ((body = *pbody) == NIL)
  469.         *pbody = tmp;
  470.     else {
  471.         while (cdr(body) != NIL)
  472.             body = cdr(body);
  473.         rplacd(body,tmp);
  474.     }
  475.  
  476.     /* restore the stack */
  477.     xlpopn(4);
  478. }
  479.  
  480. /* updateslot - update a slot definition */
  481. LOCAL void NEAR updateslot(args,slotname,defexpr)
  482.  LVAL args,slotname,defexpr;
  483. {
  484.     LVAL tmp;
  485.     for (; consp(args); args = cdr(args))
  486.         if (slotname == car(car(args))) {
  487.             if (defexpr != NIL) {
  488.                 xlsave1(tmp);
  489.                 tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  490.                 setbody(tmp,cons(defexpr,NIL));
  491.                 tmp = cons(tmp,NIL);
  492.                 defexpr = tmp;
  493.                 xlpop();
  494.             }
  495.             rplaca(cdr(car(args)),defexpr);
  496.             break;
  497.         }
  498.     if (args == NIL)
  499.         xlerror("unknown slot name",slotname);
  500. }
  501.  
  502.