Пример #1
0
void show_registers(struct pt_regs *regs)
{
	char *mode;

	mode = user_mode(regs) ? "User" : "Krnl";
	printk("%s PSW : %p %p (%pSR)\n",
	       mode, (void *) regs->psw.mask,
	       (void *) regs->psw.addr,
	       (void *) regs->psw.addr);
	printk("           R:%x T:%x IO:%x EX:%x Key:%x M:%x W:%x "
	       "P:%x AS:%x CC:%x PM:%x", mask_bits(regs, PSW_MASK_PER),
	       mask_bits(regs, PSW_MASK_DAT), mask_bits(regs, PSW_MASK_IO),
	       mask_bits(regs, PSW_MASK_EXT), mask_bits(regs, PSW_MASK_KEY),
	       mask_bits(regs, PSW_MASK_MCHECK), mask_bits(regs, PSW_MASK_WAIT),
	       mask_bits(regs, PSW_MASK_PSTATE), mask_bits(regs, PSW_MASK_ASC),
	       mask_bits(regs, PSW_MASK_CC), mask_bits(regs, PSW_MASK_PM));
#ifdef CONFIG_64BIT
	printk(" EA:%x", mask_bits(regs, PSW_MASK_EA | PSW_MASK_BA));
#endif
	printk("\n%s GPRS: " FOURLONG, mode,
	       regs->gprs[0], regs->gprs[1], regs->gprs[2], regs->gprs[3]);
	printk("           " FOURLONG,
	       regs->gprs[4], regs->gprs[5], regs->gprs[6], regs->gprs[7]);
	printk("           " FOURLONG,
	       regs->gprs[8], regs->gprs[9], regs->gprs[10], regs->gprs[11]);
	printk("           " FOURLONG,
	       regs->gprs[12], regs->gprs[13], regs->gprs[14], regs->gprs[15]);
	show_code(regs);
}
Пример #2
0
void print_backtrace_and_die(int sig, siginfo_t *info, void *secret)
{
	ucontext_t *uc = secret;
	unsigned long ip, bp, sp, addr;

	ip	= uc->uc_mcontext.gregs[IP_REG];
	bp	= uc->uc_mcontext.gregs[BP_REG];
	sp	= uc->uc_mcontext.gregs[SP_REG];
	addr	= (unsigned long) info->si_addr;

	switch (sig) {
	case SIGSEGV:
		trace_printf("SIGSEGV at %s %08lx while accessing memory address %08lx.\n",
			IP_REG_NAME, ip, addr);
		break;
	case SIGILL:
		trace_printf("SIGILL at %s %08lx\n", sig, IP_REG_NAME, ip);
		break;
	default:
		trace_printf("Signal %d at %s %08lx\n", sig, IP_REG_NAME, ip);
		break;
	};

	show_registers(uc->uc_mcontext.gregs);

	show_stack((void *) sp);

	show_code((void *) ip);

	print_trace_from(ip, (void *) bp);

	trace_flush();

	abort();
}
Пример #3
0
static void show_registers(struct pt_regs *regs)
{
	show_regs(regs);
	printk(KERN_NOTICE "Process %s (pid: %d, stackpage=%08lx)\n",
		current->comm, current->pid, (unsigned long) current);
	show_stack(current_thread_info()->task, (long *) regs->regs[0]);
	show_trace((long *) regs->regs[0]);
	show_code((unsigned int *) regs->cp0_epc);
	printk(KERN_NOTICE "\n");
}
Пример #4
0
void show_registers(struct pt_regs *regs)
{
	struct psw_bits *psw = &psw_bits(regs->psw);
	char *mode;

	mode = user_mode(regs) ? "User" : "Krnl";
	printk("%s PSW : %px %px", mode, (void *)regs->psw.mask, (void *)regs->psw.addr);
	if (!user_mode(regs))
		pr_cont(" (%pSR)", (void *)regs->psw.addr);
	pr_cont("\n");
	printk("           R:%x T:%x IO:%x EX:%x Key:%x M:%x W:%x "
	       "P:%x AS:%x CC:%x PM:%x", psw->per, psw->dat, psw->io, psw->ext,
	       psw->key, psw->mcheck, psw->wait, psw->pstate, psw->as, psw->cc, psw->pm);
	pr_cont(" RI:%x EA:%x\n", psw->ri, psw->eaba);
	printk("%s GPRS: %016lx %016lx %016lx %016lx\n", mode,
	       regs->gprs[0], regs->gprs[1], regs->gprs[2], regs->gprs[3]);
	printk("           %016lx %016lx %016lx %016lx\n",
	       regs->gprs[4], regs->gprs[5], regs->gprs[6], regs->gprs[7]);
	printk("           %016lx %016lx %016lx %016lx\n",
	       regs->gprs[8], regs->gprs[9], regs->gprs[10], regs->gprs[11]);
	printk("           %016lx %016lx %016lx %016lx\n",
	       regs->gprs[12], regs->gprs[13], regs->gprs[14], regs->gprs[15]);
	show_code(regs);
}
Пример #5
0
static void
show_namespace (gfc_namespace *ns)
{
  gfc_interface *intr;
  gfc_namespace *save;
  int op;
  gfc_equiv *eq;
  int i;

  gcc_assert (ns);
  save = gfc_current_ns;

  show_indent ();
  fputs ("Namespace:", dumpfile);

  i = 0;
  do
    {
      int l = i;
      while (i < GFC_LETTERS - 1
	     && gfc_compare_types (&ns->default_type[i+1],
				   &ns->default_type[l]))
	i++;

      if (i > l)
	fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
      else
	fprintf (dumpfile, " %c: ", l+'A');

      show_typespec(&ns->default_type[l]);
      i++;
    } while (i < GFC_LETTERS);

  if (ns->proc_name != NULL)
    {
      show_indent ();
      fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
    }

  ++show_level;
  gfc_current_ns = ns;
  gfc_traverse_symtree (ns->common_root, show_common);

  gfc_traverse_symtree (ns->sym_root, show_symtree);

  for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
    {
      /* User operator interfaces */
      intr = ns->op[op];
      if (intr == NULL)
	continue;

      show_indent ();
      fprintf (dumpfile, "Operator interfaces for %s:",
	       gfc_op2string ((gfc_intrinsic_op) op));

      for (; intr; intr = intr->next)
	fprintf (dumpfile, " %s", intr->sym->name);
    }

  if (ns->uop_root != NULL)
    {
      show_indent ();
      fputs ("User operators:\n", dumpfile);
      gfc_traverse_user_op (ns, show_uop);
    }
  
  for (eq = ns->equiv; eq; eq = eq->next)
    show_equiv (eq);

  fputc ('\n', dumpfile);
  show_indent ();
  fputs ("code:", dumpfile);
  show_code (show_level, ns->code);
  --show_level;

  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      fputs ("\nCONTAINS\n", dumpfile);
      ++show_level;
      show_namespace (ns);
      --show_level;
    }

  fputc ('\n', dumpfile);
  gfc_current_ns = save;
}
Пример #6
0
static void
show_code_node (int level, gfc_code *c)
{
  gfc_forall_iterator *fa;
  gfc_open *open;
  gfc_case *cp;
  gfc_alloc *a;
  gfc_code *d;
  gfc_close *close;
  gfc_filepos *fp;
  gfc_inquire *i;
  gfc_dt *dt;
  gfc_namespace *ns;

  if (c->here)
    {
      fputc ('\n', dumpfile);
      code_indent (level, c->here);
    }
  else
    show_indent ();

  switch (c->op)
    {
    case EXEC_END_PROCEDURE:
      break;

    case EXEC_NOP:
      fputs ("NOP", dumpfile);
      break;

    case EXEC_CONTINUE:
      fputs ("CONTINUE", dumpfile);
      break;

    case EXEC_ENTRY:
      fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
      break;

    case EXEC_INIT_ASSIGN:
    case EXEC_ASSIGN:
      fputs ("ASSIGN ", dumpfile);
      show_expr (c->expr1);
      fputc (' ', dumpfile);
      show_expr (c->expr2);
      break;

    case EXEC_LABEL_ASSIGN:
      fputs ("LABEL ASSIGN ", dumpfile);
      show_expr (c->expr1);
      fprintf (dumpfile, " %d", c->label1->value);
      break;

    case EXEC_POINTER_ASSIGN:
      fputs ("POINTER ASSIGN ", dumpfile);
      show_expr (c->expr1);
      fputc (' ', dumpfile);
      show_expr (c->expr2);
      break;

    case EXEC_GOTO:
      fputs ("GOTO ", dumpfile);
      if (c->label1)
	fprintf (dumpfile, "%d", c->label1->value);
      else
	{
	  show_expr (c->expr1);
	  d = c->block;
	  if (d != NULL)
	    {
	      fputs (", (", dumpfile);
	      for (; d; d = d ->block)
		{
		  code_indent (level, d->label1);
		  if (d->block != NULL)
		    fputc (',', dumpfile);
		  else
		    fputc (')', dumpfile);
		}
	    }
	}
      break;

    case EXEC_CALL:
    case EXEC_ASSIGN_CALL:
      if (c->resolved_sym)
	fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
      else if (c->symtree)
	fprintf (dumpfile, "CALL %s ", c->symtree->name);
      else
	fputs ("CALL ?? ", dumpfile);

      show_actual_arglist (c->ext.actual);
      break;

    case EXEC_COMPCALL:
      fputs ("CALL ", dumpfile);
      show_compcall (c->expr1);
      break;

    case EXEC_CALL_PPC:
      fputs ("CALL ", dumpfile);
      show_expr (c->expr1);
      show_actual_arglist (c->ext.actual);
      break;

    case EXEC_RETURN:
      fputs ("RETURN ", dumpfile);
      if (c->expr1)
	show_expr (c->expr1);
      break;

    case EXEC_PAUSE:
      fputs ("PAUSE ", dumpfile);

      if (c->expr1 != NULL)
	show_expr (c->expr1);
      else
	fprintf (dumpfile, "%d", c->ext.stop_code);

      break;

    case EXEC_ERROR_STOP:
      fputs ("ERROR ", dumpfile);
      /* Fall through.  */

    case EXEC_STOP:
      fputs ("STOP ", dumpfile);

      if (c->expr1 != NULL)
	show_expr (c->expr1);
      else
	fprintf (dumpfile, "%d", c->ext.stop_code);

      break;

    case EXEC_SYNC_ALL:
      fputs ("SYNC ALL ", dumpfile);
      if (c->expr2 != NULL)
	{
	  fputs (" stat=", dumpfile);
	  show_expr (c->expr2);
	}
      if (c->expr3 != NULL)
	{
	  fputs (" errmsg=", dumpfile);
	  show_expr (c->expr3);
	}
      break;

    case EXEC_SYNC_MEMORY:
      fputs ("SYNC MEMORY ", dumpfile);
      if (c->expr2 != NULL)
 	{
	  fputs (" stat=", dumpfile);
	  show_expr (c->expr2);
	}
      if (c->expr3 != NULL)
	{
	  fputs (" errmsg=", dumpfile);
	  show_expr (c->expr3);
	}
      break;

    case EXEC_SYNC_IMAGES:
      fputs ("SYNC IMAGES  image-set=", dumpfile);
      if (c->expr1 != NULL)
	show_expr (c->expr1);
      else
	fputs ("* ", dumpfile);
      if (c->expr2 != NULL)
	{
	  fputs (" stat=", dumpfile);
	  show_expr (c->expr2);
	}
      if (c->expr3 != NULL)
	{
	  fputs (" errmsg=", dumpfile);
	  show_expr (c->expr3);
	}
      break;

    case EXEC_LOCK:
    case EXEC_UNLOCK:
      if (c->op == EXEC_LOCK)
	fputs ("LOCK ", dumpfile);
      else
	fputs ("UNLOCK ", dumpfile);

      fputs ("lock-variable=", dumpfile);
      if (c->expr1 != NULL)
	show_expr (c->expr1);
      if (c->expr4 != NULL)
	{
	  fputs (" acquired_lock=", dumpfile);
	  show_expr (c->expr4);
	}
      if (c->expr2 != NULL)
	{
	  fputs (" stat=", dumpfile);
	  show_expr (c->expr2);
	}
      if (c->expr3 != NULL)
	{
	  fputs (" errmsg=", dumpfile);
	  show_expr (c->expr3);
	}
      break;

    case EXEC_ARITHMETIC_IF:
      fputs ("IF ", dumpfile);
      show_expr (c->expr1);
      fprintf (dumpfile, " %d, %d, %d",
		  c->label1->value, c->label2->value, c->label3->value);
      break;

    case EXEC_IF:
      d = c->block;
      fputs ("IF ", dumpfile);
      show_expr (d->expr1);

      ++show_level;
      show_code (level + 1, d->next);
      --show_level;

      d = d->block;
      for (; d; d = d->block)
	{
	  code_indent (level, 0);

	  if (d->expr1 == NULL)
	    fputs ("ELSE", dumpfile);
	  else
	    {
	      fputs ("ELSE IF ", dumpfile);
	      show_expr (d->expr1);
	    }

	  ++show_level;
	  show_code (level + 1, d->next);
	  --show_level;
	}

      if (c->label1)
	code_indent (level, c->label1);
      else
	show_indent ();

      fputs ("ENDIF", dumpfile);
      break;

    case EXEC_BLOCK:
      {
	const char* blocktype;
	gfc_namespace *saved_ns;

	if (c->ext.block.assoc)
	  blocktype = "ASSOCIATE";
	else
	  blocktype = "BLOCK";
	show_indent ();
	fprintf (dumpfile, "%s ", blocktype);
	++show_level;
	ns = c->ext.block.ns;
	saved_ns = gfc_current_ns;
	gfc_current_ns = ns;
	gfc_traverse_symtree (ns->sym_root, show_symtree);
	gfc_current_ns = saved_ns;
	show_code (show_level, ns->code);
	--show_level;
	show_indent ();
	fprintf (dumpfile, "END %s ", blocktype);
	break;
      }

    case EXEC_SELECT:
      d = c->block;
      fputs ("SELECT CASE ", dumpfile);
      show_expr (c->expr1);
      fputc ('\n', dumpfile);

      for (; d; d = d->block)
	{
	  code_indent (level, 0);

	  fputs ("CASE ", dumpfile);
	  for (cp = d->ext.block.case_list; cp; cp = cp->next)
	    {
	      fputc ('(', dumpfile);
	      show_expr (cp->low);
	      fputc (' ', dumpfile);
	      show_expr (cp->high);
	      fputc (')', dumpfile);
	      fputc (' ', dumpfile);
	    }
	  fputc ('\n', dumpfile);

	  show_code (level + 1, d->next);
	}

      code_indent (level, c->label1);
      fputs ("END SELECT", dumpfile);
      break;

    case EXEC_WHERE:
      fputs ("WHERE ", dumpfile);

      d = c->block;
      show_expr (d->expr1);
      fputc ('\n', dumpfile);

      show_code (level + 1, d->next);

      for (d = d->block; d; d = d->block)
	{
	  code_indent (level, 0);
	  fputs ("ELSE WHERE ", dumpfile);
	  show_expr (d->expr1);
	  fputc ('\n', dumpfile);
	  show_code (level + 1, d->next);
	}

      code_indent (level, 0);
      fputs ("END WHERE", dumpfile);
      break;


    case EXEC_FORALL:
      fputs ("FORALL ", dumpfile);
      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
	{
	  show_expr (fa->var);
	  fputc (' ', dumpfile);
	  show_expr (fa->start);
	  fputc (':', dumpfile);
	  show_expr (fa->end);
	  fputc (':', dumpfile);
	  show_expr (fa->stride);

	  if (fa->next != NULL)
	    fputc (',', dumpfile);
	}

      if (c->expr1 != NULL)
	{
	  fputc (',', dumpfile);
	  show_expr (c->expr1);
	}
      fputc ('\n', dumpfile);

      show_code (level + 1, c->block->next);

      code_indent (level, 0);
      fputs ("END FORALL", dumpfile);
      break;

    case EXEC_CRITICAL:
      fputs ("CRITICAL\n", dumpfile);
      show_code (level + 1, c->block->next);
      code_indent (level, 0);
      fputs ("END CRITICAL", dumpfile);
      break;

    case EXEC_DO:
      fputs ("DO ", dumpfile);
      if (c->label1)
	fprintf (dumpfile, " %-5d ", c->label1->value);

      show_expr (c->ext.iterator->var);
      fputc ('=', dumpfile);
      show_expr (c->ext.iterator->start);
      fputc (' ', dumpfile);
      show_expr (c->ext.iterator->end);
      fputc (' ', dumpfile);
      show_expr (c->ext.iterator->step);

      ++show_level;
      show_code (level + 1, c->block->next);
      --show_level;

      if (c->label1)
	break;

      show_indent ();
      fputs ("END DO", dumpfile);
      break;

    case EXEC_DO_CONCURRENT:
      fputs ("DO CONCURRENT ", dumpfile);
      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
        {
          show_expr (fa->var);
          fputc (' ', dumpfile);
          show_expr (fa->start);
          fputc (':', dumpfile);
          show_expr (fa->end);
          fputc (':', dumpfile);
          show_expr (fa->stride);

          if (fa->next != NULL)
            fputc (',', dumpfile);
        }
      show_expr (c->expr1);

      show_code (level + 1, c->block->next);
      code_indent (level, c->label1);
      fputs ("END DO", dumpfile);
      break;

    case EXEC_DO_WHILE:
      fputs ("DO WHILE ", dumpfile);
      show_expr (c->expr1);
      fputc ('\n', dumpfile);

      show_code (level + 1, c->block->next);

      code_indent (level, c->label1);
      fputs ("END DO", dumpfile);
      break;

    case EXEC_CYCLE:
      fputs ("CYCLE", dumpfile);
      if (c->symtree)
	fprintf (dumpfile, " %s", c->symtree->n.sym->name);
      break;

    case EXEC_EXIT:
      fputs ("EXIT", dumpfile);
      if (c->symtree)
	fprintf (dumpfile, " %s", c->symtree->n.sym->name);
      break;

    case EXEC_ALLOCATE:
      fputs ("ALLOCATE ", dumpfile);
      if (c->expr1)
	{
	  fputs (" STAT=", dumpfile);
	  show_expr (c->expr1);
	}

      if (c->expr2)
	{
	  fputs (" ERRMSG=", dumpfile);
	  show_expr (c->expr2);
	}

      if (c->expr3)
	{
	  if (c->expr3->mold)
	    fputs (" MOLD=", dumpfile);
	  else
	    fputs (" SOURCE=", dumpfile);
	  show_expr (c->expr3);
	}

      for (a = c->ext.alloc.list; a; a = a->next)
	{
	  fputc (' ', dumpfile);
	  show_expr (a->expr);
	}

      break;

    case EXEC_DEALLOCATE:
      fputs ("DEALLOCATE ", dumpfile);
      if (c->expr1)
	{
	  fputs (" STAT=", dumpfile);
	  show_expr (c->expr1);
	}

      if (c->expr2)
	{
	  fputs (" ERRMSG=", dumpfile);
	  show_expr (c->expr2);
	}

      for (a = c->ext.alloc.list; a; a = a->next)
	{
	  fputc (' ', dumpfile);
	  show_expr (a->expr);
	}

      break;

    case EXEC_OPEN:
      fputs ("OPEN", dumpfile);
      open = c->ext.open;

      if (open->unit)
	{
	  fputs (" UNIT=", dumpfile);
	  show_expr (open->unit);
	}
      if (open->iomsg)
	{
	  fputs (" IOMSG=", dumpfile);
	  show_expr (open->iomsg);
	}
      if (open->iostat)
	{
	  fputs (" IOSTAT=", dumpfile);
	  show_expr (open->iostat);
	}
      if (open->file)
	{
	  fputs (" FILE=", dumpfile);
	  show_expr (open->file);
	}
      if (open->status)
	{
	  fputs (" STATUS=", dumpfile);
	  show_expr (open->status);
	}
      if (open->access)
	{
	  fputs (" ACCESS=", dumpfile);
	  show_expr (open->access);
	}
      if (open->form)
	{
	  fputs (" FORM=", dumpfile);
	  show_expr (open->form);
	}
      if (open->recl)
	{
	  fputs (" RECL=", dumpfile);
	  show_expr (open->recl);
	}
      if (open->blank)
	{
	  fputs (" BLANK=", dumpfile);
	  show_expr (open->blank);
	}
      if (open->position)
	{
	  fputs (" POSITION=", dumpfile);
	  show_expr (open->position);
	}
      if (open->action)
	{
	  fputs (" ACTION=", dumpfile);
	  show_expr (open->action);
	}
      if (open->delim)
	{
	  fputs (" DELIM=", dumpfile);
	  show_expr (open->delim);
	}
      if (open->pad)
	{
	  fputs (" PAD=", dumpfile);
	  show_expr (open->pad);
	}
      if (open->decimal)
	{
	  fputs (" DECIMAL=", dumpfile);
	  show_expr (open->decimal);
	}
      if (open->encoding)
	{
	  fputs (" ENCODING=", dumpfile);
	  show_expr (open->encoding);
	}
      if (open->round)
	{
	  fputs (" ROUND=", dumpfile);
	  show_expr (open->round);
	}
      if (open->sign)
	{
	  fputs (" SIGN=", dumpfile);
	  show_expr (open->sign);
	}
      if (open->convert)
	{
	  fputs (" CONVERT=", dumpfile);
	  show_expr (open->convert);
	}
      if (open->asynchronous)
	{
	  fputs (" ASYNCHRONOUS=", dumpfile);
	  show_expr (open->asynchronous);
	}
      if (open->err != NULL)
	fprintf (dumpfile, " ERR=%d", open->err->value);

      break;

    case EXEC_CLOSE:
      fputs ("CLOSE", dumpfile);
      close = c->ext.close;

      if (close->unit)
	{
	  fputs (" UNIT=", dumpfile);
	  show_expr (close->unit);
	}
      if (close->iomsg)
	{
	  fputs (" IOMSG=", dumpfile);
	  show_expr (close->iomsg);
	}
      if (close->iostat)
	{
	  fputs (" IOSTAT=", dumpfile);
	  show_expr (close->iostat);
	}
      if (close->status)
	{
	  fputs (" STATUS=", dumpfile);
	  show_expr (close->status);
	}
      if (close->err != NULL)
	fprintf (dumpfile, " ERR=%d", close->err->value);
      break;

    case EXEC_BACKSPACE:
      fputs ("BACKSPACE", dumpfile);
      goto show_filepos;

    case EXEC_ENDFILE:
      fputs ("ENDFILE", dumpfile);
      goto show_filepos;

    case EXEC_REWIND:
      fputs ("REWIND", dumpfile);
      goto show_filepos;

    case EXEC_FLUSH:
      fputs ("FLUSH", dumpfile);

    show_filepos:
      fp = c->ext.filepos;

      if (fp->unit)
	{
	  fputs (" UNIT=", dumpfile);
	  show_expr (fp->unit);
	}
      if (fp->iomsg)
	{
	  fputs (" IOMSG=", dumpfile);
	  show_expr (fp->iomsg);
	}
      if (fp->iostat)
	{
	  fputs (" IOSTAT=", dumpfile);
	  show_expr (fp->iostat);
	}
      if (fp->err != NULL)
	fprintf (dumpfile, " ERR=%d", fp->err->value);
      break;

    case EXEC_INQUIRE:
      fputs ("INQUIRE", dumpfile);
      i = c->ext.inquire;

      if (i->unit)
	{
	  fputs (" UNIT=", dumpfile);
	  show_expr (i->unit);
	}
      if (i->file)
	{
	  fputs (" FILE=", dumpfile);
	  show_expr (i->file);
	}

      if (i->iomsg)
	{
	  fputs (" IOMSG=", dumpfile);
	  show_expr (i->iomsg);
	}
      if (i->iostat)
	{
	  fputs (" IOSTAT=", dumpfile);
	  show_expr (i->iostat);
	}
      if (i->exist)
	{
	  fputs (" EXIST=", dumpfile);
	  show_expr (i->exist);
	}
      if (i->opened)
	{
	  fputs (" OPENED=", dumpfile);
	  show_expr (i->opened);
	}
      if (i->number)
	{
	  fputs (" NUMBER=", dumpfile);
	  show_expr (i->number);
	}
      if (i->named)
	{
	  fputs (" NAMED=", dumpfile);
	  show_expr (i->named);
	}
      if (i->name)
	{
	  fputs (" NAME=", dumpfile);
	  show_expr (i->name);
	}
      if (i->access)
	{
	  fputs (" ACCESS=", dumpfile);
	  show_expr (i->access);
	}
      if (i->sequential)
	{
	  fputs (" SEQUENTIAL=", dumpfile);
	  show_expr (i->sequential);
	}

      if (i->direct)
	{
	  fputs (" DIRECT=", dumpfile);
	  show_expr (i->direct);
	}
      if (i->form)
	{
	  fputs (" FORM=", dumpfile);
	  show_expr (i->form);
	}
      if (i->formatted)
	{
	  fputs (" FORMATTED", dumpfile);
	  show_expr (i->formatted);
	}
      if (i->unformatted)
	{
	  fputs (" UNFORMATTED=", dumpfile);
	  show_expr (i->unformatted);
	}
      if (i->recl)
	{
	  fputs (" RECL=", dumpfile);
	  show_expr (i->recl);
	}
      if (i->nextrec)
	{
	  fputs (" NEXTREC=", dumpfile);
	  show_expr (i->nextrec);
	}
      if (i->blank)
	{
	  fputs (" BLANK=", dumpfile);
	  show_expr (i->blank);
	}
      if (i->position)
	{
	  fputs (" POSITION=", dumpfile);
	  show_expr (i->position);
	}
      if (i->action)
	{
	  fputs (" ACTION=", dumpfile);
	  show_expr (i->action);
	}
      if (i->read)
	{
	  fputs (" READ=", dumpfile);
	  show_expr (i->read);
	}
      if (i->write)
	{
	  fputs (" WRITE=", dumpfile);
	  show_expr (i->write);
	}
      if (i->readwrite)
	{
	  fputs (" READWRITE=", dumpfile);
	  show_expr (i->readwrite);
	}
      if (i->delim)
	{
	  fputs (" DELIM=", dumpfile);
	  show_expr (i->delim);
	}
      if (i->pad)
	{
	  fputs (" PAD=", dumpfile);
	  show_expr (i->pad);
	}
      if (i->convert)
	{
	  fputs (" CONVERT=", dumpfile);
	  show_expr (i->convert);
	}
      if (i->asynchronous)
	{
	  fputs (" ASYNCHRONOUS=", dumpfile);
	  show_expr (i->asynchronous);
	}
      if (i->decimal)
	{
	  fputs (" DECIMAL=", dumpfile);
	  show_expr (i->decimal);
	}
      if (i->encoding)
	{
	  fputs (" ENCODING=", dumpfile);
	  show_expr (i->encoding);
	}
      if (i->pending)
	{
	  fputs (" PENDING=", dumpfile);
	  show_expr (i->pending);
	}
      if (i->round)
	{
	  fputs (" ROUND=", dumpfile);
	  show_expr (i->round);
	}
      if (i->sign)
	{
	  fputs (" SIGN=", dumpfile);
	  show_expr (i->sign);
	}
      if (i->size)
	{
	  fputs (" SIZE=", dumpfile);
	  show_expr (i->size);
	}
      if (i->id)
	{
	  fputs (" ID=", dumpfile);
	  show_expr (i->id);
	}

      if (i->err != NULL)
	fprintf (dumpfile, " ERR=%d", i->err->value);
      break;

    case EXEC_IOLENGTH:
      fputs ("IOLENGTH ", dumpfile);
      show_expr (c->expr1);
      goto show_dt_code;
      break;

    case EXEC_READ:
      fputs ("READ", dumpfile);
      goto show_dt;

    case EXEC_WRITE:
      fputs ("WRITE", dumpfile);

    show_dt:
      dt = c->ext.dt;
      if (dt->io_unit)
	{
	  fputs (" UNIT=", dumpfile);
	  show_expr (dt->io_unit);
	}

      if (dt->format_expr)
	{
	  fputs (" FMT=", dumpfile);
	  show_expr (dt->format_expr);
	}

      if (dt->format_label != NULL)
	fprintf (dumpfile, " FMT=%d", dt->format_label->value);
      if (dt->namelist)
	fprintf (dumpfile, " NML=%s", dt->namelist->name);

      if (dt->iomsg)
	{
	  fputs (" IOMSG=", dumpfile);
	  show_expr (dt->iomsg);
	}
      if (dt->iostat)
	{
	  fputs (" IOSTAT=", dumpfile);
	  show_expr (dt->iostat);
	}
      if (dt->size)
	{
	  fputs (" SIZE=", dumpfile);
	  show_expr (dt->size);
	}
      if (dt->rec)
	{
	  fputs (" REC=", dumpfile);
	  show_expr (dt->rec);
	}
      if (dt->advance)
	{
	  fputs (" ADVANCE=", dumpfile);
	  show_expr (dt->advance);
	}
      if (dt->id)
	{
	  fputs (" ID=", dumpfile);
	  show_expr (dt->id);
	}
      if (dt->pos)
	{
	  fputs (" POS=", dumpfile);
	  show_expr (dt->pos);
	}
      if (dt->asynchronous)
	{
	  fputs (" ASYNCHRONOUS=", dumpfile);
	  show_expr (dt->asynchronous);
	}
      if (dt->blank)
	{
	  fputs (" BLANK=", dumpfile);
	  show_expr (dt->blank);
	}
      if (dt->decimal)
	{
	  fputs (" DECIMAL=", dumpfile);
	  show_expr (dt->decimal);
	}
      if (dt->delim)
	{
	  fputs (" DELIM=", dumpfile);
	  show_expr (dt->delim);
	}
      if (dt->pad)
	{
	  fputs (" PAD=", dumpfile);
	  show_expr (dt->pad);
	}
      if (dt->round)
	{
	  fputs (" ROUND=", dumpfile);
	  show_expr (dt->round);
	}
      if (dt->sign)
	{
	  fputs (" SIGN=", dumpfile);
	  show_expr (dt->sign);
	}

    show_dt_code:
      for (c = c->block->next; c; c = c->next)
	show_code_node (level + (c->next != NULL), c);
      return;

    case EXEC_TRANSFER:
      fputs ("TRANSFER ", dumpfile);
      show_expr (c->expr1);
      break;

    case EXEC_DT_END:
      fputs ("DT_END", dumpfile);
      dt = c->ext.dt;

      if (dt->err != NULL)
	fprintf (dumpfile, " ERR=%d", dt->err->value);
      if (dt->end != NULL)
	fprintf (dumpfile, " END=%d", dt->end->value);
      if (dt->eor != NULL)
	fprintf (dumpfile, " EOR=%d", dt->eor->value);
      break;

    case EXEC_OMP_ATOMIC:
    case EXEC_OMP_BARRIER:
    case EXEC_OMP_CRITICAL:
    case EXEC_OMP_FLUSH:
    case EXEC_OMP_DO:
    case EXEC_OMP_MASTER:
    case EXEC_OMP_ORDERED:
    case EXEC_OMP_PARALLEL:
    case EXEC_OMP_PARALLEL_DO:
    case EXEC_OMP_PARALLEL_SECTIONS:
    case EXEC_OMP_PARALLEL_WORKSHARE:
    case EXEC_OMP_SECTIONS:
    case EXEC_OMP_SINGLE:
    case EXEC_OMP_TASK:
    case EXEC_OMP_TASKWAIT:
    case EXEC_OMP_TASKYIELD:
    case EXEC_OMP_WORKSHARE:
      show_omp_node (level, c);
      break;

    default:
      gfc_internal_error ("show_code_node(): Bad statement code");
    }
}
Пример #7
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);
}
Пример #8
0
static void show_code0(int level, g95_code *c) {
g95_forall_iterator *fa;
char *module, *name;
g95_close *close;
g95_filepos *fp;
g95_inquire *i;
g95_open *open;
int m, comma;
g95_case *cp;
g95_alloc *a;
g95_code *d;
g95_dt *dt;

    code_indent(level, c->here); 

    switch(c->type) {
    case EXEC_NOP:
	g95_status("nop(");
	comma = 0;
	break;

    case EXEC_CONTINUE:
	g95_status("cont(");
	comma = 0;
	break;

    case EXEC_AC_START:
	g95_status("ac_start(sym='%s'", c->sym->name);
	comma = 1;
	break;

    case EXEC_AC_ASSIGN:
	g95_status("ac_assign(sym='%s', expr=", c->sym->name);
	g95_show_expr(c->expr);
	break;

    case EXEC_ASSIGN:
	g95_status("assign(lhs=");
	g95_show_expr(c->expr);
	g95_status(", rhs=");
	g95_show_expr(c->expr2);
	comma = 1;
	break;

    case EXEC_WHERE_ASSIGN:
	g95_status("where_assign(lhs=");
	g95_show_expr(c->expr);
	g95_status(", rhs=");
	g95_show_expr(c->expr2);
	comma = 1;
	break;

    case EXEC_POINTER_ASSIGN:
	g95_status("ptr_assign(lhs=");
	g95_show_expr(c->expr);
	g95_status(", rhs=");
	g95_show_expr(c->expr2);
	comma = 1;
	break;

    case EXEC_GOTO:
	if (c->label != NULL)
	    g95_status("goto(label=%d", c->label->value);
	else
	    g95_status("goto(var='%s'", c->sym->name);

	comma = 1;
	break;

    case EXEC_CALL:
	if (c->sym == NULL)
	    module = name = "";
	else {
	    module = c->sym->module;
	    name   = c->sym->name;
	}

	g95_status("call(name='%s:%s', sub='%s', arg=",
		   module, name, c->ext.sub.sub_name);
	show_actual_arglist(c->ext.sub.actual);
	comma = 1;
	break;

    case EXEC_RETURN:
	g95_status("ret(");
	comma = 0;

	if (c->expr) {
	    g95_status("value=");
	    g95_show_expr(c->expr);
	    comma = 1;
	}

	break;

    case EXEC_STOP:
	g95_status("stop(");

	if (c->expr != NULL) {
	    g95_status("expr=");
	    g95_show_expr(c->expr);
	} else
	    g95_status("code=%d", c->ext.stop_code);

	comma = 1;
	break;

  case EXEC_PAUSE:
      g95_status("pause(");

      if (c->expr != NULL) {
	  g95_status("expr=");
	  g95_show_expr(c->expr);
      } else
	  g95_status("code=%d", c->ext.stop_code);

      comma = 1;
      break;

    case EXEC_ARITHMETIC_IF:
	g95_status("arith_if(expr=");

	g95_show_expr(c->expr);

	g95_status(", lt0=%d, eq0=%d, gt0=%d",
		   c->label->value, c->label2->value, c->label3->value);

	comma = 1;
	break;

    case EXEC_IF:
	g95_status("log_if(expr=");
	g95_show_expr(c->expr);

	g95_status(", true=\n");
	show_code(level+1, c->block);

	if (c->ext.block != NULL) {
	    code_indent(level, 0);
	    g95_status(", else=\n");
	    show_code(level+1, c->ext.block);
	}

	code_indent(level, c->label);
	g95_status(") # ENDIF\n");
	break;

    case EXEC_SELECT:
	d = c->block;
	g95_status("select(expr=");
	g95_show_expr((c->expr != NULL) ? c->expr : c->expr2);
	g95_status(", cases=[\n");

	for(;d ;d=d->block) {
	    code_indent(level, 0);

	    g95_status("case(");
	    for(cp=d->ext.case_list; cp; cp=cp->next) {
		g95_status_char('(');
		g95_show_expr(cp->low);
		g95_status_char(' ');
		g95_show_expr(cp->high);
		g95_status_char(')');
		g95_status_char(' ');
	    }

	    g95_status_char('\n');

	    show_code(level+1, d->next);
	}

	code_indent(level, c->label);
	g95_status("END SELECT");
	break;

    case EXEC_WHERE:
	g95_status("WHERE ");

	d = c->block;
	g95_show_expr(d->expr);
	g95_status_char('\n');

	show_code(level+1, d->next);

	for(d=d->block; d; d=d->block) {
	    code_indent(level, 0);
	    g95_status("ELSE WHERE ");
	    g95_show_expr(d->expr);
	    g95_status_char('\n');
	    show_code(level+1, d->next);
	}

	code_indent(level, 0);
	g95_status("END WHERE");
	break;

    case EXEC_FORALL:
	g95_status("FORALL ");
	for(fa=c->ext.forall_iterator; fa; fa=fa->next) {
	    g95_show_expr(fa->var);
	    g95_status_char(' ');
	    g95_show_expr(fa->start);
	    g95_status_char(':');
	    g95_show_expr(fa->end);
	    g95_status_char(':');
	    g95_show_expr(fa->stride);

	    if (fa->next != NULL)
		g95_status_char(',');
	}

	if (c->expr != NULL) {
	    g95_status_char(',');
	    g95_show_expr(c->expr);
	}

	g95_status_char('\n');

	show_code(level+1, c->block);

	code_indent(level, 0);
	g95_status("END FORALL");
	break;
    
    case EXEC_DO:
	g95_status("do(var=");
	g95_show_expr(c->ext.iterator->var);

	g95_status(", start=");
	g95_show_expr(c->ext.iterator->start);

	g95_status(", end=");
	g95_show_expr(c->ext.iterator->end);

	g95_status(", step=");
	g95_show_expr(c->ext.iterator->step);

	g95_status(", body=\n");
	show_code(level+1, c->block);

	code_indent(level, 0);
	comma = 1;
	break;

    case EXEC_DO_WHILE:
	g95_status("do_while(expr=");
	g95_show_expr(c->expr);
	g95_status(", body=");

	show_code(level+1, c->block);

	code_indent(level, c->label);
	break;

    case EXEC_CYCLE:
	g95_status("cycle(");
	comma = 0;

	if (c->sym) {
	    g95_status("label='%s'", c->sym->name);
	    comma = 1;
	}

	break;

    case EXEC_EXIT:
	g95_status("exit(");
	comma = 0;

	if (c->sym) {
	    g95_status("label='%s'", c->sym->name);
	    comma = 1;
	}

	break;

    case EXEC_ALLOCATE:
	g95_status("allocate(");
	comma = 0;

	if (c->expr) {
	    g95_status("stat=");
	    g95_show_expr(c->expr);
	    comma = 1;
	}

	if (comma)
	    g95_status(", ");

	g95_status("alloc=[");

	for(a=c->ext.alloc_list; a; a=a->next) {
	    g95_show_expr(a->expr);
	    g95_status_char('(');

	    for(m=0; m < a->rank+a->corank; m++) {
		g95_show_expr(a->lower[m]);
		g95_status_char(':');
		g95_show_expr(a->upper[m]);

		if (m != a->rank + a->corank - 1)
		    g95_status_char(',');
	    }

	    g95_status_char(')');

	    if (a->next != NULL)
		g95_status(", ");
	}

	g95_status_char(']');
	comma = 1;
	break;

    case EXEC_DEALLOCATE:
	g95_status("deallocate(");
	comma = 0;

	if (c->expr) {
	    g95_status("stat=");
	    g95_show_expr(c->expr);
	    comma = 1;
	}

	if (comma)
	    g95_status(", ");

	g95_status("alloc=[");

	for(a=c->ext.alloc_list; a; a=a->next) {
	    g95_show_expr(a->expr);
	    if (a->next != NULL)
		g95_status(", ");
	}

	g95_status_char(']');
	comma = 1;
	break;

    case EXEC_OPEN:
	g95_status("open_(");
	open = c->ext.open;
	comma = 0;

	if (open->unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(open->unit);
	    comma = 1;
	}

	if (open->iostat) {
	    if (comma)
		g95_status(", ");

	    g95_status("iostat=");
	    g95_show_expr(open->iostat);
	    comma = 1;
	}

	if (open->file) {
	    if (comma)
		g95_status(", ");

	    g95_status("file=");
	    g95_show_expr(open->file);
	    comma = 1;
	}

	if (open->status) {
	    if (comma)
		g95_status(", ");

	    g95_status("status=");
	    g95_show_expr(open->status);
	    comma = 1;
	}

	if (open->access) {
	    if (comma)
		g95_status(", ");

	    g95_status("access=");
	    g95_show_expr(open->access);
	    comma = 1;
	}

	if (open->form) {
	    if (comma)
		g95_status(", ");

	    g95_status("form=");
	    g95_show_expr(open->form);
	    comma = 1;
	}

	if (open->recl) {
	    if (comma)
		g95_status(", ");

	    g95_status("recl=");
	    g95_show_expr(open->recl);
	    comma = 1;
	}

	if (open->blank) {
	    if (comma)
		g95_status(", ");

	    g95_status("blank=");
	    g95_show_expr(open->blank);
	    comma = 1;
	}

	if (open->position) {
	    if (comma)
		g95_status(", ");

	    g95_status("position=");
	    g95_show_expr(open->position);
	    comma = 1;
	}

	if (open->action) {
	    if (comma)
		g95_status(", ");

	    g95_status("action=");
	    g95_show_expr(open->action);
	    comma = 1;
	}

	if (open->delim) {
	    if (comma)
		g95_status(", ");

	    g95_status("delim=");
	    g95_show_expr(open->delim);
	    comma = 1;
	}

	if (open->pad) {
	    if (comma)
		g95_status(", ");

	    g95_status("pad=");
	    g95_show_expr(open->pad);
	    comma = 1;
	}

	if (open->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", open->err->value);
	    comma = 1;
	}

	break;

    case EXEC_CLOSE:
	g95_status("close(");
	close = c->ext.close;
	comma = 0;

	if (close->unit) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("unit=");
	    g95_show_expr(close->unit);
	    comma = 1;
	}

	if (close->iostat) {
	    if (comma)
		g95_status(", ");

	    g95_status("iostat=");
	    g95_show_expr(close->iostat);
	    comma = 1;
	}

	if (close->status) {
	    if (comma)
		g95_status(", ");

	    g95_status("status=");
	    g95_show_expr(close->status);
	    comma = 1;
	}

	if (close->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", close->err->value);
	    comma = 1;
	}

	break;

    case EXEC_BACKSPACE:
	g95_status("backspace(");
	goto show_filepos;

    case EXEC_ENDFILE:
	g95_status("endfile(");
	goto show_filepos;

    case EXEC_REWIND:
	g95_status("rewind(");

    show_filepos:
	fp = c->ext.filepos;
	comma = 0;

	if (fp->unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(fp->unit);
	    comma = 1;
	}

	if (fp->iostat) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("iostat=");
	    g95_show_expr(fp->iostat);
	    comma = 1;
	}

	if (fp->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", fp->err->value);
	    comma = 1;
	}

	break;

    case EXEC_INQUIRE:
	g95_status("inquire(");
	i = c->ext.inquire;
	comma = 0;

	if (i->unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(i->unit);
	    comma = 1;
	}

	if (i->file) {
	    if (comma)
		g95_status(", ");

	    g95_status("file=");
	    g95_show_expr(i->file);
	    comma = 1;
	}

	if (i->iostat) {
	    if (comma)
		g95_status(", ");

	    g95_status("iostat=");
	    g95_show_expr(i->iostat);
	    comma = 1;
	}

	if (i->exist) {
	    if (comma)
		g95_status(", ");

	    g95_status("exist=");
	    g95_show_expr(i->exist);
	    comma = 1;
	}

	if (i->opened) {
	    if (comma)
		g95_status(", ");

	    g95_status("opened=");
	    g95_show_expr(i->opened);
	    comma = 1;
	}

	if (i->number) {
	    if (comma)
		g95_status(", ");

	    g95_status("number=");
	    g95_show_expr(i->number);
	    comma = 1;
	}

	if (i->named) {
	    if (comma)
		g95_status(", ");

	    g95_status("named=");
	    g95_show_expr(i->named);
	    comma = 1;
	}

	if (i->name) {
	    if (comma)
		g95_status(", ");

	    g95_status("name=");
	    g95_show_expr(i->name);
	    comma = 1;
	}

	if (i->access) {
	    if (comma)
		g95_status(", ");

	    g95_status("access=");
	    g95_show_expr(i->access);
	    comma = 1;
	}

	if (i->sequential) {
	    if (comma)
		g95_status(", ");

	    g95_status("sequential=");
	    g95_show_expr(i->sequential);
	    comma = 1;
	}

	if (i->direct) {
	    if (comma)
		g95_status(", ");

	    g95_status("direct=");
	    g95_show_expr(i->direct);
	    comma = 1;
	}

	if (i->form) {
	    if (comma)
		g95_status(", ");

	    g95_status("form=");
	    g95_show_expr(i->form);
	    comma = 1;
	}

	if (i->formatted) {
	    if (comma)
		g95_status(", ");

	    g95_status("formatted=");
	    g95_show_expr(i->formatted);
	    comma = 1;
	}

	if (i->unformatted) {
	    if (comma)
		g95_status(", ");

	    g95_status("unformatted=");
	    g95_show_expr(i->unformatted);
	    comma = 1;
	}

	if (i->recl) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("recl=");
	    g95_show_expr(i->recl);
	    comma = 1;
	}

	if (i->nextrec) {
	    if (comma)
		g95_status(", ");

	    g95_status("nextrec=");
	    g95_show_expr(i->nextrec);
	    comma = 1;
	}

	if (i->blank) {
	    if (comma)
		g95_status(", ");

	    g95_status("blank=");
	    g95_show_expr(i->blank);
	    comma = 1;
	}

	if (i->position) {
	    if (comma)
		g95_status(", ");

	    g95_status("position=");
	    g95_show_expr(i->position);
	    comma = 1;
	}

	if (i->action) {
	    if (comma)
		g95_status(", ");

	    g95_status("action=");
	    g95_show_expr(i->action);
	    comma = 1;
	}

	if (i->read) {
	    if (comma)
		g95_status(", ");

	    g95_status("read=");
	    g95_show_expr(i->read);
	    comma = 1;
	}

	if (i->write) {
	    if (comma)
		g95_status(", ");

	    g95_status("write=");
	    g95_show_expr(i->write);
	    comma = 1;
	}

	if (i->readwrite) {
	    if (comma)
		g95_status(", ");

	    g95_status("readwrite=");
	    g95_show_expr(i->readwrite);
	    comma = 1;
	}

	if (i->delim) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("delim=");
	    g95_show_expr(i->delim);
	    comma = 1;
	}

	if (i->stream != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("stream=");
	    g95_show_expr(i->stream);
	    comma = 1;
	}

	if (i->pad) {
	    if (comma)
		g95_status(", ");

	    g95_status("pad=");
	    g95_show_expr(i->pad);
	    comma = 1;
	}

	if (i->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", i->err->value);
	    comma = 1;
	}

	break;

    case EXEC_IOLENGTH:
	g95_status("iolength(expr=");
	g95_show_expr(c->expr);
	comma = 0;
	break;

    case EXEC_READ:
	g95_status("read(expr=");
	goto show_dt;

    case EXEC_WRITE:
	g95_status("write(expr=");

    show_dt:
	dt = c->ext.dt;
	comma = 0;

	if (dt->io_unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(dt->io_unit);
	    comma = 1;
	}

	if (dt->format_expr) {
	    if (comma)
		g95_status(", ");

	    g95_status("format_expr=");
	    g95_show_expr(dt->format_expr);
	    comma = 1;
	}

	if (dt->format_label != NULL) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("format_label=%d", dt->format_label->value);
	    comma = 1;
	}

	if (dt->namelist != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("nml=%s", dt->namelist->name);
	    comma = 1;
	}

	if (dt->iostat != NULL) {
	    if (comma)
		g95_status(", ");
	    g95_status("iostat=");
	    g95_show_expr(dt->iostat);
	    comma = 1;
	}

	if (dt->size != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("size=");
	    g95_show_expr(dt->size);
	    comma = 1;
	}

	if (dt->rec != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("rec=");
	    g95_show_expr(dt->rec);
	    comma = 1;
	}

	if (dt->advance) {
	    if (comma)
		g95_status(", ");

	    g95_status("advance=");
	    g95_show_expr(dt->advance);
	    comma = 1;
	}

	break;

  case EXEC_TRANSFER:
      g95_status("transfer(expr=");
      g95_show_expr(c->expr);
      comma = 1;
      break;

  case EXEC_DT_END:
      g95_status("dt_end(");
      comma = 0;

      dt = c->ext.dt;
      if (dt != NULL) {
	  if (dt->err != NULL) {
	      if (comma)
		  g95_status(", ");
	      
	      g95_status("err=%d", dt->err->value);
	      comma = 1;
	  }

	  if (dt->end != NULL) {
	      if (comma)
		  g95_status(", ");
	      g95_status("end=%d", dt->end->value);
	      comma = 1;
	  }

	  if (dt->eor != NULL) {
	      if (comma)
		  g95_status(", ");

	      g95_status("eor=%d", dt->eor->value);
	      comma = 1;
	  }
      }

      break;

    case EXEC_ENTRY:
	g95_status("entry(name='%s'", c->sym->name);
	comma = 1;
	break;

    case EXEC_LABEL_ASSIGN:
	g95_status("assign_label(expr=");
	g95_show_expr(c->expr);
	g95_status(", label=%d", c->label->value);
	comma = 1;
	break;

    case EXEC_ERROR_STOP:
	g95_status("ERROR STOP(");
	break;

    case EXEC_SYNC_ALL:
	g95_status("SYNC ALL(");
	break;

    case EXEC_SYNC_MEMORY:
	g95_status("SYNC MEMORY(");
	break;

    case EXEC_SYNC_IMAGES:
	g95_status("SYNC IMAGES(");

	if (c->expr == NULL)
	    g95_status_char('*');

	else
	    g95_show_expr(c->expr);

	break;

    case EXEC_SYNC_TEAM:
	g95_status("SYNC TEAM(");

	if (c->expr == NULL)
	    g95_status_char('*');

	else
	    g95_show_expr(c->expr);

	break;

    case EXEC_CRITICAL:
	g95_status("CRITICAL\n");
	show_code(level+1, c->block);

	code_indent(level, 0);
	g95_status("END CRITICAL");
	break;

    default:
	g95_internal_error("show_code0(): Bad statement code");
    }

    g95_status_char(')');
    g95_status_char('\n');
}
Пример #9
0
void g95_show_namespace(g95_namespace *ns) {
g95_interface *intr;
g95_namespace *save;
int i;

    if (ns == NULL)
	return;

    save = g95_current_ns; 

    show_indent();
    g95_status("ns(");

    for(i=0; i<G95_LETTERS; i++) {
	g95_status("%c=", i+'A');
	show_typespec(&ns->default_type[i]);

	if (i != G95_LETTERS-1)
	    g95_status_char(',');

	g95_status_char((i % 3 == 2) ? '\n' : ' ');
    }

    if (ns->proc_name != NULL)
	g95_status(", name='%s'", ns->proc_name->name);

    g95_status(")\n");

    for(i=0; i<G95_INTRINSIC_OPS; i++) {    /* User operator interfaces */
	intr = ns->operator[i];
	if (intr == NULL)
	    continue;

	g95_status("operator('%s', [", g95_op2string(i));

	for(; intr; intr=intr->next)
	    g95_status(" '%s',", intr->sym->name);

	g95_status("])\n");
    }

    g95_traverse_user_op(ns, show_uop);

    g95_traverse_symtree(ns, g95_clear_sym_mark);

    g95_current_ns = ns;
    g95_traverse_symtree(ns, show_symtree);
    g95_status("\n\n");

    show_code(0, ns->code);
    show_level++; 

    for(ns=ns->contained; ns; ns=ns->sibling) {
	g95_status("# Contains\n");
	g95_show_namespace(ns);
    }

    show_level--;
    g95_status_char('\n');
    g95_current_ns = save;
}