Skip to content

Instantly share code, notes, and snippets.

@kamahen

kamahen/SWI-cpp2.h - WIP

Last active January 10, 2023 19:08
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save kamahen/05321672a9f5547e3496a4b208eb1695 to your computer and use it in GitHub Desktop.
Save kamahen/05321672a9f5547e3496a4b208eb1695 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
SWI-cpp2.h - WIP
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 2000-2022, University of Amsterdam
VU University Amsterdam
SWI-Prolog Solutions b.v.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
//#warning "SWI-cpp.h is obsolete and replaced by SWI-cpp2.h"
#ifndef _SWI_CPP_H
#define _SWI_CPP_H
#include <SWI-Prolog.h>
#include <string.h>
#include <wchar.h>
#if !(defined(__APPLE__) || defined(__FreeBSD__))
#include <malloc.h>
#endif
#ifdef __BORLANDC__
#define __inline inline
#endif
/* Define as 1 if undefined or defined as empty */
#if !defined(PL_ARITY_AS_SIZE) || (0-PL_ARITY_AS_SIZE-1)==1
#undef PL_ARITY_AS_SIZE
#define PL_ARITY_AS_SIZE 1
#endif
#ifndef ARITY_T
#if PL_ARITY_AS_SIZE
#define ARITY_T size_t
#else
#define ARITY_T int
#endif
#endif
class PlTerm;
class PlTermv;
/*******************************
* PROLOG CONSTANTS *
*******************************/
class PlFunctor
{
public:
functor_t functor;
PlFunctor(const char *name, ARITY_T arity)
{ functor = PL_new_functor(PL_new_atom(name), arity);
}
PlFunctor(const wchar_t *name, ARITY_T arity)
{ functor = PL_new_functor(PL_new_atom_wchars(wcslen(name), name), arity);
}
operator functor_t(void) const
{ return functor;
}
int operator ==(functor_t to) const
{ return functor == to;
}
};
class PlAtom
{
public:
atom_t handle;
PlAtom(atom_t h)
{ handle = h;
}
PlAtom(const char *text)
{ handle = PL_new_atom(text);
}
PlAtom(const wchar_t *text)
{ handle = PL_new_atom_wchars(wcslen(text), text);
}
PlAtom(const PlTerm &t);
operator const char *(void) const
{ return PL_atom_chars(handle);
}
operator const wchar_t *(void) const
{ return PL_atom_wchars(handle, NULL);
}
int operator ==(const char *s) const
{ return strcmp(s, PL_atom_chars(handle)) == 0;
}
int operator ==(const wchar_t *s) const
{ return wcscmp(s, PL_atom_wchars(handle, NULL)) == 0;
}
int operator ==(const PlAtom &a) const
{ return handle == a.handle;
}
int operator ==(atom_t to) const
{ return handle == to;
}
};
/*******************************
* GENERIC PROLOG TERM *
*******************************/
class PlTerm
{
public:
term_t ref;
PlTerm();
PlTerm(const PlTerm &other) : ref(other.ref) {}
PlTerm(term_t t)
{ ref = t;
}
/* C --> PlTerm */
PlTerm(const char *text);
PlTerm(const wchar_t *text);
PlTerm(long val);
PlTerm(double val);
PlTerm(const PlAtom &a);
PlTerm(void *ptr);
/* PlTerm --> C */
operator term_t(void) const
{ return ref;
}
operator char *(void) const;
operator wchar_t *(void) const;
operator long(void) const;
operator int(void) const;
operator uint32_t(void) const;
operator bool(void) const;
operator double(void) const;
operator PlAtom(void) const;
operator void *(void) const;
int type() const
{ return PL_term_type(ref);
}
/* Compounds */
PlTerm operator [](ARITY_T index) const;
ARITY_T arity() const;
const char *name() const;
/* UNIFY */
int operator =(const PlTerm &t2); /* term */
int operator =(const PlAtom &a); /* atom */
int operator =(const char *v); /* atom (from char *) */
int operator =(const wchar_t *v); /* atom (from wchar_t *) */
int operator =(long v); /* integer */
int operator =(int v); /* integer */
int operator =(double v); /* float */
int operator =(const PlFunctor &f); /* functor */
/* Comparison standard order terms */
int operator ==(const PlTerm &t2) const
{ return PL_compare(ref, t2.ref) == 0;
}
int operator !=(const PlTerm &t2) const
{ return PL_compare(ref, t2.ref) != 0;
}
int operator <(const PlTerm &t2) const
{ return PL_compare(ref, t2.ref) < 0;
}
int operator >(const PlTerm &t2) const
{ return PL_compare(ref, t2.ref) > 0;
}
int operator <=(const PlTerm &t2) const
{ return PL_compare(ref, t2.ref) <= 0;
}
int operator >=(const PlTerm &t2) const
{ return PL_compare(ref, t2.ref) >= 0;
}
/* comparison (long) */
int operator ==(long v) const;
int operator !=(long v) const;
int operator <(long v) const;
int operator >(long v) const;
int operator <=(long v) const;
int operator >=(long v) const;
/* comparison (string) */
int operator ==(const char *s) const;
int operator ==(const wchar_t *s) const;
int operator ==(const PlAtom &a) const;
};
/*******************************
* TERM VECTOR *
*******************************/
class PlTermv
{
public:
term_t a0;
size_t size;
PlTermv(int n)
{ a0 = PL_new_term_refs(n);
size = static_cast<size_t>(n);
}
PlTermv(int n, term_t t0)
{ a0 = t0;
size = static_cast<size_t>(n);
}
PlTermv(size_t n)
{ a0 = PL_new_term_refs(static_cast<int>(n));
size = n;
}
PlTermv(size_t n, term_t t0)
{ a0 = t0;
size = n;
}
/* create from args */
PlTermv(PlTerm m0);
PlTermv(PlTerm m0, PlTerm m1);
PlTermv(PlTerm m0, PlTerm m1, PlTerm m2);
PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3);
PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3, PlTerm m4);
PlTerm operator [](size_t n) const;
};
/*******************************
* SPECIALISED TERMS *
*******************************/
class PlCompound : public PlTerm
{
public:
PlCompound(const char *text);
PlCompound(const wchar_t *text);
PlCompound(const char *functor, const PlTermv &args);
PlCompound(const wchar_t *functor, const PlTermv &args);
};
class PlString : public PlTerm
{
public:
PlString(const char *text);
PlString(const char *text, size_t len);
PlString(const wchar_t *text);
PlString(const wchar_t *text, size_t len);
};
class PlCodeList : public PlTerm
{
public:
PlCodeList(const char *text);
PlCodeList(const wchar_t *text);
};
class PlCharList : public PlTerm
{
public:
PlCharList(const char *text);
PlCharList(const wchar_t *text);
};
/*******************************
* EXCEPTIONS *
*******************************/
class PlException : public PlTerm
{
public:
PlException()
{ term_t ex = PL_exception(0);
if ( ex )
ref = ex;
else
PL_fatal_error("No exception");
}
PlException(const PlTerm &t)
{ ref = t.ref;
}
operator const char *(void);
operator const wchar_t *(void);
foreign_t plThrow()
{ return static_cast<foreign_t>(PL_raise_exception(ref));
}
void cppThrow();
};
class PlTypeError : public PlException
{
public:
PlTypeError(const PlTerm &t) : PlException(t) {}
PlTypeError(const char *expected, PlTerm actual) :
PlException(PlCompound("error",
PlTermv(PL_is_variable(actual.ref) ?
PlTerm("instantiation_error") :
PlCompound("type_error",
PlTermv(expected, actual)),
PlTerm())))
{
}
};
class PlDomainError : public PlException
{
public:
PlDomainError(const PlTerm &t) : PlException(t) {}
PlDomainError(const char *expected, PlTerm actual) :
PlException(PlCompound("error",
PlTermv(PlCompound("domain_error",
PlTermv(expected, actual)),
PlTerm())))
{
}
};
class PlInstantiationError : public PlException
{
public:
PlInstantiationError(const PlTerm &t) :
PlException(PL_is_variable(t) ?
PlCompound("error",
PlTermv("instantiation_error",
t)) : t) {}
PlInstantiationError() :
PlException(PlCompound("error",
PlTermv("instantiation_error",
PlTerm())))
{
}
};
class PlExistenceError : public PlException
{
public:
PlExistenceError(const PlTerm &t) : PlException(t) {}
PlExistenceError(const char *type, PlTerm actual) :
PlException(PlCompound("error",
PlTermv(PlCompound("existence_error",
PlTermv(type, actual)),
PlTerm())))
{
}
};
class PlPermissionError : public PlException
{
public:
PlPermissionError(const PlTerm &t) : PlException(t) {}
PlPermissionError(const char *op, const char *type, PlTerm obj) :
PlException(PlCompound("error",
PlTermv(PlCompound("permission_error",
PlTermv(op, type, obj)),
PlTerm())))
{
}
};
class PlResourceError : public PlException
{
public:
PlResourceError() : PlException() {}
PlResourceError(const PlTerm &t) : PlException(t) {}
PlResourceError(const char *resource) :
PlException(PlCompound("error",
PlTermv(PlCompound("resource_error",
PlTermv(PlTerm(resource))),
PlTerm())))
{
}
};
class PlTermvDomainError : public PlException
{
public:
PlTermvDomainError(size_t size, size_t n) :
PlException(PlCompound("error",
PlTermv(PlCompound("domain_error",
PlTermv(PlCompound("argv",
size),
PlTerm(static_cast<long>(n)))),
PlTerm())))
{
}
};
/*******************************
* PLTERM IMPLEMENTATION *
*******************************/
__inline
PlTerm::PlTerm()
{ if ( !(ref = PL_new_term_ref()) )
throw PlResourceError();
}
__inline
PlTerm::PlTerm(const char *text)
{ if ( !(ref = PL_new_term_ref()) ||
!PL_put_atom_chars(ref, text) )
throw PlResourceError();
}
__inline
PlTerm::PlTerm(const wchar_t *text)
{ if ( !(ref = PL_new_term_ref()) ||
!PL_unify_wchars(ref, PL_ATOM, static_cast<size_t>(-1), text) )
throw PlResourceError();
}
__inline
PlTerm::PlTerm(long val)
{ if ( !(ref = PL_new_term_ref()) ||
!PL_put_integer(ref, val) )
throw PlResourceError();
}
__inline
PlTerm::PlTerm(double val)
{ if ( !(ref = PL_new_term_ref()) ||
!PL_put_float(ref, val) )
throw PlResourceError();
}
__inline
PlTerm::PlTerm(const PlAtom &a)
{ if ( !(ref = PL_new_term_ref()) )
throw PlResourceError();
PL_put_atom(ref, a.handle);
}
__inline
PlTerm::PlTerm(void *ptr)
{ if ( !(ref = PL_new_term_ref()) ||
!PL_put_pointer(ref, ptr) )
throw PlResourceError();
}
/*******************************
* SPECIALISED IMPLEMENTATIONS *
*******************************/
__inline
PlString::PlString(const char *text) : PlTerm()
{ if ( !PL_put_string_chars(ref, text) )
throw PlResourceError();
}
__inline
PlString::PlString(const char *text, size_t len) : PlTerm()
{ if ( !PL_put_string_nchars(ref, len, text) )
throw PlResourceError();
}
__inline
PlString::PlString(const wchar_t *text) : PlTerm()
{ if ( !PL_unify_wchars(ref, PL_STRING, static_cast<size_t>(-1), text) )
throw PlResourceError();
}
__inline
PlString::PlString(const wchar_t *text, size_t len) : PlTerm()
{ if ( !PL_unify_wchars(ref, PL_STRING, len, text) )
throw PlResourceError();
}
__inline
PlCodeList::PlCodeList(const char *text) : PlTerm()
{ if ( !PL_put_list_codes(ref, text) )
throw PlResourceError();
}
__inline
PlCharList::PlCharList(const char *text) : PlTerm()
{ if ( !PL_put_list_chars(ref, text) )
throw PlResourceError();
}
__inline
PlCodeList::PlCodeList(const wchar_t *text) : PlTerm()
{ if ( !PL_unify_wchars(ref, PL_CODE_LIST, static_cast<size_t>(-1), text) )
throw PlResourceError();
}
__inline
PlCharList::PlCharList(const wchar_t *text) : PlTerm()
{ if ( !PL_unify_wchars(ref, PL_CHAR_LIST, static_cast<size_t>(-1), text) )
throw PlResourceError();
}
/*******************************
* LISTS *
*******************************/
class PlTail : public PlTerm
{
public:
PlTail(const PlTerm &l)
{ if ( PL_is_variable(l.ref) || PL_is_list(l.ref) )
{ if ( !(ref = PL_copy_term_ref(l.ref)) )
throw PlResourceError();
} else
throw PlTypeError("list", l.ref);
}
/* building */
int append(const PlTerm &e)
{ term_t tmp, ex;
if ( (tmp = PL_new_term_ref()) &&
PL_unify_list(ref, tmp, ref) &&
PL_unify(tmp, e.ref) )
{ PL_reset_term_refs(tmp);
return TRUE;
}
if ( (ex = PL_exception(0)) )
throw PlResourceError(ex);
return FALSE;
}
int close()
{ return PL_unify_nil(ref);
}
/* enumerating */
int next(PlTerm &t)
{ if ( PL_get_list(ref, t, ref) )
return TRUE;
if ( PL_get_nil(ref) )
return FALSE;
throw PlTypeError("list", ref);
}
};
/*******************************
* REGISTER *
*******************************/
class PlRegister
{
public:
PlRegister(const char *module, const char *name, int arity,
foreign_t (f)(term_t t0, int a, control_t ctx))
{ PL_register_foreign_in_module(module, name, arity, reinterpret_cast<pl_function_t>(f), PL_FA_VARARGS);
}
PlRegister(const char *module, const char *name, foreign_t (*f)(PlTerm a0))
{ PL_register_foreign_in_module(module, name, 1, reinterpret_cast<pl_function_t>(f), 0);
}
PlRegister(const char *module, const char *name, foreign_t (*f)(PlTerm a0, PlTerm a1))
{ PL_register_foreign_in_module(module, name, 2, reinterpret_cast<pl_function_t>(f), 0);
}
PlRegister(const char *module, const char *name, foreign_t (*f)(PlTerm a0, PlTerm a1, PlTerm a2))
{ PL_register_foreign_in_module(module, name, 3, reinterpret_cast<pl_function_t>(f), 0);
}
// for non-deterministic calls
PlRegister(const char *module, const char *name, int arity,
foreign_t (f)(term_t t0, int a, control_t ctx), short flags)
{ PL_register_foreign_in_module(module, name, arity, reinterpret_cast<pl_function_t>(f), flags);
}
};
/*******************************
* CALLING PROLOG *
*******************************/
class PlFrame
{
public:
fid_t fid;
PlFrame()
{ fid = PL_open_foreign_frame();
}
~PlFrame()
{ PL_close_foreign_frame(fid);
}
void rewind()
{ PL_rewind_foreign_frame(fid);
}
};
class PlQuery
{
public:
qid_t qid;
PlQuery(predicate_t pred, const PlTermv &av)
{ qid = PL_open_query(static_cast<module_t>(0), PL_Q_PASS_EXCEPTION, pred, av.a0);
if ( !qid )
throw PlResourceError();
}
PlQuery(const char *name, const PlTermv &av)
{ predicate_t p = PL_predicate(name, static_cast<int>(av.size), "user");
qid = PL_open_query(static_cast<module_t>(0), PL_Q_PASS_EXCEPTION, p, av.a0);
if ( !qid )
throw PlResourceError();
}
PlQuery(const char *module, const char *name, const PlTermv &av)
{ atom_t ma = PL_new_atom(module);
atom_t na = PL_new_atom(name);
module_t m = PL_new_module(ma);
predicate_t p = PL_pred(PL_new_functor(na, av.size), m);
PL_unregister_atom(ma);
PL_unregister_atom(na);
qid = PL_open_query(m, PL_Q_PASS_EXCEPTION, p, av.a0);
if ( !qid )
throw PlResourceError();
}
~PlQuery()
{ if ( qid )
PL_cut_query(qid);
}
int next_solution();
};
__inline int
PlCall(const char *predicate, const PlTermv &args)
{ PlQuery q(predicate, args);
return q.next_solution();
}
__inline int
PlCall(const char *module, const char *predicate, const PlTermv &args)
{ PlQuery q(module, predicate, args);
return q.next_solution();
}
__inline int
PlCall(const char *goal)
{ PlQuery q("call", PlTermv(PlCompound(goal)));
return q.next_solution();
}
__inline int
PlCall(const wchar_t *goal)
{ PlQuery q("call", PlTermv(PlCompound(goal)));
return q.next_solution();
}
/*******************************
* ATOM (BODY) *
*******************************/
__inline
PlAtom::PlAtom(const PlTerm &t)
{ atom_t a;
if ( PL_get_atom(t.ref, &a) )
handle = a;
else
throw PlTypeError("atom", t);
}
/*******************************
* TERM (BODY) *
*******************************/
/* PlTerm --> C */
__inline PlTerm::operator char *(void) const
{ char *s;
if ( PL_get_chars(ref, &s, CVT_ALL|CVT_WRITEQ|BUF_RING) )
return s;
throw PlTypeError("text", ref);
}
__inline PlTerm::operator wchar_t *(void) const
{ wchar_t *s;
if ( PL_get_wchars(ref, NULL, &s, CVT_ALL|CVT_WRITEQ|BUF_RING) )
return s;
throw PlTypeError("text", ref);
}
__inline PlTerm::operator long(void) const
{ long v;
if ( PL_get_long(ref, &v) )
return v;
throw PlTypeError("integer", ref);
}
__inline PlTerm::operator int(void) const
{ int v;
if ( PL_get_integer(ref, &v) )
return v;
throw PlTypeError("integer", ref);
}
__inline PlTerm::operator uint32_t(void) const
{ int64_t v;
if ( PL_get_int64(ref, &v) && v >= 0 && v <= UINT32_MAX )
return v;
throw PlTypeError("uint32_t", ref);
}
__inline PlTerm::operator bool(void) const
{ int v;
if ( PL_get_bool(ref, &v) )
return v;
throw PlTypeError("bool", ref);
}
__inline PlTerm::operator double(void) const
{ double v;
if ( PL_get_float(ref, &v) )
return v;
throw PlTypeError("float", ref);
}
__inline PlTerm::operator PlAtom(void) const
{ atom_t v;
if ( PL_get_atom(ref, &v) )
return PlAtom(v);
throw PlTypeError("atom", ref);
}
__inline PlTerm::operator void *(void) const
{ void *ptr;
if ( PL_get_pointer(ref, &ptr) )
return ptr;
throw PlTypeError("pointer", ref);
}
/* compounds */
__inline PlTerm
PlTerm::operator [](ARITY_T index) const
{ PlTerm t;
if ( PL_get_arg(index, ref, t.ref) )
return t;
if ( !PL_is_compound(ref) )
{ throw PlTypeError("compound", ref);
} else
{ if ( !PL_put_uint64(t.ref, index) )
throw PlResourceError();
if ( index < 1 )
throw PlDomainError("not_less_than_zero", t.ref);
else
throw PlDomainError("arity", t.ref); /* TBD: proper exception */
}
}
__inline ARITY_T
PlTerm::arity() const
{ atom_t name;
ARITY_T arity;
if ( PL_get_name_arity(ref, &name, &arity) )
return arity;
throw PlTypeError("compound", ref);
}
__inline const char *
PlTerm::name() const
{ atom_t name;
ARITY_T arity;
if ( PL_get_name_arity(ref, &name, &arity) )
return PL_atom_chars(name);
throw PlTypeError("compound", ref);
}
/* Unification */
__inline int PlTerm::operator =(const PlTerm &t2) /* term = term */
{ int rc = PL_unify(ref, t2.ref);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(const PlAtom &a) /* term = atom */
{ int rc = PL_unify_atom(ref, a.handle);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(const char *v) /* term = atom */
{ int rc = PL_unify_atom_chars(ref, v);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(const wchar_t *v) /* term = atom */
{ int rc = PL_unify_wchars(ref, PL_ATOM, static_cast<size_t>(-1), v);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(long v)
{ int rc = PL_unify_integer(ref, v);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(int v)
{ int rc = PL_unify_integer(ref, v);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(double v)
{ int rc = PL_unify_float(ref, v);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
__inline int PlTerm::operator =(const PlFunctor &f)
{ int rc = PL_unify_functor(ref, f.functor);
term_t ex;
if ( !rc && (ex=PL_exception(0)) )
throw PlResourceError(ex);
return rc;
}
/* comparison */
__inline int PlTerm::operator ==(long v) const
{ long v0;
if ( PL_get_long(ref, &v0) )
return v0 == v;
throw PlTypeError("integer", ref);
}
__inline int PlTerm::operator !=(long v) const
{ long v0;
if ( PL_get_long(ref, &v0) )
return v0 != v;
throw PlTypeError("integer", ref);
}
__inline int PlTerm::operator <(long v) const
{ long v0;
if ( PL_get_long(ref, &v0) )
return v0 < v;
throw PlTypeError("integer", ref);
}
__inline int PlTerm::operator >(long v) const
{ long v0;
if ( PL_get_long(ref, &v0) )
return v0 > v;
throw PlTypeError("integer", ref);
}
__inline int PlTerm::operator <=(long v) const
{ long v0;
if ( PL_get_long(ref, &v0) )
return v0 <= v;
throw PlTypeError("integer", ref);
}
__inline int PlTerm::operator >=(long v) const
{ long v0;
if ( PL_get_long(ref, &v0) )
return v0 >= v;
throw PlTypeError("integer", ref);
}
/* comparison (string) */
__inline int PlTerm::operator ==(const char *s) const
{ char *s0;
if ( PL_get_chars(ref, &s0, CVT_ALL) )
return strcmp(s0, s) == 0;
throw PlTypeError("text", ref);
}
__inline int PlTerm::operator ==(const wchar_t *s) const
{ wchar_t *s0;
if ( PL_get_wchars(ref, NULL, &s0, CVT_ALL) )
return wcscmp(s0, s) == 0;
throw PlTypeError("text", ref);
}
__inline int PlTerm::operator ==(const PlAtom &a) const
{ atom_t v;
if ( PL_get_atom(ref, &v) )
return v == a.handle;
throw PlTypeError("atom", ref);
}
/*******************************
* COMPOUND (BODY) *
*******************************/
__inline void
PlPutTerm(term_t to, term_t from)
{ if ( !PL_put_term(to, from) )
throw PlResourceError();
}
__inline
PlCompound::PlCompound(const char *text) : PlTerm()
{ term_t t = PL_new_term_ref();
if ( !PL_chars_to_term(text, t) )
throw PlException(t);
PlPutTerm(ref, t);
}
__inline
PlCompound::PlCompound(const wchar_t *text) : PlTerm()
{ term_t t = PL_new_term_ref();
if ( !PL_wchars_to_term(text, t) )
throw PlException(t);
PlPutTerm(ref, t);
}
__inline
PlCompound::PlCompound(const char *functor, const PlTermv &args) : PlTerm()
{ if ( !PL_cons_functor_v(ref,
PL_new_functor(PL_new_atom(functor), args.size),
args.a0) )
throw PlResourceError();
}
__inline
PlCompound::PlCompound(const wchar_t *functor, const PlTermv &args) : PlTerm()
{ if ( !PL_cons_functor_v(
ref,
PL_new_functor(PL_new_atom_wchars(wcslen(functor), functor),
args.size),
args.a0) )
throw PlResourceError();
}
/*******************************
* TERMV (BODY) *
*******************************/
__inline PlTermv::PlTermv(PlTerm m0)
{ size = 1;
a0 = m0.ref;
}
__inline PlTermv::PlTermv(PlTerm m0, PlTerm m1)
{ size = 2;
if ( !(a0 = PL_new_term_refs(2)) )
throw PlResourceError();
PlPutTerm(a0+0, m0);
PlPutTerm(a0+1, m1);
}
__inline PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2)
{ size = 3;
if ( !(a0 = PL_new_term_refs(3)) )
throw PlResourceError();
PlPutTerm(a0+0, m0);
PlPutTerm(a0+1, m1);
PlPutTerm(a0+2, m2);
}
__inline PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3)
{ size = 4;
if ( !(a0 = PL_new_term_refs(4)) )
throw PlResourceError();
PlPutTerm(a0+0, m0);
PlPutTerm(a0+1, m1);
PlPutTerm(a0+2, m2);
PlPutTerm(a0+3, m3);
}
__inline PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2,
PlTerm m3, PlTerm m4)
{ size = 5;
if ( !(a0 = PL_new_term_refs(5)) )
throw PlResourceError();
PlPutTerm(a0+0, m0);
PlPutTerm(a0+1, m1);
PlPutTerm(a0+2, m2);
PlPutTerm(a0+3, m3);
PlPutTerm(a0+4, m4);
}
__inline PlTerm
PlTermv::operator [](size_t n) const
{ if ( n >= size )
throw PlTermvDomainError(size, n);
return PlTerm(a0+n);
}
/*******************************
* EXCEPTIONS (BODY) *
*******************************/
__inline PlException::operator const char *(void)
{ PlFrame fr;
#ifdef USE_PRINT_MESSAGE
PlTermv av(2);
av[0] = PlCompound("print_message",
PlTermv("error", ref));
PlQuery q("$write_on_string", av);
if ( q.next_solution() )
return (char *)av[1];
#else
PlTermv av(2);
av[0] = PlTerm(ref);
PlQuery q("$messages", "message_to_string", av);
if ( q.next_solution() )
return static_cast<char*>(av[1]);
#endif
return "[ERROR: Failed to generate message. Internal error]\n";
}
__inline PlException::operator const wchar_t *(void)
{ PlFrame fr;
#ifdef USE_PRINT_MESSAGE
PlTermv av(2);
av[0] = PlCompound("print_message",
PlTermv("error", ref));
PlQuery q("$write_on_string", av);
if ( q.next_solution() )
return (wchar_t *)av[1];
#else
PlTermv av(2);
av[0] = PlTerm(ref);
PlQuery q("$messages", "message_to_string", av);
if ( q.next_solution() )
return static_cast<wchar_t*>(av[1]);
#endif
return L"[ERROR: Failed to generate message. Internal error]\n";
}
__inline void
PlException::cppThrow()
{ term_t a = PL_new_term_ref();
atom_t name;
ARITY_T arity;
if ( PL_get_arg(1, ref, a) &&
PL_get_name_arity(a, &name, &arity) )
{ const char *s = PL_atom_chars(name);
if ( strcmp(s, "type_error") == 0 )
throw PlTypeError(ref);
if ( strcmp(s, "domain_error") == 0 )
throw PlDomainError(ref);
if ( strcmp(s, "resource_error") == 0 )
throw PlResourceError(ref);
}
throw *this;
}
/*******************************
* QUERY (BODY) *
*******************************/
__inline int
PlQuery::next_solution()
{ int rval;
if ( !(rval = PL_next_solution(qid)) )
{ term_t ex;
PL_close_query(qid);
qid = 0;
if ( (ex = PL_exception(0)) )
PlException(ex).cppThrow();
}
return rval;
}
/*******************************
* ENGINE *
*******************************/
class PlError
{
public:
char *message;
PlError(const char *msg)
{ size_t len = strlen(msg)+1;
message = new char[len];
#ifdef _MSC_VER /* Yek */
#pragma warning( push )
#pragma warning (disable:4996)
#endif
strncpy(message, msg, len);
#ifdef _MSC_VER
#pragma warning( pop )
#endif
}
~PlError()
{
delete[] message;
}
};
class PlEngine
{
public:
PlEngine(int argc, char **argv)
{ if ( !PL_initialise(argc, argv) )
throw PlError("failed to initialise");
}
PlEngine(char *av0)
{ int ac = 0;
char **av = static_cast<char**>(malloc(sizeof(char *) * 2));
av[ac++] = av0;
if ( !PL_initialise(1, av) )
throw PlError("failed to initialise");
}
~PlEngine()
{ PL_cleanup(0);
}
};
/*******************************
* REGISTER PREDICATES *
*******************************/
#ifndef PROLOG_MODULE
#define PROLOG_MODULE (const char*)NULL
#endif
#define NAMED_PREDICATE(plname, name, arity) \
static foreign_t \
pl_ ## name ## __ ## arity(PlTermv PL_av); \
static foreign_t \
_pl_ ## name ## __ ## arity(term_t t0, int a, control_t c) \
{ (void)a; (void)c; \
try \
{ \
return pl_ ## name ## __ ## arity(PlTermv(arity, t0)); \
} catch ( PlException &ex ) \
{ return ex.plThrow(); \
} \
} \
static PlRegister _x ## name ## __ ## arity(PROLOG_MODULE, plname, arity, \
_pl_ ## name ## __ ## arity); \
static foreign_t pl_ ## name ## __ ## arity(PlTermv PL_av)
#define NAMED_PREDICATE0(plname, name) \
static foreign_t \
pl_ ## name ## __0(void); \
static foreign_t \
_pl_ ## name ## __0(term_t t0, int a, control_t c) \
{ (void)t0; (void)a; (void)c; \
try \
{ \
return pl_ ## name ## __0(); \
} catch ( PlException &ex ) \
{ return ex.plThrow(); \
} \
} \
static PlRegister _x ## name ## __0(PROLOG_MODULE, plname, 0, \
_pl_ ## name ## __0); \
static foreign_t pl_ ## name ## __0(void)
#define NAMED_PREDICATE_NONDET(plname, name, arity) \
static foreign_t \
pl_ ## name ## __ ## arity(PlTermv PL_av, control_t handle); \
static foreign_t \
_pl_ ## name ## __ ## arity(term_t t0, int a, control_t c) \
{ (void)a; \
try \
{ \
return pl_ ## name ## __ ## arity(PlTermv(arity, t0), c); \
} catch ( PlException &ex ) \
{ return ex.plThrow(); \
} \
} \
static PlRegister _x ## name ## __ ## arity(PROLOG_MODULE, plname, arity, \
_pl_ ## name ## __ ## arity, \
PL_FA_NONDETERMINISTIC | PL_FA_VARARGS); \
static foreign_t pl_ ## name ## __ ## arity(PlTermv PL_av, control_t handle)
#define PREDICATE0(name) NAMED_PREDICATE0(#name, name)
#define PREDICATE(name, arity) NAMED_PREDICATE(#name, name, arity)
#define PREDICATE_NONDET(name, arity) NAMED_PREDICATE_NONDET(#name, name, arity)
#define PL_A1 PL_av[0]
#define PL_A2 PL_av[1]
#define PL_A3 PL_av[2]
#define PL_A4 PL_av[3]
#define PL_A5 PL_av[4]
#define PL_A6 PL_av[5]
#define PL_A7 PL_av[6]
#define PL_A8 PL_av[7]
#define PL_A9 PL_av[8]
#define PL_A10 PL_av[9]
#ifndef PL_SAFE_ARG_MACROS
#define A1 PL_A1
#define A2 PL_A2
#define A3 PL_A3
#define A4 PL_A4
#define A5 PL_A5
#define A6 PL_A6
#define A7 PL_A7
#define A8 PL_A8
#define A9 PL_A9
#define A10 PL_A10
#endif
#endif /*_SWI_CPP_H*/
Raw
test_cpp.cpp - WIP
/* Part of SWI-Prolog
Author: Jan Wielemaker and Peter Ludemann
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 2022, SWI-Prolog Solutions b.v.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
/* This is used by test_cpp.pl */
/* Most of these predicates are from test.cpp or the documentation.*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This code may be compiled using
swipl-ld -shared -o test_cpp test_cpp.cpp
and subsequently loading using
swipl
?- use_foreign_library(test_cpp).
Next, run example predicates such as below. Scan through this file
to find the predicates provided by this C++ code.
?- hello(world).
Hello world
This code is also used by test_cpp.pl, which has many examples of
how the various predicates can be called from Prolog.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define PROLOG_MODULE "user"
#include <SWI-Stream.h>
#include <SWI-Prolog.h>
#include "SWI-cpp2.h"
#include <iostream>
#include <sstream>
#include <unistd.h>
#include <errno.h>
#include <math.h>
#include <cassert>
#include <limits>
#include <string>
#include <map>
using namespace std;
PREDICATE(hello, 2)
{ std::stringstream buffer;
buffer << "Hello " << A1.as_string() << endl;
buffer << "Hello " << A1.as_string().c_str() << endl; // Same output as previous line
buffer << "Hello " << A1.as_string(EncLatin1).c_str() << endl; // Also same, if it's ASCII
buffer << "Hello " << A1.as_string(EncUTF8).c_str() << endl;
buffer << "Hello " << A1.as_string(EncLocale).c_str() << endl; // Can vary by locale settings
return A2.unify_string(buffer.str());
}
PREDICATE(hello2, 2)
{ PlAtom atom_a1(A1.as_atom());
std::stringstream buffer;
// The following have the same output as hello/1, if A1 is an atom
buffer << "Hello2 " << atom_a1.as_string() << endl;
buffer << "Hello2 " << A1.as_string().c_str() << endl;
buffer << "Hello2 " << A1.as_string(EncLatin1).c_str() << endl;
buffer << "Hello2 " << A1.as_string(EncUTF8).c_str() << endl;
buffer << "Hello2 " << A1.as_string(EncLocale).c_str() << endl;
return A2.unify_string(buffer.str());
}
PREDICATE(hello3, 2)
{ PlAtom atom_a1(A1.as_atom());
char buf[1024];
// Iostream doesn't work because `<<` doesn't support std::wstring:
// cout << "Hello3 " << atom_a1.wstring() << endl; /* Same output as hello/1 */
// If %s is used, an error will occur if A1 has a non-ascii
// character in it. In addition, a NUL ('\0') in the atom will cause
// the rest of the atom to not be printed.
int len = Ssnprintf(buf, sizeof buf,
"Hello3 %Ws\n", atom_a1.as_wstring().c_str());
if ( len > 0 )
// TODO: use len when fixed: https://github.com/SWI-Prolog/swipl-devel/issues/1074
return A2.unify_chars(PL_STRING|REP_UTF8, strlen(buf), buf);
return false;
}
PREDICATE(add, 3)
{ // as_long() converts integral floats to integers
return A3.unify_integer(A1.as_long() + A2.as_long());
}
PREDICATE(add_num, 3)
{ auto x = A1, y = A2, result = A3;
// Note that as_float() handles floats
double sum = x.as_float() + y.as_float();
if ( double(long(sum)) == sum ) /* Can float be represented as int? */
return result.unify_integer(long(sum));
return result.unify_float(sum);
}
PREDICATE(name_arity, 2)
{ std::stringstream buffer;
buffer << "name = " << A1.name().as_string() << ", arity = " << A1.arity() << endl;
return A2.unify_string(buffer.str());
}
PREDICATE(name_arity, 3) /* name_arity(+Term, -Name, -Arity) */
{ PlTerm term(A1);
PlTerm name(A2);
PlTerm arity(A3);
PlCheck(name.unify_atom(term.name()));
PlCheck(arity.unify_integer(term.arity()));
return true;
}
PREDICATE(list_modules, 1)
{ std::stringstream buffer;
PlTermv av(1);
PlQuery q("current_module", av);
while( q.next_solution() )
buffer << av[0].as_string() << endl;
q.cut();
return A1.unify_string(buffer.str());
}
PREDICATE(average, 3) /* average(+Templ, :Goal, -Average) */
{ long sum = 0;
long n = 0;
/* Some compilers (e.g., MSVC) require the following code:
PlTermv av(A2);
PlQuery q("call", av);
*/
PlQuery q("call", PlTermv(A2));
while( q.next_solution() )
{ sum += A1.as_long();
n++;
}
q.cut();
return A3.unify_float(double(sum) / double(n));
}
PREDICATE(hello, 0)
{ PlQuery q("write", PlTermv(PlTerm_atom("hello world\n")));
PlCheck(q.next_solution());
return true;
}
PREDICATE(hello_query, 2)
{ PlQuery q(A1.as_string(), PlTermv(A2));
PlCheck(q.next_solution());
// There's no need for calling q.cut() - it's done implicitly by the
// query's destructor.
return true;
}
PREDICATE(call_cut, 1)
{ PlQuery q(A1.as_string(), PlTermv());
PlCheck(q.next_solution());
q.cut(); // This tests that ~PlQuery() behaves correctly if cut() had been called
return true;
}
// TODO: add tests for PlQuery() with PL_Q_EXT_STATUS
PREDICATE(hello_call, 1)
{ PlCheck(PlCall(A1));
return true;
}
PREDICATE(hello_call_ex, 2)
{ try
{ PlCheck(PlCall(A1));
} catch ( PlException& ex )
{ Sdprintf("--- PL_CHECK PlException: %s\n", ex.as_string().c_str());
return A2.unify_term(ex);
}
return A2.unify_string("no exception");
}
PREDICATE(atom_to_string, 2)
{ PlAtom a(A1.as_atom());
PlCheck(A2.unify_string(a.as_string(EncUTF8)));
return true;
}
PREDICATE(term_to_string, 2)
{ PlCheck(A2.unify_string(A1.as_string(EncUTF8)));
return true;
}
PREDICATE(term, 1)
{ return A1.unify_term(PlCompound("hello", PlTermv(PlTerm_atom("world"))));
}
PlAtom ATOM_atom("atom");
PREDICATE(term, 2)
{ PlAtom a(A1.as_atom());
if ( a.C_ == ATOM_atom.C_ )
return A2.unify_atom("hello world"); // or A2.unify_term(PlAtom("hello world"));
if ( A1.as_string() == "string" )
return A2.unify_string("hello world");
if ( A1.as_string() == "code_list" )
return A2.unify_list_codes("hello world"); // TODO: deprecated
if ( A1.as_string() == "char_list" )
return A2.unify_list_chars("hello world"); // TODO: deprecated
if ( A1.as_string() == "term" )
return A2.unify_term(PlCompound("hello(world)"));
throw PlDomainError("type", A1);
}
PREDICATE(can_unify, 2)
{ PlFrame fr;
bool rval = A1.unify_term(A2);
fr.rewind();
return rval;
}
PREDICATE(eq1, 2)
{ PlCheck(A1.unify_term(A2));
return true;
}
PREDICATE(eq2, 2)
{ return A1.unify_term(A2);
}
PREDICATE(eq3, 2)
{ PlCheck(PL_unify(A1.C_, A2.C_));
return true;
}
PREDICATE(write_list, 1)
{ PlTerm_tail tail(A1);
PlTerm_var e;
while(tail.next(e))
cout << e.as_string() << endl;
return true;
}
PREDICATE(cappend, 3)
{ PlTerm_tail l1(A1);
PlTerm_tail l3(A3);
PlTerm_var e;
while(l1.next(e))
PlCheck(l3.append(e));
return A2.unify_term(l3);
}
// TODO: This doesn't do quite what's expected if there's an
// exception. Instead of returning the exception to Prolog, it
// ends up in the debugger.
// Possibly this is because PlCall needs the flags
// PL_Q_CATCH_EXCEPTION and not PL_Q_PASS_EXCEPTION?
PREDICATE(cpp_call_, 3)
{ int flags = A2.as_int();
int verbose = A3.as_bool();
std::string flag_str;
// if ( flags & PL_Q_DEBUG ) flag_str.append(",debug");
// if ( flags & PL_Q_DETERMINISTIC) flag_str.append(",deterministic");
if ( flags & PL_Q_NORMAL ) flag_str.append(",normal");
if ( flags & PL_Q_NODEBUG ) flag_str.append(",nodebug");
if ( flags & PL_Q_CATCH_EXCEPTION) flag_str.append(",catch_exception");
if ( flags & PL_Q_PASS_EXCEPTION) flag_str.append(",pass_exception");
if ( flags & PL_Q_ALLOW_YIELD) flag_str.append(",allow_exception");
if ( flags & PL_Q_EXT_STATUS) flag_str.append(",ext_status");
if ( flag_str.empty() )
flag_str = "cpp_call";
else
flag_str = std::string("cpp_call(").append(flag_str.substr(1)).append(")");
if ( verbose )
cout << flag_str << ": " << A1.as_string() << endl;
try
{ int rc = PlCall(A1, flags);
if ( flags & PL_Q_EXT_STATUS )
{ const char *status_str;
switch ( rc )
{ case PL_S_EXCEPTION: status_str = "exception"; break;
case PL_S_FALSE: status_str = "false"; break;
case PL_S_TRUE: status_str = "true"; break;
case PL_S_LAST: status_str = "last"; break;
case PL_S_YIELD: status_str = "yield"; break;
default: status_str = "???"; break;
}
if ( verbose )
cout << "... after call, rc=" << rc << ": " << status_str << endl;
} else
{ if ( verbose )
cout << "... after call, rc=" << rc << endl;
}
if ( rc )
{ if ( verbose )
cout << "cpp_call result: rc=" << rc << ": " << A1.as_string() << endl;
} else
{ PlException_qid ex;
if ( ex.is_null() )
{ if ( verbose )
cout << "cpp_call failed" << endl;
} else
{ if ( verbose )
cout << "cpp_call failed: ex: " << ex.as_string() << endl;
}
}
return rc; // TODO: this is wrong with some query flags
} catch ( PlException& ex )
{ if ( ex.is_null() )
{ if ( verbose )
cout << "cpp_call except is_null" << endl;
} else
{ if ( verbose )
cout << "cpp_call exception: " << ex.as_string() << endl;
}
throw;
}
}
PREDICATE(cpp_atom_codes, 2)
{ int rc = PlCall("atom_codes", PlTermv(A1, A2));
if ( ! rc )
{ PlException_qid ex;
if ( ex.is_null() )
cout << "atom_codes failed" << endl;
else
cout << "atom_codes failed: ex: " << ex.as_string() << endl; // Shouldn't happen
}
return rc;
}
/* The purpose of this predicate is mostly to show that
resource errors are dealt with appropriately: with large
enough argument, this will overflow the stacks. The Prolog
error is mapped to a C++ exception and back again when
control is passed back to Prolog. So this is just fine:
?- square_roots(1000000000, L)
ERROR: Out of global stack
*/
PREDICATE(square_roots, 2)
{ int end = A1.as_int();
PlTerm_tail list(A2);
for(int i=0; i<end; i++)
PlCheck(list.append(PlTerm_float(sqrt(double(i)))));
return list.close();
}
/* Create a dependency on malloc(). If the main system uses
* tcmalloc (default when available), the shared object should
* __not__ be linked against tcmalloc. This code crashes when
* compiled using
*
* swipl-ld -o test -ltcmalloc -shared test.cpp
*/
PREDICATE(malloc, 2)
{ void *ptr = malloc(A1.as_size_t());
return A2.unify_pointer(ptr);
}
PREDICATE(free, 1)
{ void *ptr = A1.as_pointer();
free(ptr);
return true;
}
PREDICATE(new_chars, 2)
{ char *ptr = new char[A1.as_size_t()];
return A2.unify_pointer(ptr);
}
PREDICATE(delete_chars, 1)
{ char *ptr = static_cast<char *>(A1.as_pointer());
delete[] ptr;
return true;
}
class MyClass
{
public:
const char* contents;
MyClass() : contents("foo-bar") { }
};
PREDICATE(make_my_object, 1)
{ auto myobj = new MyClass();
return A1.unify_pointer(myobj);
}
PREDICATE(my_object_contents, 2)
{ auto myobj = static_cast<MyClass*>(A1.as_pointer());
return A2.unify_string(myobj->contents);
}
PREDICATE(free_my_object, 1)
{ auto myobj = static_cast<MyClass*>(A1.as_pointer());
delete myobj;
return true;
}
PREDICATE(make_functor, 3) // make_functor(foo, x, foo(x))
{ auto f = PlFunctor(A1.as_atom().as_string().c_str(), 1);
return A3.unify_functor(f) &&
A3[1].unify_term(A2);
}
PREDICATE(make_uint64, 2)
{ PlCheck(A2.unify_integer(A1.as_uint64_t()));
return true;
}
PREDICATE(make_int64, 2)
{ int64_t i;
// This function is for testing PlCheck()
PlCheck(PL_get_int64_ex(A1.C_, &i));
PlCheck(A2.unify_integer(i));
return true;
}
/* The manual example uses gethostname(), but portability thereof is not
trivial and we should not introduce portability issues on tests that
are not about portability.
*/
static int
no_gethostname(char *buf, size_t len)
{ static const char hostname[] = "my_awesome_hostname";
if ( len <= 0 )
{ errno = ENAMETOOLONG;
return -1;
}
strncpy(buf, hostname, len);
if ( buf[len-1] )
{ errno = ENAMETOOLONG;
return -1;
}
return 0;
}
PREDICATE(hostname, 1)
{ char buf[255+1]; // SYSv2; POSIX.1 has a smaller HOST_NAME_MAX+1
if ( no_gethostname(buf, sizeof buf) == 0 )
return A1.unify_atom(buf);
return false;
}
PREDICATE(hostname2, 1)
{ char buf[255+1]; // SYSv2; POSIX.1 has a smaller HOST_NAME_MAX+1
if ( no_gethostname(buf, sizeof buf) != 0 )
throw PlFail();
PlCheck(A1.unify_atom(buf));
return true;
}
PREDICATE(ensure_PlTerm_forward_declarations_are_implemented, 0)
{ /*********************************************************************
* This code is not intended to be executed; it is only compiled, to *
* check that implementations exist where expected. *
*********************************************************************/
PlTerm_var t_var;
PlTerm_atom t_atom1("abc");
PlTerm_atom t_atom2(L"ABC");
PlTerm_atom t_atom3(PlAtom("an atom"));
PlTerm_atom p_atom4(std::string("abc"));
PlTerm_atom p_atom5(std::wstring(L"世界"));
PlTerm_term_t t_t(PL_new_term_ref());
PlTerm_term_t t_null(PlTerm::null);
PlTerm_integer t_int1(std::numeric_limits<int>::max());
PlTerm_integer t_int1b(std::numeric_limits<int>::min());
PlTerm_integer t_int2(std::numeric_limits<long>::max());
PlTerm_integer t_int2b(std::numeric_limits<long>::min());
PlTerm_integer t_int64(std::numeric_limits<int64_t>::max());
PlTerm_integer t_int64b(std::numeric_limits<int64_t>::min());
PlTerm_integer t_uint64(std::numeric_limits<uint64_t>::max());
PlTerm_integer t_uint64b(std::numeric_limits<uint64_t>::min());
PlTerm_integer p_size(static_cast<size_t>(-1));
PlTerm_integer p_size2(std::numeric_limits<size_t>::max());
PlTerm_float t_float(1.23);
PlTerm_pointer t_ptr(&t_var);
PlTerm_recorded t_rec(PlTerm_atom("xyz").record());
PlTerm_string t_string1("abc");
PlTerm_string t_string2(L"世界");
const char codes[] = {81,82,83,0};
PlTerm_list_codes s02(codes);
PlTerm_list_chars s03("mno");
PlAtom atom1("atom1");
PlAtom atom2(L"原子2");
PlAtom atom3(std::string("atom3"));
PlAtom atom4(std::wstring(L"原子4"));
PlAtom a5a(t_atom1.as_atom());
PlAtom atom_null(PlAtom::null);
// The following are unsafe (the as_string() is deleted in the statement):
// const char * x01 = t_var.as_string().c_str();
// const wchar_t *x01a = t_var.as_wstring().c_str();
const std::string s01 = atom3.as_string();
const std::wstring s01b = atom4.as_wstring();
const std::string s02a = t_var.as_string();
const std::wstring s02b = t_var.as_wstring();
atom1.register_ref();
atom1.unregister_ref();
{ int v1;
unsigned v2;
long v3;
unsigned long v4;
size_t v5;
t_int1.integer(&v1);
t_int1.integer(&v2);
t_int1.integer(&v3);
t_int1.integer(&v4);
t_int1.integer(&v5);
}
// TODO: combine this test with t_something.integer(&x04) etc.
long x04 = t_atom2.as_long();
int x05 = t_int1.as_int();
uint32_t x06 = t_var.as_uint32_t();
uint64_t x07 = t_var.as_uint64_t();
int64_t x08 = t_var.as_int64_t();
size_t x09 = t_var.as_size_t();
bool x10 = t_var.as_bool();
double x11 = t_var.as_float();
double x12 = t_var.as_double();
PlAtom x13 = t_var.as_atom();
void * x14 = t_var.as_pointer();
PlTerm x20 = t_var[1];
size_t x21 = t_var.arity();
PlAtom x22 = t_var.name();
// TODO: add comparisons, etc.
//(void)x01;
//(void)x01a;
// TODO: std::string string() const;
(void)a5a;
(void)x04;
(void)x05;
(void)x06;
(void)x07;
(void)x08;
(void)x09;
(void)x10;
(void)x11;
(void)x12;
(void)x13;
(void)x14;
(void)x20;
(void)x21;
(void)x22;
(void)t_var.unify_term(t_atom1);
(void)t_var.unify_atom(PlAtom("an atom"));
(void)t_atom1.unify_atom("abc");
(void)t_atom2.unify_atom(L"ABC");
(void)t_atom3.unify_functor(PlFunctor("f", 3));
(void)t_int1.unify_integer(123);
(void)t_int2.unify_integer(666);
(void)t_int2b.unify_integer(0);
(void)p_size.unify_integer(sizeof t_var);
(void)t_float.unify_float(1.23);
(void)t_ptr.unify_pointer(&t_var);
bool xx01;
char xx02;
signed char xx03;
unsigned char xx04;
// TODO:
// wchar_t xx05;
// char16_t xx06;
// char32_t xx07;
short xx08;
unsigned short xx09;
int xx10;
unsigned int xx11;
long xx12;
unsigned long xx13;
long long xx14;
unsigned long long xx15;
size_t xx16;
int32_t xx17;
uint32_t xx18;
uint64_t xx19;
int64_t xx20;
intptr_t xx21;
uintptr_t xx22;
t_int1.integer(&xx01);
t_int1.integer(&xx02);
t_int1.integer(&xx03);
t_int1.integer(&xx04);
// TODO:
// t_int1.integer(&xx05);
// t_int1.integer(&xx06);
// t_int1.integer(&xx07);
t_int1.integer(&xx08);
t_int1.integer(&xx09);
t_int1.integer(&xx10);
t_int1.integer(&xx11);
t_int1.integer(&xx12);
t_int1.integer(&xx13);
t_int1.integer(&xx14);
t_int1.integer(&xx15);
t_int1.integer(&xx16);
t_int1.integer(&xx17);
t_int1.integer(&xx18);
t_int1.integer(&xx19);
t_int1.integer(&xx20);
t_int1.integer(&xx21);
t_int1.integer(&xx22);
return true;
}
PREDICATE(unify_int_set, 1)
{ int i_int = 0;
unsigned i_unsigned = 0;
long i_long = 0;
unsigned long i_unsigned_long = 0;
size_t i_size = 0;
int32_t i_int32 = 0;
uint32_t i_uint32 = 0;
int64_t i_int64 = 0;
uint64_t i_uint64 = 0;
PlCheck(A1.unify_integer(i_int));
PlCheck(A1.unify_integer(i_unsigned));
PlCheck(A1.unify_integer(i_long));
PlCheck(A1.unify_integer(i_unsigned_long));
PlCheck(A1.unify_integer(i_size));
PlCheck(A1.unify_integer(i_int32));
PlCheck(A1.unify_integer(i_uint32));
PlCheck(A1.unify_integer(i_int64));
PlCheck(A1.unify_integer(i_uint64));
return true;
}
// The following are for verifying some documentation details.
PREDICATE(c_PL_unify_nil, 1) { return static_cast<foreign_t>(PL_unify_nil(A1.C_)); }
PREDICATE(cpp_unify_nil, 1) { return A1.unify_nil(); }
PREDICATE(check_c_PL_unify_nil, 1) { PlCheck(PL_unify_nil(A1.C_)); return true; }
// Repeat the above 4, for *_ex():
PREDICATE(c_PL_unify_nil_ex, 1) { return static_cast<foreign_t>(PL_unify_nil_ex(A1.C_)); }
PREDICATE(cpp_unify_nil_ex, 1) { return A1.unify_nil_ex(); }
PREDICATE(check_c_PL_unify_nil_ex, 1) { PlCheck(PL_unify_nil_ex(A1.C_)); return true; }
PREDICATE(c_PL_get_nil, 1) { return static_cast<foreign_t>(PL_get_nil(A1.C_)); }
PREDICATE(cpp_as_nil, 1) { A1.as_nil(); return true; }
PREDICATE(check_c_PL_get_nil, 1) { PlCheck(PL_get_nil(A1.C_)); return true; }
PREDICATE(check_c_PL_get_nil_ex, 1) { PlCheck(PL_get_nil_ex(A1.C_)); return true; }
// Functions re-implemented from ffi4pl.c
// range_cpp/3 is equivalent to range_ffialloc/3
/* range_cpp/3 is used in regression tests
- PL_foreign_context_address() and malloc()-ed context.
*/
struct RangeContext
{ long i;
long high;
explicit RangeContext(long i, long high)
: i(i), high(high) { }
};
PREDICATE_NONDET(range_cpp, 3)
{ auto t_low = A1, t_high = A2, t_result = A3;
PlForeignContextPtr<RangeContext> ctxt(handle);
switch( PL_foreign_control(handle) )
{ case PL_FIRST_CALL:
ctxt.set(new RangeContext(t_low.as_long(),
t_high.as_long()));
break;
case PL_REDO:
break;
case PL_PRUNED:
return true;
default:
assert(0);
return false;
}
if ( ctxt->i >= ctxt->high ||
!t_result.unify_integer(ctxt->i) )
return false;
ctxt->i += 1;
if ( ctxt->i >= ctxt->high )
return true; // Last result: succeed without a choice point
ctxt.keep();
PL_retry_address(ctxt.get()); // Succeed with a choice point
}
// For benchmarking `throw PlThrow()` vs `return false`
// Times are given for 10 million failures
// e.g.: time((between(1,10000000,X), unify_zero_0(X))).
// Baseline: time((between(1,10000000,X), fail)). 0.44 sec
// 0.68 sec - essentially the same for time((... X=0).
static foreign_t
unify_zero_0(term_t a1)
{ return static_cast<foreign_t>(PL_unify_integer(a1, 0));
}
// If you wish to use the C-style install_test_cpp() style instead, you
// need to use extern "C" to ensure that names don't get mangled.
// So, it's easier to use the PlRegister class (which might need
// modification to more than one argument).
static PlRegister _x_unify_zero_4_1(nullptr, "unify_zero_0", unify_zero_0);
// 0.68 sec
PREDICATE(unify_zero_1, 1)
{ if ( !PL_unify_integer(A1.C_, 0) )
return false;
return true;
}
// 10.9 sec
PREDICATE(unify_zero_2, 1)
{ if ( !PL_unify_integer(A1.C_, 0) )
throw PlFail();
return true;
}
// 13.5 sec
PREDICATE(unify_zero_3, 1)
{ PlCheck( PL_unify_integer(A1.C_, 0) );
return true;
}
// 15.1 sec
PREDICATE(unify_zero_4, 1)
{ PlCheck(A1.unify_integer(0));
return true;
}
// 0.71 sec
PREDICATE(unify_zero_5, 1)
{ return A1.unify_integer(0);
}
// Benchmarking the various kinds of string comparisons
// For PL_unify_chars:
// Types: PL_ATOM, PL_STRING, PL_CODE_LIST, PL_CHAR_LIST
// Representation: REP_ISO_LATIN_1, REP_UTF8, REP_MB
// Extra: PL_DIFF_LIST
// If len == static_cast<size_t>(-1), then zero-terminated
// example run: time((between(1,10000000,X), unify_foo_string_1("foobar"))).
// 1.2 sec
PREDICATE(unify_foo_atom_1, 1)
{ return A1.unify_chars(PL_ATOM|REP_ISO_LATIN_1, 3, "foo");
}
// 1.0 sec
PREDICATE(unify_foo_string_1, 1)
{ return A1.unify_chars(PL_STRING|REP_ISO_LATIN_1, 3, "foo");
}
// 0.92 sec
PREDICATE(unify_foo_atom_2a1, 1)
{ PlAtom foo("foo");
return A1.unify_atom(foo);
}
// 0.92 sec
PREDICATE(unify_foo_atom_2a2, 1)
{ return A1.unify_atom(PlAtom("foo"));
}
// 0.98 sec
PREDICATE(unify_foo_atom_2b, 1)
{ PlAtom foo(std::string("foo"));
return A1.unify_atom(foo);
}
// 1.0 sec
PREDICATE(unify_foo_string_2a, 1)
{ PlTerm_string foo("foo");
return A1.unify_term(foo);
}
// 1.0 sec
PREDICATE(unify_foo_string_2b, 1)
{ PlTerm_string foo(std::string("foo"));
return A1.unify_term(foo);
}
// end of benchmarking predicates
// Predicates for checking native integer handling
// See https://en.cppreference.com/w/cpp/types/numeric_limits
// TODO: typeid(ty).name() (needs #include <typeinfo>, #include <typeindex>)
#define DECLS_ROW(ty) X(#ty, ty, std::numeric_limits<ty>::min(), std::numeric_limits<ty>::max())
// TODO: char8_t (since C++20)
// float, double, long double
// - char16_t, char32_t, long long, unsigned long long (since C++11)
#define DECLS \
DECLS_ROW(bool) \
DECLS_ROW(char) \
DECLS_ROW(signed char) \
DECLS_ROW(unsigned char) \
DECLS_ROW(wchar_t) \
DECLS_ROW(char16_t) \
DECLS_ROW(char32_t) \
DECLS_ROW(short) \
DECLS_ROW(unsigned short) \
DECLS_ROW(int) \
DECLS_ROW(unsigned int) \
DECLS_ROW(long) \
DECLS_ROW(unsigned long) \
DECLS_ROW(long long) \
DECLS_ROW(unsigned long long) \
DECLS_ROW(size_t) \
DECLS_ROW(int32_t) \
DECLS_ROW(uint32_t) \
DECLS_ROW(uint64_t) \
DECLS_ROW(int64_t) \
DECLS_ROW(intptr_t) \
DECLS_ROW(uintptr_t)
#define X(name, x_type, x_min, x_max) \
{name, \
PlCompound("int_info", \
PlTermv(PlTerm_atom(name), \
PlTerm_integer(sizeof (x_type)), \
PlTerm_integer(x_min), \
PlTerm_integer(x_max))).record() },
typedef std::map<const std::string, record_t> IntInfo;
static const IntInfo int_info = { DECLS };
#undef X
struct IntInfoContext
{ IntInfo::const_iterator it;
explicit IntInfoContext()
: it(int_info.cbegin()) { }
};
static bool
int_info_(const std::string name, PlTerm result)
{ const auto it = int_info.find(name);
if ( it == int_info.cend() )
return false;
PlTerm t = PlTerm_recorded(it->second);
return PlRewindOnFail([result,t]() -> bool { return result.unify_term(t); });
}
PREDICATE_NONDET(int_info, 2)
{ PlForeignContextPtr<IntInfoContext> ctxt(handle);
// When PL_PRUNED is called A1 is not bound;
// therefore, we need to do the switch on PL_foreign_control(handle)
// before checking A1.is_variable(). We can't put the test for
// A1.is_variable outside the PL_foreign_control(handle) switch
// because when PL_PRUNED happens, A1 might not be a variable. That
// is, we can't use A1.is_variable() as a way of checking whether we
// should do backtracking or not. So, we need to do an extra test
// for PL_FIRST_CALL and not allocate ctxt for backtracking if
// !A1.is_variable(). (There are, of course, other ways of
// structuring this code.)
switch( PL_foreign_control(handle) )
{ case PL_FIRST_CALL:
if ( !A1.is_variable() ) // int_info is a map, so unique on lookup
return int_info_(A1.as_string(), A2);
ctxt.set(new IntInfoContext());
break;
case PL_REDO:
break;
case PL_PRUNED:
return true;
default:
assert(0);
return false;
}
assert(A1.is_variable());
while ( ctxt->it != int_info.cend() )
{ if ( int_info_(ctxt->it->first, A2 ) )
{ PlCheck(A1.unify_atom(ctxt->it->first));
ctxt->it++;
if ( ctxt->it == int_info.cend() )
return true; // Last result: no choice point
ctxt.keep();
PL_retry_address(ctxt.get()); // Succeed with choice point
}
ctxt->it++;
}
return false;
}
PREDICATE(type_error_string, 3)
{ PlException e(PlTypeError("foofoo", A1));
std::wstring msg(e.as_wstring());
PlCheck(A2.unify_string(msg));
PlCheck(A3.unify_term(e));
return true;
}
// Re-implementing w_atom_ffi_/2 in ffi4pl.c:
PREDICATE(w_atom_cpp_, 2)
{ auto stream = A1, t = A2;
IOSTREAM* s;
PlCheck(PL_get_stream(stream.C_, &s, SIO_INPUT));
{ PlStringBuffers _string_buffers;
size_t len;
const pl_wchar_t *sa = PL_atom_wchars(t.as_atom().C_, &len);
Sfprintf(s, "/%Ws/%zd", sa, len);
}
return TRUE;
}
/* TODO: Move the "cpp_options" predicate and the associated tests
to somewhere in main SWI-Prolog system. */
static PL_option_t scan_options[] =
{ PL_OPTION("quoted", OPT_BOOL),
PL_OPTION("length", OPT_SIZE),
PL_OPTION("callback", OPT_TERM),
PL_OPTION("token", OPT_ATOM),
PL_OPTION("descr", OPT_STRING),
PL_OPTIONS_END
};
// cpp_options(+Options:list, +Opt_all:bool, -Result)
// Result is: cpp_options(Quoted,Length,Callback,Token,Descr)
PREDICATE(cpp_options, 3)
{ auto options = A1, opt_all = A2, result = A3;
int quoted = false;
size_t length = 10;
PlTerm_var callback;
PlAtom token(PlAtom::null);
const char *descr = "";
bool opt_all_v = opt_all.as_bool();
int flags = opt_all_v ? OPT_ALL : 0;
PlStringBuffers _string_buffers; // for descr's contents
PlCheck(PL_scan_options(options.C_, flags, "cpp_options", scan_options,
&quoted, &length, &callback.C_, &token.C_, &descr));
PlCheck(result.unify_term(PlCompound("options",
PlTermv(PlTerm_integer(quoted),
PlTerm_integer(length),
callback,
token.not_null() ? PlTerm(token) : PlTerm_var(),
PlTerm_string(descr)))));
// TODO: The following are needed if callback and token aren't used
// by a Prolog term (e.g., if they're stored in a "blob"):
// callback.record();
// token.register_ref();
return true;
}
PREDICATE(cvt_i_bool, 2)
{ return A2.unify_integer(A1.as_bool());
}
// TODO: add tests for PL_cvt_i_*() (using PlTerm::integer())
// TODO: add PlEngine tests
PREDICATE(throw_domain_ffi, 1)
{ return PL_domain_error("footype", A1.C_);
}
PREDICATE(throw_domain_cpp1, 1)
{ throw PlDomainError("footype", A1);
}
PREDICATE(throw_domain_cpp2, 1)
{ PlCheck(PL_domain_error("footype", A1.C_));
return false; // Should never reach here
}
PREDICATE(throw_domain_cpp3, 1)
{ PL_domain_error("footype", A1.C_);
throw PlFail();
}
PREDICATE(throw_domain_cpp4, 1)
{ return PlDomainError("footype", A1).plThrow();
}
Raw
test_cpp.pl - WIP
% -*- mode: Prolog; coding: utf-8 -*-
/* Part of SWI-Prolog
Author: Jan Wielemaker and Peter Ludemann
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 2022, SWI-Prolog Solutions b.v.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
/* This tests the examples in the SWI-cpp2.h documentation. */
:- module(test_cpp,
[ test_cpp/0
]).
:- use_module(library(debug)).
:- use_module(library(lists)).
:- use_module(library(apply)).
:- autoload(library(aggregate)).
:- use_module(library(plunit)).
:- encoding(utf8).
:- use_foreign_library(foreign(test_cpp)).
test_cpp :-
run_tests([ cpp
]).
:- begin_tests(cpp).
test(hello, Out == "Hello world\nHello world\nHello world\nHello world\nHello world\n") :-
hello(world, Out).
test(hello2, Out == "Hello2 world2\nHello2 world2\nHello2 world2\nHello2 world2\nHello2 world2\n") :-
hello2(world2, Out).
test(hello3, Out == "Hello3 世界弐\n") :-
hello3(世界弐, Out).
test(hello_call, Out == "hello(foo)\n") :-
with_output_to(string(Out), hello_call(writeln(hello(foo)))).
test(hello_call, Out == "hello(世界四)\n") :-
with_output_to(string(Out), hello_call(writeln(hello(世界四)))).
test(hello_call, error(existence_error(procedure,writeln_wrong/1))) :-
hello_call(writeln_wrong(hello(世界四))).
test(hello_call, fail) :-
hello_call(atom(hello(foo))).
test(hello_call, Ex == "no exception") :-
hello_call_ex(writeln(hello(世界四)), Ex).
test(hello_call, error(e)) :-
hello_call_ex(writeln_wrong(hello(世界四)), _).
test(hello_query, Out == "hello(世界四)\n") :-
with_output_to(string(Out), hello_query(writeln, hello(世界四))).
test(hello_query, error(existence_error(procedure,writeln_wrong/1))) :-
hello_query(writeln_wrong, hello(世界四)).
test(hello_query, fail) :-
hello_query(atom, hello(foo)).
test(as_string, S == "foo") :-
atom_to_string(foo, S).
test(as_string, S = "foo(bar)") :-
term_to_string(foo(bar), S).
% Note: atom_to_string/2 and term_to_string/2 translate the data
% to a UTF-8 string. We currenly do not support encoding for
% PlTerm.unify_string(), so we get as result the byte encoding
% of the UTF8 data.
test(as_string, S == "ä¸\u0096ç\u0095\u008Cå\u009B\u009B") :-
atom_to_string(世界四, S).
test(as_string, S = "hello(ä¸\u0096ç\u0095\u008Cå\u009B\u009B)") :-
term_to_string(hello(世界四), S).
test(add_3, Result == 666) :-
add(667, -1, Result).
test(add_3, Result == 123) :-
add(100.0, 23, Result).
test(add_3_err, error(type_error(integer,0.1))) :-
add(666, 0.1, _).
test(add_num_3_a, Result == 666) :-
add_num(555, 111, Result).
test(add_num_3_b, Result == 666.6) :-
add_num(555.2, 111.4, Result).
test(add_num_3_c, error(type_error(float,"abc"))) :-
add_num(123, "abc", _Result).
testing:p(1). % For average/3 test
testing:p(10).
testing:p(20).
test(average_3, Average =:= Expected) :-
average(X, testing:p(X), Average),
Expected is (1+10+20)/3 .
test(hello_0, Out == "hello world\n") :-
with_output_to(string(Out), hello).
call_cut_test :-
setup_call_cleanup(true,
between(1, 5, _X),
atom_codes(_,_)).
test(call_cut, error(existence_error(procedure,call_cut_test/0))) :-
% This tests that an error in ~PlQuery() is handled properly
% See discussion: https://github.com/SWI-Prolog/packages-cpp/pull/27
call_cut("call_cut_test").
test(term_1, Term = hello(world)) :-
term(Term).
test(term_2a, Result == 'hello world') :-
term(atom, Result).
test(term_2b, Result == "hello world") :-
term(string, Result).
test(term_2c, Result = [104,101,108,108,111,32,119,111,114,108,100]) :-
term(code_list, Result).
test(term_2d, Result = [h,e,l,l,o,' ',w,o,r,l,d]) :-
term(char_list, Result).
test(term_2e, Result = hello(world)) :-
term(term, Result).
test(term_2f, error(domain_error(type,foo))) :-
term(foo, _Result).
test(can_unify_2a, [true(X\==Y)]) :-
can_unify(f(X), f(Y)).
test(can_unify_2b) :-
can_unify(a(X), a(1)),
assertion(var(X)).
% Note: unify_error has additional tests for eq1/2
test(eq1_2a, X == a) :-
eq1(foo(X), foo(a)).
test(eq1_2b, fail) :-
eq1(foo(_X), bar(a)).
test(make_integer_2a, X == 123) :-
make_uint64(123, X).
test(make_integer_2b) :-
X = 666,
Y = 666,
make_uint64(X, 666),
make_uint64(666, 666),
make_uint64(X, Y).
test(make_integer_2c, fail) :-
make_uint64(123, 124).
:- if(current_prolog_flag(bounded,false)).
test(make_integer_2d, error(representation_error(uint64_t))) :-
Val is 0xffffffffffffffff + 999, % uses extended integers
make_uint64(Val, _Y).
:- endif.
test(make_integer_2e, error(domain_error(not_less_than_zero,-1))) :-
make_uint64(-1, _Y).
test(make_integer_2a, X == 123) :-
make_int64(123, X).
test(make_integer_2b) :-
X = 666,
Y = 666,
make_int64(X, 666),
make_int64(666, 666),
make_int64(X, Y).
test(make_integer_2c, fail) :-
make_int64(123, 124).
:- if(current_prolog_flag(bounded,false)).
test(make_integer_2d, error(representation_error(int64_t))) :-
Val is 0xffffffffffffffff + 999, % uses extended integers
make_int64(Val, _Y).
:- endif.
test(make_integer_2e, Y == -1) :-
make_int64(-1, Y).
test(hostname_1, [Host == Host2]) :-
hostname(Host),
hostname2(Host2).
test(cappend, Result = [a,b,c,d,e]) :-
cappend([a,b,c], [d,e], Result).
test(cpp_call, Out == "abc\n") :-
with_output_to(string(Out),
cpp_call(writeln(abc), [normal])).
cpp_call(Goal, Flags) :-
query_flags(Flags, CombinedFlag),
cpp_call_(Goal, CombinedFlag, false).
test(square_roots_2a, Result == [0.0, 1.0, 1.4142135623730951, 1.7320508075688772, 2.0]) :-
square_roots(5, Result).
:- meta_predicate with_small_stacks(+, 0).
with_small_stacks(Free, Goal) :-
garbage_collect,
statistics(globalused, G),
statistics(trailused, T),
statistics(localused, L),
NewLimit is G+L+T+Free,
current_prolog_flag(stack_limit, Old),
setup_call_cleanup(
set_prolog_flag(stack_limit, NewLimit),
Goal,
set_prolog_flag(stack_limit, Old)).
test(square_roots_2b, error(resource_error(stack))) :-
with_small_stacks(5 000 000, % 400 000 seems to be about the smallest allowed value
square_roots(1000000000, _)).
test(malloc) :-
malloc(1000, Result), % smoke test
free(Result).
:- if(\+ current_prolog_flag(asan, true)).
too_big_alloc_request(Request) :-
current_prolog_flag(address_bits, Bits),
( Bits == 32
-> Request = 0xffffffff
; Bits == 64
-> Request = 0xffffffffffffffff
% 0x10000000000 is ASAN maximum on 64-bit machines
; assertion(memberchk(Bits, [32,64]))
).
:- if(current_prolog_flag(bounded,false)).
too_many_bits_alloc_request(Request) :-
% This assumes size_t is no more than 64 bits:
current_prolog_flag(address_bits, Bits),
( Bits == 32
-> Request is 0xffffffff + 1
; Bits == 64
-> Request is 0xffffffffffffffff + 1
; assertion(memberchk(Bits, [32,64]))
).
:- endif.
test(malloc) :-
too_big_alloc_request(Request),
malloc(Request, Result),
assertion(Result == 0),
free(Result).
:- if(current_prolog_flag(bounded,false)).
test(malloc) :-
too_many_bits_alloc_request(Request),
catch( ( malloc(Request, Result),
free(Result)
),
error(E,_), true),
assertion(memberchk(E, [representation_error(_),
type_error(integer,_)])).
:- endif.
% ASAN has maximum 0x10000000000
% see ASAN_OPTIONS=allocator_may_return_null=1:soft_rss_limit_mb=...:hard_rss_limit_mb=...
% https://github.com/google/sanitizers/issues/295
% https://github.com/google/sanitizers/issues/740
test(new_chars_2, error(resource_error(memory))) :-
too_big_alloc_request(Request),
new_chars(Request, Result),
delete_chars(Result).
:- if(current_prolog_flag(bounded,false)).
test(new_chars_3) :-
too_many_bits_alloc_request(Request),
catch( ( new_chars(Request, Result),
delete_chars(Result)
),
error(E,_), true),
assertion(memberchk(E, [representation_error(_),
type_error(integer,_)])).
:- endif.
:- endif.
test(new_chars_1) :-
new_chars(1000, Result), % smoke test
delete_chars(Result).
test(name_arity_1, Out == "name = foo, arity = 2\n") :-
name_arity(foo(bar,zot), Out).
test(name_arity_3) :-
name_arity(foo(bar,zot), Name, Arity),
assertion(Name == foo),
assertion(Arity == 2).
test(list_modules_0) :-
% TODO: this outputs to cout ... make a version that checks the output?
list_modules(Text),
split_string(Text, "\n", "", Strings),
forall(( member(S, Strings), S \== ""),
( atom_string(M, S),
current_module(M))).
test(my_object, Contents == "foo-bar") :-
make_my_object(MyObject),
my_object_contents(MyObject, Contents),
free_my_object(MyObject).
test(make_functor_3a, F == foo(x)) :-
make_functor(foo, x, F).
test(make_functor_3b, error(type_error(atom,123))) :-
make_functor(123, x, _).
test(make_functor_3c) :-
make_functor(bar, 123, bar(123)).
test(make_functor_3d, fail) :-
make_functor(bar, 123, bar(666)).
test(make_functor_3e, fail) :-
make_functor(bar, 123, qqsv(123)).
test(make_functor_3f, Z==6.66) :-
make_functor(bbb, Z, F),
F = bbb(6.66).
% The following are for verifying some documentation details, and for
% ensuring that various mechanisms for reporting failure and
% exceptions behave as expected.
test(c_PL_unify_nil_ex, X == []) :-
c_PL_unify_nil_ex(X).
test(c_PL_unify_nil_ex) :-
c_PL_unify_nil_ex([]).
% The following are for verifying that an exception in
% PL_occurs_term() is handled properly - exceptions such as
% out-of-stack should behave the same way, if they don't result in a
% fatal error. The same set of tests are repeated for eq1/2, eq2/2,
% eq3/2.
test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, error) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
error(occurs_check(B,f(B))) ]) :-
eq1(X, f(X)).
test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, true) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
fail]) :-
eq1(X, f(X)).
test(unify_error, [ setup(( prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, false) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
true]) :-
eq1(X, f(X)).
% Repeat the unify_error test, using eq2/2:
test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, error) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
error(occurs_check(B,f(B))) ]) :-
eq2(X, f(X)).
test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, true) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
fail]) :-
eq2(X, f(X)).
test(unify_error, [ setup(( prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, false) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
true]) :-
eq2(X, f(X)).
% Repeat the unify_error test, using eq3/2:
test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, error) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
error(occurs_check(B,f(B))) ]) :-
eq3(X, f(X)).
test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, true) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
fail]) :-
eq3(X, f(X)).
test(unify_error, [ setup(( prolog_flag(occurs_check, OCF),
set_prolog_flag(occurs_check, false) )),
cleanup( set_prolog_flag(occurs_check, OCF) ),
true]) :-
eq3(X, f(X)).
% TODO: Add tests for as_string(enc), such as enc=EncLatin1 and atom is non-ascii
% ... for PlTerm::as_string() where term isn't an atom
% Tests from test_ffi.pl, for functions translated from ffi4pl.c:
test(range_cpp1, all(X == [1,2])) :-
range_cpp(1, 3, X).
test(range_cpp2, all(X == [-2,-1,0,1,2])) :-
range_cpp(-2, 3, X).
test(range_cpp3a, all(X == [0])) :-
range_cpp(0, 1, X).
test(range_cpp3b, all(X == [10])) :-
range_cpp(10, 11, X).
test(range_cpp3c, all(X == [-2])) :-
range_cpp(-2, -1, X).
test(range_cpp4a, fail) :-
range_cpp(1, 1, _X).
test(range_cpp4a, fail) :-
range_cpp(0, 0, _X).
test(range_cpp4a, fail) :-
range_cpp(-1, -1, _X).
test(range_cpp4d, fail) :-
range_cpp(1, 2, 2).
test(range_cpp5, X == 1) :- % Will produce warning if non-deterministic
range_cpp(1, 2, X).
test(range_cpp6b, error(type_error(integer,a))) :-
range_cpp(a, 10, _).
test(range_cpp6b, error(type_error(integer,foo))) :-
range_cpp(1, foo, _).
% This is test wchar_1 in test_ffi.pl:
test(wchar_1, all(Result == ["//0", "/ /1",
"/abC/3",
"/Hello World!/12",
"/хелло/5",
"/хелло 世界/8",
"/網目錦へび [àmímé níshíkíhéꜜbì]/26"])) :-
( w_atom_cpp('', Result)
; w_atom_cpp(' ', Result)
; w_atom_cpp('abC', Result)
; w_atom_cpp('Hello World!', Result)
; w_atom_cpp('хелло', Result)
; w_atom_cpp('хелло 世界', Result)
; w_atom_cpp('網目錦へび [àmímé níshíkíhéꜜbì]', Result)
).
% TODO: decouple this test from message hooks
% ('$messages':message_to_string/2 or print_message/'$write_on_string'/2):
test(type_error_string, S == "Type error: `foofoo' expected, found `'foo-bar'' (an atom)") :-
type_error_string('foo-bar', S, T),
assertion(unifiable(T, error(type_error(foofoo,'foo-bar'),A), [A=B])),
assertion(var(A)),
assertion(var(B)),
assertion(A\==B).
test(int_info) :-
findall(Name:Info, int_info(Name, Info), Infos),
assertion(memberchk(uint32_t:int_info(uint32_t,4,0,4294967295), Infos)).
% int_info_cut test checks that PL_PRUNED works as expected:
test(int_info_cut, Name:Info == bool:int_info(bool, 1, 0, 1)) :-
int_info(Name, Info), !.
test(cvt_i_bool, R == 1) :- cvt_i_bool(true, R).
test(cvt_i_bool, R == 1) :- cvt_i_bool(on, R).
test(cvt_i_bool, R == 1) :- cvt_i_bool(1, R).
test(cvt_i_bool, error(type_error(bool,666))) :- cvt_i_bool(666, _R).
test(cvt_i_bool, error(type_error(bool,-666))) :- cvt_i_bool(-666, _R).
:- if(current_prolog_flag(bounded,false)).
test(cvt_i_bool, error(type_error(bool,18446744073709552614))) :-
Val is 0xffffffffffffffff + 999, % uses extended integers
cvt_i_bool(Val, _R).
:- endif.
test(cvt_i_bool, R == 0) :- cvt_i_bool(false, R).
test(cvt_i_bool, R == 0) :- cvt_i_bool(off, R).
test(cvt_i_bool, R == 0) :- cvt_i_bool(0, R).
test(cvt_i_bool, error(type_error(bool,'FALSE'))) :- cvt_i_bool('FALSE', _R).
test(cvt_i_bool, error(type_error(bool,0.0))) :- cvt_i_bool(0.0, _R).
test(cvt_i_bool, error(type_error(bool,"false"))) :- cvt_i_bool("false", _R).
% TODO: the following sometimes causes a crash:
test(scan_options, [R = options(1, 5, foo(bar), _, "")]) :- % Note use of (=)/2 because of uninstantiated variable
cpp_options([quoted(true), length(5), callback(foo(bar))], false, R).
test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :-
cpp_options([token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar))], false, R).
test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :-
cpp_options([token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar)), unknown_option(blah)], false, R).
test(scan_options, [error(domain_error(cpp_options,unknown_option(blah)))]) :-
cpp_options([token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar)), unknown_option(blah)], true, _).
test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :-
cpp_options(options{token:qqsv, descr:"DESCR", quoted:true, length:5, callback:foo(bar)}, false, R).
test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :-
cpp_options([token(qqsv), descr("DESCR"), quoted, length(5), callback(foo(bar))], false, R).
test(scan_options, [R == options(0, 5, foo(bar), qqsv, "DESCR")]) :-
cpp_options([token(qqsv), descr("DESCR"), length(5), callback(foo(bar))], false, R).
test(scan_options, [error(instantiation_error)]) :-
cpp_options([token(qqsv), _, descr("DESCR"), length(5), callback(foo(bar))], false, _).
test(scan_options, [error(type_error(option,123))]) :- % TODO: is this intended behavior?
cpp_options([token(qqsv), descr("DESCR"), 123, length(5), callback(foo(bar))], false, _R).
test(scan_options, [error(type_error(option,123))]) :- % TODO: is this intended behavior?
cpp_options([token(qqsv), 123, descr("DESCR"), length(5), callback(foo(bar))], false, _R).
test(scan_options, [error(domain_error(cpp_options,unknown_option:blah))]) :-
cpp_options(options{token:qqsv, descr:"DESCR", quoted:true, length:5, callback:foo(bar), unknown_option:blah}, true, _).
test(error_term, error(domain_error(footype,qqsv("ABC")),context(throw_domain_ffi/1,_Msg))) :-
throw_domain_ffi(qqsv("ABC")).
test(error_term, [error(domain_error(footype,qqsv("ABC")),_)]) :-
throw_domain_cpp1(qqsv("ABC")).
test(error_term, error(domain_error(footype,qqsv("ABC")),context(throw_domain_cpp2/1,_Msg))) :-
throw_domain_cpp2(qqsv("ABC")).
test(error_term, error(domain_error(footype,qqsv("ABC")),context(throw_domain_cpp3/1,_Msg))) :-
throw_domain_cpp3(qqsv("ABC")).
test(error_term, [error(domain_error(footype,qqsv("ABC")),_)]) :-
throw_domain_cpp4(qqsv("ABC")).
:- end_tests(cpp).
w_atom_cpp(Atom, String) :-
with_output_to(string(String), w_atom_cpp_(current_output, Atom)).
%! query_flag(?Name, ?Bit)
%
% Flags for PL_open_query(). Check with SWI-Prolog.h. Same code
% appears in test_ffi.pl. This is duplicated to simplify
% installation of these tests in the binary version.
%
% This code is mainly for debugging.
query_flag(debug, I) => I = 0x0001.
query_flag(normal, I) => I = 0x0002.
query_flag(nodebug, I) => I = 0x0004.
query_flag(catch_exception, I) => I = 0x0008.
query_flag(pass_exception, I) => I = 0x0010.
query_flag(allow_yield, I) => I = 0x0020.
query_flag(ext_status, I) => I = 0x0040.
query_flag(deterministic, I) => I = 0x0100.
% TODO: are there any other mutually exclusive flags?
% TODO: this code is different from PlQuery::verify()
check_query_flag(Flags) :-
query_flag(normal, F1),
query_flag(catch_exception, F2),
query_flag(pass_exception, F3),
Mask is F1 \/ F2 \/ F3,
Bits is popcount(Flags /\ Mask),
( Bits =< 1
-> true
; domain_error(query_flags, Flags)
).
query_flags(Flags, CombinedFlag) :-
maplist(query_flag, Flags, Ints),
aggregate_all(sum(I), member(I, Ints), CombinedFlag).
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment