Пример #1
0
/*-------------------------------------------------------------------------*
 * PL_GET_PRED_INDICATOR                                                   *
 *                                                                         *
 * returns the functor and initializes the arity of the predicate indicator*
 * func= -1 if it is a variable, arity= -1 if it is a variable             *
 *-------------------------------------------------------------------------*/
int
Pl_Get_Pred_Indicator(WamWord pred_indic_word, Bool must_be_ground, int *arity)
{
    WamWord word, tag_mask;
    int func;

    DEREF(pred_indic_word, word, tag_mask);
    if (tag_mask == TAG_REF_MASK && must_be_ground)
        Pl_Err_Instantiation();

    if (!Pl_Get_Structure(ATOM_CHAR('/'), 2, pred_indic_word))
    {
        if (!Flag_Value(FLAG_STRICT_ISO) &&
                Pl_Rd_Callable(word, &func, arity) != NULL)
            return func;

        Pl_Err_Type(pl_type_predicate_indicator, pred_indic_word);
    }

    pl_pi_name_word = Pl_Unify_Variable();
    pl_pi_arity_word = Pl_Unify_Variable();

    if (must_be_ground)
        func = Pl_Rd_Atom_Check(pl_pi_name_word);
    else
    {
        DEREF(pl_pi_name_word, word, tag_mask);
        if (tag_mask == TAG_REF_MASK)
            func = -1;
        else
            func = Pl_Rd_Atom_Check(pl_pi_name_word);
    }

    if (must_be_ground)
    {
        *arity = Pl_Rd_Positive_Check(pl_pi_arity_word);

        if (*arity > MAX_ARITY)
            Pl_Err_Representation(pl_representation_max_arity);
    }
    else
    {
        DEREF(pl_pi_arity_word, word, tag_mask);
        if (tag_mask == TAG_REF_MASK)
            *arity = -1;
        else
        {
            *arity = Pl_Rd_Positive_Check(pl_pi_arity_word);

            if (*arity > MAX_ARITY)
                Pl_Err_Representation(pl_representation_max_arity);
        }
    }

    return func;
}
Пример #2
0
/*-------------------------------------------------------------------------*
 * BOUND_VAR                                                               *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static void
Bound_Var(WamWord *adr)
{
  long *p;

  for (p = pl_glob_dico_var; p < bound_var_ptr; p++)
    if (*p == (long) adr)
      return;

  if (bound_var_ptr - pl_glob_dico_var >= MAX_VAR_IN_TERM)
    Pl_Err_Representation(pl_representation_too_many_variables);

  *bound_var_ptr++ = (long) adr;
}
Пример #3
0
/*-------------------------------------------------------------------------*
 * COLLECT_VARIABLE                                                        *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static Bool
Collect_Variable(WamWord *adr)
{
  PlLong *p;

  for (p = pl_glob_dico_var; p < var_ptr; p++)
    if (*p == (PlLong) adr)	/* already present */
      return TRUE;

  if (var_ptr - pl_glob_dico_var >= MAX_VAR_IN_TERM)
    Pl_Err_Representation(pl_representation_too_many_variables);

  *var_ptr++ = (PlLong) adr;

  return TRUE;
}
Пример #4
0
/*-------------------------------------------------------------------------*
 * LINK_KEY_VAR                                                            *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static void
Link_Key_Var(WamWord *adr)
{
  long *p;

  for (p = pl_glob_dico_var; p < key_var_ptr; p++)
    if (*p == (long) adr)
      return;

  if (next_key_var_ptr < save_key_var_ptr)
    {		      /* same as Pl_Unify(Tag_REF(adr), *next_key_var_ptr++) */
      *adr = *(WamWord *) (*next_key_var_ptr);
      next_key_var_ptr++;
      return;
    }

  if (key_var_ptr - pl_glob_dico_var >= MAX_VAR_IN_TERM)
    Pl_Err_Representation(pl_representation_too_many_variables);

  *key_var_ptr++ = (long) adr;
}
Пример #5
0
/*-------------------------------------------------------------------------*
 * PL_BLT_UNIV                                                             *
 *                                                                         *
 *-------------------------------------------------------------------------*/
Bool FC
Pl_Blt_Univ(WamWord term_word, WamWord list_word)
{
  WamWord word, tag_mask;
  WamWord *adr;
  WamWord car_word;
  int lst_length;
  WamWord *arg1_adr;
  WamWord *term_adr, *lst_adr, *stc_adr;
  WamWord functor_word, functor_tag;
  int functor;
  int arity;


  Pl_Set_C_Bip_Name("=..", 2);

  DEREF(term_word, word, tag_mask);

  if (tag_mask == TAG_REF_MASK)
    goto list_to_term;

				/* from term to list functor+args */

  if (tag_mask == TAG_LST_MASK)
    {
      adr = UnTag_LST(word);
      car_word = Tag_ATM(ATOM_CHAR('.'));
      lst_length = 1 + 2;
      arg1_adr = &Car(adr);
    }
  else if (tag_mask == TAG_STC_MASK)
    {
      adr = UnTag_STC(word);
      car_word = Tag_ATM(Functor(adr));
      lst_length = 1 + Arity(adr);
      arg1_adr = &Arg(adr, 0);
    }
#ifndef NO_USE_FD_SOLVER
  else if (tag_mask == TAG_FDV_MASK)
    {
      adr = UnTag_FDV(word);
      car_word = Tag_REF(adr);	/* since Dont_Separate_Tag */
      lst_length = 1 + 0;
    } 
#endif
  else				/* TAG_ATM/INT/FLT_MASK */
    {
      car_word = word;
      lst_length = 1 + 0;
    }

  Pl_Check_For_Un_List(list_word);

  Pl_Unset_C_Bip_Name();

  for (;;)
    {
      if (!Pl_Get_List(list_word) || !Pl_Unify_Value(car_word))
	return FALSE;

      list_word = Pl_Unify_Variable();

      if (--lst_length == 0)
	break;

      car_word = *arg1_adr++;
    }

  return Pl_Get_Nil(list_word);

  /* from list functor+args to term */

list_to_term:

  term_adr = UnTag_REF(word);

  DEREF(list_word, word, tag_mask);
  if (tag_mask == TAG_REF_MASK)
    Pl_Err_Instantiation();

  if (word == NIL_WORD)
    Pl_Err_Domain(pl_domain_non_empty_list, list_word);

  if (tag_mask != TAG_LST_MASK)
    Pl_Err_Type(pl_type_list, list_word);

  lst_adr = UnTag_LST(word);
  DEREF(Car(lst_adr), functor_word, functor_tag);
  if (functor_tag == TAG_REF_MASK)
    Pl_Err_Instantiation();

  DEREF(Cdr(lst_adr), word, tag_mask);

  if (word == NIL_WORD)
    {
      if (functor_tag != TAG_ATM_MASK && functor_tag != TAG_INT_MASK &&
	  functor_tag != TAG_FLT_MASK)
	Pl_Err_Type(pl_type_atomic, functor_word);

      term_word = functor_word;
      goto finish;
    }

  if (functor_tag != TAG_ATM_MASK)
    Pl_Err_Type(pl_type_atom, functor_word);

  if (tag_mask == TAG_REF_MASK)
    Pl_Err_Instantiation();

  if (tag_mask != TAG_LST_MASK)
    Pl_Err_Type(pl_type_list, list_word);

  functor = UnTag_ATM(functor_word);

  stc_adr = H;

  H++;				/* space for f/n maybe lost if a list */
  arity = 0;

  for (;;)
    {
      arity++;
      lst_adr = UnTag_LST(word);
      DEREF(Car(lst_adr), word, tag_mask);
      Do_Copy_Of_Word(tag_mask, word); /* since Dont_Separate_Tag */
      Global_Push(word);

      DEREF(Cdr(lst_adr), word, tag_mask);
      if (word == NIL_WORD)
	break;

      if (tag_mask == TAG_REF_MASK)
	Pl_Err_Instantiation();

      if (tag_mask != TAG_LST_MASK)
	Pl_Err_Type(pl_type_list, list_word);
    }

  if (arity > MAX_ARITY)
    Pl_Err_Representation(pl_representation_max_arity);

  if (functor == ATOM_CHAR('.') && arity == 2)	/* a list */
    term_word = Tag_LST(stc_adr + 1);
  else
    {
      *stc_adr = Functor_Arity(functor, arity);
      term_word = Tag_STC(stc_adr);
    }

finish:
  Bind_UV(term_adr, term_word);
  Pl_Unset_C_Bip_Name();
  return TRUE;
}
Пример #6
0
/*-------------------------------------------------------------------------*
 * PL_BLT_FUNCTOR                                                          *
 *                                                                         *
 *-------------------------------------------------------------------------*/
Bool FC
Pl_Blt_Functor(WamWord term_word, WamWord functor_word, WamWord arity_word)
{
  WamWord word, tag_mask;
  WamWord *adr;
  WamWord tag_functor;
  int arity;
  Bool res;


  Pl_Set_C_Bip_Name("functor", 3);

  DEREF(term_word, word, tag_mask);
  if (tag_mask != TAG_REF_MASK)
    {
      if (tag_mask == TAG_LST_MASK)
	res = Pl_Un_Atom_Check(ATOM_CHAR('.'), functor_word) &&
	  Pl_Un_Integer_Check(2, arity_word);
      else if (tag_mask == TAG_STC_MASK)
	{
	  adr = UnTag_STC(word);
	  res = Pl_Un_Atom_Check(Functor(adr), functor_word) &&
	    Pl_Un_Integer_Check(Arity(adr), arity_word);
	}
      else
	res = Pl_Unify(word, functor_word) && Pl_Un_Integer_Check(0, arity_word);

      goto finish;
    }


				/* tag_mask == TAG_REF_MASK */

  DEREF(functor_word, word, tag_mask);
  if (tag_mask == TAG_REF_MASK)
    Pl_Err_Instantiation();

  if (tag_mask != TAG_ATM_MASK && tag_mask != TAG_INT_MASK && 
      tag_mask != TAG_FLT_MASK)
    Pl_Err_Type(pl_type_atomic, functor_word);

  tag_functor = tag_mask;
  functor_word = word;

  arity = Pl_Rd_Positive_Check(arity_word);

  if (arity > MAX_ARITY)
    Pl_Err_Representation(pl_representation_max_arity);

  if (tag_functor == TAG_ATM_MASK && UnTag_ATM(functor_word) == ATOM_CHAR('.')
      && arity == 2)
    {
      res = (Pl_Get_List(term_word)) ? Pl_Unify_Void(2), TRUE : FALSE;
      goto finish;
    }

  if (tag_functor == TAG_ATM_MASK && arity > 0)
    {
      res = (Pl_Get_Structure(UnTag_ATM(functor_word), arity, term_word)) ?
	Pl_Unify_Void(arity), TRUE : FALSE;
      goto finish;
    }

  if (arity != 0)
    Pl_Err_Type(pl_type_atom, functor_word);

  res = Pl_Unify(functor_word, term_word);

finish:
  Pl_Unset_C_Bip_Name();

  return res;
}
Пример #7
0
/*-------------------------------------------------------------------------*
 * FORMAT                                                                  *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static void
Format(StmInf *pstm, char *format, WamWord *lst_adr)

#define IMPOSS -12345678

{
  WamWord word;
  Bool has_n;
  long generic;
  long n, n1;
  char *p;
  long x;
  double d;
  int lg, stop;
  int i, k;
  char *format_stack[256];
  char **top_stack = format_stack;
  char buff[2048];


  *top_stack++ = format;
  do
    {
      format = *--top_stack;

      while (*format)
	{
	  if (*format == '%')	/* C printf format */
	    {
	      if (format[1] == '%')
		{
		  Pl_Stream_Putc('%', pstm);
		  format += 2;
		  continue;
		}

	      p = buff;
	      n = n1 = IMPOSS;

	      do
		if ((*p++ = *format++) == '*')
		  {
		    if (n == IMPOSS)
		      n = Arg_Integer(&lst_adr);
		    else
		      n1 = Arg_Integer(&lst_adr);
		  }
	      while ((char *) strchr("diouxXpnceEfgGs", p[-1]) == NULL);

	      *p = '\0';
	      if (strchr("eEfgG", p[-1]) == NULL)
		{
		  generic = (p[-1] == 's') ? (long) Arg_Atom(&lst_adr)
		    : Arg_Integer(&lst_adr);
		  if (n != IMPOSS)
		    {
		      if (n1 != IMPOSS)
			Pl_Stream_Printf(pstm, buff, n, n1, generic);
		      else
			Pl_Stream_Printf(pstm, buff, n, generic);
		    }
		  else
		    Pl_Stream_Printf(pstm, buff, generic);
		}
	      else
		{
		  d = Arg_Float(&lst_adr);
		  if (n != IMPOSS)
		    {
		      if (n1 != IMPOSS)
			Pl_Stream_Printf(pstm, buff, n, n1, d);
		      else
			Pl_Stream_Printf(pstm, buff, n, d);
		    }
		  else
		    Pl_Stream_Printf(pstm, buff, d);
		}
	      continue;
	    }

	  if (*format != '~')
	    {
	      Pl_Stream_Putc(*format, pstm);
	      format++;
	      continue;
	    }

	  if (*++format == '*')
	    {
	      n = Arg_Integer(&lst_adr);
	      format++;
	      has_n = TRUE;
	    }
	  else
	    {
	      p = format;
	      n = strtol(format, &format, 10);
	      has_n = (format != p);
	    }



	  switch (*format)
	    {
	    case 'a':
	      p = Arg_Atom(&lst_adr);
	      if (has_n)
		Pl_Stream_Printf(pstm, "%*s", -n, p);
	      else
		Pl_Stream_Puts(p, pstm);
	      break;

	    case 'c':
	      x = Arg_Integer(&lst_adr);
	      if (!Is_Valid_Code(x))
		Pl_Err_Representation(pl_representation_character_code);

	      do
		Pl_Stream_Putc(x, pstm);
	      while (--n > 0);
	      break;

	    case 'e':
	    case 'E':
	    case 'f':
	    case 'g':
	    case 'G':
	      x = *format;
	      d = Arg_Float(&lst_adr);

	      if (has_n)
		sprintf(buff, "%%.%ld%c", n, (char) x);
	      else
		sprintf(buff, "%%%c", (char) x);

	      Pl_Stream_Printf(pstm, buff, d);
	      break;

	    case 'd':
	    case 'D':
	      x = Arg_Integer(&lst_adr);

	      if (n == 0 && *format == 'd')
		{
		  Pl_Stream_Printf(pstm, "%ld", x);
		  break;
		}

	      if (x < 0)
		{
		  Pl_Stream_Putc('-', pstm);
		  x = -x;
		}

	      sprintf(buff, "%ld", x);
	      lg = strlen(buff) - n;
	      if (lg <= 0)
		{
		  Pl_Stream_Puts("0.", pstm);
		  for (i = 0; i < -lg; i++)
		    Pl_Stream_Putc('0', pstm);
		  Pl_Stream_Printf(pstm, "%ld", x);
		  break;
		}


	      stop = (*format == 'D') ? lg % 3 : -1;

	      if (stop == 0)
		stop = 3;

	      for (p = buff, i = 0; *p; p++, i++)
		{
		  if (i == lg)
		    Pl_Stream_Putc('.', pstm), stop = -1;

		  if (i == stop)
		    Pl_Stream_Putc(',', pstm), stop += 3;
		  Pl_Stream_Putc(*p, pstm);
		}
	      break;

	    case 'r':
	    case 'R':
	      x = Arg_Integer(&lst_adr);

	      if (!has_n || n < 2 || n > 36)
		n = 8;

	      k = ((*format == 'r') ? 'a' : 'A') - 10;

	      if (x < 0)
		{
		  Pl_Stream_Putc('-', pstm);
		  x = -x;
		}

	      p = buff + sizeof(buff) - 1;
	      *p = '\0';
	      do
		{
		  i = x % n;
		  x = x / n;
		  --p;
		  *p = (i < 10) ? i + '0' : i + k;
		}
	      while (x);
	      Pl_Stream_Puts(p, pstm);
	      break;

	    case 's':
	    case 'S':
	      word = Read_Arg(&lst_adr);
	      if (*format == 's')
		p = Pl_Rd_Codes_Check(word);
	      else
		p = Pl_Rd_Chars_Check(word);

	      if (has_n)
		Pl_Stream_Printf(pstm, "%-*.*s", n, n, p);
	      else
		Pl_Stream_Printf(pstm, "%s", p);
	      break;

	    case 'i':
	      do
		Read_Arg(&lst_adr);
	      while (--n > 0);
	      break;

	    case 'k':
	      word = Read_Arg(&lst_adr);
	      Pl_Write_Term(pstm, -1, MAX_PREC,
			 WRITE_IGNORE_OP | WRITE_QUOTED, word);
	      break;

	    case 'q':
	      word = Read_Arg(&lst_adr);
	      Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS |
			 WRITE_NAME_VARS | WRITE_QUOTED, word);
	      break;

	    case 'p':		/* only work if print.pl is linked */
	      word = Read_Arg(&lst_adr);
	      Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS |
			 WRITE_NAME_VARS | WRITE_PORTRAYED, word);
	      break;

	    case 'w':
	      word = Read_Arg(&lst_adr);
	      Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS |
			 WRITE_NAME_VARS, word);
	      break;

	    case '~':
	      Pl_Stream_Putc('~', pstm);
	      break;

	    case 'N':
	      if (pstm->line_pos == 0)
		break;
	    case 'n':
	      do
		Pl_Stream_Putc('\n', pstm);
	      while (--n > 0);
	      break;

	    case '?':
	      if (format[1])
		*top_stack++ = format + 1;

	      format = Arg_Atom(&lst_adr);
	      continue;

	    default:
	      Pl_Err_Domain(pl_domain_format_control_sequence,
			    Tag_ATM(ATOM_CHAR(*format)));
	    }
	  format++;
	}
    }
  while (top_stack > format_stack);
}
Пример #8
0
/*-------------------------------------------------------------------------*
 * COPY_TERM_REC                                                           *
 *                                                                         *
 * p is the next address to use to store the rest of a term.               *
 *-------------------------------------------------------------------------*/
static void
Copy_Term_Rec(WamWord *dst_adr, WamWord *src_adr, WamWord **p)
{
    WamWord word, tag_mask;
    WamWord *adr;
    WamWord *q;
    int i;

terminal_rec:

    DEREF(*src_adr, word, tag_mask);

    switch (Tag_From_Tag_Mask(tag_mask))
    {
    case REF:
        adr = UnTag_REF(word);
        q = *p;
        if (adr < q && adr >= base_copy)	/* already a copy */
        {
            *dst_adr = word;
            return;
        }

        if (top_vars >= end_vars)
            Pl_Err_Representation(pl_representation_too_many_variables);

        *top_vars++ = word;	                /* word to restore    */
        *top_vars++ = (WamWord) adr;	        /* address to restore */
        *adr = *dst_adr = Tag_REF(dst_adr);	/* bind to a new copy */
        return;

#ifndef NO_USE_FD_SOLVER
    case FDV:
        adr = UnTag_FDV(word);
        q = *p;
        if (adr < q && adr >= base_copy)	/* already a copy */
        {
            *dst_adr = Tag_REF(adr);	/* since Dont_Separate_Tag */
            return;
        }

        if (top_vars >= end_vars)
            Pl_Err_Representation(pl_representation_too_many_variables);

        *top_vars++ = word;	        /* word to restore    */
        *top_vars++ = (WamWord) adr;	/* address to restore */
        q = *p;
        *p = q + Fd_Copy_Variable(q, adr);
        *adr = *dst_adr = Tag_REF(q);	/* bind to a new copy */
        return;
#endif

    case FLT:
        adr = UnTag_FLT(word);
        q = *p;
        q[0] = adr[0];
#if WORD_SIZE == 32
        q[1] = adr[1];
        *p = q + 2;
#else
        *p = q + 1;
#endif
        *dst_adr = Tag_FLT(q);
        return;

    case LST:
        adr = UnTag_LST(word);
        q = *p;
        *dst_adr = Tag_LST(q);

        *p = &Cdr(q) + 1;
        q = &Car(q);
        adr = &Car(adr);
        Copy_Term_Rec(q++, adr++, p);

        dst_adr = q;
        src_adr = adr;
        goto terminal_rec;

    case STC:
        adr = UnTag_STC(word);
        q = *p;
        *dst_adr = Tag_STC(q);

        Functor_And_Arity(q) = Functor_And_Arity(adr);

        i = Arity(adr);
        *p = &Arg(q, i - 1) + 1;

        q = &Arg(q, 0);
        adr = &Arg(adr, 0);
        while (--i)
            Copy_Term_Rec(q++, adr++, p);

        dst_adr = q;
        src_adr = adr;
        goto terminal_rec;

    default:
        *dst_adr = word;
        return;
    }
}