int_procs.c

LastWave

        n++;
      }
    }
    
    /* Delete the old array and set the new one */
    Free(theCProcs);
    theCProcs = array;
    nCProcs = n;
    
    /* And sort it */
    qsort(theCProcs,nCProcs,sizeof(LWPROC),&qsortcmp);
  }   
}

/* Looking for a ccommand with name 'name' */
LWPROC GetCProc(char *name)
{
  LWPROC *pc;
  
  pc = (LWPROC *) bsearch(name,theCProcs,nCProcs,sizeof(LWPROC),&bsearchcmp);
  if (pc == NULL) return(NULL);
  return(*pc);
}

  
 
/***********************************************************************************
 *
 *  Managing the SCommands
 *
 ***********************************************************************************/
 
/* The hash table of the scommands */
static HASHTABLE procHashTable; 

static LWPROC NewSProc(void)
{
  LWPROC c;
  
  c = NewProc();
  
  c->flagSP = YES;
  
#ifdef DEBUGALLOC
DebugType = "SProc";
#endif

  c->p.sp = (SPROC) Malloc(sizeof(SProc));
 
   
  c->p.sp->varList = c->p.sp->varDefList = c->p.sp->varTypeList = NULL;
  c->p.sp->script = NULL;
  c->p.sp->filename = NULL;
  return(c);
}


/* Remove a command from the hash table (do not decrease the nref) */
LWPROC RemoveSProc(LWPROC c)
{
  LWPROC c1;
  char flagSP = c->flagSP;

  if (flagSP == NO) Errorf("RemoveSProc() : Weird error (%s)",c->name);

  c1 = (LWPROC) GetRemoveElemHashTable(procHashTable,c->name);
  if (c1 != c) 
    Errorf("RemoveSProc() Weird error");
  c1->flagStillExist = NO;
  
  return(c1);
}


/* Function to Initialize the scommands hash table (to be called at initialization) */
static void InitSProcs(void)
{
  /* We just need to create the hash table */
  procHashTable = NewHashTable(1000);  
}

/* Looking for a scommand and its index in the table */
LWPROC GetSProc(char *name)
{
  if (procHashTable==NULL) return(NULL);
  
  return((LWPROC) GetElemHashTable(procHashTable,name));
}


/* Check the name of a procedure */
char IsValidProcName(char *name)
{
  if (IsValidSymbolChar1(*name) == NO) return(NO);
  name++;
  while(*name != '\0') {
    if (IsValidSymbolChar(*name) == NO) return(NO);
    name++;
  }
  return(YES);
}


/* General GetProc */
LWPROC GetProc(char *name)
{
  LWPROC c;
  
  if (*name == '\\') return(GetCProc(name+1));
  c = GetSProc(name);
  if (c==NULL) return(GetCProc(name));
  else return(c);
}


/*
 * Get a variable Pattern
 */
int GetVarPattern(char **list,char ***type, char ***var, char ***def,char *procName)
{
  int n;
  char **list1;
  char *var1;
  
  n = GetListSize(list);
  
  *type = (char **) TMalloc((n+1)*sizeof(char *));
  *var = (char **) TMalloc((n+1)*sizeof(char *));
  *def = (char **) TMalloc((n+1)*sizeof(char *));
  
  n = 0;
  while (*list) {
    if (*list != NULL && **list == '{') {
      ParseWordList(*list,&list1);
      if (*list1 == NULL || 
          (**list1 != '&' && *(list1+1) != NULL && *(list1+2) != NULL) ||
          (**list1 == '&' && *(list1+1) == NULL) ||
          (**list1 == '&' && *(list1+1) != NULL && *(list1+2) != NULL && *(list1+3) != NULL)) {
        if (procName) Errorf("GetVarPattern() : Bad variable list in definition of procedure '%s'",procName);
        Errorf("GetVarPattern() : Bad variable pattern");
      }
      if (**list1 == '&') {
        (*type)[n] = GetArgType(*list1);
        if ((*type)[n] == NULL) {
          if (procName) Errorf("GetVarPattern() : Unknown variable type '%s' in variable list of procedure '%s'",*list1,procName);
          Errorf("GetVarPattern() : Unknown variable type '%s'\n",*list1);
        }
        list1++;
      }
      else (*type)[n] = NULL;
      (*var)[n] = list1[0];
      (*def)[n] = list1[1];
    }
    else {
      (*type)[n] = NULL;
      (*var)[n] = *list;
      (*def)[n] = NULL;
    }

    /* Check variable name */
    var1 = (*var)[n];
    if ((*var1 == '.'  && !IsValidSymbol(var1+1)) || (*var1 != '.'  && !IsValidSymbol(var1))) {
      if (procName) Errorf("GetVarPattern() : Bad variable name '%s' in variable list of procedure '%s'",var1,procName);
      Errorf("GetVarPattern() : Bad variable name '%s' in variable pattern",var1);
    }
    if (*var1 == '.' && list[1] != NULL) {
      if (procName) Errorf("GetVarPattern() : Dotted variable '%s' must be the last in variable list of procedure '%s'",var1,procName);
      Errorf("GetVarPattern() : Dotted variable '%s' must be the last in variable pattern",var1);
    }
    if (*var1 == '.' && (*type)[n] != NULL && (*type)[n] != wordlistType && (*type)[n] != listvType) {
      if (procName) Errorf("GetVarPattern() : Dotted variable '%s' must be of type '%s' or '%s' in variable list of procedure '%s'",var1,wordlistType,listvType,procName);
	  Errorf("GetVarPattern() : Dotted variable '%s' must of type '%s' or '%s'",var1,wordlistType,listvType);    
	}

    list++;
    n++;
  }

  (*type)[n] = NULL;
  (*var)[n] = NULL;
  (*def)[n] = NULL;
  
  return(n);
}


SPROC SetProc(char *name, char **list, char **help, SCRIPT script)
{
  int nargs;
  char **type,**def,**var;
  LWPROC sc;
  static char str[100]; 
  int i;
  char str4[30];

  /* Reading the variable pattern */
  if (*list == NULL) nargs = 0;
  else nargs = GetVarPattern(list,&type, &var, &def,NULL);

  /* Deleting former version of the function if not anonymous */
  if (name != NULL) {
    sc = GetProc(name);  
    if (sc != NULL) {
      if (sc->flagSP) {
        Printf("  ... redefining script command '%s'\n",sc->name);
        RemoveSProc(sc);
        Free(sc->name);
        sprintf(str4,"<%p>",(void *) sc);
        sc->name = CopyStr(str4);
        DeleteProc(sc);
      }
      else {
        Printf("  ... overloading C-Proc '%s'\n",sc->name);
        sc->flagStillExist = NO;
      }
    }
  }   

  /* Allocation of the sproc */ 
  sc = NewSProc();
  if (name != NULL) {
    sc->name = CopyStr(name);
  	AddElemHashTable(procHashTable,(AHASHELEM) sc);
  }
  else  {
    sprintf(str,"<%p>",(void *) sc);
    sc->name = CopyStr(str);
  }
  TempValue(sc);
  
  /* Setting the varList, varDefList, varTypeList of the scommand */
  sc->p.sp->varList = Malloc((nargs+1)*sizeof(char *));
  sc->p.sp->varDefList = Malloc((nargs+1)*sizeof(char *));
  sc->p.sp->varTypeList = Malloc((nargs+1)*sizeof(char *));
  for (i=0;i<nargs; i++) {
    sc->p.sp->varTypeList[i] = type[i];
    sc->p.sp->varList[i] = CopyStr(var[i]);
    if (def[i]) sc->p.sp->varDefList[i] = CopyStr(def[i]);
    else sc->p.sp->varDefList[i] = NULL;
  }    
  sc->p.sp->varList[i] = sc->p.sp->varTypeList[i] = sc->p.sp->varDefList[i] = NULL;    
  
  /* Set the script */
  sc->p.sp->script = script;
  script->nRef++;
  sc->flagStillExist = YES;
  
  /* Set the filename it has been sourced from */
  if (toplevelCur->sourceFilename != NULL) 
    sc->p.sp->filename = CopyStr(toplevelCur->sourceFilename);
  else
    sc->p.sp->filename = CopyStr("Terminal");
    
  /* Set the Usage and the help if any */  
  if (help != NULL) sc->description = CopyList(help);
  
  /* And the package name */
  if (toplevelCur->packageName != NULL) sc->package = CopyStr(toplevelCur->packageName);
  else sc->package = CopyStr("kernel");
  
  return((SPROC) sc);
}



/*
 * Defining a new scommand : the 'setproc' command 
 */

void C_SetProc(char **argv)
{ 
  int i;
  char **list,**help;
  char *name;
  SCRIPT script;
  
  /* reading the name */
  argv = ParseArgv(argv,tWORD,&name,-1);
  
  /* Checking the name */
  if (strcmp(name,"-") && !IsValidProcName(name)) Errorf("Invalid name for procedure '%s'",name);
  if (!strcmp(name,"-")) name = NULL;
  
  /* Counting the number of arguments */
  for (i = 0;argv[i] != NULL;i++);
  
  help = NULL;
  if (i == 2)  argv = ParseArgv(argv,tWORDLIST,&list,tSCRIPT,&script,0);
  else argv = ParseArgv(argv,tWORDLIST,&list,tLIST,&help,tSCRIPT,&script,0);
  
  SetResultValue(SetProc(name,list,help,script));
}


void  GetVarListProc (LWPROC c)
{
  char **varList,**varDefList, **varTypeList;

  InitResult();
  
    varList = c->p.sp->varList;
    if (varList == NULL) return;
    varDefList = c->p.sp->varDefList;
    varTypeList = c->p.sp->varTypeList;
    while(*varList != NULL) {
      if (*varTypeList != NULL) {
        if (*varDefList != NULL) AppendResultf("{%s %s %s}",*varTypeList,*varList,*varDefList);
        else AppendResultf("{%s %s}",*varTypeList,*varList);
      }
      else {
        if (*varDefList != NULL) AppendResultf("{%s %s}",*varList,*varDefList);
        else AppendResultStr(*varList);
      }
      if (varList[1] != NULL) AppendResultf(" ");
      varList++;
      varDefList++;
      varTypeList++;
    }

}

/*
 * Manipulating scommands ans ccommands
 */

void C_Proc(char **argv)
{
  char *action,*name,*str,*str1,*str2,*str3;
  LWPROC c,sc;
  char **list,**list1;
  int i;
  char opt;
  char flagMatch;
  int n;
  LISTV lv,lvs,lvc,lv1;
  char str4[100];
  
  argv = ParseArgv(argv,tWORD,&action,-1);
  
  /* help command */
  if (!strcmp(action,"help")) {
    argv = ParseArgv(argv,tSTR,&name,tLIST_,NULL,&list,0);
    if (list == NULL) {
	  c = GetProc(name);
	  if (c != NULL) {
	    lv = TNewListv();
	    if (c->description != NULL) {
	      for(list= c->description;*list != NULL;list++) {
	        ParseWordList(*list,&list1);
	        lv1 = TNewListv();
	        for(;*list1 != NULL;list1++) {
	          AppendStr2Listv(lv1,*list1);
	        }
	        AppendValue2Listv(lv,(VALUE) lv1);
	      } 
	    }
	    SetResultValue(lv);
	    return;
	  }
	  Errorf("Unknown command name '%s'",name);
	}
	else {
	  c = GetSProc(name);
	  if (c == NULL) Errorf("Unknown script command name '%s'",name);
	  if (c->description != NULL) DeleteList(c->description);
	  c->description = CopyList(list);
	}
  }


  /* get action */
  else if (!strcmp(action,"get")) {
    argv = ParseArgv(argv,tSTR,&name,0);
    c = GetProc(name);
    if (c == NULL) Errorf("Unknown procedure '%s'",name);
    SetResultValue(c);
    return;
  }

  /* var action */
  else if (!strcmp(action,"var")) {
    argv = ParseArgv(argv,tSTR,&name,0);
    SetResultStr("");
    c = GetSProc(name);
    if (c == NULL) Errorf("Unknown script command '%s'",name);
    GetVarListProc(c);
    return;
  }    

  /* The file action */
  else if (!strcmp(action,"file")) {
    argv = ParseArgv(argv,tSTR,&name,0);
    c = GetSProc(name);
    if (c == NULL) Errorf("Unknown script command '%s'",name);
    SetResultStr(c->p.sp->filename);
  }    

  /* The package action */
  else if (!strcmp(action,"package")) {
    argv = ParseArgv(argv,tSTR,&name,0);
    c = GetProc(name);
    if (c != NULL) {
      if (c->package) SetResultStr(c->package);
      return;
    }
    Errorf("Unknown command '%s'",name);
  }    

  /* The 'hash' action (used just for checking...) */
  else if (!strcmp(action,"hash")) {
    argv = ParseArgv(argv,0);
    for (i=0;i<procHashTable->nRows;i++) {
      n = 0;
      for (c = (LWPROC) procHashTable->rows[i]; c != NULL; c = c->next) n++;
      if (i != 0) AppendResultf(" %d",n);
      else AppendResultf("%d",n);
    }
  }
  
  /* script action */
  else if (!strcmp(action,"script")) {
    argv = ParseArgv(argv,tSTR,&name,0);
    c = GetSProc(name);
    if (c == NULL) Errorf("Unknown script command '%s'",name);  
    SetResultValue(c->p.sp->script);
  } 
  
  /* list, slist, clist  action */
  else if (!strcmp(action,"list") || !strcmp(action,"slist") || !strcmp(action,"clist")) {
    argv = ParseArgv(argv,tSTR_,"[^_]*",&str,tSTR_,"*",&str1,tSTR_,"*",&str2,-1);
    
    if (!strcmp(action,"slist")) str2 = str1;
    
    if (!strcmp(str1,"-m")) {
      str1[0] = '*';
      str1[1] = '\0';
      flagMatch = NO;
    }
    else flagMatch = YES;
    while(opt = ParseOption(&argv)) { 
      switch(opt) {
      case 'm': flagMatch = NO; break;
      default : ErrorOption(opt);
      }
    }  
    NoMoreArgs(argv);  

    lvs = NULL;
    if (!strcmp(action,"list") || !strcmp(action,"slist")) {
      lvs = TNewListv();
      lvc = NULL;
      for (i=0;i<procHashTable->nRows;i++) {
        for(c = (LWPROC) (procHashTable->rows[i]);c != NULL;c = c->next) {
          if (((flagMatch && MatchStr(c->name,str)) || (!flagMatch && !strcmp(c->name,str))) && 
              ((c->package == NULL && (!strcmp(str2,"*") || !strcmp(str2,""))) || (c->package != NULL && MatchStr(c->package,str2))))
            AppendStr2Listv(lvs,c->name);
        }
      }
    }

    if (!strcmp(action,"list") || !strcmp(action,"clist")) {
      
      lvc = TNewListv();
      if (*str == '\\') str3 = str+1;
      else str3 = str;     
      
      for (i=0;i<nCProcs;i++) {
        c = theCProcs[i];
        if (MatchStr(c->procTable->name,str1) && MatchStr(c->procTable->packageName,str2) &&
            ((flagMatch && MatchStr(c->name,str3)) || (!flagMatch && !strcmp(str3,c->name)))) {
          if (str3 != str) AppendListResultf("\\%s",c->name); 
          else  AppendStr2Listv(lvc,c->name);
        }
      } 
      
     } 
    
     if (lvs == NULL) SetResultValue(lvc);
     else if (lvc == NULL) SetResultValue(lvs);
     else {
       lv = TNewListv();
       AppendValue2Listv(lv,(VALUE) lvs);
       AppendValue2Listv(lv,(VALUE) lvc);
       SetResultValue(lv);
     }
  }
  
  /* ctable action */
  else if (!strcmp(action,"ctable")) {
    argv = ParseArgv(argv,tSTR_,"*",&str,tSTR_,"*",&str1,0);
    lv = TNewListv();
    for (i=0; theCCmdTables[i] != NULL; i++) {
      if (MatchStr(theCCmdTables[i]->name,str) && MatchStr(theCCmdTables[i]->packageName,str1)) {
        AppendStr2Listv(lv,theCCmdTables[i]->name);
      }
    }
    SetResultValue(lv);
  }
  
  /* delete action */
  else if (!strcmp(action,"delete")) {
  	if (*argv == NULL) Errorf("Missing <command> argument");
    while (1) {
      if (*argv == NULL) break;
      if (**argv == '%') {
        argv = ParseArgv(argv,tPROC,&c,-1);
        if (c->flagSP == NO) Errorf("Sorry cannot delete c-procedure '%s'",c->name);
      }
      else {
        argv = ParseArgv(argv,tSTR,&name,-1);
        c = (LWPROC) GetElemHashTable(procHashTable,name);
        if (c == NULL) Errorf("Unknown script command '%s'",name);
      }
      if (!(c->flagStillExist)) Errorf("The procedure '%s' is not in the procedure table",c->name);
      
      c->flagStillExist = NO;
      RemoveSProc(c);
      Free(c->name);
      sprintf(str4,"<%p>",(void *) c);
      c->name = CopyStr(str4);
      DeleteProc(c);
    }
  }

  /* undef action */
  else if (!strcmp(action,"undef")) {
    while (1) {
      if (*argv == NULL) break;
      argv = ParseArgv(argv,tWORD,&name,-1);
      c = (LWPROC) GetElemHashTable(procHashTable,name);
      if (c == NULL) Errorf("Unknown script command '%s'",name);
      c->flagStillExist = NO;
      RemoveSProc(c);
      Free(c->name);
      sprintf(str4,"<%p>",(void *) c);
      c->name = CopyStr(str4);
      DeleteProc(c);
    }
  }

  /* def action */
  else if (!strcmp(action,"def")) {
    argv = ParseArgv(argv,tWORD,&name,tPROC,&c,0);
    if (!IsValidProcName(name)) Errorf("Bad name for procedure : '%s'",name);
    if (c->flagSP == NO) Errorf("Expect a script procedure");
    c = (LWPROC) GetElemHashTable(procHashTable,name);
    if (c != NULL) Errorf("Expect an anonymous procedure");