static int bind_varnames(term_t varnames ARG_LD) { CACHE_REGS Term t = Yap_GetFromSlot(varnames); while(!IsVarTerm(t) && IsPairTerm(t)) { Term tl = HeadOfTerm(t); Functor f; Term tv, t2, t1; if (!IsApplTerm(tl)) return FALSE; if ((f = FunctorOfTerm(tl)) != FunctorEq) { return FALSE; } t1 = ArgOfTerm(1, tl); if (IsVarTerm(t1)) { return PL_error(NULL, 0, "variable_names", ERR_INSTANTIATION, 0, t1); } t2 = ArgOfTerm(2, tl); tv = Yap_MkApplTerm(LOCAL_FunctorVar, 1, &t1); if (IsVarTerm(t2)) { Bind_and_Trail(VarOfTerm(t2), tv); } t = TailOfTerm(t); } return TRUE; }
/** * Specify an alias to the stream. The alias <tt>Name</tt> must be an atom. The * alias can be used instead of the stream descriptor for every operation * concerning the stream. * * @param + _tname_ Name of Alias * @param + _tstream_ stream identifier * * @return */ static Int add_alias_to_stream (USES_REGS1) { Term tname = Deref(ARG1); Term tstream = Deref(ARG2); Atom at; Int sno; if (IsVarTerm(tname)) { Yap_Error(INSTANTIATION_ERROR, tname, "$add_alias_to_stream"); return (FALSE); } else if (!IsAtomTerm (tname)) { Yap_Error(TYPE_ERROR_ATOM, tname, "$add_alias_to_stream"); return (FALSE); } if (IsVarTerm(tstream)) { Yap_Error(INSTANTIATION_ERROR, tstream, "$add_alias_to_stream"); return (FALSE); } else if (!IsApplTerm (tstream) || FunctorOfTerm (tstream) != FunctorStream || !IsIntTerm(ArgOfTerm(1,tstream))) { Yap_Error(DOMAIN_ERROR_STREAM_OR_ALIAS, tstream, "$add_alias_to_stream"); return (FALSE); } at = AtomOfTerm(tname); sno = (int)IntOfTerm(ArgOfTerm(1,tstream)); if (Yap_AddAlias(at, sno)) return(TRUE); /* we could not create the alias, time to close the stream */ Yap_CloseStream(sno); Yap_Error(PERMISSION_ERROR_NEW_ALIAS_FOR_STREAM, tname, "open/3"); return (FALSE); }
static Int qq_open(USES_REGS1) { PRED_LD Term t = Deref(ARG1); if (!IsVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) = FunctorDQuasiQuotation) { void *ptr; char *start; size_t l int s; Term t0, t1, t2; if (IsPointerTerm((t0 = ArgOfTerm(1, t))) && IsPointerTerm((t1 = ArgOfTerm(2, t))) && IsIntegerTerm((t2 = ArgOfTerm(3, t)))) { ptr = PointerOfTerm(t0); start = PointerOfTerm(t1); len = IntegerOfTerm(t2); if ((s = Yap_open_buf_read_stream(start, len, ENC_UTF8, MEM_BUF_USER)) < 0) return false; return Yap_unify(ARG2, Yap_MkStream(s)); } else { Yap_Error(TYPE_ERROR_READ_CONTEXT, t); } return FALSE; } }
static bool bind_variable_names(Term t USES_REGS) { while (!IsVarTerm(t) && IsPairTerm(t)) { Term tl = HeadOfTerm(t); Functor f; Term tv, t2, t1; if (!IsApplTerm(tl)) return FALSE; if ((f = FunctorOfTerm(tl)) != FunctorEq) { return FALSE; } t1 = ArgOfTerm(1, tl); if (IsVarTerm(t1)) { Yap_Error(INSTANTIATION_ERROR, t1, "variable_names"); return false; } t2 = ArgOfTerm(2, tl); tv = Yap_MkApplTerm(FunctorDollarVar, 1, &t1); if (IsVarTerm(t2)) { YapBind(VarOfTerm(t2), tv); } t = TailOfTerm(t); } return true; }
const char *Yap_GetFileName(Term t USES_REGS) { char *buf = Malloc(YAP_FILENAME_MAX + 1); if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorSlash) { snprintf(buf, YAP_FILENAME_MAX, "%s/%s", Yap_GetFileName(ArgOfTerm(1, t)), Yap_GetFileName(ArgOfTerm(2, t))); } if (IsAtomTerm(t)) { return RepAtom(AtomOfTerm(t))->StrOfAE; } if (IsStringTerm(t)) { return StringOfTerm(t); } return Yap_TextTermToText(t PASS_REGS); }
/* * Here we initialize the arguments indexing */ YAP_Int p_udi_args_init(Term spec, int arity, UdiInfo blk) { int i; Term arg; Atom idxtype; UdiControlBlock *cb; struct udi_p_args p_arg; for (i = 1; i <= arity; i++) { arg = ArgOfTerm(i,spec); if (IsAtomTerm(arg)) { idxtype = AtomOfTerm(arg); if (idxtype == AtomMinus) //skip this argument continue; p_arg.control = NULL; cb = NULL; while ((cb = (UdiControlBlock *) utarray_next(indexing_structures, cb))) { if (idxtype == (*cb)->decl){ p_arg.arg = i; p_arg.control = *cb; p_arg.idxstr = (*cb)->init(spec, i, arity); utarray_push_back(blk->args, &p_arg); } } if (p_arg.control == NULL){ /* not "-" and not found */ fprintf(stderr, "Invalid Spec (%s)\n", AtomName(idxtype)); return FALSE; } } } return TRUE; }
static Term get_matrix_element(Term t1, Term t2 USES_REGS) { if (!IsPairTerm(t2)) { if (t2 == MkAtomTerm(AtomLength)) { Int sz = 1; while (IsApplTerm(t1)) { Functor f = FunctorOfTerm(t1); if (NameOfFunctor(f) != AtomNil) { return MkIntegerTerm(sz); } sz *= ArityOfFunctor(f); t1 = ArgOfTerm(1, t1); } return MkIntegerTerm(sz); } Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]"); return FALSE; } while (IsPairTerm(t2)) { Int indx; Term indxt = Eval(HeadOfTerm(t2) PASS_REGS); if (!IsIntegerTerm(indxt)) { Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]"); return FALSE; } indx = IntegerOfTerm(indxt); if (!IsApplTerm(t1)) { Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]"); return FALSE; } else { Functor f = FunctorOfTerm(t1); if (ArityOfFunctor(f) < indx) { Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]"); return FALSE; } } t1 = ArgOfTerm(indx, t1); t2 = TailOfTerm(t2); } if (t2 != TermNil) { Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]"); return FALSE; } return Eval(t1 PASS_REGS); }
static Term add_names(Term t, Term tail) { Term topt = Yap_MkNewApplTerm(Yap_MkFunctor(AtomVariableNames, 1), 1); Yap_unify(t, ArgOfTerm(1, topt)); if (IsPairTerm(tail) || tail == TermNil) { return MkPairTerm(topt, tail); } else { return MkPairTerm(topt, MkPairTerm(tail, TermNil)); } }
static Term add_priority(Term t, Term tail) { Term topt = Yap_MkNewApplTerm(Yap_MkFunctor(AtomPriority, 1), 1); Yap_unify(t, ArgOfTerm(1, topt)); if (IsPairTerm(tail) || tail == TermNil) { return MkPairTerm(topt, tail); } else { return MkPairTerm(topt, MkPairTerm(tail, TermNil)); } }
YAPPredicate::YAPPredicate(Term &t, Term &tmod, CELL *&ts, const char *pname) { Term t0 = t; ap = nullptr; restart: if (IsVarTerm(t)) { throw YAPError(SOURCE(), INSTANTIATION_ERROR, t0, pname); } else if (IsAtomTerm(t)) { ap = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod)); ts = nullptr; } else if (IsIntegerTerm(t) && tmod == IDB_MODULE) { ts = nullptr; ap = Yap_FindLUIntKey(IntegerOfTerm(t)); } else if (IsPairTerm(t)) { t = Yap_MkApplTerm(FunctorCsult, 1, &t); goto restart; } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); if (IsExtensionFunctor(fun)) { throw YAPError(SOURCE(), TYPE_ERROR_CALLABLE, Yap_TermToIndicator(t, tmod), pname); } if (fun == FunctorModule) { tmod = ArgOfTerm(1, t); if (IsVarTerm(tmod)) { throw YAPError(SOURCE(), INSTANTIATION_ERROR, t0, pname); } if (!IsAtomTerm(tmod)) { throw YAPError(SOURCE(), TYPE_ERROR_ATOM, t0, pname); } t = ArgOfTerm(2, t); goto restart; } ap = RepPredProp(Yap_GetPredPropByFunc(fun, tmod)); ts = RepAppl(t) + 1; } else { throw YAPError(SOURCE(), TYPE_ERROR_CALLABLE, t0, pname); } }
static int unbind_variable_names(Term t USES_REGS) { while (!IsVarTerm(t) && IsPairTerm(t)) { Term tl = HeadOfTerm(t); Functor f; Term *tp2, t1; if (!IsApplTerm(tl)) return FALSE; if ((f = FunctorOfTerm(tl)) != FunctorEq) { return FALSE; } t1 = ArgOfTerm(1, tl); tp2 = RepAppl(tl) + 2; while (*tp2 != t1) { tp2 = (CELL *)*tp2; } RESET_VARIABLE(tp2); t = TailOfTerm(t); } return TRUE; }
Term YAPTerm::getArg(arity_t i) { BACKUP_MACHINE_REGS(); Term tf = 0; Term t0 = gt(); if (IsApplTerm(t0)) { if (i > ArityOfFunctor(FunctorOfTerm(t0))) throw YAPError(SOURCE(), DOMAIN_ERROR_OUT_OF_RANGE, t0, "t0.getArg()"); tf = (ArgOfTerm(i, t0)); } else if (IsPairTerm(t0)) { if (i == 1) tf = (HeadOfTerm(t0)); else if (i == 2) tf = (TailOfTerm(t0)); else throw YAPError(SOURCE(), DOMAIN_ERROR_OUT_OF_RANGE, t0, "t0.getArg()"); } else { throw YAPError(SOURCE(), TYPE_ERROR_COMPOUND, t0, "t0.getArg()"); } RECOVER_MACHINE_REGS(); return tf; }
YAPTerm YAPApplTerm::getArg(int arg) { BACKUP_H(); YAPTerm to = YAPTerm( ArgOfTerm(arg, gt() ) ); RECOVER_H(); return to; }
/* * New user indexed predicate: * the first argument is the term. */ static YAP_Int p_new_udi( USES_REGS1 ) { Term spec = Deref(ARG1); PredEntry *p; UdiInfo blk; int info; /* get the predicate from the spec, copied from cdmgr.c */ if (IsVarTerm(spec)) { Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1"); return FALSE; } else if (!IsApplTerm(spec)) { Yap_Error(TYPE_ERROR_COMPOUND,spec,"new user index/1"); return FALSE; } else { Functor fun = FunctorOfTerm(spec); Term tmod = CurrentModule; while (fun == FunctorModule) { tmod = ArgOfTerm(1,spec); if (IsVarTerm(tmod) ) { Yap_Error(INSTANTIATION_ERROR, spec, "new user index/1"); return FALSE; } if (!IsAtomTerm(tmod) ) { Yap_Error(TYPE_ERROR_ATOM, spec, "new user index/1"); return FALSE; } spec = ArgOfTerm(2, spec); fun = FunctorOfTerm(spec); } p = RepPredProp(PredPropByFunc(fun, tmod)); } if (!p) return FALSE; /* boring, boring, boring! */ if ((p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) || (p->ModuleOfPred == PROLOG_MODULE)) { Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, spec, "udi/2"); return FALSE; } if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) { Yap_Error(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, spec, "udi/2"); return FALSE; } /* TODO: remove AtomRTree from atom list */ /* this is the real work */ blk = (UdiInfo) Yap_AllocCodeSpace(sizeof(struct udi_info)); memset((void *) blk,0, sizeof(struct udi_info)); if (!blk) { Yap_Error(OUT_OF_HEAP_ERROR, spec, "new user index/1"); return FALSE; } /*Init UdiInfo */ utarray_new(blk->args, &arg_icd); utarray_new(blk->clauselist, &cl_icd); blk->p = p; /*Now Init args list*/ info = p_udi_args_init(spec, p->ArityOfPE, blk); if (!info) { utarray_free(blk->args); utarray_free(blk->clauselist); Yap_FreeCodeSpace((char *) blk); return FALSE; } /*Push into the hash*/ HASH_ADD_UdiInfo(UdiControlBlocks, p, blk); p->PredFlags |= UDIPredFlag; return TRUE; }
static Int p_socket_bind(USES_REGS1) { Term t1 = Deref(ARG1); Term t2 = Deref(ARG2); int sno; Functor fun; socket_info status; int fd; if ((sno = Yap_CheckSocketStream(t1, "socket_bind/2")) < 0) { return (FALSE); } status = Yap_GetSocketStatus(sno); fd = Yap_GetStreamFd(sno); if (status != new_socket) { /* ok, this should be an error, as you are trying to bind */ return(FALSE); } if (IsVarTerm(t2)) { Yap_Error(INSTANTIATION_ERROR,t2,"socket_bind/2"); return(FALSE); } if (!IsApplTerm(t2)) { Yap_Error(DOMAIN_ERROR_STREAM,t2,"socket_bind/2"); return(FALSE); } fun = FunctorOfTerm(t2); #if HAVE_SYS_UN_H if (fun == FunctorAfUnix || fun == FunctorAfLocal) { struct sockaddr_un sock; Term taddr = ArgOfTerm(1, t2); char *s; int len; if (IsVarTerm(taddr)) { Yap_Error(INSTANTIATION_ERROR,t2,"socket_bind/2"); return(FALSE); } if (!IsAtomTerm(taddr)) { Yap_Error(TYPE_ERROR_ATOM,taddr,"socket_bind/2"); return(FALSE); } s = RepAtom(AtomOfTerm(taddr))->StrOfAE; sock.sun_family = AF_UNIX; if ((len = strlen(s)) > 107) /* hit me with a broomstick */ { Yap_Error(DOMAIN_ERROR_STREAM,taddr,"socket_bind/2"); return(FALSE); } sock.sun_family=AF_UNIX; strcpy(sock.sun_path,s); if (bind(fd, (struct sockaddr *)(&sock), ((size_t) (((struct sockaddr_un *) 0)->sun_path) + len)) < 0) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (bind: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (bind)"); #endif return(FALSE); } Yap_UpdateSocketStream(sno, server_socket, af_unix); return(TRUE); } else #endif if (fun == FunctorAfInet) { Term thost = ArgOfTerm(1, t2); Term tport = ArgOfTerm(2, t2); char *shost; struct hostent *he; struct sockaddr_in saddr; Int port; memset((void *)&saddr,(int) 0, sizeof(saddr)); if (IsVarTerm(thost)) { saddr.sin_addr.s_addr = INADDR_ANY; } else if (!IsAtomTerm(thost)) { Yap_Error(TYPE_ERROR_ATOM,thost,"socket_bind/2"); return(FALSE); } else { shost = RepAtom(AtomOfTerm(thost))->StrOfAE; if((he=gethostbyname(shost))==NULL) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (gethostbyname: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (gethostbyname)"); #endif return(FALSE); } memcpy((void *)&saddr.sin_addr, (void *)he->h_addr_list[0], he->h_length); } if (IsVarTerm(tport)) { port = 0; } else { port = IntOfTerm(tport); } saddr.sin_port = htons(port); saddr.sin_family = AF_INET; if(bind(fd,(struct sockaddr *)&saddr, sizeof(saddr))==-1) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (bind: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (bind)"); #endif return(FALSE); } if (IsVarTerm(tport)) { /* get the port number */ #if _WIN32 || defined(__MINGW32__) int namelen; #else unsigned int namelen; #endif Term t; if (getsockname(fd, (struct sockaddr *)&saddr, &namelen) < 0) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (getsockname: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_bind/2 (getsockname)"); #endif return(FALSE); } t = MkIntTerm(ntohs(saddr.sin_port)); Yap_unify(ArgOfTermCell(2, t2),t); } Yap_UpdateSocketStream(sno, server_socket, af_inet); return(TRUE); } else return(FALSE); }
static Int p_socket_connect(USES_REGS1) { Term t1 = Deref(ARG1); Term t2 = Deref(ARG2); Functor fun; int sno; socket_info status; int fd; int flag; Term out; if ((sno = Yap_CheckSocketStream(t1, "socket_connect/3")) < 0) { return (FALSE); } if (IsVarTerm(t2)) { Yap_Error(INSTANTIATION_ERROR,t2,"socket_connect/3"); return(FALSE); } if (!IsApplTerm(t2)) { Yap_Error(DOMAIN_ERROR_STREAM,t2,"socket_connect/3"); return(FALSE); } fun = FunctorOfTerm(t2); fd = Yap_GetStreamFd(sno); status = Yap_GetSocketStatus(sno); if (status != new_socket) { /* ok, this should be an error, as you are trying to bind */ return(FALSE); } #if HAVE_SYS_UN_H if (fun == FunctorAfUnix) { struct sockaddr_un sock; Term taddr = ArgOfTerm(1, t2); char *s; int len; if (IsVarTerm(taddr)) { Yap_Error(INSTANTIATION_ERROR,t2,"socket_connect/3"); return(FALSE); } if (!IsAtomTerm(taddr)) { Yap_Error(TYPE_ERROR_ATOM,taddr,"socket_connect/3"); return(FALSE); } s = RepAtom(AtomOfTerm(taddr))->StrOfAE; sock.sun_family = AF_UNIX; if ((len = strlen(s)) > 107) /* beat me with a broomstick */ { Yap_Error(DOMAIN_ERROR_STREAM,taddr,"socket_connect/3"); return(FALSE); } sock.sun_family=AF_UNIX; strcpy(sock.sun_path,s); if ((flag = connect(fd, (struct sockaddr *)(&sock), ((size_t) (((struct sockaddr_un *) 0)->sun_path) + len))) < 0) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (connect: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (connect)"); #endif return(FALSE); } Yap_UpdateSocketStream(sno, client_socket, af_unix); } else #endif if (fun == FunctorAfInet) { Term thost = ArgOfTerm(1, t2); Term tport = ArgOfTerm(2, t2); char *shost; struct hostent *he; struct sockaddr_in saddr; unsigned short int port; memset((void *)&saddr,(int) 0, sizeof(saddr)); if (IsVarTerm(thost)) { Yap_Error(INSTANTIATION_ERROR,thost,"socket_connect/3"); return(FALSE); } else if (!IsAtomTerm(thost)) { Yap_Error(TYPE_ERROR_ATOM,thost,"socket_connect/3"); return(FALSE); } else { shost = RepAtom(AtomOfTerm(thost))->StrOfAE; if((he=gethostbyname(shost))==NULL) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (gethostbyname: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (gethostbyname)"); #endif return(FALSE); } memcpy((void *)&saddr.sin_addr, (void *)he->h_addr_list[0], he->h_length); } if (IsVarTerm(tport)) { Yap_Error(INSTANTIATION_ERROR,tport,"socket_connect/3"); return(FALSE); } else if (!IsIntegerTerm(tport)) { Yap_Error(TYPE_ERROR_INTEGER,tport,"socket_connect/3"); return(FALSE); } else { port = (unsigned short int)IntegerOfTerm(tport); } saddr.sin_port = htons(port); saddr.sin_family = AF_INET; #if ENABLE_SO_LINGER { struct linger ling; /* For making sockets linger. */ /* disabled: I see why no reason why we should throw things away by default!! */ ling.l_onoff = 1; ling.l_linger = 0; if (setsockopt(fd, SOL_SOCKET, SO_LINGER, (void *) &ling, sizeof(ling)) < 0) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (setsockopt_linger: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (setsockopt_linger)"); #endif return FALSE; } } #endif { int one = 1; /* code by David MW Powers */ if (setsockopt(fd, SOL_SOCKET, SO_BROADCAST, (void *)&one, sizeof(one))) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (setsockopt_broadcast: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (setsockopt_broadcast)"); #endif return FALSE; } } flag = connect(fd,(struct sockaddr *)&saddr, sizeof(saddr)); if(flag<0) { #if HAVE_STRERROR Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (connect: %s)", strerror(socket_errno)); #else Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "socket_connect/3 (connect)"); #endif return FALSE; } Yap_UpdateSocketStream(sno, client_socket, af_inet); } else return(FALSE); out = t1; return(Yap_unify(out,ARG3)); }
xarg * Yap_ArgListToVector (Term listl, const param_t *def, int n) { CACHE_REGS xarg *a = calloc( n , sizeof(xarg) ); if (IsApplTerm(listl) && FunctorOfTerm(listl) == FunctorModule) listl = ArgOfTerm(2,listl); if (!IsPairTerm(listl) && listl != TermNil) { if (IsVarTerm(listl) ) { free( a ); LOCAL_Error_TYPE = INSTANTIATION_ERROR; LOCAL_Error_Term = listl; return NULL; } if (IsAtomTerm(listl) ) { xarg *na = matchKey( AtomOfTerm(listl), a, n, def); if (!na) { free( a ); LOCAL_Error_TYPE = TYPE_ERROR_LIST; LOCAL_Error_Term = listl; return NULL; } } else if (IsApplTerm(listl)) { Functor f = FunctorOfTerm( listl ); if (IsExtensionFunctor(f)) { free( a ); LOCAL_Error_TYPE = TYPE_ERROR_LIST; LOCAL_Error_Term = listl; return NULL; } arity_t arity = ArityOfFunctor( f ); if (arity != 1) { free( a ); LOCAL_Error_TYPE = TYPE_ERROR_LIST; LOCAL_Error_Term = listl; return NULL; } xarg *na = matchKey( NameOfFunctor( f ), a, n, def); if (!na) { free( a ); LOCAL_Error_TYPE = TYPE_ERROR_LIST; LOCAL_Error_Term = listl; return NULL; } } else { free( a ); LOCAL_Error_TYPE = TYPE_ERROR_LIST; LOCAL_Error_Term = listl; return NULL; } listl = MkPairTerm( listl, TermNil ); } while (IsPairTerm(listl)) { Term hd = HeadOfTerm( listl ); listl = TailOfTerm( listl ); if (IsVarTerm(hd) || IsVarTerm(listl)) { LOCAL_Error_TYPE = INSTANTIATION_ERROR; if (IsVarTerm(hd)) { LOCAL_Error_Term = hd; } else { LOCAL_Error_Term = listl; } free( a ); return NULL; } if (IsAtomTerm(hd)) { xarg *na = matchKey( AtomOfTerm( hd ), a, n, def); if (!na) return NULL; na->used = true; na->tvalue = TermNil; continue; } else if (IsApplTerm( hd )) { Functor f = FunctorOfTerm( hd ); if (IsExtensionFunctor(f)) { LOCAL_Error_TYPE = TYPE_ERROR_PARAMETER; LOCAL_Error_Term = hd; free( a ); return NULL; } arity_t arity = ArityOfFunctor( f ); if (arity != 1) { LOCAL_Error_TYPE = DOMAIN_ERROR_OUT_OF_RANGE; LOCAL_Error_Term = hd; free( a ); return NULL; } xarg *na = matchKey( NameOfFunctor( f ), a, n, def); if (!na) { free( a ); return NULL; } na->used = 1; na->tvalue = ArgOfTerm(1, hd); } else { LOCAL_Error_TYPE = TYPE_ERROR_PARAMETER; free( a ); return NULL; } } if (IsVarTerm(listl)) { LOCAL_Error_TYPE = INSTANTIATION_ERROR; LOCAL_Error_Term = listl; free( a ); return NULL; } else if (listl != TermNil) { LOCAL_Error_TYPE = TYPE_ERROR_LIST; LOCAL_Error_Term = listl; free( a ); return NULL; } return a; }
/* copy to a new list of terms */ static int key_mergesort(CELL *pt, Int size, int my_p, Functor FuncDMinus) { if (size > 2) { Int half_size = size / 2; CELL *pt_left, *pt_right, *end_pt, *end_pt_left; int left_p, right_p; pt_right = pt + half_size*2; left_p = my_p^1; right_p = my_p; if (!key_mergesort(pt, half_size, left_p, FuncDMinus)) return(FALSE); if (!key_mergesort(pt_right, size-half_size, right_p, FuncDMinus)) return(FALSE); /* now implement a simple merge routine */ /* pointer to after the end of the list */ end_pt = pt + 2*size; /* pointer to the element after the last element to the left */ end_pt_left = pt+half_size*2; /* where is left list */ pt_left = pt+left_p; /* where is right list */ pt_right += right_p; /* where is new list */ pt += my_p; /* while there are elements in the left or right vector do compares */ while (pt_left < end_pt_left && pt_right < end_pt) { /* if the element to the left is larger than the one to the right */ Term t0 = pt_left[0] , t1 = pt_right[0]; if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus) return(FALSE); t0 = ArgOfTerm(1,t0); if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus) return(FALSE); t1 = ArgOfTerm(1,t1); if (Yap_compare_terms(t0, t1) <= 0) { /* copy the one to the left */ pt[0] = pt_left[0]; /* and avance the two pointers */ pt += 2; pt_left += 2; } else { /* otherwise, copy the one to the right */ pt[0] = pt_right[0]; pt += 2; pt_right += 2; } } /* if any elements were left in the left vector just copy them */ while (pt_left < end_pt_left) { pt[0] = pt_left[0]; pt += 2; pt_left += 2; } /* if any elements were left in the right vector and they are in the wrong place, just copy them */ if (my_p != right_p) { while(pt_right < end_pt) { pt[0] = pt_right[0]; pt += 2; pt_right += 2; } } } else { if (size > 1) { Term t0 = pt[0], t1 = pt[2]; if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus) return(FALSE); t0 = ArgOfTerm(1,t0); if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus) return(FALSE); t1 = ArgOfTerm(1,t1); if (Yap_compare_terms(t0,t1) > 0) { CELL t = pt[2]; pt[2+my_p] = pt[0]; pt[my_p] = t; } else if (my_p) { pt[1] = pt[0]; pt[3] = pt[2]; } } else { if (my_p) pt[1] = pt[0]; } } return(TRUE); }
/****** new user indexed predicate; the type right now is just rtrees, but in the future we'll have more. the second argument is the term. ******/ static Int p_new_udi( USES_REGS1 ) { Term spec = Deref(ARG2), udi_type = Deref(ARG1); PredEntry *p; UdiControlBlock cmd; Atom udi_t; void *info; /* fprintf(stderr,"new pred babe\n");*/ /* get the predicate from the spec, copied from cdmgr.c */ if (IsVarTerm(spec)) { Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1"); return FALSE; } else if (!IsApplTerm(spec)) { Yap_Error(TYPE_ERROR_COMPOUND,spec,"new user index/1"); return FALSE; } else { Functor fun = FunctorOfTerm(spec); Term tmod = CurrentModule; while (fun == FunctorModule) { tmod = ArgOfTerm(1,spec); if (IsVarTerm(tmod) ) { Yap_Error(INSTANTIATION_ERROR, spec, "new user index/1"); return FALSE; } if (!IsAtomTerm(tmod) ) { Yap_Error(TYPE_ERROR_ATOM, spec, "new user index/1"); return FALSE; } spec = ArgOfTerm(2, spec); fun = FunctorOfTerm(spec); } p = RepPredProp(PredPropByFunc(fun, tmod)); } if (!p) return FALSE; /* boring, boring, boring! */ if ((p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) || (p->ModuleOfPred == PROLOG_MODULE)) { Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, spec, "udi/2"); return FALSE; } if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) { Yap_Error(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, spec, "udi/2"); return FALSE; } /* just make sure we're looking at the right user type! */ if (IsVarTerm(udi_type)) { Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1"); return FALSE; } else if (!IsAtomTerm(udi_type)) { Yap_Error(TYPE_ERROR_ATOM,spec,"new user index/1"); return FALSE; } udi_t = AtomOfTerm(udi_type); if (udi_t == AtomRTree) { cmd = &RtreeCmd; } else { Yap_Error(TYPE_ERROR_ATOM,spec,"new user index/1"); return FALSE; } /* this is the real work */ info = cmd->init(spec, (void *)p, p->ArityOfPE); if (!info) return FALSE; /* add to table */ if (!add_udi_block(info, p, cmd)) { Yap_Error(OUT_OF_HEAP_ERROR, spec, "new user index/1"); return FALSE; } p->PredFlags |= UDIPredFlag; return TRUE; }
static Term Eval(Term t USES_REGS) { if (IsVarTerm(t)) { return Yap_ArithError(INSTANTIATION_ERROR,t,"in arithmetic"); } else if (IsNumTerm(t)) { return t; } else if (IsAtomTerm(t)) { ExpEntry *p; Atom name = AtomOfTerm(t); if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 0)))) { /* error */ Term ti[2]; /* error */ ti[0] = t; ti[1] = MkIntTerm(0); t = Yap_MkApplTerm(FunctorSlash, 2, ti); return Yap_ArithError(TYPE_ERROR_EVALUABLE, t, "atom %s in arithmetic expression", RepAtom(name)->StrOfAE); } return Yap_eval_atom(p->FOfEE); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); if (fun == FunctorString) { const char *s = StringOfTerm(t); if (s[1] == '\0') return MkIntegerTerm(s[0]); return Yap_ArithError(TYPE_ERROR_EVALUABLE, t, "string in arithmetic expression"); } else if ((Atom)fun == AtomFoundVar) { return Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil, "cyclic term in arithmetic expression"); } else { Int n = ArityOfFunctor(fun); Atom name = NameOfFunctor(fun); ExpEntry *p; Term t1, t2; if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, n)))) { Term ti[2]; /* error */ ti[0] = t; ti[1] = MkIntegerTerm(n); t = Yap_MkApplTerm(FunctorSlash, 2, ti); return Yap_ArithError(TYPE_ERROR_EVALUABLE, t, "functor %s/%d for arithmetic expression", RepAtom(name)->StrOfAE,n); } if (p->FOfEE == op_power && p->ArityOfEE == 2) { t2 = ArgOfTerm(2, t); if (IsPairTerm(t2)) { return get_matrix_element(ArgOfTerm(1, t), t2 PASS_REGS); } } *RepAppl(t) = (CELL)AtomFoundVar; t1 = Eval(ArgOfTerm(1,t) PASS_REGS); if (t1 == 0L) { *RepAppl(t) = (CELL)fun; return FALSE; } if (n == 1) { *RepAppl(t) = (CELL)fun; return Yap_eval_unary(p->FOfEE, t1); } t2 = Eval(ArgOfTerm(2,t) PASS_REGS); *RepAppl(t) = (CELL)fun; if (t2 == 0L) return FALSE; return Yap_eval_binary(p->FOfEE,t1,t2); } } /* else if (IsPairTerm(t)) */ { if (TailOfTerm(t) != TermNil) { return Yap_ArithError(TYPE_ERROR_EVALUABLE, t, "string must contain a single character to be evaluated as an arithmetic expression"); } return Eval(HeadOfTerm(t) PASS_REGS); } }
/// Yap_ArgList2ToVector is much the same as before, /// but assumes parameters also have something called a /// scope xarg * Yap_ArgList2ToVector (Term listl, const param2_t *def, int n) { CACHE_REGS xarg *a = calloc( n , sizeof(xarg) ); if (!IsPairTerm(listl) && listl != TermNil) { if (IsVarTerm(listl) ) { return failed( INSTANTIATION_ERROR, listl, a); } if (IsAtomTerm(listl) ) { xarg *na = matchKey2( AtomOfTerm(listl), a, n, def); if (!na) { return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, listl, a); } } if (IsApplTerm(listl)) { Functor f = FunctorOfTerm( listl ); if (IsExtensionFunctor(f)) { return failed( TYPE_ERROR_PARAMETER, listl, a); } arity_t arity = ArityOfFunctor( f ); if (arity != 1) { return failed( TYPE_ERROR_LIST, listl, a); } xarg *na = matchKey2( NameOfFunctor( f ), a, n, def); if (!na) { return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, listl, a); } } else { return failed( TYPE_ERROR_LIST, listl, a); } listl = MkPairTerm( listl, TermNil ); } while (IsPairTerm(listl)) { Term hd = HeadOfTerm( listl ); if (IsVarTerm(hd)) { return failed( INSTANTIATION_ERROR, hd, a); } if (IsAtomTerm(hd)) { xarg *na = matchKey2( AtomOfTerm( hd ), a, n, def); if (!na) { return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a); } na->used = true; na->tvalue = TermNil; continue; } else if (IsApplTerm( hd )) { Functor f = FunctorOfTerm( hd ); if (IsExtensionFunctor(f)) { return failed( TYPE_ERROR_PARAMETER, hd, a); } arity_t arity = ArityOfFunctor( f ); if (arity != 1) { return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a); } xarg *na = matchKey2( NameOfFunctor( f ), a, n, def); if (na) { na->used = 1; na->tvalue = ArgOfTerm(1, hd); } else { return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a); } } else { return failed( INSTANTIATION_ERROR, hd, a); } listl = TailOfTerm(listl); } if (IsVarTerm(listl)) { return failed( INSTANTIATION_ERROR, listl, a); } if (TermNil != listl) { return failed( TYPE_ERROR_LIST, listl, a); } return a; }