Exemple #1
0
/******************************************************************************
 *                                                                            *
 ******************************************************************************/
int open_namelist(const char *fname)
{
    int nml = -1;
    FILE *f = fopen(fname, "r");
    NML *fl = NULL;

    if ( f == NULL ) {
        fprintf(stderr, "Could not open \"%s\"\n", fname);
        return -1;
    }

    nml = list_count++;
    file_list = realloc(file_list, sizeof(NML)*list_count);
    fl = &file_list[nml];
    fl->count = 0; fl->section = NULL;

    lineno = 0;
    while ( readline(f, buf) ) {
        if (buf[0] != '&') {
            fprintf(stderr, "Error in file \"%s\"\n", fname);
            fprintf(stderr, "\"%s\"\n",buf);
            list_count--;
            file_list = realloc(file_list, sizeof(NML)*list_count);
            nml = -1;
            break;
        }
        fl->count++;
        fl->section = realloc(fl->section, sizeof(NML_Section)*fl->count);
        get_section(f, &fl->section[fl->count-1], &buf[1]);
    }

    fclose(f);
#if DEBUG_NML
    show_namelist(nml);
    exit(0);
#endif

    return nml;
}
Exemple #2
0
static void
show_omp_node (int level, gfc_code *c)
{
  gfc_omp_clauses *omp_clauses = NULL;
  const char *name = NULL;

  switch (c->op)
    {
    case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
    case EXEC_OMP_BARRIER: name = "BARRIER"; break;
    case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
    case EXEC_OMP_FLUSH: name = "FLUSH"; break;
    case EXEC_OMP_DO: name = "DO"; break;
    case EXEC_OMP_MASTER: name = "MASTER"; break;
    case EXEC_OMP_ORDERED: name = "ORDERED"; break;
    case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
    case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
    case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
    case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
    case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
    case EXEC_OMP_SINGLE: name = "SINGLE"; break;
    case EXEC_OMP_TASK: name = "TASK"; break;
    case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
    case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
    case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
    default:
      gcc_unreachable ();
    }
  fprintf (dumpfile, "!$OMP %s", name);
  switch (c->op)
    {
    case EXEC_OMP_DO:
    case EXEC_OMP_PARALLEL:
    case EXEC_OMP_PARALLEL_DO:
    case EXEC_OMP_PARALLEL_SECTIONS:
    case EXEC_OMP_SECTIONS:
    case EXEC_OMP_SINGLE:
    case EXEC_OMP_WORKSHARE:
    case EXEC_OMP_PARALLEL_WORKSHARE:
    case EXEC_OMP_TASK:
      omp_clauses = c->ext.omp_clauses;
      break;
    case EXEC_OMP_CRITICAL:
      if (c->ext.omp_name)
	fprintf (dumpfile, " (%s)", c->ext.omp_name);
      break;
    case EXEC_OMP_FLUSH:
      if (c->ext.omp_namelist)
	{
	  fputs (" (", dumpfile);
	  show_namelist (c->ext.omp_namelist);
	  fputc (')', dumpfile);
	}
      return;
    case EXEC_OMP_BARRIER:
    case EXEC_OMP_TASKWAIT:
    case EXEC_OMP_TASKYIELD:
      return;
    default:
      break;
    }
  if (omp_clauses)
    {
      int list_type;

      if (omp_clauses->if_expr)
	{
	  fputs (" IF(", dumpfile);
	  show_expr (omp_clauses->if_expr);
	  fputc (')', dumpfile);
	}
      if (omp_clauses->final_expr)
	{
	  fputs (" FINAL(", dumpfile);
	  show_expr (omp_clauses->final_expr);
	  fputc (')', dumpfile);
	}
      if (omp_clauses->num_threads)
	{
	  fputs (" NUM_THREADS(", dumpfile);
	  show_expr (omp_clauses->num_threads);
	  fputc (')', dumpfile);
	}
      if (omp_clauses->sched_kind != OMP_SCHED_NONE)
	{
	  const char *type;
	  switch (omp_clauses->sched_kind)
	    {
	    case OMP_SCHED_STATIC: type = "STATIC"; break;
	    case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
	    case OMP_SCHED_GUIDED: type = "GUIDED"; break;
	    case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
	    case OMP_SCHED_AUTO: type = "AUTO"; break;
	    default:
	      gcc_unreachable ();
	    }
	  fprintf (dumpfile, " SCHEDULE (%s", type);
	  if (omp_clauses->chunk_size)
	    {
	      fputc (',', dumpfile);
	      show_expr (omp_clauses->chunk_size);
	    }
	  fputc (')', dumpfile);
	}
      if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
	{
	  const char *type;
	  switch (omp_clauses->default_sharing)
	    {
	    case OMP_DEFAULT_NONE: type = "NONE"; break;
	    case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
	    case OMP_DEFAULT_SHARED: type = "SHARED"; break;
	    case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
	    default:
	      gcc_unreachable ();
	    }
	  fprintf (dumpfile, " DEFAULT(%s)", type);
	}
      if (omp_clauses->ordered)
	fputs (" ORDERED", dumpfile);
      if (omp_clauses->untied)
	fputs (" UNTIED", dumpfile);
      if (omp_clauses->mergeable)
	fputs (" MERGEABLE", dumpfile);
      if (omp_clauses->collapse)
	fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
      for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
	if (omp_clauses->lists[list_type] != NULL
	    && list_type != OMP_LIST_COPYPRIVATE)
	  {
	    const char *type;
	    if (list_type >= OMP_LIST_REDUCTION_FIRST)
	      {
		switch (list_type)
		  {
		  case OMP_LIST_PLUS: type = "+"; break;
		  case OMP_LIST_MULT: type = "*"; break;
		  case OMP_LIST_SUB: type = "-"; break;
		  case OMP_LIST_AND: type = ".AND."; break;
		  case OMP_LIST_OR: type = ".OR."; break;
		  case OMP_LIST_EQV: type = ".EQV."; break;
		  case OMP_LIST_NEQV: type = ".NEQV."; break;
		  case OMP_LIST_MAX: type = "MAX"; break;
		  case OMP_LIST_MIN: type = "MIN"; break;
		  case OMP_LIST_IAND: type = "IAND"; break;
		  case OMP_LIST_IOR: type = "IOR"; break;
		  case OMP_LIST_IEOR: type = "IEOR"; break;
		  default:
		    gcc_unreachable ();
		  }
		fprintf (dumpfile, " REDUCTION(%s:", type);
	      }
	    else
	      {
		switch (list_type)
		  {
		  case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
		  case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
		  case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
		  case OMP_LIST_SHARED: type = "SHARED"; break;
		  case OMP_LIST_COPYIN: type = "COPYIN"; break;
		  default:
		    gcc_unreachable ();
		  }
		fprintf (dumpfile, " %s(", type);
	      }
	    show_namelist (omp_clauses->lists[list_type]);
	    fputc (')', dumpfile);
	  }
    }
  fputc ('\n', dumpfile);
  if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
    {
      gfc_code *d = c->block;
      while (d != NULL)
	{
	  show_code (level + 1, d->next);
	  if (d->block == NULL)
	    break;
	  code_indent (level, 0);
	  fputs ("!$OMP SECTION\n", dumpfile);
	  d = d->block;
	}
    }
  else
    show_code (level + 1, c->block->next);
  if (c->op == EXEC_OMP_ATOMIC)
    return;
  code_indent (level, 0);
  fprintf (dumpfile, "!$OMP END %s", name);
  if (omp_clauses != NULL)
    {
      if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
	{
	  fputs (" COPYPRIVATE(", dumpfile);
	  show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
	  fputc (')', dumpfile);
	}
      else if (omp_clauses->nowait)
	fputs (" NOWAIT", dumpfile);
    }
  else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
    fprintf (dumpfile, " (%s)", c->ext.omp_name);
}
Exemple #3
0
long scan_namelist(NAMELIST_TEXT *nl, char *line)
{
    register char *ptr, *ptr_e;
    char *ptr_p, *ptr_to_free ;
    long n_entities, i, j, length_values, length;
    char *values;
    static char *buffer = NULL;
    static long bufsize = 0;
#define BIGBUFSIZE 16384
#define INDEX_LIMIT 16380
#if !defined(vxWorks)
    long k, m, n, len, insideCommand;
    char psBuffer[16384], tempptr[16384], command[16384];
    FILE *fID;
#ifdef CONDOR_COMPILE
    char tmpName[1024];
#endif
#endif

    values = NULL;
    length_values = 0;
    if (!buffer)
        buffer = tmalloc(sizeof(*buffer)*(bufsize = 128));

    nl->n_entities = 0;
    nl->group_name = NULL;
    nl->entity   = NULL;
    nl->value    = NULL;
    nl->n_values = nl->n_subscripts = NULL;
    nl->subscript = nl->repeat = NULL;

#ifdef DEBUG
    printf("scan_namelist: line = <%s>\n", line);
#endif
    cp_str(&ptr_to_free, line);
    ptr = ptr_to_free;

    /* Find group name--it's a token starting with '$' or '&'. */
#if DOLLARSIGN_TOO
    if (!(ptr_p=next_unquoted_char(ptr, '$', '"')) &&
        !(ptr_p=next_unquoted_char(ptr, '&', '"')) ) {
        free(ptr_to_free);
        fprintf(stderr, "error: namelist scanning problem---missing group name:\n%s\n", ptr);
        return(-1);
        }
#else
    if (!(ptr_p=next_unquoted_char(ptr, '&', '"'))) {
        free(ptr_to_free);
        fprintf(stderr, "error: namelist scanning problem---missing group name:\n%s\n", ptr);
        return(-1);
        }
#endif
    ptr_p++;
    if ((nl->group_name=get_token(ptr_p))==NULL) {
        free(ptr_to_free);
        fprintf(stderr, "error: namelist scanning problem---missing group name:\n%s\n", ptr);
        return(-1);
        }
#ifdef DEBUG
    printf("scan_namelist: nl->group_name = <%s>\n", nl->group_name);
#endif

    /* Count entities--each entity is associated with an equals sign,
     * since these are all assignments. */
#if DOLLARSIGN_TOO
    n_entities = count_occurences(ptr_p, '=', "$&");
#else
    n_entities = count_occurences(ptr_p, '=', "&");
#endif
    if (n_entities==0) {
        free(ptr_to_free);
        return(nl->n_entities=0);
        }
#ifdef DEBUG
    printf("scan_namelist: n_entities = %ld\n", n_entities);
#endif

    /* allocate memory for parallel arrays representing the namelist:
     *   nl->entity is an array of entity names
     *   nl->value is an array of arrays of values assigned
     *   nl->repeat is an array of arrays of repeat factors applied to values
     *   nl->n_values is an array of numbers of values
     *   nl->n_subscripts is an array of numbers of subscripts
     *   nl->subscript is an array of arrays of subscripts
     */
    nl->entity   = tmalloc(sizeof(*(nl->entity  ))*n_entities);
    nl->value    = tmalloc(sizeof(*(nl->value   ))*n_entities);
    nl->repeat   = tmalloc(sizeof(*(nl->repeat  ))*n_entities);
    nl->n_values = tmalloc(sizeof(*(nl->n_values))*n_entities);
    nl->n_subscripts = tmalloc(sizeof(*(nl->n_subscripts))*n_entities);
    nl->subscript    = tmalloc(sizeof(*(nl->subscript))*n_entities);

#ifdef DEBUG
    printf("scan_namelist: allocation successful\n");
#endif

    /* scan individual items--look for entity names and successively extract
     * strings containing assignments for single entities.  For each string,
     * extract a list of values and repeat factors.
     */
    for (i=0; i<n_entities; i++) {
        /* Find next entity name, which terminates with '='.  ptr_p
         * points to the section of the string being parsed.  I.e., everything
         * before ptr_p has been parsed already. */
        if (!(ptr_e = next_unquoted_char(ptr_p, '=', '"'))) {
            fprintf(stderr, "scan_namelist: no '=' in string >%s<\n", ptr_p);
            exit(1);
            }

        ptr = ptr_e;
        while (isspace(*(ptr-1)))
            ptr--;
        *ptr = 0;                /* end entity name string at '=' or space */

        while (isspace(*ptr_p))    /* advance to start of name      */
            ptr_p++;
        cp_str(nl->entity+i, ptr_p);   /* copy the entity name */
        nl->n_subscripts[i] = extract_subscripts(nl->entity[i], nl->subscript+i);

#ifdef DEBUG
        printf("scan_namelist: nl->entity[%ld] = <%s>\n", i, nl->entity[i]);
        printf("remainder: <%s>\n", ptr_e+1);
#endif

        /* Set ptr to point to start of values list, which follows the '='
         * that was just found and deleted. */
        ptr = ptr_e + 1;

        /* Find next entity name, if there is one, and insert a 0 before it
         * to mark end of current values list. */
        if ((ptr_e = next_unquoted_char(ptr, '=', '"'))) {
            /* set ptr_e to point to end of values list for current entity,
             * which is at the comma or space preceeding the next entity name
             */
#ifdef DEBUG
            printf("scan_namelist: next list is <%s>\n", ptr_e);
#endif
            /* Skip whitespace and get to the entity name. */
            ptr_e--;
            while (isspace(*ptr_e) && ptr_e!=ptr)
                ptr_e--;
            /* Skip over the entity name. */
            while (*ptr_e==')' || *ptr_e=='}') {
                ptr_e--;
                while (*ptr_e!='(' && *ptr_e!='{' && ptr_e!=ptr)
                    ptr_e--;
                }
            while (!(isspace(*ptr_e) || *ptr_e==',') && ptr_e!=ptr)
                ptr_e--;
            ptr_p = ptr_e+1;      /* Save start of next entity. */
            /* Skip trailing whitespace and commas in the values list. */
            while ((isspace(*ptr_e) || *ptr_e==',') && ptr_e!=ptr)
                ptr_e--;
            /* If there's nothing left, there was no value given. */
            if (++ptr_e==ptr)
                bomb("missing value in namelist", NULL);
            /* Mark end of values with a NUL, and set ptr_p to the point
             * where processing begins for the next entity. */
            *ptr_e = 0;
            }
        else {
            /* There is no following entity, so there should be a '$end'
             * '&end', or just '$' or '&'.   */
            /* set ptr_e to $end of string, check for error */
#ifdef DEBUG
            printf("scan_namelist: last item is <%s>\n", ptr);
#endif
#if DOLLARSIGN_TOO
            if (!(ptr_e=next_unquoted_char(ptr, '&', '"')) && !(ptr_e=next_unquoted_char(ptr, '$', '"')) ) {
                fprintf(stderr, "error: namelist improperly terminated\n");
                return(-1);
                }
#else
            if (!(ptr_e=next_unquoted_char(ptr, '&', '"'))) {
                fprintf(stderr, "error: namelist improperly terminated\n");
                return(-1);
                }
#endif
            *ptr_e = 0;           /* Delete the symbol. */

            /* If the number of entities doesn't match what was counted before,
             * something is really goofy. */
            if (i!=n_entities-1) {
#ifdef DEBUG
                printf("scan_namelist: fatal error: n_entites=%ld, i=%ld\n", n_entities,
                      i);
#endif
                return(-1);
                }

            /* Scan backwards to the first token. Make sure there are some
             * values listed. */
            ptr_e--;
            while ((isspace(*ptr_e) || *ptr_e==',') && ptr_e!=ptr)
                ptr_e--;
            if (++ptr_e==ptr) {
#ifdef DEBUG
            printf("scan_namelist: fatal error: ptr_e = ptr\n");
            printf("scan_namelist: ptr = <%s>\n", ptr);
#endif
                fprintf(stderr, "error: no values listed for namelist field %s\n",
                        nl->entity[i]);
                return(-1);     /* No values listed. */
                }
            *ptr_e = 0;
            ptr_p = ptr_e;
            }
        /* ptr now points to the beginning of the values list, which is
         * NUL terminated.  ptr_p points to the beginning of the rest of
         * what remains to be parsed. */
#ifdef DEBUG
        printf("scan_namelist: values list = <%s>\n", ptr);
        printf("scan_namelist: remainder = <%s>\n", ptr_p);
#endif
#if !defined(vxWorks)
	length = strlen(ptr);
	if (length == 0) {
            fprintf(stderr, "error: missing values for namelist field %s\n",
                    nl->entity[i]);
            return -1;
	}
	n = 0;
	j = 0;
	k = 0;
	insideCommand = 0;
	while (n<length) {
	  if (j>INDEX_LIMIT) {
	      fprintf(stderr, "error: values for namelist field %s is too long\n",
		      nl->entity[i]);
	      return -1;
	  }
	  if (ptr[n]=='\\') {
            if (ptr[n+1]!='}' && ptr[n+1]!='{')
              tempptr[j++] = ptr[n++];
            else
              n++;
	    if (n<length) {
	      if (insideCommand) {
		command[k] = ptr[n];
		k++;
		n++;		
	      } else {
		tempptr[j] = ptr[n];
		j++;
		n++;
	      }
	    }
	  } else if (ptr[n]=='{') {
	    if (insideCommand) {
	      fprintf(stderr, "error: values for namelist field %s has invalid command brackets\n",
		      nl->entity[i]);
	      return -1;
	    }
	    insideCommand = 1;
	    k = 0;
	    n++;
	  } else if (ptr[n]=='}') {
	    if (!insideCommand) {
	      fprintf(stderr, "error: values for namelist field %s has invalid command brackets\n",
		      nl->entity[i]);
	      return -1;
	    }
	    insideCommand = 0;
	    command[k] = 0;
	    n++;
#ifndef CONDOR_COMPILE
	    if ((fID = popen(command, "r")) == NULL) {
	      fprintf(stderr, "error: invalid command for namelist field %s\n",
		      nl->entity[i]);
              fprintf(stderr, "command was %s\n", command);
	      return -1;
	    }
	    if (feof(fID)) {
	      fprintf(stderr, "error: command for namelist field %s returns EOF\n",
		      nl->entity[i]);
              fprintf(stderr, "command was %s\n", command);
	      return -1;
	    }
	    if (fgets(psBuffer, 128, fID) == NULL) {
	      fprintf(stderr, "error: command for namelist field %s returns NULL\n",
		      nl->entity[i]);
              fprintf(stderr, "command was %s\n", command);
	      return -1;
	    }
            pclose(fID);
#else
            tmpnam(tmpName);
            sprintf(psBuffer, "%s > %s", command, tmpName);
            system(psBuffer);
            if (!(fID = fopen(tmpName, "r"))) {
	      fprintf(stderr, "error: command for namelist field %s failed\n",
		      nl->entity[i]);
              fprintf(stderr, "command was %s\n", command);
	      return -1;
            }
            if (fgets(psBuffer, 128, fID) == NULL) {
	      fprintf(stderr, "error: command for namelist field %s returns NULL\n",
		      nl->entity[i]);
              fprintf(stderr, "command was %s\n", command);
	      return -1;
            }
            fclose(fID);
            remove(tmpName);
 #endif
	    len = strlen(psBuffer)-1;
	    if ((len > 0) && (psBuffer[len] == '\n')) {
	      psBuffer[len] = 0;
	    }
	    m = 0;
	    len = strlen(psBuffer);
	    if (j+len>INDEX_LIMIT) {
	      fprintf(stderr, "error: values for namelist field %s is too long\n",
		      nl->entity[i]);
	      return -1;
	    }
	    while (m < len) {
	      tempptr[j] = psBuffer[m];
	      j++;
	      m++;
	    } 
	  } else {
	    if (insideCommand) {
	      command[k] = ptr[n];
	      n++;
	      k++;
	    } else {
	      tempptr[j] = ptr[n];
	      n++;
	      j++;
	    }
	  }
	}
	tempptr[j] = 0;
	
	ptr = tempptr;
#endif
        /* Process string of values.  Values must be separated by commas. */
        length = strlen(ptr)+1;
        if (length==1) {
            fprintf(stderr, "error: missing values for namelist field %s\n",
                    nl->entity[i]);
            return -1;
            }
        if (values==NULL) {
            values = tmalloc(length*sizeof(*values));
            length_values = length;
            }
        else if (length>length_values) {
            tfree(values);
            values = tmalloc(length*sizeof(*values));
            }
        strcpy_ss(values, ptr);
        nl->n_values[i] = count_occurences(values, ',', "")+1;
        nl->value[i]    = tmalloc(sizeof(*(nl->value[i]))*nl->n_values[i]);
        nl->repeat[i]   = tmalloc(sizeof(*(nl->repeat[i]))*nl->n_values[i]);
#ifdef DEBUG
        printf("scan_namelist: allocation successful--nl->n_values[%ld]=%ld\n",
            i, nl->n_values[i]);
#endif

        for (j=0; j<nl->n_values[i]; j++) {
#ifdef DEBUG
          printf("scan_namelist: scanning tokens from >%s<\n",
                 values);
#endif
            ptr = nl->value[i][j] =
                    get_token_tq(values, ", ", ", ", "\"'", "\"'");
#ifdef DEBUG
            printf("scan_namelist: looping over values--j=%ld\n", j);
            printf("scan_namelist: token is <%s>\n", ptr);
#endif 
            if (!ptr) {
                fprintf(stderr, "error: missing values for namelist field %s\n",
                        nl->entity[i]);
                return -1;
                }
            if (!isdigit(*ptr)) {
                nl->repeat[i][j] = 1;
                un_quote(ptr);
                }
            else {
                ptr_e = ptr;
                while (isdigit(*ptr))
                    ptr++;
                if (*ptr!='*') {
                    nl->repeat[i][j] = 1;
                    continue;
                    }
                *ptr = 0;
                if ((length=strlen(ptr_e))-1>bufsize)
                    buffer = trealloc(buffer, sizeof(*buffer)*(bufsize=length+1024));
                strcpy_ss(buffer, ptr_e);
                strcpy_ss(nl->value[i][j], ptr+1);
                un_quote(nl->value[i][j]);
#ifdef DEBUG
                printf("doing repeat scan: ptr_e = <%s>  ptr+1 = <%s>\nbuffer = <%s>\n",
                    ptr_e, ptr+1, buffer);
#endif
                if (sscanf(buffer, "%ld", nl->repeat[i]+j)!=1)
                    bomb("bad repeat specifier in namelist", NULL);
                }
#ifdef DEBUG
            printf("scan_namelist: nl->value[%ld][%ld] = %ld*<%s>\n",
                i, j, nl->repeat[i][j], nl->value[i][j]);
            printf("remainder: <%s>\n\n", values);
#endif
            }
        }

    free(values);
    free(ptr_to_free);
#ifdef DEBUG
    nl->n_entities = n_entities;
    show_namelist(stdout, nl);
#endif
    return(nl->n_entities=n_entities);
    }