home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / src / Tools / ObjectTcl-1.1 / OtclMethod.C < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-30  |  15.7 KB  |  577 lines
  1. /*  _ __ ___ _
  2.  * | |\ /  /| |  $Id: OtclMethod.C,v 1.4 1995/05/09 16:14:33 deans Exp $
  3.  * | | /  / | |  Copyright (C) 1995 IXI Limited.
  4.  * |_|/__/_\|_|  IXI Limited, Cambridge, England.
  5.  *
  6.  * Component   : OtclMethod.C
  7.  *
  8.  * Author      : Dean Sheehan (deans@x.co.uk)
  9.  *
  10.  * Description : Contains the implementation of OtclMethod class and subclasses.
  11.  *
  12.  * License     :
  13.             Object Tcl License & Copyright
  14.             ------------------------------
  15.  
  16. IXI Object Tcl software, both binary and source (hereafter, Software) is copyrighted by IXI Limited (IXI), and ownership remains with IXI. 
  17.  
  18. IXI grants you (herafter, Licensee) a license to use the Software for academic, research and internal business purposes only, without a fee. Licensee may distribute the binary and source code (if required) to third parties provided that the copyright notice and this statement appears on all copies and that no charge is associated with such copies. 
  19.  
  20. Licensee may make derivative works. However, if Licensee distributes any derivative work based on or derived from the Software, then Licensee will (1) notify IXI regarding its distribution of the derivative work, and (2) clearly notify users that such derivative work is a modified version and not the original IXI Object Tcl distributed by IXI. IXI strongly recommends that Licensee provide IXI the right to incorporate such modifications into future releases of the Software under these license terms. 
  21.  
  22. Any Licensee wishing to make commercial use of the Software should contact IXI, to negotiate an appropriate license for such commercial use. Commercial use includes (1) integration of all or part of the source code into a product for sale or license by or on behalf of Licensee to third parties, or (2) distribution of the binary code or source code to third parties that need it to utilize a commercial product sold or licensed by or on behalf of Licensee. 
  23.  
  24. IXI MAKES NO REPRESENTATIONS ABOUT THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. IXI SHALL NOT BE LIABLE FOR ANY DAMAGES WHATSOEVER SUFFERED BY THE USERS OF THIS SOFTWARE. 
  25.  
  26. Copyright (C) 1995, IXI Limited 
  27.  
  28. By using or copying this Software, Licensee agrees to abide by the copyright law and all other applicable laws of England and the U.S., including, but not limited to, export control laws, and the terms of this license. IXI shall have the right to terminate this license immediately by written notice upon Licensee's breach of, or non-compliance with, any of its terms. Licensee may be held legally responsible for any copyright infringement that is caused or encouraged by Licensee's failure to abide by the terms of this license. 
  29.  
  30. Comments and questions are welcome and can be sent to
  31. otcl@x.co.uk 
  32.  
  33. For more information on copyright and licensing issues, contact: 
  34. Legal Department, IXI Limited, Vision Park, Cambridge CB4 4ZR,
  35. ENGLAND. 
  36.  
  37.  *
  38.  */
  39.  
  40. // Tcl Includes
  41. #include <tclInt.h>
  42.  
  43. // Local Includes
  44. #include "OtclError.H"
  45. #include "Otcl.H"
  46. #include "OtclMethod.H"
  47. #include "OtclFormalArg.H"
  48. #include "OtclPart.H"
  49.  
  50. OtclMethod::OtclMethod (char *n, OtclMethod::Access a, OtclClassOtcl *o)
  51. {
  52.    name = (char*)malloc(strlen(n) + strlen(o->giveName()) + 3);
  53.    sprintf(name,"%s::%s",o->giveName(),n);
  54.    access = a;
  55.    otclClass = o;
  56.    body = NULL;
  57.    formalArgHead = NULL;
  58.    formalArgTail = NULL;
  59.    currentFormalArg = NULL;
  60.    formalArgsSpecified = OTCL_FALSE;
  61. }
  62.  
  63. OtclMethod::~OtclMethod ()
  64. {
  65.    free(name);
  66.    if (body != NULL)
  67.    {
  68.       free(body);
  69.    }
  70.  
  71.    // Cleanup FormArgs...
  72.    OtclFormalArg *current = formalArgHead;
  73.    OtclFormalArg *previous = NULL;
  74.    while (current != NULL)
  75.    {
  76.       previous = current;
  77.       current = current->getNext();
  78.       delete previous;
  79.    }
  80. }
  81.  
  82. int OtclMethod::setFormalArgs (Tcl_Interp *interp, char *args)
  83. {
  84.    if (formalArgsSpecified == OTCL_TRUE)
  85.    {
  86.       return overlayFormalArgs(interp,args);
  87.    }
  88.    formalArgsSpecified = OTCL_TRUE;
  89.  
  90.    // Break args into argument specifiers.
  91.    int argc;
  92.    char **argv;
  93.    if (Tcl_SplitList(interp,args,&argc,&argv) == TCL_ERROR)
  94.    {
  95.       return TCL_ERROR;
  96.    }
  97.  
  98.    // Iterate over the argument specifiers
  99.    OtclFormalArg *formalArg;
  100.    int innerArgc;
  101.    char **innerArgv;
  102.    for (int arg = 0; arg < argc; arg++)
  103.    {
  104.       // Break the arg specifier into argument name and default value
  105.       if (Tcl_SplitList(interp,argv[arg],&innerArgc,&innerArgv) == TCL_ERROR)
  106.       {
  107.          free((char*)argv);
  108.          return TCL_ERROR;
  109.       }
  110.  
  111.       if (innerArgc == 0)
  112.       {
  113.          Otcl::setTclResult(interp,SYNTAX_ERROR_IN_FORMAL_ARG_ERR,arg+1,name,
  114.                             argv[arg]);
  115.          free((char*)argv);
  116.          free((char*)innerArgv);
  117.          return TCL_ERROR;
  118.       }
  119.  
  120.       if (innerArgc > 2)
  121.       {
  122.          // Too many parts to argument specifier
  123.          Otcl::setTclResult(interp,SYNTAX_ERROR_IN_FORMAL_ARG_ERR,arg+1,name,
  124.                             argv[arg]);
  125.          free((char*)argv);
  126.          free((char*)innerArgv);
  127.          return TCL_ERROR;
  128.       }
  129.  
  130.       if (argExists(innerArgv[0],NULL))
  131.       {
  132.          Otcl::setTclResult(interp,DUP_FORMAL_ARGUMENT_ERR,innerArgv[0],name);
  133.          free((char*)argv);
  134.          free((char*)innerArgv);
  135.          return TCL_ERROR;
  136.       }
  137.  
  138.       if (innerArgc == 1)
  139.       {
  140.          formalArg = new OtclFormalArg(innerArgv[0]);
  141.       }
  142.       else
  143.       {
  144.          formalArg = new OtclFormalArg(innerArgv[0],innerArgv[1]);
  145.       }
  146.  
  147.       // Link it into methods formal argument list
  148.       if (formalArgHead == NULL)
  149.       {
  150.          formalArgHead = formalArg;
  151.       }
  152.       else
  153.       {
  154.          formalArgTail->setNext(formalArg);
  155.       }
  156.       formalArgTail = formalArg;
  157.  
  158.       free((char*)innerArgv);
  159.       
  160.    } 
  161.  
  162.    free((char*)argv);
  163.  
  164.    return TCL_OK;
  165. }
  166.  
  167. int OtclMethod::overlayFormalArgs (Tcl_Interp *interp, char *args)
  168. {
  169.    // Break args into argument specifiers.
  170.    int argc;
  171.    char **argv;
  172.    if (Tcl_SplitList(interp,args,&argc,&argv) == TCL_ERROR)
  173.    {
  174.       return TCL_ERROR;
  175.    }
  176.  
  177.    // Iterate over the argument specifiers
  178.    OtclFormalArg *formalArg = formalArgHead;
  179.    int innerArgc;
  180.    char **innerArgv;
  181.    for (int arg = 0; arg < argc; arg++)
  182.    {
  183.  
  184.       if (formalArg == NULL)
  185.       {
  186.          free((char*)argv);
  187.          Otcl::setTclResult(interp,DIFF_NO_OF_FORMAL_ARGS_IN_SPECS_ERR,name);
  188.          return TCL_ERROR;
  189.       }
  190.  
  191.       // Break the arg specifier into argument name and default value
  192.       if (Tcl_SplitList(interp,argv[arg],&innerArgc,&innerArgv) == TCL_ERROR)
  193.       {
  194.          free((char*)argv);
  195.          return TCL_ERROR;
  196.       }
  197.  
  198.       if (innerArgc == 0)
  199.       {
  200.          Otcl::setTclResult(interp,SYNTAX_ERROR_IN_FORMAL_ARG_ERR,arg+1,name,
  201.                             argv[arg]);
  202.          free((char*)argv);
  203.          free((char*)innerArgv);
  204.          return TCL_ERROR;
  205.       }
  206.  
  207.       if (innerArgc > 1)
  208.       {
  209.          Otcl::setTclResult(interp,PUBLIC_IMP_DEFAULT_FORMAL_ARGS_ERR,name);
  210.          free((char*)argv);
  211.          free((char*)innerArgv);
  212.          return TCL_ERROR;
  213.       }
  214.  
  215.       if (argExists(innerArgv[0],formalArg))
  216.       {
  217.          Otcl::setTclResult(interp,DUP_FORMAL_ARGUMENT_ERR,innerArgv[0],name);
  218.          free((char*)argv);
  219.          free((char*)innerArgv);
  220.          return TCL_ERROR;
  221.       }
  222.  
  223.       // Specify the new name of the formal arg
  224.       formalArg->setName(innerArgv[0]);
  225.  
  226.       formalArg = formalArg->getNext();
  227.  
  228.       free((char*)innerArgv);
  229.    } 
  230.  
  231.    if (formalArg != NULL)
  232.    {
  233.       free((char*)argv);
  234.       Otcl::setTclResult(interp,DIFF_NO_OF_FORMAL_ARGS_IN_SPECS_ERR,name);
  235.       return TCL_ERROR;
  236.    }
  237.  
  238.    free((char*)argv);
  239.  
  240.    return TCL_OK;
  241. }
  242.  
  243. int OtclMethod::argExists (char *n, OtclFormalArg *end)
  244. {
  245.    OtclFormalArg *ofa = formalArgHead;
  246.    while (ofa != end)
  247.    {
  248.       if (strcmp(n,ofa->getName()) == 0)
  249.       {
  250.          return OTCL_TRUE;
  251.       }
  252.       ofa = ofa->getNext();
  253.    }
  254.    return OTCL_FALSE;
  255. }
  256.  
  257. int OtclMethod::setBody (Tcl_Interp *interp, char *b)
  258. {
  259.    if (body != NULL)
  260.    {
  261.       Otcl::setTclResult(interp,BODY_ALREADY_SPECIFIED_ERR,name);
  262.       return TCL_ERROR;
  263.    }
  264.  
  265.    body = strdup(b);
  266.    return TCL_OK;
  267. }
  268.  
  269. int OtclMethod::hasBody (void)
  270. {
  271.    return (body == NULL ? OTCL_FALSE : OTCL_TRUE);
  272. }
  273.  
  274. int OtclMethod::execute (Tcl_Interp *interp, int argc, char *argv[])
  275. {
  276.    if (bindActualToFormal(interp,argc,argv) != TCL_OK)
  277.    {
  278.       return TCL_ERROR;
  279.    }
  280.  
  281.    return evaluateMethodBody(interp);
  282. }
  283.  
  284. int OtclMethod::bindActualToFormal (Tcl_Interp *tclInterp,
  285.                                     int argc, char *argv[])
  286. {
  287.    // Cast the Tcl publicised interp structur to the private (actual)
  288.    // structure
  289.    Interp *interp = (Interp*)tclInterp;
  290.    CallFrame *frame = interp->framePtr;
  291.    frame->argc = argc;
  292.    frame->argv = argv;
  293.  
  294.    OtclFormalArg *current = formalArgHead;
  295.    int argIndex = 0;
  296.    while (current != NULL)
  297.    {
  298.       // if args finished then run over rest to fill in defaults
  299.       if (argIndex == argc)
  300.       {
  301.          while (current != NULL)
  302.          {
  303.             if (current->createLocal(tclInterp,frame) != TCL_OK)
  304.             {
  305.                char msg[256];
  306.                sprintf(msg,CALLING_INFO_ERR,name, interp->errorLine);
  307.                Tcl_AddErrorInfo(tclInterp,msg);
  308.                return TCL_ERROR;
  309.             }
  310.             current = current->getNext();
  311.          }
  312.          break;
  313.       }
  314.  
  315.       // If last formal arg and it is called 'args' it take the
  316.       // remainder of the actual args
  317.       if (current->getNext() == NULL && current->takesRemainingActuals())
  318.       {
  319.          if (current->createLocal(tclInterp,frame,(argc - argIndex),
  320.                                 &argv[argIndex]) != TCL_OK)
  321.          {
  322.             char msg[256];
  323.             sprintf(msg,CALLING_INFO_ERR,name, interp->errorLine);
  324.             Tcl_AddErrorInfo(tclInterp,msg);
  325.             return TCL_ERROR;
  326.          }
  327.          argIndex = argc; // As we have used up all the args!
  328.          break;
  329.       }
  330.  
  331.       // Finaly it looks like we have a normal case :-)
  332.       if (current->createLocal(tclInterp,frame,argv[argIndex]) != TCL_OK)
  333.       {
  334.          char msg[256];
  335.          sprintf(msg,CALLING_INFO_ERR,name,interp->errorLine);
  336.          Tcl_AddErrorInfo(tclInterp,msg);
  337.          return TCL_ERROR;
  338.       }
  339.  
  340.       argIndex++;
  341.       current = current->getNext();
  342.    }
  343.  
  344.    // if args left then error
  345.    if (argIndex != argc)
  346.    {
  347.       Otcl::setTclResult(tclInterp,TOO_MANY_ARGS_TO_METHOD_ERR,name);
  348.  
  349.       // Context
  350.       char msg[256];
  351.       sprintf(msg,CALLING_INFO_ERR,name,interp->errorLine);
  352.       Tcl_AddErrorInfo(tclInterp,msg);
  353.       return TCL_ERROR;
  354.    }
  355.  
  356.    return TCL_OK;
  357. }
  358.  
  359. int OtclMethod::evaluateMethodBody (Tcl_Interp *tclInterp)
  360. {
  361.    Interp *interp = (Interp*)tclInterp;
  362.  
  363.    int result = Tcl_Eval(tclInterp,body);
  364.  
  365.    char msg[256];
  366.  
  367.    switch (result)
  368.    {
  369.      case TCL_ERROR: 
  370.         // Record information telling where the error occurred.
  371.         sprintf(msg,CALLING_INFO_ERR,name, interp->errorLine);
  372.         Tcl_AddErrorInfo(tclInterp,msg);
  373.         break;
  374.  
  375.      case TCL_RETURN:
  376.         result = interp->returnCode;
  377.         interp->returnCode = TCL_OK;
  378.         if (result == TCL_ERROR)
  379.         {
  380.            Tcl_SetVar2(tclInterp,"errorCode",NULL,
  381.                      (interp->errorCode != NULL) ? interp->errorCode : "NONE",
  382.                      TCL_GLOBAL_ONLY);
  383.             interp->flags |= ERROR_CODE_SET;
  384.             if (interp->errorInfo != NULL)
  385.             {
  386.                Tcl_SetVar2(tclInterp,"errorInfo",NULL,
  387.                            interp->errorInfo, TCL_GLOBAL_ONLY);
  388.                interp->flags |= ERR_IN_PROGRESS;
  389.             }
  390.         }
  391.         break;
  392.  
  393.      case TCL_BREAK:
  394.         Otcl::setTclResult(tclInterp,BREAK_NOT_IN_LOOP_ERR);
  395.         result = TCL_ERROR;
  396.         break;
  397.  
  398.      case TCL_CONTINUE:
  399.         Otcl::setTclResult(tclInterp,CONTINUE_NOT_IN_LOOP_ERR);
  400.         result = TCL_ERROR;
  401.         break;
  402.    }
  403.  
  404.    return result;
  405. }
  406.  
  407. int OtclMethod::isAccessible (Tcl_Interp *interp)
  408. {
  409.    if (access == PUBLIC)
  410.    {
  411.       return OTCL_TRUE;
  412.    }
  413.  
  414.    // Look at the _otcl_class_ variable in the top interp frame
  415.    // if it exists and it point to the class owning this method then
  416.    // its accessible :-)
  417.    char *callingClass = Tcl_GetVar2(interp,OTCL_CLASS_VARIABLE_NAME,NULL,0);
  418.    if (callingClass != NULL)
  419.    {
  420.       OtclClass *callingClassPtr;
  421.       sscanf(callingClass,"%lx",(long**)&callingClassPtr);
  422.       if (callingClassPtr == otclClass)
  423.       {
  424.          return OTCL_TRUE;
  425.       }
  426.    }
  427.    
  428.    return OTCL_FALSE;
  429. }
  430.  
  431. char *OtclMethod::giveFirstFormalArgName (void)
  432. {
  433.    currentFormalArg = formalArgHead;
  434.    if (currentFormalArg != NULL)
  435.    {
  436.       return currentFormalArg->getName();
  437.    }
  438.    return NULL;
  439. }
  440.  
  441. char *OtclMethod::giveNextFormalArgName (void)
  442. {
  443.    if (currentFormalArg != NULL)
  444.    {
  445.       currentFormalArg = currentFormalArg->getNext();
  446.    }
  447.    if (currentFormalArg != NULL)
  448.    {
  449.       return currentFormalArg->getName();
  450.    }
  451.    return NULL;
  452. }
  453.  
  454. OtclInstanceMethod::OtclInstanceMethod (char *n, OtclMethod::Access a,
  455.                                         OtclClassOtcl *o) :
  456.    OtclMethod(n,a,o)
  457. {
  458. }
  459.  
  460. OtclInstanceMethod::~OtclInstanceMethod ()
  461. {
  462. }
  463.  
  464. OtclConstructorMethod::OtclConstructorMethod (OtclClassOtcl *o) :
  465.    OtclInstanceMethod(OTCL_CONSTRUCTOR_METHOD_NAME,OtclMethod::PUBLIC,o)
  466. {
  467.    for (int s = 0; s < MAX_SUPERCLASSES; s++)
  468.    {
  469.       parentConstructorArgs[s] = NULL;
  470.    }
  471. }
  472.  
  473. OtclConstructorMethod::~OtclConstructorMethod ()
  474. {
  475.    for (int s = 0; s < MAX_SUPERCLASSES; s++)
  476.    {
  477.       if (parentConstructorArgs[s] != NULL)
  478.       {
  479.          free((char*)parentConstructorArgs[s]);
  480.       }
  481.    }
  482. }
  483.  
  484. int OtclConstructorMethod::setParentConstructors (Tcl_Interp *interp,
  485.                                                   char *constructorStr)
  486. {
  487.    char **argv;
  488.    int argc;
  489.    if (Tcl_SplitList(interp,constructorStr,&argc,&argv) == TCL_ERROR)
  490.    {
  491.       return TCL_ERROR;
  492.    }
  493.  
  494.    int index;
  495.    for (int i = 0; i < argc; i++)
  496.    {
  497.       // The first word in the string is the name of the parent class.
  498.       char *endOfParent = strpbrk(argv[i]," \n\r\t");
  499.       if (endOfParent == NULL)
  500.       {
  501.          Otcl::setTclResult(interp,SYNTAX_ERROR_PARENT_CONSTRUCTOR_ERR,argv[i],
  502.                             otclClass->giveName());
  503.          free((char*)argv);
  504.          return TCL_ERROR;
  505.       }
  506.  
  507.       *endOfParent = NULL;
  508.       if ((index = otclClass->giveIndexOfSuperclass(argv[i])) == -1)
  509.       {
  510.          Otcl::setTclResult(interp,PARENT_CONSTRUCTOR_UNKNOWN_CLASS_ERR,
  511.                             otclClass->giveName(),argv[i]);
  512.          free((char*)argv);
  513.          return TCL_ERROR;
  514.       }
  515.  
  516.       if (parentConstructorArgs[index] != NULL)
  517.       {
  518.          // Duplicate call to parent class
  519.          Otcl::setTclResult(interp,DUP_CONSTRUCTOR_ERR,argv[i],
  520.                             otclClass->giveName());
  521.          free((char*)argv);
  522.          return TCL_ERROR;
  523.       }
  524.  
  525.       parentConstructorArgs[index] = strdup(endOfParent + 1);
  526.    }
  527.  
  528.    free((char*)argv);
  529.    return TCL_OK;
  530. }
  531.  
  532. int OtclConstructorMethod::execute (Tcl_Interp *interp, int argc, char *argv[],
  533.                                     OtclPartOtcl *part)
  534. {
  535.    if (bindActualToFormal(interp,argc,argv) != TCL_OK)
  536.    {
  537.       return TCL_ERROR;
  538.    }
  539.  
  540.    // invoke parts parent constructors
  541.    for (int s = 0; s < MAX_SUPERCLASSES; s++)
  542.    {
  543.       if (part->constructParent(s,interp,parentConstructorArgs[s]) != TCL_OK)
  544.       {
  545.          return TCL_ERROR;
  546.       }
  547.    }
  548.  
  549.    return evaluateMethodBody(interp);
  550. }
  551.  
  552. OtclDestructorMethod::OtclDestructorMethod (OtclClassOtcl *o) :
  553.    OtclInstanceMethod(OTCL_DESTRUCTOR_METHOD_NAME,OtclMethod::PUBLIC,o)
  554. {
  555. }
  556.  
  557. OtclDestructorMethod::~OtclDestructorMethod ()
  558. {
  559. }
  560.  
  561. int OtclDestructorMethod::setFormalArgs (Tcl_Interp *interp, char *)
  562. {
  563.    Otcl::setTclResult(interp,DESTRUCTOR_CANNOT_HAVE_ARGS_ERR,
  564.                       otclClass->giveName());
  565.    return TCL_ERROR;
  566. }
  567.  
  568. OtclClassMethod::OtclClassMethod (char *n, OtclMethod::Access a,
  569.                                   OtclClassOtcl *o) :
  570.    OtclMethod(n,a,o)
  571. {
  572. }
  573.  
  574. OtclClassMethod::~OtclClassMethod ()
  575. {
  576. }
  577.