Пример #1
0
void ListedMacroUserFunction::Evaluate(LispPtr& aResult,LispEnvironment& aEnvironment,
              LispPtr& aArguments)
{
  LispPtr newArgs;
  LispIterator iter(aArguments);
  LispPtr* ptr =  &newArgs;
  LispInt arity = Arity();
  LispInt i=0;
  // TODO: the code would look a lot easier if we could do with only an iterator
  while (i < arity && iter.getObj())
  {
    (*ptr) = (iter.getObj()->Copy());
    ptr = &((*ptr)->Nixed());
    i++;
    ++iter;
  }

  if (!iter.getObj()->Nixed()) {
    *ptr = iter.getObj()->Copy();
    (*ptr)->Nixed();
    ++iter;
    assert(!iter.getObj());
  } else {
    LispPtr head(aEnvironment.iList->Copy());
    head->Nixed() = iter.getObj();
    *ptr = LispSubList::New(head);
  }

  MacroUserFunction::Evaluate(aResult, aEnvironment, newArgs);
}
Пример #2
0
/*-------------------------------------------------------------------------*/
AtomInf *Get_Functor_Arity(WamWord start_word,int *arity,WamWord **arg_adr)

{
 WamWord word,tag,*adr;

 Deref(start_word,word,tag,adr)

 switch(tag)
    {
     case CST:
         *arity=0;
         return UnTag_CST(word);

     case LST:
         adr=UnTag_LST(word);
         *arity=2;
         *arg_adr=&Car(adr);
         return atom_dot;

     case STC:
         adr=UnTag_STC(word);
         *arity=Arity(adr);
         *arg_adr=&Arg(adr,0);
         return Functor(adr);

     default:
         return NULL;
    }
}
Пример #3
0
void ListedBranchingUserFunction::Evaluate(LispPtr& aResult,LispEnvironment& aEnvironment,
                                           LispPtr& aArguments)
{
  LispPtr newArgs;
  LispIterator iter(aArguments);
  LispPtr* ptr =  &newArgs;
  const LispInt arity = Arity();
  // Make a copy of the arguments first
  // TODO: if we were to change the internal representation to a cons cell, this copying would not be needed
  for (LispInt i = 0; i < arity && iter.getObj(); ++i,++iter)
  {
    *ptr = iter.getObj()->Copy();
    ptr = &((*ptr)->Nixed());
  }

  if (!iter.getObj()->Nixed())
  {
    (*ptr) = (iter.getObj()->Copy());
    ++iter;
    assert(!iter.getObj());
  }
  else
  {
    LispPtr head(aEnvironment.iList->Copy());
    head->Nixed() = iter.getObj();
    *ptr = (LispSubList::New(head));
  }
  BranchingUserFunction::Evaluate(aResult, aEnvironment, newArgs);
}
Пример #4
0
namespace Ginger {

Ref * cgiValue( Ref * pc, class MachineClass * vm ) {
	if ( vm->count != 1 ) throw Ginger::Mishap( "ArgsMismatch" );
	
	Ref r = vm->fastPeek();
	if ( !IsStringKind( r ) ) throw Ginger::Mishap( "Non-string argument needed for getEnv" );	
	Ref * str_K = RefToPtr4( r );
	
	char * fieldname = reinterpret_cast< char * >( str_K + 1 );
	const char * value = vm->getAppContext().cgiValue( fieldname );
	vm->fastPeek() = vm->heap().copyString( pc, value );
	return pc;
}
SysInfo infoCgiValue( 
    SysNames( "cgiValue" ), 
    Arity( 1 ), 
    Arity( 1 ), 
    cgiValue, 
    "Returns value of a CGI " 
);

} // namespace Ginger
Пример #5
0
/*-------------------------------------------------------------------------*
 * PL_TERM_SIZE                                                            *
 *                                                                         *
 *-------------------------------------------------------------------------*/
int
Pl_Term_Size(WamWord start_word)
{
    WamWord word, tag_mask;
    WamWord *adr;
    int i;
    int n = 0;			/* init to zero for terminal_rec */

terminal_rec:

    DEREF(start_word, word, tag_mask);

    switch (Tag_From_Tag_Mask(tag_mask))
    {
#ifndef NO_USE_FD_SOLVER
    case FDV:		/* 1+ for <REF,->fdv_adr> since Dont_Separate_Tag */
        return n + 1 + Fd_Variable_Size(UnTag_FDV(word));
#endif

    case FLT:
#if WORD_SIZE == 32
        return n + 1 + 2;
#else
        return n + 1 + 1;
#endif

    case LST:
        adr = UnTag_LST(word);
        adr = &Car(adr);
        n += 1 + Pl_Term_Size(*adr++);
        start_word = *adr;
        goto terminal_rec;

    case STC:
        adr = UnTag_STC(word);
        n += 2;			/* tagged word + f_n */

        i = Arity(adr);
        adr = &Arg(adr, 0);
        while (--i)
            n += Pl_Term_Size(*adr++);

        start_word = *adr;
        goto terminal_rec;

    default:
        return n + 1;
    }
}
Пример #6
0
/*-------------------------------------------------------------------------*
 * PL_TREAT_VARS_OF_TERM                                                   *
 *                                                                         *
 * Call fct for each variable found in a term.                             *
 *-------------------------------------------------------------------------*/
void
Pl_Treat_Vars_Of_Term(WamWord start_word, Bool generic_var, void (*fct) ())
{
    WamWord word, tag_mask;
    WamWord *adr;
    int i;

terminal_rec:

    DEREF(start_word, word, tag_mask);

    switch (Tag_Of(word))
    {
    case REF:
        (*fct) (UnTag_REF(word), word);
        break;

#ifndef NO_USE_FD_SOLVER
    case FDV:
        if (generic_var)
            (*fct) (UnTag_FDV(word), word);
        break;
#endif

    case LST:
        adr = UnTag_LST(word);
        adr = &Car(adr);
        Pl_Treat_Vars_Of_Term(*adr++, generic_var, fct);

        start_word = *adr;
        goto terminal_rec;

    case STC:
        adr = UnTag_STC(word);
        i = Arity(adr);
        adr = &Arg(adr, 0);
        while (--i)
            Pl_Treat_Vars_Of_Term(*adr++, generic_var, fct);

        start_word = *adr;
        goto terminal_rec;
    }
}
Пример #7
0
/*-------------------------------------------------------------------------*
 * CHECK_IF_VAR_OCCURS                                                     *
 *                                                                         *
 * Only called if var_adr resides in the heap since a var residing in the  *
 * local stack cannot appear in a term (there is no binding from the heap  *
 * to the local stack in the WAM).                                         *
 *-------------------------------------------------------------------------*/
static Bool
Check_If_Var_Occurs(WamWord *var_adr, WamWord term_word)
{
  WamWord word, tag_mask;
  WamWord *adr;
  int i;

 terminal_rec:

  DEREF(term_word, word, tag_mask);

  if (tag_mask == TAG_REF_MASK)
    return UnTag_REF(word) == var_adr;

  if (tag_mask == TAG_LST_MASK)
    {
      adr = UnTag_LST(word);
      adr = &Car(adr);
      if (Check_If_Var_Occurs(var_adr, *adr++))
	return TRUE;

      term_word = *adr;
      goto terminal_rec;
    }

  if (tag_mask == TAG_STC_MASK)
    {
      adr = UnTag_STC(word);

      i = Arity(adr);
      adr = &Arg(adr, 0);
      while (--i)
	if (Check_If_Var_Occurs(var_adr, *adr++))
	  return TRUE;

      term_word = *adr;
      goto terminal_rec;
    }

  return FALSE;
}
Пример #8
0
/*-------------------------------------------------------------------------*
 * ADD_FD_VARIABLES                                                        *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static void
Add_Fd_Variables(WamWord e_word)
{
  WamWord word, tag_mask;
  WamWord *adr;
  int i;

  DEREF(e_word, word, tag_mask);

  if (tag_mask == TAG_REF_MASK)
    {
      if (vars_sp - vars_tbl == VARS_STACK_SIZE)
	Pl_Err_Resource(pl_resource_too_big_fd_constraint);

      *vars_sp++ = word;
      *vars_sp++ = 1;		/* FD var */
      return;
    }


  if (tag_mask == TAG_LST_MASK)
    {
      adr = UnTag_LST(word);

      Add_Fd_Variables(Car(adr));
      Add_Fd_Variables(Cdr(adr));
    }

  if (tag_mask == TAG_STC_MASK)
    {
      adr = UnTag_STC(word);

      i = Arity(adr);
      do
	Add_Fd_Variables(Arg(adr, --i));
      while (i);
    }
}
Пример #9
0
/*-------------------------------------------------------------------------*/
AtomInf *Get_Compound(WamWord tag,WamWord word,int *arity,WamWord **arg_adr)

{
 WamWord *adr;

 switch(tag)
    {
     case LST:
         adr=UnTag_LST(word);
         *arity=2;
         *arg_adr=&Car(adr);
         return atom_dot;

     case STC:
         adr=UnTag_STC(word);
         *arity=Arity(adr);
         *arg_adr=&Arg(adr,0);
         return Functor(adr);

     default:
         return NULL;
    }
}
Пример #10
0
LispInt ListedBranchingUserFunction::IsArity(LispInt aArity) const
{
    // nr arguments handled is bound by a minimum: the number of arguments
    // to this function.
    return Arity() <= aArity;
}
Пример #11
0
LispInt BranchingUserFunction::IsArity(LispInt aArity) const
{
    return (Arity() == aArity);
}
Пример #12
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;
}
Пример #13
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;
    }
}
Пример #14
0
/*-------------------------------------------------------------------------*
 * PL_COPY_CONTIGUOUS_TERM                                                 *
 *                                                                         *
 * Copy a contiguous term (dereferenced), the result is a contiguous term. *
 *-------------------------------------------------------------------------*/
void
Pl_Copy_Contiguous_Term(WamWord *dst_adr, WamWord *src_adr)
#define Old_Adr_To_New_Adr(adr)  ((dst_adr)+((adr)-(src_adr)))
{
    WamWord word, *adr;
    WamWord *q;
    int i;

terminal_rec:

    word = *src_adr;

    switch (Tag_Of(word))
    {
    case REF:
        adr = UnTag_REF(word);
        q = Old_Adr_To_New_Adr(adr);
        *dst_adr = Tag_REF(q);
        if (adr > src_adr)	/* only useful for Dont_Separate_Tag */
            Pl_Copy_Contiguous_Term(q, adr);
        return;

#ifndef NO_USE_FD_SOLVER
    case FDV:
        adr = UnTag_FDV(word);
        Fd_Copy_Variable(dst_adr, adr);
        return;
#endif

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

    case LST:
        adr = UnTag_LST(word);
        q = Old_Adr_To_New_Adr(adr);
        *dst_adr = Tag_LST(q);
        q = &Car(q);
        adr = &Car(adr);
        Pl_Copy_Contiguous_Term(q++, adr++);
        dst_adr = q;
        src_adr = adr;
        goto terminal_rec;

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

        Functor_And_Arity(q) = Functor_And_Arity(adr);

        i = Arity(adr);

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

        dst_adr = q;
        src_adr = adr;
        goto terminal_rec;

    default:
        *dst_adr = word;
        return;
    }
}
Пример #15
0
/*-------------------------------------------------------------------------*
 * LOAD_MATH_EXPRESSION                                                    *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static WamWord
Load_Math_Expression(WamWord exp)
{
  WamWord word, tag_mask;
  WamWord *adr;
  WamWord *lst_adr;
  ArithInf *arith;

  DEREF(exp, word, tag_mask);

  if (tag_mask == TAG_INT_MASK || tag_mask == TAG_FLT_MASK)
    return word;

  if (tag_mask == TAG_LST_MASK)
    {
      lst_adr = UnTag_LST(word);
      DEREF(Cdr(lst_adr), word, tag_mask);
      if (word != NIL_WORD)
	{
	  word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
	  Pl_Unify_Atom(ATOM_CHAR('.'));
	  Pl_Unify_Integer(2);
	  Pl_Err_Type(pl_type_evaluable, word);
	}
      DEREF(Car(lst_adr), word, tag_mask);
      if (tag_mask == TAG_REF_MASK)
	Pl_Err_Instantiation();

      if (tag_mask != TAG_INT_MASK) 
	{
	  Pl_Err_Type(pl_type_integer, word);
	}
      return word;
    }

  if (tag_mask == TAG_STC_MASK)
    {
      adr = UnTag_STC(word);

      arith = (ArithInf *) Pl_Hash_Find(arith_tbl, Functor_And_Arity(adr));
      if (arith == NULL)
	{
	  word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
	  Pl_Unify_Atom(Functor(adr));
	  Pl_Unify_Integer(Arity(adr));
	  Pl_Err_Type(pl_type_evaluable, word);
	}
      
      if (Arity(adr) == 1)
	return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0)));

      return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0)),
			      Load_Math_Expression(Arg(adr, 1)));
    }

  if (tag_mask == TAG_REF_MASK)
    Pl_Err_Instantiation();

  if (tag_mask == TAG_ATM_MASK)
    {
      word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
      Pl_Unify_Value(exp);
      Pl_Unify_Integer(0);		/* then type_error */
    }

  Pl_Err_Type(pl_type_evaluable, word);
  return word;
}
Пример #16
0
/*-------------------------------------------------------------------------*
 * NORMALIZE                                                               *
 *                                                                         *
 * This functions normalizes a term.                                       *
 * Input:                                                                  *
 *    e_word: term to normalize                                            *
 *    sign  : current sign of the term (-1 or +1)                          *
 *                                                                         *
 * Output:                                                                 *
 *    p     : the associated polynomial term                               *
 *                                                                         *
 * Normalizes the term and loads it into p.                                *
 * Non-Linear operations are simplified and loaded into a stack to be      *
 * executed later.                                                         *
 *                                                                         *
 * T1*T2 : T1 and T2 are normalized to give the polynomials p1 and p2, with*
 *         p1 = c1 + a1X1 + a2X2 + ... + anXn                              *
 *         p2 = c2 + b1X1 + b2X2 + ... + bmXm                              *
 *         and replaced by c1*c2 +                                         *
 *                         a1X1 * c2 + a1X1 * b1X1 + ... + a1X1 * bmXm     *
 *                         ...                                             *
 *                         anX1 * c2 + anXn * b1X1 + ... + anXn * bmXm     *
 *                                                                         *
 * T1**T2: T1 and T2 are loaded into 2 new words word1 and word2 that can  *
 *         be integers or variables (tagged words). The code emitted       *
 *         depends on 3 possibilities (var**var is not allowed)            *
 *         (+ optim 1**T2, 0**T2, T1**0, T1**1), NB 0**0=1                 *
 *-------------------------------------------------------------------------*/
static Bool
Normalize(WamWord e_word, int sign, Poly *p)
{
  WamWord word, tag_mask;
  WamWord *adr;
  WamWord *fdv_adr;
  WamWord word1, word2, word3;
  WamWord f_n, le_word, re_word;
  int i;
  PlLong n1, n2, n3;

 terminal_rec:

  DEREF(e_word, word, tag_mask);

  if (tag_mask == TAG_FDV_MASK)
    {
      fdv_adr = UnTag_FDV(word);
      Add_Monom(p, sign, 1, Tag_REF(fdv_adr));
      return TRUE;
    }

  if (tag_mask == TAG_INT_MASK)
    {
      n1 = UnTag_INT(word);
      if (n1 > MAX_COEF_FOR_SORT)
	sort = TRUE;

      Add_Cst_To_Poly(p, sign, n1);
      return TRUE;
    }

  if (tag_mask == TAG_REF_MASK)
    {
      if (vars_sp - vars_tbl >= VARS_STACK_SIZE)
	Pl_Err_Resource(pl_resource_too_big_fd_constraint);

      *vars_sp++ = word;
      Add_Monom(p, sign, 1, word);
      return TRUE;
    }

  if (tag_mask == TAG_ATM_MASK)
    {
      word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
      Pl_Unify_Value(e_word);
      Pl_Unify_Integer(0);
    type_error:
      Pl_Err_Type(pl_type_fd_evaluable, word);
    }

  if (tag_mask != TAG_STC_MASK)
    goto type_error;


  adr = UnTag_STC(word);

  f_n = Functor_And_Arity(adr);
  for (i = 0; i < NB_OF_OP; i++)
    if (arith_tbl[i] == f_n)
      break;

  le_word = Arg(adr, 0);
  re_word = Arg(adr, 1);

  switch (i)
    {
    case PLUS_1:
      e_word = le_word;
      goto terminal_rec;

    case PLUS_2:
      if (!Normalize(le_word, sign, p))
	return FALSE;
      e_word = re_word;
      goto terminal_rec;

    case MINUS_2:
      if (!Normalize(le_word, sign, p))
	return FALSE;
      e_word = re_word;
      sign = -sign;
      goto terminal_rec;

    case MINUS_1:
      e_word = le_word;
      sign = -sign;
      goto terminal_rec;

    case TIMES_2:
#ifdef DEVELOP_TIMES_2
#if 1				/* optimize frequent use: INT*VAR */
      DEREF(le_word, word, tag_mask);
      if (tag_mask != TAG_INT_MASK)
	goto any;

      n1 = UnTag_INT(word);

      if (n1 > MAX_COEF_FOR_SORT)
	sort = TRUE;

      DEREF(re_word, word, tag_mask);
      if (tag_mask != TAG_REF_MASK)
	{
	  if (tag_mask != TAG_FDV_MASK)
	    goto any;
	  else
	    {
	      fdv_adr = UnTag_FDV(word);
	      word = Tag_REF(fdv_adr);
	    }
	}
      Add_Monom(p, sign, n1, word);
      return TRUE;
    any:
#endif
      {
	Poly p1, p2;
	int i1, i2;

	New_Poly(p1);
	New_Poly(p2);

	if (!Normalize(le_word, 1, &p1) || !Normalize(re_word, 1, &p2))
	  return FALSE;

	Add_Cst_To_Poly(p, sign, p1.c * p2.c);

	for (i1 = 0; i1 < p1.nb_monom; i1++)
	  {
	    Add_Monom(p, sign, p1.m[i1].a * p2.c, p1.m[i1].x_word);
	    for (i2 = 0; i2 < p2.nb_monom; i2++)
	      if (!Add_Multiply_Monom(p, sign, p1.m + i1, p2.m + i2))
		return FALSE;
	  }

	for (i2 = 0; i2 < p2.nb_monom; i2++)
	  Add_Monom(p, sign, p2.m[i2].a * p1.c, p2.m[i2].x_word);

	return TRUE;
      }
#else
      if (!Load_Term_Into_Word(le_word, &word1) ||
	  !Load_Term_Into_Word(re_word, &word2))
	return FALSE;

      if (Tag_Is_INT(word1))
	{
	  n1 = UnTag_INT(word1);
	  if (Tag_Is_INT(word2))
	    {
	      n2 = UnTag_INT(word2);
	      n1 = n1 * n2;
	      Add_Cst_To_Poly(p, sign, n1);
	      return TRUE;
	    }

	  Add_Monom(p, sign, n1, word2);
	  return TRUE;
	}

      if (Tag_Is_INT(word2))
	{
	  n2 = UnTag_INT(word2);
	  Add_Monom(p, sign, n2, word1);
	  return TRUE;
	}


      word1 = (word1 == word2)
	? Push_Delayed_Cstr(DC_X2_EQ_Y, word1, 0, 0)
	: Push_Delayed_Cstr(DC_XY_EQ_Z, word1, word2, 0);

      Add_Monom(p, sign, 1, word1);
      return TRUE;
#endif

    case POWER_2:
      if (!Load_Term_Into_Word(le_word, &word1) ||
	  !Load_Term_Into_Word(re_word, &word2))
	return FALSE;

      if (Tag_Is_INT(word1))
	{
	  n1 = UnTag_INT(word1);
	  if (Tag_Is_INT(word2))
	    {
	      n2 = UnTag_INT(word2);
	      if ((n1 = Pl_Power(n1, n2)) < 0)
		return FALSE;

	      Add_Cst_To_Poly(p, sign, n1);
	      return TRUE;
	    }

	  if (n1 == 1)
	    {
	      Add_Cst_To_Poly(p, sign, 1);
	      return TRUE;
	    }

	  word = (n1 == 0)
	    ? Push_Delayed_Cstr(DC_ZERO_POWER_N_EQ_Y, word2, 0, 0)
	    : Push_Delayed_Cstr(DC_A_POWER_N_EQ_Y, word1, word2, 0);
	  goto end_power;
	}

      if (Tag_Mask_Of(word2) != TAG_INT_MASK)
	Pl_Err_Instantiation();
      else
	{
	  n2 = UnTag_INT(word2);
	  if (n2 == 0)
	    {
	      Add_Cst_To_Poly(p, sign, 1);
	      return TRUE;
	    }

	  word = (n2 == 1)
	    ? word1
	    : (n2 == 2)
	    ? Push_Delayed_Cstr(DC_X2_EQ_Y, word1, 0, 0)
	    : Push_Delayed_Cstr(DC_X_POWER_A_EQ_Y, word1, word2, 0);
	}
    end_power:
      Add_Monom(p, sign, 1, word);
      return TRUE;

    case MIN_2:
      if (!Load_Term_Into_Word(le_word, &word1) ||
	  !Load_Term_Into_Word(re_word, &word2))
	return FALSE;

      if (Tag_Is_INT(word1))
	{
	  n1 = UnTag_INT(word1);
	  if (Tag_Is_INT(word2))
	    {
	      n2 = UnTag_INT(word2);
	      n1 = math_min(n1, n2);
	      Add_Cst_To_Poly(p, sign, n1);
	      return TRUE;
	    }

	  word = Push_Delayed_Cstr(DC_MIN_X_A_EQ_Z, word2, word1, 0);
	  goto end_min;
	}

      if (Tag_Is_INT(word2))
	word = Push_Delayed_Cstr(DC_MIN_X_A_EQ_Z, word1, word2, 0);
      else
	word = Push_Delayed_Cstr(DC_MIN_X_Y_EQ_Z, word1, word2, 0);

    end_min:
      Add_Monom(p, sign, 1, word);
      return TRUE;

    case MAX_2:
      if (!Load_Term_Into_Word(le_word, &word1) ||
	  !Load_Term_Into_Word(re_word, &word2))
	return FALSE;

      if (Tag_Is_INT(word1))
	{
	  n1 = UnTag_INT(word1);
	  if (Tag_Is_INT(word2))
	    {
	      n2 = UnTag_INT(word2);
	      n1 = math_max(n1, n2);
	      Add_Cst_To_Poly(p, sign, n1);
	      return TRUE;
	    }

	  word = Push_Delayed_Cstr(DC_MAX_X_A_EQ_Z, word2, word1, 0);
	  goto end_max;
	}

      if (Tag_Is_INT(word2))
	word = Push_Delayed_Cstr(DC_MAX_X_A_EQ_Z, word1, word2, 0);
      else
	word = Push_Delayed_Cstr(DC_MAX_X_Y_EQ_Z, word1, word2, 0);

    end_max:
      Add_Monom(p, sign, 1, word);
      return TRUE;

    case DIST_2:
      if (!Load_Term_Into_Word(le_word, &word1) ||
	  !Load_Term_Into_Word(re_word, &word2))
	return FALSE;

      if (Tag_Is_INT(word1))
	{
	  n1 = UnTag_INT(word1);
	  if (Tag_Is_INT(word2))
	    {
	      n2 = UnTag_INT(word2);
	      n1 = (n1 >= n2) ? n1 - n2 : n2 - n1;
	      Add_Cst_To_Poly(p, sign, n1);
	      return TRUE;
	    }

	  word = Push_Delayed_Cstr(DC_ABS_X_MINUS_A_EQ_Z, word2, word1, 0);
	  goto end_dist;
	}

      if (Tag_Is_INT(word2))
	word = Push_Delayed_Cstr(DC_ABS_X_MINUS_A_EQ_Z, word1, word2, 0);
      else
	word = Push_Delayed_Cstr(DC_ABS_X_MINUS_Y_EQ_Z, word1, word2, 0);

    end_dist:
      Add_Monom(p, sign, 1, word);
      return TRUE;

    case QUOT_2:
      word3 = Make_Self_Ref(H);	/* word3 = remainder */
      Global_Push(word3);
      goto quot_rem;

    case REM_2:
      word3 = Make_Self_Ref(H);	/* word3 = remainder */
      Global_Push(word3);
      goto quot_rem;

    case QUOT_REM_3:
    quot_rem:
    if (!Load_Term_Into_Word(le_word, &word1) ||
	!Load_Term_Into_Word(re_word, &word2) ||
	(i == QUOT_REM_3 && !Load_Term_Into_Word(Arg(adr, 2), &word3)))
      return FALSE;

    if (Tag_Is_INT(word1))
      {
	n1 = UnTag_INT(word1);
	if (Tag_Is_INT(word2))
	  {
	    n2 = UnTag_INT(word2);
	    if (n2 == 0)
	      return FALSE;
	    n3 = n1 % n2;

	    if (i == QUOT_2 || i == QUOT_REM_3)
	      {
		if (i == QUOT_REM_3)
		  PRIM_CSTR_2(pl_x_eq_c, word3, word);
		else
		  H--;	/* recover word3 space */
		n3 = n1 / n2;
	      }

	    Add_Cst_To_Poly(p, sign, n3);
	    return TRUE;
	  }

	word = Push_Delayed_Cstr(DC_QUOT_REM_A_Y_R_EQ_Z, word1, word2,
				 word3);
	goto end_quot_rem;
      }

    if (Tag_Is_INT(word2))
      word = Push_Delayed_Cstr(DC_QUOT_REM_X_A_R_EQ_Z, word1, word2,
			       word3);
    else
      word = Push_Delayed_Cstr(DC_QUOT_REM_X_Y_R_EQ_Z, word1, word2,
			       word3);

    end_quot_rem:
    Add_Monom(p, sign, 1, (i == REM_2) ? word3 : word);
    return TRUE;

    case DIV_2:
      if (!Load_Term_Into_Word(le_word, &word1) ||
	  !Load_Term_Into_Word(re_word, &word2))
	return FALSE;

      if (Tag_Is_INT(word1))
	{
	  n1 = UnTag_INT(word1);
	  if (Tag_Is_INT(word2))
	    {
	      n2 = UnTag_INT(word2);
	      if (n2 == 0 || n1 % n2 != 0)
		return FALSE;
	      n1 /= n2;
	      Add_Cst_To_Poly(p, sign, n1);
	      return TRUE;
	    }

	  word = Push_Delayed_Cstr(DC_DIV_A_Y_EQ_Z, word1, word2, 0);
	  goto end_div;
	}

      if (Tag_Is_INT(word2))
	word = Push_Delayed_Cstr(DC_DIV_X_A_EQ_Z, word1, word2, 0);
      else
	word = Push_Delayed_Cstr(DC_DIV_X_Y_EQ_Z, word1, word2, 0);

    end_div:
      Add_Monom(p, sign, 1, word);
      return TRUE;

    default:
      word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
      Pl_Unify_Atom(Functor(adr));
      Pl_Unify_Integer(Arity(adr));
      goto type_error;
    }

  return TRUE;
}
Пример #17
0
/*-------------------------------------------------------------------------*
 * This file is not compiled separately but included twice by wam_inst.c:  *
 *    - to define the Unify function (classical unification).              *
 *    - to define the Unify_Occurs_Check function (+ occurs check).        *
 *-------------------------------------------------------------------------*/
Bool FC
UNIFY_FCT_NAME(WamWord start_u_word, WamWord start_v_word)
{
  WamWord u_word, u_tag_mask;
  WamWord v_word, v_tag_mask;
  WamWord *u_adr, *v_adr;
  int i;

 terminal_rec:

  DEREF(start_u_word, u_word, u_tag_mask);
  DEREF(start_v_word, v_word, v_tag_mask);

  if (u_tag_mask == TAG_REF_MASK)
    {
      u_adr = UnTag_REF(u_word);
      if (v_tag_mask == TAG_REF_MASK)
	{
	  v_adr = UnTag_REF(v_word);

	  if (u_adr > v_adr)
	    Bind_UV(u_adr, Tag_REF(v_adr));
	  else if (v_adr > u_adr)
	    Bind_UV(v_adr, Tag_REF(u_adr));
	}
      else
	{
#ifdef OCCURS_CHECK
	  if (!Is_A_Local_Adr(u_adr) &&	/* no binding from heap to local */
	      Check_If_Var_Occurs(u_adr, v_word))
	    return FALSE;
#endif
	  Do_Copy_Of_Word(v_tag_mask, v_word);
	  Bind_UV(u_adr, v_word);
	}

      return TRUE;
    }


  if (v_tag_mask == TAG_REF_MASK)
    {
      v_adr = UnTag_REF(v_word);

#ifdef OCCURS_CHECK
      if (!Is_A_Local_Adr(v_adr) &&	/* no binding from heap to local */
	  Check_If_Var_Occurs(v_adr, u_word))
	return FALSE;
#endif
      Do_Copy_Of_Word(u_tag_mask, u_word);
      Bind_UV(v_adr, u_word);

      return TRUE;
    }

  if (u_word == v_word)
    return TRUE;

  if (v_tag_mask == TAG_LST_MASK)
    {
      if (u_tag_mask != v_tag_mask)
	return FALSE;

      u_adr = UnTag_LST(u_word);
      v_adr = UnTag_LST(v_word);

      u_adr = &Car(u_adr);
      v_adr = &Car(v_adr);

      if (!UNIFY_FCT_NAME(*u_adr++, *v_adr++))
	return FALSE;

      start_u_word = *u_adr;
      start_v_word = *v_adr;
      goto terminal_rec;
    }

  if (v_tag_mask == TAG_STC_MASK)
    {
      if (u_tag_mask != v_tag_mask)
	return FALSE;

      u_adr = UnTag_STC(u_word);
      v_adr = UnTag_STC(v_word);

      if (Functor_And_Arity(u_adr) != Functor_And_Arity(v_adr))
	return FALSE;

      i = Arity(u_adr);
      u_adr = &Arg(u_adr, 0);
      v_adr = &Arg(v_adr, 0);
      while (--i)
	if (!UNIFY_FCT_NAME(*u_adr++, *v_adr++))
	  return FALSE;

      start_u_word = *u_adr;
      start_v_word = *v_adr;
      goto terminal_rec;
    }

#ifndef NO_USE_FD_SOLVER
  if (v_tag_mask == TAG_INT_MASK && u_tag_mask == TAG_FDV_MASK)
    return Fd_Unify_With_Integer(UnTag_FDV(u_word), UnTag_INT(v_word));
     
  if (v_tag_mask == TAG_FDV_MASK)
    {
      v_adr = UnTag_FDV(v_word);

      if (u_tag_mask == TAG_INT_MASK)
	return Fd_Unify_With_Integer(v_adr, UnTag_INT(u_word));

      if (u_tag_mask != v_tag_mask) /* i.e. TAG_FDV_MASK */
	return FALSE;
      
      return Fd_Unify_With_Fd_Var(UnTag_FDV(u_word), v_adr);
    }
#endif

  if (v_tag_mask == TAG_FLT_MASK)
    return (u_tag_mask == v_tag_mask && 
	    Pl_Obtain_Float(UnTag_FLT(u_word)) ==
	    Pl_Obtain_Float(UnTag_FLT(v_word)));

  return FALSE;
}
Пример #18
0
/*-------------------------------------------------------------------------*
 * SIMPLIFY                                                                *
 *                                                                         *
 * This function returns the result of the simplified boolean expression   *
 * given in e_word. NOT operators are only applied to variables.           *
 *                                                                         *
 * Input:                                                                  *
 *    sign  : current sign of the boolean term (-1 (inside a ~) or +1)     *
 *    e_word: boolean term to simplify                                     *
 *                                                                         *
 * Output:                                                                 *
 *    The returned result is a pointer to a node of the following form:    *
 *                                                                         *
 *    for binary boolean not operator (~):                                 *
 *        [1]: variable involved (tagged word)                             *
 *        [0]: operator NOT                                                *
 *                                                                         *
 *    for unary boolean operators (<=> ~<=> ==> ~==> /\ ~/\ \/ ~\/):       *
 *        [2]: right boolean exp (pointer to node)                         *
 *        [1]: left  boolean exp (pointer to node)                         *
 *        [0]: operator (EQUIV, NEQUIV, IMPLY, NIMPLY, AND, NAND, OR, NOR) *
 *                                                                         *
 *    for boolean false value (0):                                         *
 *        [0]: ZERO                                                        *
 *                                                                         *
 *    for boolean true value (1):                                          *
 *        [0]: ONE                                                         *
 *                                                                         *
 *    for boolean variable:                                                *
 *        [0]: tagged word                                                 *
 *                                                                         *
 *    for binary math operators (= \= < >= > <=) (partial / full AC):      *
 *        [2]: right math exp (tagged word)                                *
 *        [1]: left  math exp (tagged word)                                *
 *        [0]: operator (EQ, NEQ, LT, LTE, EQ_F, NEQ_F, LT_F, LTE_F)       *
 *             (GT, GTE, GT_F, and GTE_F becomes LT, LTE, LT_F and LTE_F)  *
 *                                                                         *
 * These nodes are stored in a hybrid stack. NB: XOR same as NEQUIV        *
 *-------------------------------------------------------------------------*/
static WamWord *
Simplify(int sign, WamWord e_word)
{
  WamWord word, tag_mask;
  WamWord *adr;
  WamWord f_n, le_word, re_word;
  int op, n;
  WamWord *exp, *sp1;
  WamWord l, r;

#ifdef DEBUG
  printf("ENTERING %5ld: %2d: ", sp - stack, sign);
  Pl_Write(e_word);
  printf("\n");
#endif

  exp = sp;

  if (sp - stack > BOOL_STACK_SIZE - 5)
    Pl_Err_Resource(pl_resource_too_big_fd_constraint);

  DEREF(e_word, word, tag_mask);
  if (tag_mask == TAG_REF_MASK || tag_mask == TAG_FDV_MASK)
    {
      adr = UnTag_Address(word);
      if (vars_sp - vars_tbl == VARS_STACK_SIZE)
	Pl_Err_Resource(pl_resource_too_big_fd_constraint);

      *vars_sp++ = word;
      *vars_sp++ = 0;		/* bool var */

      if (sign != 1)
	*sp++ = NOT;

      *sp++ = Tag_REF(adr);
      return exp;
    }

  if (tag_mask == TAG_INT_MASK)
    {
      n = UnTag_INT(word);
      if ((unsigned) n > 1)
	goto type_error;

      *sp++ = ZERO + ((sign == 1) ? n : 1 - n);
      return exp;
    }

  if (tag_mask == TAG_ATM_MASK)
    {
      word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
      Pl_Unify_Value(e_word);
      Pl_Unify_Integer(0);
    type_error:
      Pl_Err_Type(pl_type_fd_bool_evaluable, word);
    }


  if (tag_mask != TAG_STC_MASK)
    goto type_error;

  adr = UnTag_STC(word);

  f_n = Functor_And_Arity(adr);
  if (bool_xor == f_n)
    op = NEQUIV;
  else
    {
      for (op = 0; op < NB_OF_OP; op++)
	if (bool_tbl[op] == f_n)
	  break;

      if (op == NB_OF_OP)
	{
	  word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
	  Pl_Unify_Atom(Functor(adr));
	  Pl_Unify_Integer(Arity(adr));
	  goto type_error;
	}
    }

  le_word = Arg(adr, 0);
  re_word = Arg(adr, 1);

  if (op == NOT)
    return Simplify(-sign, le_word);

  if (sign != 1)
    op = (op % 2 == EQ % 2) ? op + 1 : op - 1;

  if (op >= EQ && op <= LTE_F)
    {
      Add_Fd_Variables(le_word);
      Add_Fd_Variables(re_word);

      n = (op == GT || op == GT_F) ? op - 2 :
	(op == GTE || op == GTE_F) ? op + 2 : op;

      *sp++ = n;
      *sp++ = (n == op) ? le_word : re_word;
      *sp++ = (n == op) ? re_word : le_word;
      return exp;
    }

  sp += 3;
  exp[0] = op;
  exp[1] = (WamWord) Simplify(1, le_word);
  sp1 = sp;
  exp[2] = (WamWord) Simplify(1, re_word);

  l = *(WamWord *) (exp[1]);
  r = *(WamWord *) (exp[2]);

  /* NB: beware when calling below Simplify() (while has been just called above)
   * this can ran into stack overflow (N^2 space complexity). 
   * Try to recover the stack before calling Simplify().
   * Other stack recovery are less important (e.g. when only using exp[1]).
   *
   * In the following exp[] += sizeof(WamWord) is used to "skip" the NOT
   * in a simplification (points to the next cell).
   */

  switch (op)
    {
    case EQUIV:
      if (l == ZERO)		/* 0 <=> R is ~R */
	{
	  sp = exp;
	  return Simplify(-1, re_word);
	}

      if (l == ONE)		/* 1 <=> R is R */
	{
	  return (WamWord *) exp[2];
	}

      if (r == ZERO)		/* L <=> 0 is ~L */
	{
	  sp = exp;
	  return Simplify(-1, le_word);
	}

      if (r == ONE)		/* L <=> 1 is L */
	{
	  sp = sp1;
	  return (WamWord *) exp[1];
	}

      if (l == NOT)		/* ~X <=> R is X <=> ~R */
	{
	  exp[1] += sizeof(WamWord); 
	  sp = sp1;
	  exp[2] = (WamWord) Simplify(-1, re_word);
	  break;
	}

      if (r == NOT)		/* L <=> ~X is ~L <=> X */
	{			/* NB: cannot recover the stack */	  
	  exp[1] = (WamWord) Simplify(-1, le_word);
	  exp[2] += sizeof(WamWord);
	  break;
	}
      break;

    case NEQUIV:
      if (l == ZERO)		/* 0 ~<=> R is R */
	{
	  return (WamWord *) exp[2];
	}

      if (l == ONE)		/* 1 ~<=> R is ~R */
	{
	  sp = exp;
	  return Simplify(-1, re_word);
	}

      if (r == ZERO)		/* L ~<=> 0 is L */
	{
	  sp = sp1;
	  return (WamWord *) exp[1];
	}

      if (r == ONE)		/* L ~<=> 1 is ~L */
	{
	  sp = exp;
	  return Simplify(-1, le_word);
	}

      if (l == NOT)		/* ~X ~<=> R is X <=> R */
	{
	  exp[0] = EQUIV;
	  exp[1] += sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L ~<=> ~X is L <=> X */
	{
	  exp[0] = EQUIV;
	  exp[2] += sizeof(WamWord);
	  break;
	}

      if (IsVar(l) && !IsVar(r)) /* X ~<=> R is X <=> ~R */
	{
	  exp[0] = EQUIV;
	  sp = sp1;
	  exp[2] = (WamWord) Simplify(-1, re_word);
	  break;
	}

      if (IsVar(r) && !IsVar(l)) /* L ~<=> X is L <=> ~X */
	{
	  exp[0] = EQUIV;	/* NB: cannot recover the stack */
	  exp[1] = (WamWord) Simplify(-1, le_word);
	  break;
	}
      break;

    case IMPLY:
      if (l == ZERO || r == ONE) /* 0 ==> R is 1 , L ==> 1 is 1 */
	{
	  sp = exp;
	  *sp++ = ONE;
	  break;
	}

      if (l == ONE)		/* 1 ==> R is R */
	{
	  return (WamWord *) exp[2];
	}

      if (r == ZERO)		/* L ==> 0 is ~L */
	return sp = exp, Simplify(-1, le_word);

      if (l == NOT)		/* ~X ==> R is X \/ R */
	{
	  exp[0] = OR;
	  exp[1] += sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L ==> ~X is X ==> ~L */
	{
	  exp[1] = exp[2] + sizeof(WamWord);
	  exp[2] = (WamWord) Simplify(-1, le_word);
	  break;
	}
      break;

    case NIMPLY:
      if (l == ZERO || r == ONE) /* 0 ~==> R is 0 , L ~==> 1 is 0 */
	{
	  sp = exp;
	  *sp++ = ZERO;
	  break;
	}

      if (l == ONE)		/* 1 ~==> R is ~R */
	{
	  sp = exp;
	  return Simplify(-1, re_word);
	}

      if (r == ZERO)		/* L ~==> 0 is L */
	{
	  sp = sp1;
	  return (WamWord *) exp[1];
	}

      if (l == NOT)		/* ~X ~==> R is X ~\/ R */
	{
	  exp[0] = NOR;
	  exp[1] += sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L ~==> ~X is L /\ X */
	{
	  exp[0] = AND;
	  exp[2] += sizeof(WamWord);
	  break;
	}
      break;

    case AND:
      if (l == ZERO || r == ZERO) /* 0 /\ R is 0 , L /\ 0 is 0 */
	{
	  sp = exp;
	  *sp++ = ZERO;
	  break;
	}

      if (l == ONE)		/* 1 /\ R is R */
	{
	  return (WamWord *) exp[2];
	}

      if (r == ONE)		/* L /\ 1 is L */
	{
	  sp = sp1;
	  return (WamWord *) exp[1];
	}

      if (l == NOT)		/* ~X /\ R is R ~==> X */
	{
	  exp[0] = NIMPLY;
	  word = exp[1];
	  exp[1] = exp[2];
	  exp[2] = word + sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L /\ ~X is L ~==> X */
	{
	  exp[0] = NIMPLY;
	  exp[2] += sizeof(WamWord);
	  break;
	}
      break;

    case NAND:
      if (l == ZERO || r == ZERO) /* 0 ~/\ R is 1 , L ~/\ 0 is 1 */
	{
	  sp = exp;
	  *sp++ = ONE;
	  break;
	}

      if (l == ONE)		/* 1 ~/\ R is ~R */
	{
	  sp = exp;
	  return Simplify(-1, re_word);
	}

      if (r == ONE)		/* L ~/\ 1 is ~L */
	{
	  sp = exp;
	  return Simplify(-1, le_word);
	}

      if (l == NOT)		/* ~X ~/\ R is R ==> X */
	{
	  exp[0] = IMPLY;
	  word = exp[1];
	  exp[1] = exp[2];
	  exp[2] = word + sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L ~/\ ~X is L ==> X */
	{
	  exp[0] = IMPLY;
	  exp[2] += sizeof(WamWord);
	  break;
	}
      break;

    case OR:
      if (l == ONE || r == ONE)	/* 1 \/ R is 1 , L \/ 1 is 1 */
	{
	  sp = exp;
	  *sp++ = ONE;
	  break;
	}

      if (l == ZERO)		/* 0 \/ R is R */
	{
	  return (WamWord *) exp[2];
	}

      if (r == ZERO)		/* L \/ 0 is L */
	{
	  sp = sp1;
	  return (WamWord *) exp[1];
	}

      if (l == NOT)		/* ~X \/ R is X ==> R */
	{
	  exp[0] = IMPLY;
	  exp[1] += sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L \/ ~X is X ==> L */
	{
	  exp[0] = IMPLY;
	  word = exp[1];
	  exp[1] = exp[2] + sizeof(WamWord);
	  exp[2] = word;
	  break;
	}
      break;

    case NOR:
      if (l == ONE || r == ONE)	/* 1 ~\/ R is 0 , L ~\/ 1 is 0 */
	{
	  sp = exp;
	  *sp++ = ZERO;
	  break;
	}

      if (l == ZERO)		/* 0 ~\/ R is ~R */
	{
	  sp = exp;
	  return Simplify(-1, re_word);
	}

      if (r == ZERO)		/* L ~\/ 0 is ~L */
	{
	  sp = exp;
	  return Simplify(-1, le_word);
	}

      if (l == NOT)		/* ~X ~\/ R is X ~==> R */
	{
	  exp[0] = NIMPLY;
	  exp[1] += sizeof(WamWord);
	  break;
	}

      if (r == NOT)		/* L ~\/ ~X is X ~==> L */
	{
	  exp[0] = NIMPLY;
	  word = exp[1];
	  exp[1] = exp[2] + sizeof(WamWord);
	  exp[2] = word;
	  break;
	}
      break;
    }

  return exp;
}
Пример #19
0
LispInt ListedMacroUserFunction::IsArity(LispInt aArity) const
{
    return Arity() <= aArity;
}
Пример #20
0
static bool recursive_print(std::ostream& out, const NodePtr root,
	 const RuleTable& rules, BindingsPtr bindings,
	 std::size_t indent,
	 Context& context) {
   if (root->is_leaf()) {
      return !!(out << root->get_token().get_literal());
   } else {
      Arity arity(root->size());
      Operator op = root->get_op();
      BindingsPtr local_bindings;
      RuleTable::print_iterator it, end;
      int found = 0;
      for (it = rules.reversed_find(op, arity, end); it != end; ++it) {
	 ++found;
	 local_bindings = std::make_shared<Bindings>(bindings);
	 if (matches(root, it->second->get_tree_expression(),
	       local_bindings, context)) break;
      }
      if (it == end) {
	 // try wildcard rules
	 for (it = rules.reversed_find(op, Arity(), end);
	       it != end; ++it) {
	    ++found;
	    local_bindings = std::make_shared<Bindings>(bindings);
	    if (matches(root, it->second->get_tree_expression(),
		  local_bindings, context)) break;
	 }
	 if (it == end) {
	    std::ostringstream os;
	    if (found > 0) {
	       os << "no matching ";
	    } else {
	       os << "no ";
	    }
	    os << "rule found for '" << op.get_name() << "' with " <<
	       root->size() << " parameters";
	    throw Exception(root->get_location(), os.str());
	 }
      }
      context.descend(root);
      const NodePtr& node = it->second->get_rhs();
      std::size_t add_indent = 0;
      for (std::size_t pi = 0; pi < node->size(); ++pi) {
	 const NodePtr& subnode = node->get_operand(pi);
	 if (subnode->is_leaf()) {
	    Token t = subnode->get_token();
	    switch (t.get_tokenval()) {
	       case parser::token::TEXT_LITERAL: {
		     expand_text(out, t, indent);
		     int new_indent = get_indent(t.get_text());
		     if (new_indent >= 0) add_indent = new_indent;
		     break;
		  }
	       case parser::token::VARIABLE:
		  if (!expand_variable(out, t.get_text(), rules,
			indent + add_indent,
			bindings, local_bindings, context)) {
		     std::ostringstream os;
		     os << "undefined variable in replacement text: " <<
			t.get_text();
		     throw Exception(subnode->get_location(), os.str());
		  }
		  break;
	       default:
		  assert(false); std::abort();
	    }
	 } else if (subnode->get_op() == Op::print_expression_listvar) {
	    std::string varname =
	       subnode->get_operand(0)->get_token().get_text();
	    if (!local_bindings->defined(varname)) {
	       std::ostringstream os;
	       os << "undefined variable in replacement list: " <<
		  varname;
	       throw Exception(subnode->get_location(), os.str());
	    }
	    AttributePtr list = local_bindings->get(varname);
	    if (list->get_type() != Attribute::list) {
	       std::ostringstream os;
	       os << "list expected: " << varname;
	       throw Exception(subnode->get_location(), os.str());
	    }
	    if (list->size() > 0) {
	       recursive_print(out, list->get_value(0)->get_node(),
		  rules, bindings, indent + add_indent, context);
	    }
	    for (std::size_t i = 1; i < list->size(); ++i) {
	       if (subnode->size() == 2) {
		  Token t = subnode->get_operand(1)->get_token();
		  expand_text(out, t, indent);
		  int new_indent = get_indent(t.get_text());
		  if (new_indent >= 0) add_indent = new_indent;
	       }
	       recursive_print(out, list->get_value(i)->get_node(),
		  rules, bindings, indent + add_indent, context);
	    }
	 } else {
	    assert(subnode->get_op() == Op::expression);
	    Expression expr(subnode, local_bindings);
	    if (!recursive_print(out, expr.convert_to_node(),
		  rules, bindings, indent, context)) {
	       return false;
	    }
	 }
      }
   }
   context.ascend();
   return true;
}
Пример #21
0
void BranchingUserFunction::Evaluate(LispPtr& aResult,LispEnvironment& aEnvironment,
                                     LispPtr& aArguments)
{
    const LispInt arity = Arity();
    LispInt i;

    if (Traced()) {
        LispPtr tr(LispSubList::New(aArguments));
        TraceShowEnter(aEnvironment, tr);
        tr = nullptr;
    }

    LispIterator iter(aArguments);
    ++iter;

    // unrollable arguments
    std::unique_ptr<LispPtr[]> arguments(arity == 0 ? nullptr : new LispPtr[arity]);

    // Walk over all arguments, evaluating them as necessary
    for (i = 0; i < arity; i++, ++iter) {
        if (!iter.getObj())
            throw LispErrWrongNumberOfArgs();

        if (iParameters[i].iHold) {
            arguments[i] = iter.getObj()->Copy();
        } else {
            //Check(iter.getObj(), KLispErrWrongNumberOfArgs);  // checked above
            InternalEval(aEnvironment, arguments[i], *iter);
        }
    }

    if (Traced()) {
        LispIterator iter(aArguments);
        for (i = 0; i < arity; i++)
            TraceShowArg(aEnvironment, *++iter, arguments[i]);
    }

    // declare a new local stack.
    LispLocalFrame frame(aEnvironment, Fenced());

    // define the local variables.
    for (i = 0; i < arity; i++) {
        const LispString* variable = iParameters[i].iParameter;
        // set the variable to the new value
        aEnvironment.NewLocal(variable, arguments[i]);
    }

    // walk the rules database, returning the evaluated result if the
    // predicate is true.
    const std::size_t nrRules = iRules.size();
    UserStackInformation &st = aEnvironment.iEvaluator->StackInformation();
    for (std::size_t i = 0; i < nrRules; i++) {
        BranchRuleBase* thisRule = iRules[i];
        assert(thisRule);

        st.iRulePrecedence = thisRule->Precedence();
        bool matches = thisRule->Matches(aEnvironment, arguments.get());
        if (matches) {
            st.iSide = 1;
            InternalEval(aEnvironment, aResult, thisRule->Body());
            goto FINISH;
        }

        // If rules got inserted, walk back
        while (thisRule != iRules[i] && i > 0)
            i--;
    }

    // No predicate was true: return a new expression with the evaluated
    // arguments.

    {
        LispPtr full(aArguments->Copy());
        if (arity == 0) {
            full->Nixed() = nullptr;
        } else {
            full->Nixed() = arguments[0];
            for (i = 0; i < arity - 1; i++)
                arguments[i]->Nixed() = arguments[i + 1];
        }
        aResult = LispSubList::New(full);
    }

FINISH:
    if (Traced()) {
        LispPtr tr(LispSubList::New(aArguments));
        TraceShowLeave(aEnvironment, aResult, tr);
        tr = nullptr;
    }
}
Пример #22
0
namespace Ginger {

Ref * sysIsLowerCase( Ref * pc, class MachineClass * vm ) {
    if ( vm->count != 1 ) throw Ginger::Mishap( "Wrong number of arguments" );
    
    Ref r = vm->fastPeek();
    if ( IsCharacter( r ) ) {
        vm->fastPeek() = islower( CharacterToChar( r ) ) ? SYS_TRUE : SYS_FALSE;
    } else if ( IsString( r ) ) {
        Ref * str_K = RefToPtr4( r );
        char * s = reinterpret_cast< char * >( &str_K[ 1 ] );
        vm->fastPeek() = SYS_TRUE;
        while ( *s != 0 ) {
            if ( not islower( *s++ ) ) {
                vm->fastPeek() = SYS_FALSE;
                break;
            }
        }
    } else {
        throw Ginger::Mishap( "Non-character argument" ).culprit( "Argument", refToShowString( r ) );  
    } 
    
    return pc;
}
SysInfo infoIsLowerCase( 
    FullName( "isLowerCase" ), 
    Arity( 1 ), 
    Arity( 1 ), 
    sysIsLowerCase, 
    "Returns true for a lower case character or string, otherwise false" 
);

Ref * sysIsUpperCase( Ref * pc, class MachineClass * vm ) {
    if ( vm->count != 1 ) throw Ginger::Mishap( "Wrong number of arguments" );
    
    Ref r = vm->fastPeek();
    if ( IsCharacter( r ) ) {
        vm->fastPeek() = isupper( CharacterToChar( r ) ) ? SYS_TRUE : SYS_FALSE;
    } else if ( IsString( r ) ) {
        Ref * str_K = RefToPtr4( r );
        char * s = reinterpret_cast< char * >( &str_K[ 1 ] );
        vm->fastPeek() = SYS_TRUE;
        while ( *s != 0 ) {
            if ( not isupper( *s++ ) ) {
                vm->fastPeek() = SYS_FALSE;
                break;
            }
        }
    } else {
        throw Ginger::Mishap( "Non-character argument" ).culprit( "Argument", refToShowString( r ) );  
    }     
    return pc;
}
SysInfo infoIsUpperCase( 
    FullName( "isUpperCase" ), 
    Arity( 1 ), 
    Arity( 1 ), 
    sysIsUpperCase, 
    "Returns true for a upper case character or string, otherwise false" 
);

}
Пример #23
0
/*-------------------------------------------------------------------------*
 * SHOW_STRUCTURE                                                          *
 *                                                                         *
 *-------------------------------------------------------------------------*/
static void
Show_Structure(int depth, int prec, int context, WamWord *stc_adr)
{
  WamWord word, tag_mask;
  WamWord *adr;
  WamWord f_n = Functor_And_Arity(stc_adr);
  int functor = Functor(stc_adr);
  int arity = Arity(stc_adr);
  OperInf *oper;
  int nb_args_to_disp;
  int i, j, n;
  char str[32];
  Bool bracket;
  Bool surround_space;
  char *p;


  depth--;

  if (name_vars && f_n == dollar_varname_1 && stc_adr >= name_number_above_H)
    {
      DEREF(Arg(stc_adr, 0), word, tag_mask);
      if (tag_mask == TAG_ATM_MASK)
	{
	  p = pl_atom_tbl[UnTag_ATM(word)].name;
	  if (Is_Valid_Var_Name(p))
	    {
	      Out_String(p);
	      pl_last_writing = W_IDENTIFIER;
	      return;
	    }
	}
    }

  if (number_vars && f_n == dollar_var_1 && stc_adr >= name_number_above_H)
    {
      DEREF(Arg(stc_adr, 0), word, tag_mask);
      if (tag_mask == TAG_INT_MASK && (n = UnTag_INT(word)) >= 0)
	{
	  i = n % 26;
	  j = n / 26;

	  Out_Char('A' + i);

	  if (j)
	    {
	      sprintf(str, "%d", j);
	      Out_String(str);
	    }

	  pl_last_writing = W_IDENTIFIER;
	  return;
	}
    }

  if (ignore_op || arity > 2)
    goto functional;

  if (f_n == curly_brackets_1)
    {
      Out_Char('{');
      if (space_args)
	Out_Space();
      Show_Term(depth, MAX_PREC, GENERAL_TERM, Arg(stc_adr, 0));
      if (space_args)
	Out_Space();
      Out_Char('}');
      return;
    }

  bracket = FALSE;

  if (arity == 1 && (oper = Pl_Lookup_Oper(functor, PREFIX)))
    {
#if 1
      /* Koen de Bosschere says "in case of ambiguity :          */
      /* select the associative operator over the nonassociative */
      /* select prefix over postfix".                            */

      OperInf *oper1;

      if (oper->prec > oper->right
	  && (oper1 = Pl_Lookup_Oper(functor, POSTFIX))
	  && oper1->left == oper1->prec)
	{
	  oper = oper1;
	  goto postfix;
	}
#endif
      if (oper->prec > prec || (context == INSIDE_LEFT_ASSOC_OP &&
				(oper->prec == oper->right
				 && oper->prec == prec)))
	{			/* prevent also the case: fy T yf(x) */
	  Out_Char('(');
	  bracket = TRUE;
	}


      Show_Atom(GENERAL_TERM, functor);

      last_prefix_op = W_PREFIX_OP_ANY;

      if (space_args
#if SPACE_ARGS_RESTRICTED	/* space_args -> space after fx operator */
	  && oper->prec > oper->right
#endif
	  )
	Out_Space();
      else
	if (strcmp(pl_atom_tbl[functor].name, "-") == 0)
	  {
	    last_prefix_op = W_PREFIX_OP_MINUS;
	    p_bracket_minus = &bracket;
	  }

      Show_Term(depth, oper->right, INSIDE_ANY_OP, Arg(stc_adr, 0));
      last_prefix_op = W_NO_PREFIX_OP;

      /* Here we need a while(bracket--) instead of if(bracket) because
       * in some cases with the minus op and additional bracket is needed.
       * Example: with op(100, xfx, &) (recall the prec of - is 200). 
       * The term ((-(1)) & b must be displayed as: (- (1)) & b
       * Concerning the sub-term - (1), the first ( is emitted  10 lines above
       * because the precedence of - (200) is > precedence of & (100).
       * The second ( is emitted by Need_Space() because the argument of - begins 
       * by a digit. At the return we have to close 2 ).
       */

      while (bracket--)	
	Out_Char(')');

      return;
    }


  if (arity == 1 && (oper = Pl_Lookup_Oper(functor, POSTFIX)))
    {
    postfix:
      if (oper->prec > prec)
	{
	  Out_Char('(');
	  bracket = TRUE;
	}

      context =
	(oper->left == oper->prec) ? INSIDE_LEFT_ASSOC_OP : INSIDE_ANY_OP;

      Show_Term(depth, oper->left, context, Arg(stc_adr, 0));

      if (space_args
#if SPACE_ARGS_RESTRICTED	/* space_args -> space before xf operator */
	  && oper->prec > oper->left
#endif
	  )
	Out_Space();

      Show_Atom(GENERAL_TERM, functor);

      if (bracket)
	Out_Char(')');

      return;
    }


  if (arity == 2 && (oper = Pl_Lookup_Oper(functor, INFIX)))
    {
      if (oper->prec > prec || (context == INSIDE_LEFT_ASSOC_OP &&
				(oper->prec == oper->right
				 && oper->prec == prec)))
	{			/* prevent also the case: T xfy U yf(x) */
	  Out_Char('(');
	  bracket = TRUE;
	}

      context =
	(oper->left == oper->prec) ? INSIDE_LEFT_ASSOC_OP : INSIDE_ANY_OP;

      Show_Term(depth, oper->left, context, Arg(stc_adr, 0));

#if 1 /* to show | unquoted if it is an infix operator with prec > 1000 */
      if (functor == ATOM_CHAR('|') && oper->prec > 1000)
	{
	  if (space_args)
	    Out_Space();
	  Out_Char('|');
	  if (space_args)
	    Out_Space();
	}
      else
#endif
	if (functor == ATOM_CHAR(','))
	  {
	    Out_Char(',');
	    if (space_args)
	      Out_Space();
	  }
	else
	  {
	    surround_space = FALSE;

	    if (pl_atom_tbl[functor].prop.type == IDENTIFIER_ATOM ||
		pl_atom_tbl[functor].prop.type == OTHER_ATOM ||
		(space_args
#ifdef SPACE_ARGS_RESTRICTED	/* space_args -> space around xfx operators */
		 && oper->left != oper->prec && oper->right != oper->prec
#endif
		 ))
	      {
		surround_space = TRUE;
		Out_Space();
	      }

	    Show_Atom(GENERAL_TERM, functor);

	    if (surround_space)
	      Out_Space();
	  }

      Show_Term(depth, oper->right, INSIDE_ANY_OP, Arg(stc_adr, 1));

      if (bracket)
	Out_Char(')');

      return;
    }



 functional:			/* functional notation */

  Show_Atom(GENERAL_TERM, functor);
  Out_Char('(');

  nb_args_to_disp = i = (arity < depth + 1 || depth < 0) ? arity : depth + 1;
  adr = &Arg(stc_adr, 0);

  goto start_display;

  do
    {
      Out_Char(',');
      if (space_args)
	Out_Space();
    start_display:
      Show_Term(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, *adr++);
    }
  while (--i);

  if (arity != nb_args_to_disp)
    {
      Out_Char(',');
      if (space_args)
	Out_Space();
      Show_Atom(GENERAL_TERM, atom_dots);
    }

  Out_Char(')');
}
Пример #24
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;
}