├── .gitignore ├── CMakeLists.txt ├── README.md ├── SWI-cpp.h ├── SWI-cpp2-atommap.h ├── SWI-cpp2-flags.h ├── SWI-cpp2-plx.h ├── SWI-cpp2.cpp ├── SWI-cpp2.h ├── calc.cpp ├── calc.pl ├── config.h.cmake ├── likes.cpp ├── likes.pl ├── main.cpp ├── pl2cpp.doc ├── test_cpp.cpp ├── test_cpp.pl ├── test_ffi.c └── test_ffi.pl /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.obj 3 | *.a 4 | *.so 5 | *.dylib 6 | *.dSYM 7 | *.dll 8 | *.exp 9 | *.ilk 10 | *.lib 11 | *.pdb 12 | *.old 13 | *.qlf 14 | *.out 15 | *.aux 16 | *.idx 17 | *.ilg 18 | *.ind 19 | *.log 20 | *.toc 21 | *.bbl 22 | *.blg 23 | *~ 24 | TAGS 25 | Makefile 26 | autom4te.cache 27 | config.log 28 | config.status 29 | configure 30 | pl2cpp.tex 31 | pl2cpp.pdf 32 | pl2cpp.html 33 | likes 34 | likes.exe 35 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.10) 2 | project(swipl-cpp) 3 | 4 | include("../cmake/PrologPackage.cmake") 5 | 6 | if(MSVC) 7 | set(CMAKE_CXX_STANDARD 20) 8 | else() 9 | set(CMAKE_CXX_STANDARD 17) # C++-17 ought to suffice, C++-20 is better? 10 | endif() 11 | set(CMAKE_C_STANDARD 11) 12 | 13 | configure_file(config.h.cmake config.h) 14 | 15 | install_src(pkg_cpp_headers 16 | FILES SWI-cpp.h SWI-cpp2.h SWI-cpp2.cpp 17 | SWI-cpp2-plx.h SWI-cpp2-atommap.h 18 | # TODO: (maybe) SWI-cpp2-flags.h 19 | DESTINATION ${SWIPL_INSTALL_INCLUDE}) 20 | 21 | swipl_examples(test_cpp.cpp test_ffi.c likes.cpp likes.pl README.md) 22 | 23 | pkg_doc( 24 | pl2cpp 25 | SOURCES pl2cpp.doc 26 | DEPENDS pkg_cpp_headers) 27 | 28 | # FFI tests. The `TEST_ONLY` for the plugin declaration prevents 29 | # installing the generated module. 30 | 31 | if(NOT STATIC_EXTENSIONS) 32 | test_libs(ffi cpp) 33 | 34 | swipl_plugin( 35 | test_ffi 36 | TEST_ONLY 37 | MODULE test_ffi 38 | C_SOURCES test_ffi.c) 39 | 40 | swipl_plugin( 41 | test_cpp 42 | TEST_ONLY 43 | MODULE test_cpp 44 | C_LIBS ${SOCKET_LIBRARIES} 45 | C_SOURCES test_cpp.cpp) 46 | endif() 47 | 48 | # Make sure we stick to the C++17 standard 49 | if(CMAKE_COMPILER_IS_GNUCC AND CMAKE_BUILD_TYPE STREQUAL "Debug") 50 | target_compile_options(plugin_test_cpp PRIVATE -std=c++17 -Wpedantic -Wwrite-strings) 51 | endif() 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SWI-Prolog C++ interface 2 | 3 | ## Embedding SWI-Prolog in a C++ program 4 | 5 | The files likes.pl and likes.cpp provide a simple example embedding 6 | SWI-Prolog. To compile, run 7 | 8 | swipl-ld -o likes likes.cpp likes.pl 9 | 10 | Next, run as e.g. 11 | 12 | ./likes john 13 | ./likes -happy 14 | 15 | ## Extending SWI-Prolog using C++ code 16 | 17 | The file `test_cpp.cpp` adds foreign predicates to SWI-Prolog. 18 | To compile, run 19 | 20 | swipl-ld -shared -o test_cpp test_cpp.cpp 21 | 22 | Next, run as e.g. 23 | 24 | swipl test.pl 25 | ?- use_foreign_library(test_cpp). 26 | ?- hello(world). 27 | Hello world 28 | true. 29 | 30 | ## Testing 31 | 32 | This package also provides tests for the native C SWI-Prolog foreign 33 | language interface because this is the most convenient place to do so 34 | and the C++ interface depends on the C interface. Most of the testing 35 | thereof is indirect through its usage in the core system as well as many 36 | of the packages. 37 | -------------------------------------------------------------------------------- /SWI-cpp.h: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Jan Wielemaker 4 | E-mail: J.Wielemaker@vu.nl 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2000-2024, University of Amsterdam 7 | VU University Amsterdam 8 | SWI-Prolog Solutions b.v. 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in 20 | the documentation and/or other materials provided with the 21 | distribution. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | #warning "SWI-cpp.h is obsolete and replaced by SWI-cpp2.h" 38 | 39 | #ifndef _SWI_CPP_H 40 | #define _SWI_CPP_H 41 | 42 | #include 43 | #include 44 | #include 45 | #if !(defined(__APPLE__) || defined(__FreeBSD__)) 46 | #include 47 | #endif 48 | 49 | #ifdef __BORLANDC__ 50 | #define __inline inline 51 | #endif 52 | 53 | /* Define as 1 if undefined or defined as empty */ 54 | #if !defined(PL_ARITY_AS_SIZE) || (0-PL_ARITY_AS_SIZE-1)==1 55 | #undef PL_ARITY_AS_SIZE 56 | #define PL_ARITY_AS_SIZE 1 57 | #endif 58 | 59 | #ifndef ARITY_T 60 | #if PL_ARITY_AS_SIZE 61 | #define ARITY_T size_t 62 | #else 63 | #define ARITY_T int 64 | #endif 65 | #endif 66 | 67 | class PlTerm; 68 | class PlTermv; 69 | 70 | /******************************* 71 | * PROLOG CONSTANTS * 72 | *******************************/ 73 | 74 | class PlFunctor 75 | { 76 | public: 77 | functor_t functor; 78 | 79 | PlFunctor(const char *name, ARITY_T arity) 80 | { functor = PL_new_functor(PL_new_atom(name), arity); 81 | } 82 | PlFunctor(const wchar_t *name, ARITY_T arity) 83 | { functor = PL_new_functor(PL_new_atom_wchars(wcslen(name), name), arity); 84 | } 85 | 86 | operator functor_t(void) const 87 | { return functor; 88 | } 89 | 90 | int operator ==(functor_t to) const 91 | { return functor == to; 92 | } 93 | }; 94 | 95 | 96 | class PlAtom 97 | { 98 | public: 99 | atom_t handle; 100 | 101 | PlAtom(atom_t h) 102 | { handle = h; 103 | } 104 | PlAtom(const char *text) 105 | { handle = PL_new_atom(text); 106 | } 107 | PlAtom(const wchar_t *text) 108 | { handle = PL_new_atom_wchars(wcslen(text), text); 109 | } 110 | PlAtom(const PlTerm &t); 111 | 112 | operator const char *(void) const 113 | { return PL_atom_chars(handle); 114 | } 115 | operator const wchar_t *(void) const 116 | { return PL_atom_wchars(handle, NULL); 117 | } 118 | 119 | int operator ==(const char *s) const 120 | { return strcmp(s, PL_atom_chars(handle)) == 0; 121 | } 122 | int operator ==(const wchar_t *s) const 123 | { return wcscmp(s, PL_atom_wchars(handle, NULL)) == 0; 124 | } 125 | int operator ==(const PlAtom &a) const 126 | { return handle == a.handle; 127 | } 128 | int operator ==(atom_t to) const 129 | { return handle == to; 130 | } 131 | }; 132 | 133 | /******************************* 134 | * GENERIC PROLOG TERM * 135 | *******************************/ 136 | 137 | 138 | class PlTerm 139 | { 140 | public: 141 | term_t ref; 142 | 143 | PlTerm(); 144 | PlTerm(const PlTerm &other) : ref(other.ref) {} 145 | PlTerm(term_t t) 146 | { ref = t; 147 | } 148 | 149 | /* C --> PlTerm */ 150 | PlTerm(const char *text); 151 | PlTerm(const wchar_t *text); 152 | PlTerm(long val); 153 | PlTerm(double val); 154 | PlTerm(const PlAtom &a); 155 | PlTerm(void *ptr); 156 | 157 | /* PlTerm --> C */ 158 | operator term_t(void) const 159 | { return ref; 160 | } 161 | operator char *(void) const; 162 | operator wchar_t *(void) const; 163 | operator long(void) const; 164 | operator int(void) const; 165 | operator uint32_t(void) const; 166 | operator bool(void) const; 167 | operator double(void) const; 168 | operator PlAtom(void) const; 169 | operator void *(void) const; 170 | 171 | int type() const 172 | { return PL_term_type(ref); 173 | } 174 | 175 | /* Compounds */ 176 | PlTerm operator [](ARITY_T index) const; 177 | ARITY_T arity() const; 178 | const char *name() const; 179 | 180 | /* UNIFY */ 181 | int operator =(const PlTerm &t2); /* term */ 182 | int operator =(const PlAtom &a); /* atom */ 183 | int operator =(const char *v); /* atom (from char *) */ 184 | int operator =(const wchar_t *v); /* atom (from wchar_t *) */ 185 | int operator =(long v); /* integer */ 186 | int operator =(int v); /* integer */ 187 | int operator =(double v); /* float */ 188 | int operator =(const PlFunctor &f); /* functor */ 189 | 190 | /* Comparison standard order terms */ 191 | int operator ==(const PlTerm &t2) const 192 | { return PL_compare(ref, t2.ref) == 0; 193 | } 194 | int operator !=(const PlTerm &t2) const 195 | { return PL_compare(ref, t2.ref) != 0; 196 | } 197 | int operator <(const PlTerm &t2) const 198 | { return PL_compare(ref, t2.ref) < 0; 199 | } 200 | int operator >(const PlTerm &t2) const 201 | { return PL_compare(ref, t2.ref) > 0; 202 | } 203 | int operator <=(const PlTerm &t2) const 204 | { return PL_compare(ref, t2.ref) <= 0; 205 | } 206 | int operator >=(const PlTerm &t2) const 207 | { return PL_compare(ref, t2.ref) >= 0; 208 | } 209 | /* comparison (long) */ 210 | int operator ==(long v) const; 211 | int operator !=(long v) const; 212 | int operator <(long v) const; 213 | int operator >(long v) const; 214 | int operator <=(long v) const; 215 | int operator >=(long v) const; 216 | 217 | /* comparison (string) */ 218 | int operator ==(const char *s) const; 219 | int operator ==(const wchar_t *s) const; 220 | int operator ==(const PlAtom &a) const; 221 | }; 222 | 223 | 224 | /******************************* 225 | * TERM VECTOR * 226 | *******************************/ 227 | 228 | class PlTermv 229 | { 230 | public: 231 | term_t a0; 232 | size_t size; 233 | 234 | PlTermv(int n) 235 | { a0 = PL_new_term_refs(n); 236 | size = static_cast(n); 237 | } 238 | PlTermv(int n, term_t t0) 239 | { a0 = t0; 240 | size = static_cast(n); 241 | } 242 | PlTermv(size_t n) 243 | { a0 = PL_new_term_refs(static_cast(n)); 244 | size = n; 245 | } 246 | PlTermv(size_t n, term_t t0) 247 | { a0 = t0; 248 | size = n; 249 | } 250 | 251 | /* create from args */ 252 | PlTermv(PlTerm m0); 253 | PlTermv(PlTerm m0, PlTerm m1); 254 | PlTermv(PlTerm m0, PlTerm m1, PlTerm m2); 255 | PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3); 256 | PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3, PlTerm m4); 257 | 258 | PlTerm operator [](size_t n) const; 259 | }; 260 | 261 | /******************************* 262 | * SPECIALISED TERMS * 263 | *******************************/ 264 | 265 | class PlCompound : public PlTerm 266 | { 267 | public: 268 | 269 | PlCompound(const char *text); 270 | PlCompound(const wchar_t *text); 271 | PlCompound(const char *functor, const PlTermv &args); 272 | PlCompound(const wchar_t *functor, const PlTermv &args); 273 | }; 274 | 275 | 276 | class PlString : public PlTerm 277 | { 278 | public: 279 | 280 | PlString(const char *text); 281 | PlString(const char *text, size_t len); 282 | PlString(const wchar_t *text); 283 | PlString(const wchar_t *text, size_t len); 284 | }; 285 | 286 | 287 | class PlCodeList : public PlTerm 288 | { 289 | public: 290 | 291 | PlCodeList(const char *text); 292 | PlCodeList(const wchar_t *text); 293 | }; 294 | 295 | 296 | class PlCharList : public PlTerm 297 | { 298 | public: 299 | 300 | PlCharList(const char *text); 301 | PlCharList(const wchar_t *text); 302 | }; 303 | 304 | 305 | /******************************* 306 | * EXCEPTIONS * 307 | *******************************/ 308 | 309 | class PlException : public PlTerm 310 | { 311 | public: 312 | PlException() 313 | { term_t ex = PL_exception(0); 314 | if ( ex ) 315 | ref = ex; 316 | else 317 | PL_fatal_error("No exception"); 318 | } 319 | 320 | PlException(const PlTerm &t) 321 | { ref = t.ref; 322 | } 323 | 324 | operator const char *(void); 325 | operator const wchar_t *(void); 326 | 327 | foreign_t plThrow() 328 | { return static_cast(PL_raise_exception(ref)); 329 | } 330 | 331 | void cppThrow(); 332 | }; 333 | 334 | 335 | class PlTypeError : public PlException 336 | { 337 | public: 338 | 339 | PlTypeError(const PlTerm &t) : PlException(t) {} 340 | 341 | PlTypeError(const char *expected, PlTerm actual) : 342 | PlException(PlCompound("error", 343 | PlTermv(PL_is_variable(actual.ref) ? 344 | PlTerm("instantiation_error") : 345 | PlCompound("type_error", 346 | PlTermv(expected, actual)), 347 | PlTerm()))) 348 | { 349 | } 350 | }; 351 | 352 | 353 | class PlDomainError : public PlException 354 | { 355 | public: 356 | 357 | PlDomainError(const PlTerm &t) : PlException(t) {} 358 | 359 | PlDomainError(const char *expected, PlTerm actual) : 360 | PlException(PlCompound("error", 361 | PlTermv(PlCompound("domain_error", 362 | PlTermv(expected, actual)), 363 | PlTerm()))) 364 | { 365 | } 366 | }; 367 | 368 | 369 | class PlInstantiationError : public PlException 370 | { 371 | public: 372 | 373 | PlInstantiationError(const PlTerm &t) : 374 | PlException(PL_is_variable(t) ? 375 | PlCompound("error", 376 | PlTermv("instantiation_error", 377 | t)) : t) {} 378 | 379 | PlInstantiationError() : 380 | PlException(PlCompound("error", 381 | PlTermv("instantiation_error", 382 | PlTerm()))) 383 | { 384 | } 385 | }; 386 | 387 | 388 | class PlExistenceError : public PlException 389 | { 390 | public: 391 | 392 | PlExistenceError(const PlTerm &t) : PlException(t) {} 393 | 394 | PlExistenceError(const char *type, PlTerm actual) : 395 | PlException(PlCompound("error", 396 | PlTermv(PlCompound("existence_error", 397 | PlTermv(type, actual)), 398 | PlTerm()))) 399 | { 400 | } 401 | }; 402 | 403 | 404 | class PlPermissionError : public PlException 405 | { 406 | public: 407 | 408 | PlPermissionError(const PlTerm &t) : PlException(t) {} 409 | 410 | PlPermissionError(const char *op, const char *type, PlTerm obj) : 411 | PlException(PlCompound("error", 412 | PlTermv(PlCompound("permission_error", 413 | PlTermv(op, type, obj)), 414 | PlTerm()))) 415 | { 416 | } 417 | }; 418 | 419 | 420 | class PlResourceError : public PlException 421 | { 422 | public: 423 | PlResourceError() : PlException() {} 424 | 425 | PlResourceError(const PlTerm &t) : PlException(t) {} 426 | 427 | PlResourceError(const char *resource) : 428 | PlException(PlCompound("error", 429 | PlTermv(PlCompound("resource_error", 430 | PlTermv(PlTerm(resource))), 431 | PlTerm()))) 432 | { 433 | } 434 | }; 435 | 436 | 437 | class PlTermvDomainError : public PlException 438 | { 439 | public: 440 | 441 | PlTermvDomainError(size_t size, size_t n) : 442 | PlException(PlCompound("error", 443 | PlTermv(PlCompound("domain_error", 444 | PlTermv(PlCompound("argv", 445 | size), 446 | PlTerm(static_cast(n)))), 447 | PlTerm()))) 448 | { 449 | } 450 | }; 451 | 452 | 453 | /******************************* 454 | * PLTERM IMPLEMENTATION * 455 | *******************************/ 456 | 457 | __inline 458 | PlTerm::PlTerm() 459 | { if ( !(ref = PL_new_term_ref()) ) 460 | throw PlResourceError(); 461 | } 462 | 463 | __inline 464 | PlTerm::PlTerm(const char *text) 465 | { if ( !(ref = PL_new_term_ref()) || 466 | !PL_put_atom_chars(ref, text) ) 467 | throw PlResourceError(); 468 | } 469 | 470 | __inline 471 | PlTerm::PlTerm(const wchar_t *text) 472 | { if ( !(ref = PL_new_term_ref()) || 473 | !PL_unify_wchars(ref, PL_ATOM, static_cast(-1), text) ) 474 | throw PlResourceError(); 475 | } 476 | 477 | __inline 478 | PlTerm::PlTerm(long val) 479 | { if ( !(ref = PL_new_term_ref()) || 480 | !PL_put_integer(ref, val) ) 481 | throw PlResourceError(); 482 | } 483 | 484 | __inline 485 | PlTerm::PlTerm(double val) 486 | { if ( !(ref = PL_new_term_ref()) || 487 | !PL_put_float(ref, val) ) 488 | throw PlResourceError(); 489 | } 490 | 491 | __inline 492 | PlTerm::PlTerm(const PlAtom &a) 493 | { if ( !(ref = PL_new_term_ref()) ) 494 | throw PlResourceError(); 495 | 496 | PL_put_atom(ref, a.handle); 497 | } 498 | 499 | __inline 500 | PlTerm::PlTerm(void *ptr) 501 | { if ( !(ref = PL_new_term_ref()) || 502 | !PL_put_pointer(ref, ptr) ) 503 | throw PlResourceError(); 504 | } 505 | 506 | /******************************* 507 | * SPECIALISED IMPLEMENTATIONS * 508 | *******************************/ 509 | 510 | __inline 511 | PlString::PlString(const char *text) : PlTerm() 512 | { if ( !PL_put_string_chars(ref, text) ) 513 | throw PlResourceError(); 514 | } 515 | 516 | __inline 517 | PlString::PlString(const char *text, size_t len) : PlTerm() 518 | { if ( !PL_put_string_nchars(ref, len, text) ) 519 | throw PlResourceError(); 520 | } 521 | 522 | __inline 523 | PlString::PlString(const wchar_t *text) : PlTerm() 524 | { if ( !PL_unify_wchars(ref, PL_STRING, static_cast(-1), text) ) 525 | throw PlResourceError(); 526 | } 527 | 528 | __inline 529 | PlString::PlString(const wchar_t *text, size_t len) : PlTerm() 530 | { if ( !PL_unify_wchars(ref, PL_STRING, len, text) ) 531 | throw PlResourceError(); 532 | } 533 | 534 | __inline 535 | PlCodeList::PlCodeList(const char *text) : PlTerm() 536 | { if ( !PL_put_list_codes(ref, text) ) 537 | throw PlResourceError(); 538 | } 539 | 540 | __inline 541 | PlCharList::PlCharList(const char *text) : PlTerm() 542 | { if ( !PL_put_list_chars(ref, text) ) 543 | throw PlResourceError(); 544 | } 545 | 546 | __inline 547 | PlCodeList::PlCodeList(const wchar_t *text) : PlTerm() 548 | { if ( !PL_unify_wchars(ref, PL_CODE_LIST, static_cast(-1), text) ) 549 | throw PlResourceError(); 550 | } 551 | 552 | __inline 553 | PlCharList::PlCharList(const wchar_t *text) : PlTerm() 554 | { if ( !PL_unify_wchars(ref, PL_CHAR_LIST, static_cast(-1), text) ) 555 | throw PlResourceError(); 556 | } 557 | 558 | 559 | /******************************* 560 | * LISTS * 561 | *******************************/ 562 | 563 | class PlTail : public PlTerm 564 | { 565 | public: 566 | 567 | PlTail(const PlTerm &l) 568 | { if ( PL_is_variable(l.ref) || PL_is_list(l.ref) ) 569 | { if ( !(ref = PL_copy_term_ref(l.ref)) ) 570 | throw PlResourceError(); 571 | } else 572 | throw PlTypeError("list", l.ref); 573 | } 574 | 575 | /* building */ 576 | int append(const PlTerm &e) 577 | { term_t tmp, ex; 578 | 579 | if ( (tmp = PL_new_term_ref()) && 580 | PL_unify_list(ref, tmp, ref) && 581 | PL_unify(tmp, e.ref) ) 582 | { PL_reset_term_refs(tmp); 583 | return TRUE; 584 | } 585 | 586 | if ( (ex = PL_exception(0)) ) 587 | throw PlResourceError(ex); 588 | 589 | return FALSE; 590 | } 591 | int close() 592 | { return PL_unify_nil(ref); 593 | } 594 | 595 | /* enumerating */ 596 | int next(PlTerm &t) 597 | { if ( PL_get_list(ref, t, ref) ) 598 | return TRUE; 599 | 600 | if ( PL_get_nil(ref) ) 601 | return FALSE; 602 | 603 | throw PlTypeError("list", ref); 604 | } 605 | }; 606 | 607 | 608 | /******************************* 609 | * REGISTER * 610 | *******************************/ 611 | 612 | 613 | class PlRegister 614 | { 615 | public: 616 | 617 | PlRegister(const char *module, const char *name, int arity, 618 | foreign_t (f)(term_t t0, int a, control_t ctx)) 619 | { PL_register_foreign_in_module(module, name, arity, reinterpret_cast(f), PL_FA_VARARGS); 620 | } 621 | 622 | PlRegister(const char *module, const char *name, foreign_t (*f)(PlTerm a0)) 623 | { PL_register_foreign_in_module(module, name, 1, reinterpret_cast(f), 0); 624 | } 625 | PlRegister(const char *module, const char *name, foreign_t (*f)(PlTerm a0, PlTerm a1)) 626 | { PL_register_foreign_in_module(module, name, 2, reinterpret_cast(f), 0); 627 | } 628 | PlRegister(const char *module, const char *name, foreign_t (*f)(PlTerm a0, PlTerm a1, PlTerm a2)) 629 | { PL_register_foreign_in_module(module, name, 3, reinterpret_cast(f), 0); 630 | } 631 | 632 | // for non-deterministic calls 633 | PlRegister(const char *module, const char *name, int arity, 634 | foreign_t (f)(term_t t0, int a, control_t ctx), short flags) 635 | { PL_register_foreign_in_module(module, name, arity, reinterpret_cast(f), flags); 636 | } 637 | }; 638 | 639 | 640 | /******************************* 641 | * CALLING PROLOG * 642 | *******************************/ 643 | 644 | class PlFrame 645 | { 646 | public: 647 | fid_t fid; 648 | 649 | PlFrame() 650 | { fid = PL_open_foreign_frame(); 651 | } 652 | 653 | ~PlFrame() 654 | { PL_close_foreign_frame(fid); 655 | } 656 | 657 | void rewind() 658 | { PL_rewind_foreign_frame(fid); 659 | } 660 | }; 661 | 662 | 663 | class PlQuery 664 | { 665 | public: 666 | qid_t qid; 667 | 668 | PlQuery(predicate_t pred, const PlTermv &av) 669 | { qid = PL_open_query(static_cast(0), PL_Q_PASS_EXCEPTION, pred, av.a0); 670 | if ( !qid ) 671 | throw PlResourceError(); 672 | } 673 | PlQuery(const char *name, const PlTermv &av) 674 | { predicate_t p = PL_predicate(name, static_cast(av.size), "user"); 675 | 676 | qid = PL_open_query(static_cast(0), PL_Q_PASS_EXCEPTION, p, av.a0); 677 | if ( !qid ) 678 | throw PlResourceError(); 679 | } 680 | PlQuery(const char *module, const char *name, const PlTermv &av) 681 | { atom_t ma = PL_new_atom(module); 682 | atom_t na = PL_new_atom(name); 683 | module_t m = PL_new_module(ma); 684 | predicate_t p = PL_pred(PL_new_functor(na, av.size), m); 685 | 686 | PL_unregister_atom(ma); 687 | PL_unregister_atom(na); 688 | 689 | qid = PL_open_query(m, PL_Q_PASS_EXCEPTION, p, av.a0); 690 | if ( !qid ) 691 | throw PlResourceError(); 692 | } 693 | 694 | ~PlQuery() 695 | { if ( qid ) 696 | PL_cut_query(qid); 697 | } 698 | 699 | int next_solution(); 700 | }; 701 | 702 | 703 | __inline int 704 | PlCall(const char *predicate, const PlTermv &args) 705 | { PlQuery q(predicate, args); 706 | return q.next_solution(); 707 | } 708 | 709 | __inline int 710 | PlCall(const char *module, const char *predicate, const PlTermv &args) 711 | { PlQuery q(module, predicate, args); 712 | return q.next_solution(); 713 | } 714 | 715 | __inline int 716 | PlCall(const char *goal) 717 | { PlQuery q("call", PlTermv(PlCompound(goal))); 718 | return q.next_solution(); 719 | } 720 | 721 | __inline int 722 | PlCall(const wchar_t *goal) 723 | { PlQuery q("call", PlTermv(PlCompound(goal))); 724 | return q.next_solution(); 725 | } 726 | 727 | 728 | 729 | /******************************* 730 | * ATOM (BODY) * 731 | *******************************/ 732 | 733 | __inline 734 | PlAtom::PlAtom(const PlTerm &t) 735 | { atom_t a; 736 | 737 | if ( PL_get_atom(t.ref, &a) ) 738 | handle = a; 739 | else 740 | throw PlTypeError("atom", t); 741 | } 742 | 743 | 744 | /******************************* 745 | * TERM (BODY) * 746 | *******************************/ 747 | 748 | /* PlTerm --> C */ 749 | 750 | __inline PlTerm::operator char *(void) const 751 | { char *s; 752 | 753 | if ( PL_get_chars(ref, &s, CVT_ALL|CVT_WRITEQ|BUF_RING) ) 754 | return s; 755 | 756 | throw PlTypeError("text", ref); 757 | } 758 | 759 | __inline PlTerm::operator wchar_t *(void) const 760 | { wchar_t *s; 761 | 762 | if ( PL_get_wchars(ref, NULL, &s, CVT_ALL|CVT_WRITEQ|BUF_RING) ) 763 | return s; 764 | 765 | throw PlTypeError("text", ref); 766 | } 767 | 768 | __inline PlTerm::operator long(void) const 769 | { long v; 770 | 771 | if ( PL_get_long(ref, &v) ) 772 | return v; 773 | 774 | throw PlTypeError("integer", ref); 775 | } 776 | 777 | __inline PlTerm::operator int(void) const 778 | { int v; 779 | 780 | if ( PL_get_integer(ref, &v) ) 781 | return v; 782 | 783 | throw PlTypeError("integer", ref); 784 | } 785 | 786 | __inline PlTerm::operator uint32_t(void) const 787 | { int64_t v; 788 | 789 | if ( PL_get_int64(ref, &v) && v >= 0 && v <= UINT32_MAX ) 790 | return v; 791 | 792 | throw PlTypeError("uint32_t", ref); 793 | } 794 | 795 | __inline PlTerm::operator bool(void) const 796 | { int v; 797 | 798 | if ( PL_get_bool(ref, &v) ) 799 | return v; 800 | 801 | throw PlTypeError("bool", ref); 802 | } 803 | 804 | __inline PlTerm::operator double(void) const 805 | { double v; 806 | 807 | if ( PL_get_float(ref, &v) ) 808 | return v; 809 | 810 | throw PlTypeError("float", ref); 811 | } 812 | 813 | __inline PlTerm::operator PlAtom(void) const 814 | { atom_t v; 815 | 816 | if ( PL_get_atom(ref, &v) ) 817 | return PlAtom(v); 818 | 819 | throw PlTypeError("atom", ref); 820 | } 821 | 822 | __inline PlTerm::operator void *(void) const 823 | { void *ptr; 824 | 825 | if ( PL_get_pointer(ref, &ptr) ) 826 | return ptr; 827 | 828 | throw PlTypeError("pointer", ref); 829 | } 830 | 831 | /* compounds */ 832 | 833 | __inline PlTerm 834 | PlTerm::operator [](ARITY_T index) const 835 | { PlTerm t; 836 | 837 | if ( PL_get_arg(index, ref, t.ref) ) 838 | return t; 839 | 840 | if ( !PL_is_compound(ref) ) 841 | { throw PlTypeError("compound", ref); 842 | } else 843 | { if ( !PL_put_uint64(t.ref, index) ) 844 | throw PlResourceError(); 845 | 846 | if ( index < 1 ) 847 | throw PlDomainError("not_less_than_zero", t.ref); 848 | else 849 | throw PlDomainError("arity", t.ref); /* TBD: proper exception */ 850 | } 851 | } 852 | 853 | 854 | __inline ARITY_T 855 | PlTerm::arity() const 856 | { atom_t name; 857 | ARITY_T arity; 858 | 859 | if ( PL_get_name_arity(ref, &name, &arity) ) 860 | return arity; 861 | 862 | throw PlTypeError("compound", ref); 863 | } 864 | 865 | 866 | __inline const char * 867 | PlTerm::name() const 868 | { atom_t name; 869 | ARITY_T arity; 870 | 871 | if ( PL_get_name_arity(ref, &name, &arity) ) 872 | return PL_atom_chars(name); 873 | 874 | throw PlTypeError("compound", ref); 875 | } 876 | 877 | 878 | /* Unification */ 879 | 880 | __inline int PlTerm::operator =(const PlTerm &t2) /* term = term */ 881 | { int rc = PL_unify(ref, t2.ref); 882 | term_t ex; 883 | 884 | if ( !rc && (ex=PL_exception(0)) ) 885 | throw PlResourceError(ex); 886 | return rc; 887 | } 888 | 889 | __inline int PlTerm::operator =(const PlAtom &a) /* term = atom */ 890 | { int rc = PL_unify_atom(ref, a.handle); 891 | term_t ex; 892 | 893 | if ( !rc && (ex=PL_exception(0)) ) 894 | throw PlResourceError(ex); 895 | return rc; 896 | } 897 | 898 | __inline int PlTerm::operator =(const char *v) /* term = atom */ 899 | { int rc = PL_unify_atom_chars(ref, v); 900 | term_t ex; 901 | 902 | if ( !rc && (ex=PL_exception(0)) ) 903 | throw PlResourceError(ex); 904 | return rc; 905 | } 906 | 907 | __inline int PlTerm::operator =(const wchar_t *v) /* term = atom */ 908 | { int rc = PL_unify_wchars(ref, PL_ATOM, static_cast(-1), v); 909 | term_t ex; 910 | 911 | if ( !rc && (ex=PL_exception(0)) ) 912 | throw PlResourceError(ex); 913 | return rc; 914 | } 915 | 916 | __inline int PlTerm::operator =(long v) 917 | { int rc = PL_unify_integer(ref, v); 918 | term_t ex; 919 | 920 | if ( !rc && (ex=PL_exception(0)) ) 921 | throw PlResourceError(ex); 922 | return rc; 923 | } 924 | 925 | __inline int PlTerm::operator =(int v) 926 | { int rc = PL_unify_integer(ref, v); 927 | term_t ex; 928 | 929 | if ( !rc && (ex=PL_exception(0)) ) 930 | throw PlResourceError(ex); 931 | return rc; 932 | } 933 | 934 | __inline int PlTerm::operator =(double v) 935 | { int rc = PL_unify_float(ref, v); 936 | term_t ex; 937 | 938 | if ( !rc && (ex=PL_exception(0)) ) 939 | throw PlResourceError(ex); 940 | return rc; 941 | } 942 | 943 | __inline int PlTerm::operator =(const PlFunctor &f) 944 | { int rc = PL_unify_functor(ref, f.functor); 945 | term_t ex; 946 | 947 | if ( !rc && (ex=PL_exception(0)) ) 948 | throw PlResourceError(ex); 949 | return rc; 950 | } 951 | 952 | /* comparison */ 953 | 954 | 955 | __inline int PlTerm::operator ==(long v) const 956 | { long v0; 957 | 958 | if ( PL_get_long(ref, &v0) ) 959 | return v0 == v; 960 | 961 | throw PlTypeError("integer", ref); 962 | } 963 | 964 | __inline int PlTerm::operator !=(long v) const 965 | { long v0; 966 | 967 | if ( PL_get_long(ref, &v0) ) 968 | return v0 != v; 969 | 970 | throw PlTypeError("integer", ref); 971 | } 972 | 973 | __inline int PlTerm::operator <(long v) const 974 | { long v0; 975 | 976 | if ( PL_get_long(ref, &v0) ) 977 | return v0 < v; 978 | 979 | throw PlTypeError("integer", ref); 980 | } 981 | 982 | __inline int PlTerm::operator >(long v) const 983 | { long v0; 984 | 985 | if ( PL_get_long(ref, &v0) ) 986 | return v0 > v; 987 | 988 | throw PlTypeError("integer", ref); 989 | } 990 | 991 | __inline int PlTerm::operator <=(long v) const 992 | { long v0; 993 | 994 | if ( PL_get_long(ref, &v0) ) 995 | return v0 <= v; 996 | 997 | throw PlTypeError("integer", ref); 998 | } 999 | 1000 | __inline int PlTerm::operator >=(long v) const 1001 | { long v0; 1002 | 1003 | if ( PL_get_long(ref, &v0) ) 1004 | return v0 >= v; 1005 | 1006 | throw PlTypeError("integer", ref); 1007 | } 1008 | 1009 | /* comparison (string) */ 1010 | 1011 | __inline int PlTerm::operator ==(const char *s) const 1012 | { char *s0; 1013 | 1014 | if ( PL_get_chars(ref, &s0, CVT_ALL) ) 1015 | return strcmp(s0, s) == 0; 1016 | 1017 | throw PlTypeError("text", ref); 1018 | } 1019 | 1020 | __inline int PlTerm::operator ==(const wchar_t *s) const 1021 | { wchar_t *s0; 1022 | 1023 | if ( PL_get_wchars(ref, NULL, &s0, CVT_ALL) ) 1024 | return wcscmp(s0, s) == 0; 1025 | 1026 | throw PlTypeError("text", ref); 1027 | } 1028 | 1029 | __inline int PlTerm::operator ==(const PlAtom &a) const 1030 | { atom_t v; 1031 | 1032 | if ( PL_get_atom(ref, &v) ) 1033 | return v == a.handle; 1034 | 1035 | throw PlTypeError("atom", ref); 1036 | } 1037 | 1038 | 1039 | /******************************* 1040 | * COMPOUND (BODY) * 1041 | *******************************/ 1042 | 1043 | __inline void 1044 | PlPutTerm(term_t to, term_t from) 1045 | { if ( !PL_put_term(to, from) ) 1046 | throw PlResourceError(); 1047 | } 1048 | 1049 | 1050 | __inline 1051 | PlCompound::PlCompound(const char *text) : PlTerm() 1052 | { term_t t = PL_new_term_ref(); 1053 | 1054 | if ( !PL_chars_to_term(text, t) ) 1055 | throw PlException(t); 1056 | 1057 | PlPutTerm(ref, t); 1058 | } 1059 | 1060 | __inline 1061 | PlCompound::PlCompound(const wchar_t *text) : PlTerm() 1062 | { term_t t = PL_new_term_ref(); 1063 | 1064 | if ( !PL_wchars_to_term(text, t) ) 1065 | throw PlException(t); 1066 | 1067 | PlPutTerm(ref, t); 1068 | } 1069 | 1070 | __inline 1071 | PlCompound::PlCompound(const char *functor, const PlTermv &args) : PlTerm() 1072 | { if ( !PL_cons_functor_v(ref, 1073 | PL_new_functor(PL_new_atom(functor), args.size), 1074 | args.a0) ) 1075 | throw PlResourceError(); 1076 | } 1077 | 1078 | __inline 1079 | PlCompound::PlCompound(const wchar_t *functor, const PlTermv &args) : PlTerm() 1080 | { if ( !PL_cons_functor_v( 1081 | ref, 1082 | PL_new_functor(PL_new_atom_wchars(wcslen(functor), functor), 1083 | args.size), 1084 | args.a0) ) 1085 | throw PlResourceError(); 1086 | } 1087 | 1088 | /******************************* 1089 | * TERMV (BODY) * 1090 | *******************************/ 1091 | 1092 | 1093 | __inline PlTermv::PlTermv(PlTerm m0) 1094 | { size = 1; 1095 | a0 = m0.ref; 1096 | } 1097 | 1098 | __inline PlTermv::PlTermv(PlTerm m0, PlTerm m1) 1099 | { size = 2; 1100 | if ( !(a0 = PL_new_term_refs(2)) ) 1101 | throw PlResourceError(); 1102 | PlPutTerm(a0+0, m0); 1103 | PlPutTerm(a0+1, m1); 1104 | } 1105 | 1106 | __inline PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2) 1107 | { size = 3; 1108 | if ( !(a0 = PL_new_term_refs(3)) ) 1109 | throw PlResourceError(); 1110 | PlPutTerm(a0+0, m0); 1111 | PlPutTerm(a0+1, m1); 1112 | PlPutTerm(a0+2, m2); 1113 | } 1114 | 1115 | __inline PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3) 1116 | { size = 4; 1117 | if ( !(a0 = PL_new_term_refs(4)) ) 1118 | throw PlResourceError(); 1119 | PlPutTerm(a0+0, m0); 1120 | PlPutTerm(a0+1, m1); 1121 | PlPutTerm(a0+2, m2); 1122 | 1123 | PlPutTerm(a0+3, m3); 1124 | } 1125 | 1126 | __inline PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, 1127 | PlTerm m3, PlTerm m4) 1128 | { size = 5; 1129 | if ( !(a0 = PL_new_term_refs(5)) ) 1130 | throw PlResourceError(); 1131 | PlPutTerm(a0+0, m0); 1132 | PlPutTerm(a0+1, m1); 1133 | PlPutTerm(a0+2, m2); 1134 | PlPutTerm(a0+3, m3); 1135 | PlPutTerm(a0+4, m4); 1136 | } 1137 | 1138 | 1139 | __inline PlTerm 1140 | PlTermv::operator [](size_t n) const 1141 | { if ( n >= size ) 1142 | throw PlTermvDomainError(size, n); 1143 | 1144 | return PlTerm(a0+n); 1145 | } 1146 | 1147 | 1148 | /******************************* 1149 | * EXCEPTIONS (BODY) * 1150 | *******************************/ 1151 | 1152 | __inline PlException::operator const char *(void) 1153 | { PlFrame fr; 1154 | #ifdef USE_PRINT_MESSAGE 1155 | PlTermv av(2); 1156 | 1157 | av[0] = PlCompound("print_message", 1158 | PlTermv("error", ref)); 1159 | PlQuery q("$write_on_string", av); 1160 | if ( q.next_solution() ) 1161 | return (char *)av[1]; 1162 | #else 1163 | PlTermv av(2); 1164 | av[0] = PlTerm(ref); 1165 | PlQuery q("$messages", "message_to_string", av); 1166 | if ( q.next_solution() ) 1167 | return static_cast(av[1]); 1168 | #endif 1169 | return "[ERROR: Failed to generate message. Internal error]\n"; 1170 | } 1171 | 1172 | 1173 | __inline PlException::operator const wchar_t *(void) 1174 | { PlFrame fr; 1175 | #ifdef USE_PRINT_MESSAGE 1176 | PlTermv av(2); 1177 | 1178 | av[0] = PlCompound("print_message", 1179 | PlTermv("error", ref)); 1180 | PlQuery q("$write_on_string", av); 1181 | if ( q.next_solution() ) 1182 | return (wchar_t *)av[1]; 1183 | #else 1184 | PlTermv av(2); 1185 | av[0] = PlTerm(ref); 1186 | PlQuery q("$messages", "message_to_string", av); 1187 | if ( q.next_solution() ) 1188 | return static_cast(av[1]); 1189 | #endif 1190 | return L"[ERROR: Failed to generate message. Internal error]\n"; 1191 | } 1192 | 1193 | 1194 | __inline void 1195 | PlException::cppThrow() 1196 | { term_t a = PL_new_term_ref(); 1197 | atom_t name; 1198 | ARITY_T arity; 1199 | 1200 | if ( PL_get_arg(1, ref, a) && 1201 | PL_get_name_arity(a, &name, &arity) ) 1202 | { const char *s = PL_atom_chars(name); 1203 | 1204 | if ( strcmp(s, "type_error") == 0 ) 1205 | throw PlTypeError(ref); 1206 | if ( strcmp(s, "domain_error") == 0 ) 1207 | throw PlDomainError(ref); 1208 | if ( strcmp(s, "resource_error") == 0 ) 1209 | throw PlResourceError(ref); 1210 | } 1211 | 1212 | throw *this; 1213 | } 1214 | 1215 | 1216 | /******************************* 1217 | * QUERY (BODY) * 1218 | *******************************/ 1219 | 1220 | __inline int 1221 | PlQuery::next_solution() 1222 | { int rval; 1223 | 1224 | if ( !(rval = PL_next_solution(qid)) ) 1225 | { term_t ex; 1226 | 1227 | PL_close_query(qid); 1228 | qid = 0; 1229 | 1230 | if ( (ex = PL_exception(0)) ) 1231 | PlException(ex).cppThrow(); 1232 | } 1233 | return rval; 1234 | } 1235 | 1236 | 1237 | /******************************* 1238 | * ENGINE * 1239 | *******************************/ 1240 | 1241 | class PlError 1242 | { 1243 | public: 1244 | char *message; 1245 | 1246 | PlError(const char *msg) 1247 | { size_t len = strlen(msg)+1; 1248 | message = new char[len]; 1249 | #ifdef _MSC_VER /* Yek */ 1250 | #pragma warning( push ) 1251 | #pragma warning (disable:4996) 1252 | #endif 1253 | strncpy(message, msg, len); 1254 | #ifdef _MSC_VER 1255 | #pragma warning( pop ) 1256 | #endif 1257 | } 1258 | 1259 | ~PlError() 1260 | { 1261 | delete[] message; 1262 | } 1263 | }; 1264 | 1265 | 1266 | class PlEngine 1267 | { 1268 | public: 1269 | 1270 | PlEngine(int argc, char **argv) 1271 | { if ( !PL_initialise(argc, argv) ) 1272 | throw PlError("failed to initialise"); 1273 | } 1274 | 1275 | PlEngine(char *av0) 1276 | { int ac = 0; 1277 | char **av = static_cast(malloc(sizeof(char *) * 2)); 1278 | 1279 | av[ac++] = av0; 1280 | 1281 | if ( !PL_initialise(1, av) ) 1282 | throw PlError("failed to initialise"); 1283 | } 1284 | 1285 | ~PlEngine() 1286 | { PL_cleanup(0); 1287 | } 1288 | }; 1289 | 1290 | 1291 | /******************************* 1292 | * REGISTER PREDICATES * 1293 | *******************************/ 1294 | 1295 | #ifndef PROLOG_MODULE 1296 | #define PROLOG_MODULE (const char*)NULL 1297 | #endif 1298 | 1299 | #define NAMED_PREDICATE(plname, name, arity) \ 1300 | static foreign_t \ 1301 | pl_ ## name ## __ ## arity(PlTermv PL_av); \ 1302 | static foreign_t \ 1303 | _pl_ ## name ## __ ## arity(term_t t0, int a, control_t c) \ 1304 | { (void)a; (void)c; \ 1305 | try \ 1306 | { \ 1307 | return pl_ ## name ## __ ## arity(PlTermv(arity, t0)); \ 1308 | } catch ( PlException &ex ) \ 1309 | { return ex.plThrow(); \ 1310 | } \ 1311 | } \ 1312 | static PlRegister _x ## name ## __ ## arity(PROLOG_MODULE, plname, arity, \ 1313 | _pl_ ## name ## __ ## arity); \ 1314 | static foreign_t pl_ ## name ## __ ## arity(PlTermv PL_av) 1315 | 1316 | #define NAMED_PREDICATE0(plname, name) \ 1317 | static foreign_t \ 1318 | pl_ ## name ## __0(void); \ 1319 | static foreign_t \ 1320 | _pl_ ## name ## __0(term_t t0, int a, control_t c) \ 1321 | { (void)t0; (void)a; (void)c; \ 1322 | try \ 1323 | { \ 1324 | return pl_ ## name ## __0(); \ 1325 | } catch ( PlException &ex ) \ 1326 | { return ex.plThrow(); \ 1327 | } \ 1328 | } \ 1329 | static PlRegister _x ## name ## __0(PROLOG_MODULE, plname, 0, \ 1330 | _pl_ ## name ## __0); \ 1331 | static foreign_t pl_ ## name ## __0(void) 1332 | 1333 | #define NAMED_PREDICATE_NONDET(plname, name, arity) \ 1334 | static foreign_t \ 1335 | pl_ ## name ## __ ## arity(PlTermv PL_av, control_t handle); \ 1336 | static foreign_t \ 1337 | _pl_ ## name ## __ ## arity(term_t t0, int a, control_t c) \ 1338 | { (void)a; \ 1339 | try \ 1340 | { \ 1341 | return pl_ ## name ## __ ## arity(PlTermv(arity, t0), c); \ 1342 | } catch ( PlException &ex ) \ 1343 | { return ex.plThrow(); \ 1344 | } \ 1345 | } \ 1346 | static PlRegister _x ## name ## __ ## arity(PROLOG_MODULE, plname, arity, \ 1347 | _pl_ ## name ## __ ## arity, \ 1348 | PL_FA_NONDETERMINISTIC | PL_FA_VARARGS); \ 1349 | static foreign_t pl_ ## name ## __ ## arity(PlTermv PL_av, control_t handle) 1350 | 1351 | #define PREDICATE0(name) NAMED_PREDICATE0(#name, name) 1352 | #define PREDICATE(name, arity) NAMED_PREDICATE(#name, name, arity) 1353 | #define PREDICATE_NONDET(name, arity) NAMED_PREDICATE_NONDET(#name, name, arity) 1354 | 1355 | #define PL_A1 PL_av[0] 1356 | #define PL_A2 PL_av[1] 1357 | #define PL_A3 PL_av[2] 1358 | #define PL_A4 PL_av[3] 1359 | #define PL_A5 PL_av[4] 1360 | #define PL_A6 PL_av[5] 1361 | #define PL_A7 PL_av[6] 1362 | #define PL_A8 PL_av[7] 1363 | #define PL_A9 PL_av[8] 1364 | #define PL_A10 PL_av[9] 1365 | 1366 | #ifndef PL_SAFE_ARG_MACROS 1367 | #define A1 PL_A1 1368 | #define A2 PL_A2 1369 | #define A3 PL_A3 1370 | #define A4 PL_A4 1371 | #define A5 PL_A5 1372 | #define A6 PL_A6 1373 | #define A7 PL_A7 1374 | #define A8 PL_A8 1375 | #define A9 PL_A9 1376 | #define A10 PL_A10 1377 | #endif 1378 | 1379 | #endif /*_SWI_CPP_H*/ 1380 | -------------------------------------------------------------------------------- /SWI-cpp2-atommap.h: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Jan Wielemaker and Peter Ludemann 4 | E-mail: J.Wielemaker@vu.nl 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2000-2023, University of Amsterdam 7 | VU University Amsterdam 8 | SWI-Prolog Solutions b.v. 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in 20 | the documentation and/or other materials provided with the 21 | distribution. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | #ifndef _SWI_CPP2_ATOMMAP_H 38 | #define _SWI_CPP2_ATOMMAP_H 39 | 40 | #include 41 | #include 42 | #include 43 | 44 | #include "SWI-cpp2.h" 45 | 46 | 47 | // The AtomMap class is a wrapper around a std::map, mapping alias 48 | // names to blobs. The blobs are of type PlAtom or PlTerm, so this is 49 | // actually an atom->atom or atom->term map. 50 | // The entries are protected by a mutex, so the operations are thread-safe. 51 | // The operations do appropriate calls to register and unregister the atoms/blobs. 52 | // 53 | // When defining an AtomMap, you specify the value type and how it is stored. 54 | // The supported values are: 55 | // PlAtom,PlAtom 56 | // PlTerm,PlRecord 57 | // The API automatically converts between the value and stored value types. 58 | // 59 | // The operations are: 60 | // PlAtom find(PlAtom name) - look up, returning PlAtom::null if not found 61 | // void insert(PlAtom name, PlAtom symbol) - insert, throwing a 62 | // PlPermissionError if it's already there 63 | // void erase(PlAtom name) - remove the entry (no error if it's already been removed) 64 | 65 | 66 | template 67 | class AtomMap 68 | { 69 | public: 70 | explicit AtomMap() = delete; 71 | // On error, the message is something like 72 | // No permission to `' 73 | // using PlPermissionError(insert_op_, insert_type_, key) 74 | explicit AtomMap(const std::string& insert_op, const std::string& insert_type) 75 | : insert_op_(insert_op), insert_type_(insert_type) 76 | { } 77 | AtomMap(const AtomMap&) = delete; 78 | AtomMap(const AtomMap&&) = delete; 79 | AtomMap& operator =(const AtomMap&) = delete; 80 | AtomMap& operator =(const AtomMap&&) = delete; 81 | 82 | ~AtomMap() 83 | { std::scoped_lock lock__(lock_); 84 | auto lookup = entries_.begin(); 85 | while ( lookup != entries_.end() ) 86 | lookup = erase_inside_lock(lookup); 87 | } 88 | 89 | void 90 | insert(PlAtom key, ValueType value) 91 | { std::scoped_lock lock__(lock_); 92 | insert_inside_lock(key, value); 93 | } 94 | 95 | [[nodiscard]] 96 | ValueType 97 | find(PlAtom key) 98 | { std::shared_lock lock__(lock_); 99 | return find_inside_lock(key); 100 | } 101 | 102 | void 103 | erase(PlAtom key) 104 | { std::scoped_lock lock__(lock_); 105 | erase_inside_lock(key); 106 | } 107 | 108 | size_t 109 | size() 110 | { std::shared_lock lock__(lock_); 111 | return size_inside_lock(); 112 | } 113 | 114 | private: 115 | typedef std::map map_t; 116 | 117 | [[nodiscard]] 118 | ValueType 119 | find_inside_lock(PlAtom key) 120 | { const auto lookup = entries_.find(key.unwrap()); 121 | if ( lookup == entries_.end() ) 122 | return ValueType(ValueType::null); 123 | else 124 | return ValueType(lookup->second); 125 | } 126 | 127 | void 128 | insert_inside_lock(PlAtom key, ValueType value) 129 | { const auto lookup = find_inside_lock(key); 130 | if ( lookup.is_null() ) 131 | { StoredValueType stored_value(StoredValueType::null); 132 | register_value(value, &stored_value); 133 | key.register_ref(); 134 | entries_.insert(std::make_pair(key.unwrap(), stored_value)); 135 | } else if ( lookup != value ) 136 | { throw PlPermissionError(insert_op_, insert_type_, PlTerm_atom(key)); 137 | } 138 | } 139 | 140 | void 141 | erase_inside_lock(PlAtom key) 142 | { auto lookup = entries_.find(key.unwrap()); 143 | if ( lookup == entries_.end() ) 144 | return; 145 | // TODO: As an alternative to removing the entry, leave it in place 146 | // (with db==nullptr showing that it's been closed; or with 147 | // the value as PlAtom::null), so that rocks_close/1 can 148 | // distinguish an alias lookup that should throw a 149 | // PlExistenceError because it's never been opened. 150 | erase_inside_lock(lookup); 151 | } 152 | 153 | auto erase_inside_lock(typename map_t::iterator lookup) 154 | { PlAtom(lookup->first).unregister_ref(); 155 | unregister_stored_value(&lookup->second); 156 | return entries_.erase(lookup); 157 | } 158 | 159 | size_t 160 | size_inside_lock() const 161 | { return entries_.size(); 162 | } 163 | 164 | // Implementation for map 165 | 166 | static void 167 | register_value(const PlAtom &value, PlAtom *stored_value) 168 | { *stored_value = value; 169 | stored_value->register_ref(); 170 | } 171 | 172 | static void 173 | unregister_stored_value(PlAtom *stored_value) 174 | { stored_value->unregister_ref(); 175 | } 176 | 177 | // Implementation for map (external: PlAtom,PlTerm>) 178 | 179 | static void 180 | register_value(const PlTerm &value, PlRecord *stored_value) 181 | { *stored_value = value.record(); 182 | } 183 | 184 | static void 185 | unregister_stored_value(PlRecord *stored_value) 186 | { stored_value->erase(); 187 | } 188 | 189 | // Data: mutex + map 190 | 191 | std::shared_mutex lock_; 192 | 193 | // TODO: Define the necessary operators for PlAtom, so that it can be 194 | // the key instead of atom_t. 195 | map_t entries_; 196 | 197 | std::string insert_op_; // for PlPermissionError 198 | std::string insert_type_; // for PlPermissionError 199 | }; 200 | 201 | #endif /*_SWI_CPP2_ATOMMAP_H*/ 202 | -------------------------------------------------------------------------------- /SWI-cpp2-flags.h: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Jan Wielemaker and Peter Ludemann 4 | E-mail: J.Wielemaker@vu.nl 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2024, SWI-Prolog Solutions b.v. 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | #ifndef _SWI_CPP2_FLAGS_H 36 | #define _SWI_CPP2_FLAGS_H 37 | 38 | #include 39 | #include 40 | #include 41 | 42 | #include "SWI-cpp2.h" 43 | 44 | // TODO: add documentation to pl2cpp.doc 45 | 46 | /* WARNING: experimetal code, subject to change 47 | 48 | Class \ctype{PlOptionsFlag} contains utilities for translating between a 49 | list of strings and an flag of bits. The flag is designated as 50 | \ctopy{FlagT}, and typically is \ctype{int} or \ctype{unsigned}. 51 | 52 | \begin{description} 53 | \constructor{PlOptionsFlag}{string domain, vector str2flag} - 54 | \arg{domain} is used for exceptions; \arg{str2flag} maps 55 | strings to flag values. here may be multiple strings that map 56 | to the same flag; the first one is preferred by 57 | PlOptionsFlag::as_string(). 58 | \cfunction{FlagT}{PlOptionsFlag::lookup_list}{PlTerm options, bool throw_not_found} - 59 | process \arg{options}, a list of strings or atoms, into a flag by looking 60 | up each itme and or-ing the flag values. If a lookup fails 61 | and \arg{throw_not_found} is \const{true} (the default), 62 | \ctype{PlDomainError} is thrown. 63 | \cfunction{FlagT}{PlOptionsFlag::lookup}{PlTerm e, bool throw_not_found}- 64 | process a single \arg{option}, returning its flag value. 65 | If a lookup fails 66 | and \arg{throw_not_found} is \const{true} (the default), 67 | \ctype{PlDomainError} is thrown, otherwise 0 is returned. 68 | \cfunction{string}PlOptionsFlag::as_string}{FlagT flags} - 69 | Return a string containing a comma-separated list of 70 | the preferred strings corresponding to the bits in \arg{flags}. 71 | If a bit value is found, "???" is added to the list 72 | TODO: with C++-20, std::format("{:x}") 73 | \end{description} 74 | 75 | */ 76 | 77 | template 78 | class PlOptionsFlag { 79 | public: 80 | explicit PlOptionsFlag() = delete; 81 | explicit PlOptionsFlag(const std::string& domain, 82 | const std::vector>& str2flag) 83 | : domain_(domain), 84 | str2flag_v_(str2flag) 85 | { for ( auto const& sf : str2flag ) 86 | { str2flag_[sf.first] = sf.second; 87 | } 88 | } 89 | 90 | FlagT lookup_list(PlTerm options, bool throw_not_found = true) const 91 | { PlTerm_tail tail(options); 92 | PlTerm_var e; 93 | FlagT flags = 0; 94 | while (tail.next(e)) 95 | { flags |= lookup(e, throw_not_found); 96 | } 97 | PlCheckFail(tail.unify_nil()); 98 | return flags; 99 | } 100 | 101 | FlagT lookup(PlTerm option, bool throw_not_found = true) const 102 | { option.must_be_atom_or_string(); 103 | auto const f = str2flag_.find(option.as_string()); 104 | if ( f != str2flag_.end() ) 105 | return f->second; 106 | if ( throw_not_found ) 107 | throw PlDomainError(domain_, option); 108 | return 0; 109 | } 110 | 111 | std::string as_string(FlagT flags) const 112 | { std::string result; 113 | for ( auto const& f : str2flag_v_ ) 114 | { if ( (flags & f.second) == f.second ) 115 | { result += "," + f.first; 116 | flags &= ~f.second; 117 | } 118 | } 119 | if ( flags != 0 ) 120 | result += ",???"; // TODO (C++-20): std::format("{:x}", flags) 121 | return result.empty() ? result : result.substr(1); 122 | } 123 | 124 | private: 125 | std::string domain_; 126 | std::map str2flag_; 127 | std::vector> str2flag_v_; 128 | }; 129 | 130 | #endif /*_SWI_CPP2_FLAGS_H*/ 131 | -------------------------------------------------------------------------------- /SWI-cpp2-plx.h: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Jan Wielemaker and Peter Ludemann 4 | E-mail: J.Wielemaker@vu.nl 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2000-2023, University of Amsterdam 7 | VU University Amsterdam 8 | SWI-Prolog Solutions b.v. 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in 20 | the documentation and/or other materials provided with the 21 | distribution. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | // This file was derived from WUNUSED is changed to 38 | // [[nodiscard]], and added to some functions that don't have WUNUSEd 39 | // (possibly WUNUSED should be added for them in SWI-Prolog.h). 40 | 41 | // Commented out lines are because: 42 | // - no return value 43 | // - return value 0 doesn't mean "fail" 44 | // - private 45 | // - has "..." or similar that requires a bit more work. 46 | // In addition, some functions that return a boolean as an "int" have 47 | // been changed to use a C++ "bool" (the template functions PlWrap() 48 | // and PlEx() have been written to handle this situations). 49 | 50 | // This file is included by SWI-cpp2.h -- it is kept separate because 51 | // it is derived from SWI-Prolog.h 52 | 53 | #ifndef _SWI_CPP2_PLX_H 54 | #define _SWI_CPP2_PLX_H 55 | 56 | #if PLVERSION >= 90311 57 | #define PLX_BOOL bool 58 | #else 59 | // for the "stable" release that still has int's in SWI-Prolog.h: 60 | #define PLX_BOOL int 61 | #endif 62 | 63 | /* Wrapper macros - each PL_*() function has a corresponding Plx_*() wrapper: 64 | PLX_EXCE is for functions whose return code only indicates an error; this error 65 | is turned into a "throw". 66 | PLX_WRAP is for functions whose return code could mean either an error or failure 67 | PLX_ASIS and PLX_VOID are for functions that are used as-is 68 | */ 69 | 70 | // TODO: remove PlWrapDebug() when global ordering bug is fixed 71 | // https://github.com/SWI-Prolog/swipl-devel/issues/1155 72 | 73 | #ifdef O_DEBUG 74 | void PlWrapDebug(const char*); 75 | #else 76 | #define PlWrapDebug(m) 77 | #endif 78 | 79 | #define PLX_EXCE(type, name, params, args) inline void Plx_ ## name params { PlWrapDebug("EXCE-" #name); PlEx(PL_ ## name args); } 80 | 81 | #define PLX_WRAP(type, name, params, args) [[nodiscard]] inline type Plx_ ## name params { PlWrapDebug("WRAP-" #name); return PlWrap(PL_ ## name args); } 82 | 83 | #define PLX_ASIS(type, name, params, args) [[nodiscard]] inline type Plx_ ## name params { PlWrapDebug("ASIS-"#name); return PL_ ## name args; } 84 | #define PLX_VOID(type, name, params, args) inline void Plx_ ## name params { PlWrapDebug("VOID-" #name); PL_ ## name args; } 85 | 86 | PLX_ASIS(int , foreign_control , (control_t c), (c)) 87 | PLX_ASIS(intptr_t , foreign_context , (control_t c), (c)) 88 | PLX_ASIS(void * , foreign_context_address , (control_t c), (c)) 89 | PLX_ASIS(predicate_t , foreign_context_predicate , (control_t c), (c)) 90 | 91 | PLX_VOID(void , register_extensions , (const PL_extension *e), (e)) 92 | PLX_VOID(void , register_extensions_in_module , (const char *module, const PL_extension *e), (module, e)) 93 | 94 | // (skipped):: int PL_register_foreign(const char *name, int arity, pl_function_t func, int flags, ...); 95 | // (skipped):: int PL_register_foreign_in_module( const char *module , const char *name, int arity, pl_function_t func, int flags, ...); 96 | 97 | // Deprecated: PL_load_extensions(const PL_extension *e); 98 | 99 | // TODO: document PL_license() 100 | PLX_VOID(void , license , (const char *license, const char *module), (license, module)) 101 | 102 | PLX_ASIS(module_t , context , (), ()) 103 | PLX_ASIS(atom_t , module_name , (module_t module), (module)) 104 | PLX_WRAP(module_t , new_module , (atom_t name), (name)) 105 | PLX_EXCE(PLX_BOOL , strip_module , (term_t in, module_t *m, term_t out), (in, m, out)) 106 | PLX_WRAP(fid_t , open_foreign_frame , (), ()) 107 | 108 | PLX_VOID(void , rewind_foreign_frame , (fid_t cid), (cid)) 109 | PLX_VOID(void , close_foreign_frame , (fid_t cid), (cid)) 110 | PLX_VOID(void , discard_foreign_frame , (fid_t cid), (cid)) 111 | 112 | PLX_WRAP(predicate_t , pred , (functor_t f, module_t m), (f, m)) 113 | PLX_WRAP(predicate_t , predicate , (const char *name, int arity, const char* module), (name, arity, module)) 114 | PLX_EXCE(PLX_BOOL , predicate_info , (predicate_t pred, atom_t *name, size_t *arity, module_t *module), (pred, name, arity, module)) 115 | PLX_WRAP(qid_t , open_query , (module_t m, int flags, predicate_t pred, term_t t0), (m, flags, pred, t0)) 116 | // TODO: PL_next_solution() needs special handling: 117 | // [[nodiscard]] int PL_next_solution(qid_t qid); 118 | PLX_EXCE(int , close_query , (qid_t qid), (qid)) 119 | PLX_EXCE(int , cut_query , (qid_t qid), (qid)) 120 | PLX_ASIS(qid_t , current_query , (), ()) 121 | PLX_ASIS(PL_engine_t , query_engine , (qid_t qid), (qid)) 122 | PLX_ASIS(PLX_BOOL , can_yield , (), ()) 123 | // [[nodiscard]] 124 | PLX_WRAP(PLX_BOOL , call , (term_t t, module_t m), (t, m)) 125 | // TODO: Needs special case - see PL_next_solution(): 126 | // [[nodiscard]] int PL_call_predicate(module_t m, int debug, predicate_t pred, term_t t0); 127 | PLX_ASIS(term_t , exception , (qid_t qid), (qid)) 128 | PLX_ASIS(PLX_BOOL , raise_exception , (term_t exception), (exception)) 129 | // Deprecated: int PL_throw(term_t exception); 130 | PLX_VOID(void , clear_exception , (), ()) 131 | // TODO: document PL_yielded() 132 | PLX_ASIS(term_t , yielded , (qid_t qid), (qid)) 133 | PLX_EXCE(PLX_BOOL , assert , (term_t term, module_t m, int flags), (term, m, flags)) 134 | PLX_WRAP(term_t , new_term_refs , (size_t n), (n)) 135 | PLX_WRAP(term_t , new_term_ref , (), ()) 136 | PLX_WRAP(term_t , copy_term_ref , (term_t from), (from)) 137 | PLX_VOID(void , free_term_ref , (term_t t), (t)) 138 | PLX_VOID(void , reset_term_refs , (term_t r), (r)) 139 | /* [[deprecated]] */ 140 | PLX_WRAP(atom_t , new_atom , (const char *s), (s)) 141 | 142 | PLX_WRAP(atom_t , new_atom_nchars , (size_t len, const char *s), (len, s)) 143 | PLX_WRAP(atom_t , new_atom_wchars , (size_t len, const pl_wchar_t *s), (len, s)) 144 | PLX_WRAP(atom_t , new_atom_mbchars , (int rep, size_t len, const char *s), (rep, len, s)) 145 | // Deprecated: const char *PL_atom_chars(atom_t a); 146 | PLX_WRAP(const char * , atom_nchars , (atom_t a, size_t *len), (a, len)) 147 | PLX_EXCE(PLX_BOOL , atom_mbchars , (atom_t a, size_t *len, char **s, unsigned int flags), (a, len, s, flags)) 148 | PLX_WRAP(const wchar_t * , atom_wchars , (atom_t a, size_t *len), (a, len)) 149 | PLX_VOID(void , register_atom , (atom_t a), (a)) 150 | PLX_VOID(void , unregister_atom , (atom_t a), (a)) 151 | // (skipped):: void _PL_debug_register_atom(atom_t a, const char *file, int line, const char *func); 152 | // (skipped):: void _PL_debug_unregister_atom(atom_t a, const char *file, int line, const char *func); 153 | 154 | PLX_WRAP(functor_t , new_functor , (atom_t f, size_t a), (f, a)) 155 | PLX_ASIS(atom_t , functor_name , (functor_t f), (f)) 156 | PLX_ASIS(size_t , functor_arity , (functor_t f), (f)) 157 | [[nodiscard]] 158 | PLX_ASIS(PLX_BOOL , get_atom , (term_t t, atom_t *a), (t, a)) 159 | [[nodiscard]] 160 | PLX_ASIS(PLX_BOOL , get_bool , (term_t t, int *value), (t, value)) 161 | [[nodiscard]] 162 | PLX_ASIS(PLX_BOOL , get_atom_chars , (term_t t, char **a), (t, a)) 163 | [[nodiscard]] 164 | // Deprecated: int PL_get_string(term_t t, char **s, size_t *len); 165 | [[nodiscard]] 166 | PLX_ASIS(PLX_BOOL , get_chars , (term_t t, char **s, unsigned int flags), (t, s, flags)) 167 | [[nodiscard]] 168 | PLX_ASIS(PLX_BOOL , get_list_chars , (term_t l, char **s, unsigned int flags), (l, s, flags)) 169 | [[nodiscard]] 170 | PLX_ASIS(PLX_BOOL , get_atom_nchars , (term_t t, size_t *len, char **a), (t, len, a)) 171 | [[nodiscard]] 172 | PLX_ASIS(PLX_BOOL , get_list_nchars , (term_t l, size_t *len, char **s, unsigned int flags), (l, len, s, flags)) 173 | [[nodiscard]] 174 | PLX_ASIS(PLX_BOOL , get_nchars , (term_t t, size_t *len, char **s, unsigned int flags), (t, len, s, flags)) 175 | [[nodiscard]] 176 | PLX_ASIS(PLX_BOOL , get_integer , (term_t t, int *i), (t, i)) 177 | [[nodiscard]] 178 | PLX_ASIS(PLX_BOOL , get_long , (term_t t, long *i), (t, i)) 179 | [[nodiscard]] 180 | PLX_ASIS(PLX_BOOL , get_intptr , (term_t t, intptr_t *i), (t, i)) 181 | [[nodiscard]] 182 | PLX_ASIS(PLX_BOOL , get_pointer , (term_t t, void **ptr), (t, ptr)) 183 | [[nodiscard]] 184 | PLX_ASIS(PLX_BOOL , get_float , (term_t t, double *f), (t, f)) 185 | [[nodiscard]] 186 | PLX_ASIS(PLX_BOOL , get_functor , (term_t t, functor_t *f), (t, f)) 187 | [[nodiscard]] 188 | PLX_ASIS(PLX_BOOL , get_name_arity , (term_t t, atom_t *name, size_t *arity), (t, name, arity)) 189 | [[nodiscard]] 190 | PLX_ASIS(PLX_BOOL , get_compound_name_arity , (term_t t, atom_t *name, size_t *arity), (t, name, arity)) 191 | [[nodiscard]] 192 | PLX_ASIS(PLX_BOOL , get_module , (term_t t, module_t *module), (t, module)) 193 | [[nodiscard]] 194 | PLX_ASIS(PLX_BOOL , get_arg , (size_t index, term_t t, term_t a), (index, t, a)) 195 | [[nodiscard]] 196 | PLX_ASIS(PLX_BOOL , get_dict_key , (atom_t key, term_t dict, term_t value), (key, dict, value)) 197 | [[nodiscard]] 198 | PLX_ASIS(PLX_BOOL , get_list , (term_t l, term_t h, term_t t), (l, h, t)) 199 | [[nodiscard]] 200 | PLX_ASIS(PLX_BOOL , get_head , (term_t l, term_t h), (l, h)) 201 | [[nodiscard]] 202 | PLX_ASIS(PLX_BOOL , get_tail , (term_t l, term_t t), (l, t)) 203 | [[nodiscard]] 204 | PLX_ASIS(PLX_BOOL , get_nil , (term_t l), (l)) 205 | [[nodiscard]] 206 | [[deprecated]] 207 | PLX_ASIS(int , get_term_value , (term_t t, term_value_t *v), (t, v)) 208 | PLX_ASIS(char * , quote , (int chr, const char *data), (chr, data)) 209 | // See the definition of PL_for_dict - return code determined by func: 210 | PLX_ASIS(int , for_dict , (term_t dict, 211 | int (*func)(term_t key, term_t value, void *closure), 212 | void *closure, int flags), 213 | (dict, func, closure, flags)) 214 | PLX_ASIS(int , term_type , (term_t t), (t)) 215 | PLX_ASIS(PLX_BOOL , is_variable , (term_t t), (t)) 216 | PLX_ASIS(PLX_BOOL , is_ground , (term_t t), (t)) 217 | PLX_ASIS(PLX_BOOL , is_atom , (term_t t), (t)) 218 | PLX_ASIS(PLX_BOOL , is_integer , (term_t t), (t)) 219 | PLX_ASIS(PLX_BOOL , is_string , (term_t t), (t)) 220 | PLX_ASIS(PLX_BOOL , is_float , (term_t t), (t)) 221 | PLX_ASIS(PLX_BOOL , is_rational , (term_t t), (t)) 222 | PLX_ASIS(PLX_BOOL , is_compound , (term_t t), (t)) 223 | PLX_ASIS(PLX_BOOL , is_callable , (term_t t), (t)) 224 | PLX_ASIS(PLX_BOOL , is_functor , (term_t t, functor_t f), (t, f)) 225 | PLX_ASIS(PLX_BOOL , is_list , (term_t t), (t)) 226 | PLX_ASIS(PLX_BOOL , is_dict , (term_t t), (t)) 227 | PLX_ASIS(PLX_BOOL , is_pair , (term_t t), (t)) 228 | PLX_ASIS(PLX_BOOL , is_atomic , (term_t t), (t)) 229 | PLX_ASIS(PLX_BOOL , is_number , (term_t t), (t)) 230 | PLX_ASIS(PLX_BOOL , is_acyclic , (term_t t), (t)) 231 | // TODO: put_variable, put_atom, put_bool, put_atom_char, put_int64, etc. always return true? 232 | PLX_EXCE(PLX_BOOL , put_variable , (term_t t), (t)) 233 | PLX_EXCE(PLX_BOOL , put_atom , (term_t t, atom_t a), (t, a)) 234 | PLX_EXCE(PLX_BOOL , put_bool , (term_t t, int val), (t, val)) 235 | PLX_EXCE(PLX_BOOL , put_atom_chars , (term_t t, const char *chars), (t, chars)) 236 | PLX_EXCE(PLX_BOOL , put_string_chars , (term_t t, const char *chars), (t, chars)) 237 | PLX_EXCE(PLX_BOOL , put_chars , (term_t t, int flags, size_t len, const char *chars), (t, flags, len, chars)) 238 | PLX_EXCE(PLX_BOOL , put_list_chars , (term_t t, const char *chars), (t, chars)) 239 | PLX_EXCE(PLX_BOOL , put_list_codes , (term_t t, const char *chars), (t, chars)) 240 | PLX_EXCE(PLX_BOOL , put_atom_nchars , (term_t t, size_t l, const char *chars), (t, l, chars)) 241 | PLX_EXCE(PLX_BOOL , put_string_nchars , (term_t t, size_t len, const char *chars), (t, len, chars)) 242 | PLX_EXCE(PLX_BOOL , put_list_nchars , (term_t t, size_t l, const char *chars), (t, l, chars)) 243 | PLX_EXCE(PLX_BOOL , put_list_ncodes , (term_t t, size_t l, const char *chars), (t, l, chars)) 244 | PLX_EXCE(PLX_BOOL , put_integer , (term_t t, long i), (t, i)) 245 | PLX_EXCE(PLX_BOOL , put_pointer , (term_t t, void *ptr), (t, ptr)) 246 | PLX_EXCE(PLX_BOOL , put_float , (term_t t, double f), (t, f)) 247 | PLX_EXCE(PLX_BOOL , put_functor , (term_t t, functor_t functor), (t, functor)) 248 | PLX_EXCE(PLX_BOOL , put_list , (term_t l), (l)) 249 | PLX_EXCE(PLX_BOOL , put_nil , (term_t l), (l)) 250 | PLX_EXCE(PLX_BOOL , put_term , (term_t t1, term_t t2), (t1, t2)) 251 | PLX_EXCE(int , put_dict , (term_t t, atom_t tag, size_t len, const atom_t *keys, term_t values), (t, tag, len, keys, values)) 252 | // TODO: 253 | // PL_EXPORT(atom_t) _PL_cons_small_int(int64_t v); // 0 return code means not a small int 254 | // PL_EXPORT(void) _PL_unregister_keys(size_t len, atom_t *keys); 255 | // (skipped):: int PL_cons_functor(term_t h, functor_t f, ...) WUNUSED; 256 | PLX_EXCE(PLX_BOOL , cons_functor_v , (term_t h, functor_t fd, term_t a0), (h, fd, a0)) 257 | PLX_EXCE(PLX_BOOL , cons_list , (term_t l, term_t h, term_t t), (l, h, t)) 258 | 259 | // [[nodiscard]] 260 | PLX_WRAP(PLX_BOOL , unify , (term_t t1, term_t t2), (t1, t2)) 261 | // [[nodiscard]] 262 | PLX_WRAP(PLX_BOOL , unify_atom , (term_t t, atom_t a), (t, a)) 263 | // [[nodiscard]] 264 | PLX_WRAP(PLX_BOOL , unify_atom_chars , (term_t t, const char *chars), (t, chars)) 265 | // [[nodiscard]] 266 | PLX_WRAP(PLX_BOOL , unify_list_chars , (term_t t, const char *chars), (t, chars)) 267 | // [[nodiscard]] 268 | PLX_WRAP(PLX_BOOL , unify_list_codes , (term_t t, const char *chars), (t, chars)) 269 | // [[nodiscard]] 270 | PLX_WRAP(PLX_BOOL , unify_string_chars , (term_t t, const char *chars), (t, chars)) 271 | // [[nodiscard]] 272 | PLX_WRAP(PLX_BOOL , unify_atom_nchars , (term_t t, size_t l, const char *s), (t, l, s)) 273 | // [[nodiscard]] 274 | PLX_WRAP(PLX_BOOL , unify_list_ncodes , (term_t t, size_t l, const char *s), (t, l, s)) 275 | // [[nodiscard]] 276 | PLX_WRAP(PLX_BOOL , unify_list_nchars , (term_t t, size_t l, const char *s), (t, l, s)) 277 | // [[nodiscard]] 278 | PLX_WRAP(PLX_BOOL , unify_string_nchars , (term_t t, size_t len, const char *chars), (t, len, chars)) 279 | // [[nodiscard]] 280 | PLX_WRAP(PLX_BOOL , unify_bool , (term_t t, int n), (t, n)) 281 | // [[nodiscard]] 282 | PLX_WRAP(PLX_BOOL , unify_integer , (term_t t, intptr_t n), (t, n)) 283 | // [[nodiscard]] 284 | PLX_WRAP(PLX_BOOL , unify_float , (term_t t, double f), (t, f)) 285 | // [[nodiscard]] 286 | PLX_WRAP(PLX_BOOL , unify_pointer , (term_t t, void *ptr), (t, ptr)) 287 | // [[nodiscard]] 288 | PLX_WRAP(PLX_BOOL , unify_functor , (term_t t, functor_t f), (t, f)) 289 | // [[nodiscard]] 290 | PLX_WRAP(PLX_BOOL , unify_compound , (term_t t, functor_t f), (t, f)) 291 | // [[nodiscard]] 292 | PLX_WRAP(PLX_BOOL , unify_list , (term_t l, term_t h, term_t t), (l, h, t)) 293 | // [[nodiscard]] 294 | PLX_WRAP(PLX_BOOL , unify_nil , (term_t l), (l)) 295 | // [[nodiscard]] 296 | PLX_WRAP(PLX_BOOL , unify_arg , (size_t index, term_t t, term_t a), (index, t, a)) 297 | // (skipped):: // [[nodiscard]] bool PL_unify_term(term_t t, ...) 298 | // [[nodiscard]] 299 | PLX_WRAP(PLX_BOOL , unify_chars , (term_t t, int flags, size_t len, const char *s), (t, flags, len, s)) 300 | 301 | // [[nodiscard]] 302 | PLX_ASIS(int , skip_list , (term_t list, term_t tail, size_t *len), (list, tail, len)) 303 | // [[nodiscard]] 304 | PLX_WRAP(PLX_BOOL , unify_wchars , (term_t t, int type, size_t len, const pl_wchar_t *s), (t, type, len, s)) 305 | // [[nodiscard]] 306 | PLX_WRAP(PLX_BOOL , unify_wchars_diff , (term_t t, term_t tail, int type, size_t len, const pl_wchar_t *s), (t, tail, type, len, s)) 307 | 308 | // [[nodiscard]] 309 | PLX_ASIS(PLX_BOOL , get_wchars , (term_t l, size_t *length, pl_wchar_t **s, unsigned flags), (l, length, s, flags)) 310 | // TODO: document PL_utf8_strlen 311 | // [[nodiscard]] 312 | PLX_ASIS(size_t , utf8_strlen , (const char *s, size_t len), (s, len)) 313 | // [[nodiscard]] 314 | PLX_ASIS(PLX_BOOL , get_int64 , (term_t t, int64_t *i), (t, i)) 315 | // [[nodiscard]] 316 | PLX_ASIS(PLX_BOOL , get_uint64 , (term_t t, uint64_t *i), (t, i)) 317 | // [[nodiscard]] 318 | PLX_WRAP(PLX_BOOL , unify_int64 , (term_t t, int64_t value), (t, value)) 319 | // [[nodiscard]] 320 | PLX_WRAP(PLX_BOOL , unify_uint64 , (term_t t, uint64_t value), (t, value)) 321 | // [[nodiscard]] 322 | PLX_EXCE(PLX_BOOL , put_int64 , (term_t t, int64_t i), (t, i)) 323 | // [[nodiscard]] 324 | PLX_EXCE(PLX_BOOL , put_uint64 , (term_t t, uint64_t i), (t, i)) 325 | PLX_ASIS(PLX_BOOL , is_attvar , (term_t t), (t)) 326 | PLX_WRAP(PLX_BOOL , get_attr , (term_t v, term_t a), (v, a)) 327 | PLX_WRAP(PLX_BOOL , get_delay_list , (term_t l), (l)) 328 | PLX_EXCE(PLX_BOOL , get_atom_ex , (term_t t, atom_t *a), (t, a)) 329 | PLX_EXCE(PLX_BOOL , get_integer_ex , (term_t t, int *i), (t, i)) 330 | PLX_EXCE(PLX_BOOL , get_long_ex , (term_t t, long *i), (t, i)) 331 | PLX_EXCE(PLX_BOOL , get_int64_ex , (term_t t, int64_t *i), (t, i)) 332 | PLX_EXCE(PLX_BOOL , get_uint64_ex , (term_t t, uint64_t *i), (t, i)) 333 | PLX_EXCE(PLX_BOOL , get_intptr_ex , (term_t t, intptr_t *i), (t, i)) 334 | PLX_EXCE(PLX_BOOL , get_size_ex , (term_t t, size_t *i), (t, i)) 335 | PLX_EXCE(PLX_BOOL , get_bool_ex , (term_t t, int *i), (t, i)) 336 | PLX_EXCE(PLX_BOOL , get_float_ex , (term_t t, double *f), (t, f)) 337 | PLX_EXCE(PLX_BOOL , get_char_ex , (term_t t, int *p, int eof), (t, p, eof)) 338 | PLX_EXCE(PLX_BOOL , unify_bool_ex , (term_t t, int val), (t, val)) 339 | PLX_EXCE(PLX_BOOL , get_pointer_ex , (term_t t, void **addrp), (t, addrp)) 340 | PLX_WRAP(PLX_BOOL , unify_list_ex , (term_t l, term_t h, term_t t), (l, h, t)) 341 | PLX_EXCE(PLX_BOOL , unify_nil_ex , (term_t l), (l)) 342 | PLX_WRAP(PLX_BOOL , get_list_ex , (term_t l, term_t h, term_t t), (l, h, t)) 343 | PLX_EXCE(PLX_BOOL , get_nil_ex , (term_t l), (l)) 344 | 345 | PLX_ASIS(PLX_BOOL , instantiation_error , (term_t culprit), (culprit)) 346 | PLX_ASIS(PLX_BOOL , uninstantiation_error , (term_t culprit), (culprit)) 347 | PLX_ASIS(PLX_BOOL , representation_error , (const char *resource), (resource)) 348 | PLX_ASIS(PLX_BOOL , type_error , (const char *expected, term_t culprit), (expected, culprit)) 349 | PLX_ASIS(PLX_BOOL , domain_error , (const char *expected, term_t culprit), (expected, culprit)) 350 | PLX_ASIS(PLX_BOOL , existence_error , (const char *type, term_t culprit), (type, culprit)) 351 | PLX_ASIS(PLX_BOOL , permission_error , (const char *operation, const char *type, term_t culprit), (operation, type, culprit)) 352 | PLX_ASIS(PLX_BOOL , resource_error , (const char *resource), (resource)) 353 | PLX_ASIS(PLX_BOOL , syntax_error , (const char *msg, IOSTREAM *in), (msg, in)) 354 | 355 | PLX_ASIS(PLX_BOOL , is_blob , (term_t t, PL_blob_t **type), (t, type)) 356 | PLX_WRAP(PLX_BOOL , unify_blob , (term_t t, void *blob, size_t len, PL_blob_t *type), (t, blob, len, type)) 357 | PLX_WRAP(atom_t , new_blob , (void *blob, size_t len, PL_blob_t *type), (blob, len, type)) 358 | PLX_EXCE(PLX_BOOL , put_blob , (term_t t, void *blob, size_t len, PL_blob_t *type), (t, blob, len, type)) 359 | PLX_WRAP(PLX_BOOL , get_blob , (term_t t, void **blob, size_t *len, PL_blob_t **type), (t, blob, len, type)) 360 | PLX_ASIS(void* , blob_data , (atom_t a, size_t *len, struct PL_blob_t **type), (a, len, type)) 361 | PLX_ASIS(PLX_BOOL , free_blob , (atom_t blob), (blob)) 362 | // Should not call PL_register_blob_type, so it's not defined: 363 | // PLX_VOID(void , register_blob_type , (PL_blob_t *type), (type)) 364 | PLX_ASIS(PL_blob_t* , find_blob_type , (const char* name), (name)) 365 | PLX_ASIS(PLX_BOOL , unregister_blob_type , (PL_blob_t *type), (type)) 366 | 367 | #ifdef __GNU_MP__ 368 | [[nodiscard]] 369 | PLX_WRAP(PLX_BOOL , get_mpz , (term_t t, mpz_t mpz), (t, mpz)) 370 | [[nodiscard]] 371 | PLX_WRAP(PLX_BOOL , get_mpq , (term_t t, mpq_t mpq), (t, mpq)) 372 | [[nodiscard]] 373 | PLX_WRAP(PLX_BOOL , unify_mpz , (term_t t, mpz_t mpz), (t, mpz)) 374 | [[nodiscard]] 375 | PLX_WRAP(PLX_BOOL , unify_mpq , (term_t t, mpq_t mpq), (t, mpq)) 376 | #endif 377 | 378 | // PL_get_file_name(), PL_get_file_nameW() exception is controlled by PL_FILE_NOERRORS 379 | PLX_ASIS(PLX_BOOL , get_file_name , (term_t n, char **name, int flags), (n, name, flags)) 380 | PLX_ASIS(PLX_BOOL , get_file_nameW , (term_t n, wchar_t **name, int flags), (n, name, flags)) 381 | // TODO: document PL_changed_cwd() 382 | PLX_VOID(void , changed_cwd , (), ()) 383 | // TODO: document PL_cwd() 384 | PLX_ASIS(char * , cwd , (char *buf, size_t buflen), (buf, buflen)) 385 | 386 | PLX_EXCE(PLX_BOOL , cvt_i_bool , (term_t p, int *c), (p, c)) 387 | PLX_EXCE(PLX_BOOL , cvt_i_char , (term_t p, char *c), (p, c)) 388 | PLX_EXCE(PLX_BOOL , cvt_i_schar , (term_t p, signed char *c), (p, c)) 389 | PLX_EXCE(PLX_BOOL , cvt_i_uchar , (term_t p, unsigned char *c), (p, c)) 390 | PLX_EXCE(PLX_BOOL , cvt_i_short , (term_t p, short *s), (p, s)) 391 | PLX_EXCE(PLX_BOOL , cvt_i_ushort , (term_t p, unsigned short *s), (p, s)) 392 | PLX_EXCE(PLX_BOOL , cvt_i_int , (term_t p, int *c), (p, c)) 393 | PLX_EXCE(PLX_BOOL , cvt_i_uint , (term_t p, unsigned int *c), (p, c)) 394 | PLX_EXCE(PLX_BOOL , cvt_i_long , (term_t p, long *c), (p, c)) 395 | PLX_EXCE(PLX_BOOL , cvt_i_ulong , (term_t p, unsigned long *c), (p, c)) 396 | PLX_EXCE(PLX_BOOL , cvt_i_llong , (term_t p, long long *c), (p, c)) 397 | PLX_EXCE(PLX_BOOL , cvt_i_ullong , (term_t p, unsigned long long *c), (p, c)) 398 | PLX_EXCE(PLX_BOOL , cvt_i_int32 , (term_t p, int32_t *c), (p, c)) 399 | PLX_EXCE(PLX_BOOL , cvt_i_uint32 , (term_t p, uint32_t *c), (p, c)) 400 | PLX_EXCE(PLX_BOOL , cvt_i_int64 , (term_t p, int64_t *c), (p, c)) 401 | PLX_EXCE(PLX_BOOL , cvt_i_uint64 , (term_t p, uint64_t *c), (p, c)) 402 | PLX_EXCE(PLX_BOOL , cvt_i_size_t , (term_t p, size_t *c), (p, c)) 403 | PLX_EXCE(PLX_BOOL , cvt_i_float , (term_t p, double *c), (p, c)) 404 | PLX_EXCE(PLX_BOOL , cvt_i_single , (term_t p, float *c), (p, c)) 405 | PLX_EXCE(PLX_BOOL , cvt_i_string , (term_t p, char **c), (p, c)) 406 | PLX_EXCE(PLX_BOOL , cvt_i_codes , (term_t p, char **c), (p, c)) 407 | PLX_EXCE(PLX_BOOL , cvt_i_atom , (term_t p, atom_t *c), (p, c)) 408 | PLX_EXCE(PLX_BOOL , cvt_i_address , (term_t p, void *c), (p, c)) 409 | PLX_EXCE(PLX_BOOL , cvt_o_int64 , (int64_t c, term_t p), (c, p)) 410 | PLX_EXCE(PLX_BOOL , cvt_o_float , (double c, term_t p), (c, p)) 411 | PLX_EXCE(PLX_BOOL , cvt_o_single , (float c, term_t p), (c, p)) 412 | PLX_EXCE(PLX_BOOL , cvt_o_string , (const char *c, term_t p), (c, p)) 413 | PLX_EXCE(PLX_BOOL , cvt_o_codes , (const char *c, term_t p), (c, p)) 414 | PLX_EXCE(PLX_BOOL , cvt_o_atom , (atom_t c, term_t p), (c, p)) 415 | PLX_EXCE(PLX_BOOL , cvt_o_address , (void *address, term_t p), (address, p)) 416 | 417 | PLX_WRAP(term_t , new_nil_ref , (), ()) 418 | PLX_ASIS(PLX_BOOL , cvt_encoding , (), ()) 419 | PLX_ASIS(PLX_BOOL , cvt_set_encoding , (int enc), (enc)) 420 | // (skipped):: void SP_set_state(int state); 421 | // (skipped):: int SP_get_state(); 422 | PLX_ASIS(int , compare , (term_t t1, term_t t2), (t1, t2)) 423 | PLX_ASIS(PLX_BOOL , same_compound , (term_t t1, term_t t2), (t1, t2)) 424 | // (skipped):: int PL_warning(const char *fmt , ...) WPRINTF12; 425 | // (skipped):: int PL_warningX(const char *fmt , ...); 426 | // (skipped):: void PL_fatal_error(const char *fmt , ...) WPRINTF12; 427 | // (skipped):: void PL_api_error(const char *fmt, ...) WPRINTF12; 428 | // (skipped):: void PL_system_error(const char *fmt, ...) WPRINTF12; 429 | 430 | PLX_WRAP(record_t , record , (term_t term), (term)) 431 | PLX_EXCE(PLX_BOOL , recorded , (record_t record, term_t term), (record, term)) 432 | PLX_VOID(void , erase , (record_t record), (record)) 433 | PLX_WRAP(record_t , duplicate_record , (record_t r), (r)) 434 | PLX_WRAP(char * , record_external , (term_t t, size_t *size), (t, size)) 435 | PLX_EXCE(PLX_BOOL , recorded_external , (const char *rec, term_t term), (rec, term)) 436 | PLX_EXCE(PLX_BOOL , erase_external , (char *rec), (rec)) 437 | // (skipped):: bool PL_set_prolog_flag(const char *name, int type, ...); 438 | // (skipped):: PL_atomic_t _PL_get_atomic(term_t t); 439 | // (skipped):: void _PL_put_atomic(term_t t, PL_atomic_t a); 440 | // (skipped):: bool _PL_unify_atomic(term_t t, PL_atomic_t a); 441 | // (skipped):: bool _PL_get_arg_sz(size_t index, term_t t, term_t a); 442 | // (skipped):: bool _PL_get_arg(int index, term_t t, term_t a); 443 | PLX_VOID(void , mark_string_buffers , (buf_mark_t *mark), (mark)) 444 | PLX_VOID(void , release_string_buffers_from_mark, (buf_mark_t mark), (mark)) 445 | PLX_WRAP(PLX_BOOL , unify_stream , (term_t t, IOSTREAM *s), (t, s)) 446 | // TODO: document PL_get_stream_handle 447 | PLX_EXCE(PLX_BOOL , get_stream_handle , (term_t t, IOSTREAM **s), (t, s)) 448 | PLX_EXCE(PLX_BOOL , get_stream , (term_t t, IOSTREAM **s, int flags), (t, s, flags)) 449 | PLX_EXCE(PLX_BOOL , get_stream_from_blob , (atom_t a, IOSTREAM**s, int flags), (a, s, flags)) 450 | PLX_WRAP(IOSTREAM* , acquire_stream , (IOSTREAM *s), (s)) 451 | PLX_EXCE(PLX_BOOL , release_stream , (IOSTREAM *s), (s)) 452 | // TODO: document PL_release_stream_noerror() 453 | PLX_WRAP(PLX_BOOL , release_stream_noerror , (IOSTREAM *s), (s)) 454 | // TODO: document PL_open_resource() 455 | PLX_WRAP(IOSTREAM * , open_resource , (module_t m, const char *name, const char *rc_class, const char *mode), (m, name, rc_class, mode)) 456 | 457 | // (skipped):: IOSTREAM **_PL_streams(void); /* base of streams */ 458 | PLX_ASIS(PLX_BOOL , write_term , (IOSTREAM *s, term_t term, int precedence, int flags), (s, term, precedence, flags)) 459 | PLX_ASIS(int , ttymode , (IOSTREAM *s), (s)) 460 | 461 | // TODO: PL_put_term_from_chars depends on CVT_EXCEPTION - ? make version that checks this and throws an exception? 462 | PLX_ASIS(PLX_BOOL , put_term_from_chars , (term_t t, int flags, size_t len, const char *s), (t, flags, len, s)) 463 | 464 | // PL_chars_to_term(), PL_wchars_to_term() put error into term for syntax errors 465 | [[nodiscard]] 466 | PLX_ASIS(PLX_BOOL , chars_to_term , (const char *chars, term_t term), (chars, term)) 467 | [[nodiscard]] 468 | PLX_ASIS(PLX_BOOL , wchars_to_term , (const pl_wchar_t *chars, term_t term), (chars, term)) 469 | 470 | // In the following, some of the functions can return `false` without 471 | // a Prolog error; in these cases, a PlUnknownError is thrown. 472 | // If you wish finer control, use the PL_*() version of the call. 473 | PLX_ASIS(PLX_BOOL , initialise , (int argc, char **argv), (argc, argv)) 474 | PLX_ASIS(PLX_BOOL , winitialise , (int argc, wchar_t **argv), (argc, argv)) 475 | PLX_ASIS(PLX_BOOL , is_initialised , (int *argc, char ***argv), (argc, argv)) 476 | PLX_EXCE(PLX_BOOL , set_resource_db_mem , (const unsigned char *data, size_t size), (data, size)) 477 | PLX_ASIS(PLX_BOOL , toplevel , (), ()) 478 | PLX_ASIS(int , cleanup , (int status), (status)) 479 | PLX_VOID(void , cleanup_fork , (), ()) 480 | PLX_ASIS(PLX_BOOL , halt , (int status), (status)) 481 | 482 | PLX_ASIS(void * , dlopen , (const char *file, int flags), (file, flags)) 483 | PLX_ASIS(const char * , dlerror , (), ()) 484 | PLX_ASIS(void * , dlsym , (void *handle, char *symbol), (handle, symbol)) 485 | PLX_ASIS(int , dlclose , (void *handle), (handle)) 486 | 487 | // TODO: document PL_dispatch(), PL_add_to_protocol, etc. 488 | PLX_ASIS(int , dispatch , (int fd, int wait), (fd, wait)) 489 | PLX_VOID(void , add_to_protocol , (const char *buf, size_t count), (buf, count)) 490 | PLX_ASIS(char * , prompt_string , (int fd), (fd)) 491 | PLX_VOID(void , write_prompt , (int dowrite), (dowrite)) 492 | PLX_VOID(void , prompt_next , (int fd), (fd)) 493 | PLX_ASIS(char * , atom_generator , (const char *prefix, int state), (prefix, state)) 494 | PLX_ASIS(pl_wchar_t* , atom_generator_w , (const pl_wchar_t *pref, pl_wchar_t *buffer, size_t buflen, int state), (pref, buffer, buflen, state)) 495 | 496 | PLX_ASIS(void * , malloc , (size_t size), (size)) 497 | PLX_ASIS(void * , malloc_atomic , (size_t size), (size)) 498 | PLX_ASIS(void * , malloc_uncollectable , (size_t size), (size)) 499 | PLX_ASIS(void * , malloc_atomic_uncollectable , (size_t size), (size)) 500 | PLX_ASIS(void * , realloc , (void *mem, size_t size), (mem, size)) 501 | PLX_ASIS(void * , malloc_unmanaged , (size_t size), (size)) 502 | PLX_ASIS(void * , malloc_atomic_unmanaged , (size_t size), (size)) 503 | PLX_VOID(void , free , (void *mem), (mem)) 504 | PLX_ASIS(PLX_BOOL , linger , (void *mem), (mem)) 505 | 506 | PLX_ASIS(PL_dispatch_hook_t , dispatch_hook , (PL_dispatch_hook_t h), (h)) 507 | PLX_VOID(void , abort_hook , (PL_abort_hook_t h), (h)) 508 | PLX_VOID(void , initialise_hook , (PL_initialise_hook_t h), (h)) 509 | PLX_ASIS(PLX_BOOL , abort_unhook , (PL_abort_hook_t h), (h)) 510 | PLX_ASIS(PL_agc_hook_t , agc_hook , (PL_agc_hook_t h), (h)) 511 | 512 | // TODO: bool PL_scan_options(term_t options, int flags, const char *opttype, PL_option_t specs[], ...); 513 | // Deprecated: void (*PL_signal(int sig, void (*func)(int)))(int); 514 | PLX_ASIS(int , sigaction , (int sig, pl_sigaction_t *act, pl_sigaction_t *old), (sig, act, old)) 515 | PLX_VOID(void , interrupt , (int sig), (sig)) 516 | PLX_ASIS(PLX_BOOL , raise , (int sig), (sig)) 517 | PLX_ASIS(int , handle_signals , (), ()) 518 | PLX_ASIS(int , get_signum_ex , (term_t sig, int *n), (sig, n)) 519 | // (skipped):: int PL_action(int, ...); 520 | PLX_VOID(void , on_halt , (int (*f)(int, void *), void *closure), (f, closure)) 521 | PLX_VOID(void , exit_hook , (int (*f)(int, void *), void *closure), (f, closure)) 522 | PLX_VOID(void , backtrace , (int depth, int flags), (depth, flags)) 523 | PLX_ASIS(char * , backtrace_string , (int depth, int flags), (depth, flags)) 524 | PLX_ASIS(int , check_data , (term_t data), (data)) 525 | PLX_ASIS(int , check_stacks , (), ()) 526 | PLX_ASIS(int , current_prolog_flag , (atom_t name, int type, void *ptr), (name, type, ptr)) 527 | PLX_ASIS(unsigned int , version_info , (int which), (which)) 528 | PLX_ASIS(intptr_t , query , (int i), (i)) 529 | PLX_ASIS(int , thread_self , (), ()) 530 | PLX_WRAP(int , unify_thread_id , (term_t t, int i), (t, i)) 531 | PLX_WRAP(int , get_thread_id_ex , (term_t t, int *idp), (t, idp)) 532 | PLX_ASIS(int , get_thread_alias , (int tid, atom_t *alias), (tid, alias)) 533 | // TODO: document thread_attach_engine; make PLX_WRAP version (tid < 0) 534 | PLX_ASIS(int , thread_attach_engine , (PL_thread_attr_t *attr), (attr)) 535 | PLX_EXCE(int , thread_destroy_engine , (), ()) 536 | PLX_ASIS(int , thread_at_exit , (void (*function)(void *), void *closure, int global), (function, closure, global)) 537 | PLX_ASIS(int , thread_raise , (int tid, int sig), (tid, sig)) 538 | 539 | // JW: disabled. Claims these functions are not present in Windows, blocking the build. 540 | #if 0 && defined(_WINDOWS_) || defined(_WINDOWS_H) /* is included */ 541 | PLX_ASIS(int , w32thread_raise , (DWORD dwTid, int sig), (dwTid, sig)) 542 | PLX_ASIS(int , wait_for_console_input , (void *handle), (handle)) 543 | PLX_ASIS(int , w32_wrap_ansi_console , (), ()) 544 | PLX_ASIS(const char* , w32_running_under_wine , (), ()) 545 | PLX_EXCE(LRESULT , win_message_proc , (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam), (hwnd, message, wParam, lParam)) 546 | #endif 547 | 548 | PLX_ASIS(PL_engine_t , create_engine , (PL_thread_attr_t *attributes), (attributes)) 549 | PLX_ASIS(int , set_engine , (PL_engine_t engine, PL_engine_t *old), (engine, old)) 550 | PLX_ASIS(int , destroy_engine , (PL_engine_t engine), (engine)) 551 | PLX_ASIS(hash_table_t , new_hash_table , (size_t size, void (*free_symbol)(table_key_t n, table_value_t v)), (size, free_symbol)) 552 | PLX_ASIS(int , register_profile_type , (PL_prof_type_t *type), (type)) 553 | PLX_ASIS(void* , prof_call , (void *handle, PL_prof_type_t *type), (handle, type)) 554 | PLX_VOID(void , prof_exit , (void *node), (node)) 555 | // (skipped):: PL_EXPORT_DATA(int) plugin_is_GPL_compatible; 556 | // (skipped):: int emacs_module_init(void*); 557 | PLX_ASIS(int , prolog_debug , (const char *topic), (topic)) 558 | PLX_ASIS(int , prolog_nodebug , (const char *topic), (topic)) 559 | 560 | // (skipped):: bool _PL_get_xpce_reference(term_t t, xpceref_t *ref); 561 | // (skipped):: bool _PL_unify_xpce_reference(term_t t, xpceref_t *ref); 562 | // (skipped):: bool _PL_put_xpce_reference_i(term_t t, uintptr_t r); 563 | // (skipped):: bool _PL_put_xpce_reference_a(term_t t, atom_t name); 564 | 565 | PLX_ASIS(int , get_context , (struct pl_context_t *c, int thead_id), (c, thead_id)) 566 | PLX_ASIS(int , step_context , (struct pl_context_t *c), (c)) 567 | PLX_ASIS(int , describe_context , (struct pl_context_t *c, char *buf, size_t len), (c, buf, len)) 568 | 569 | 570 | #undef PLX_EXCE 571 | #undef PLX_WRAP 572 | #undef PLX_ASIS 573 | #undef PLX_VOID 574 | 575 | #endif /* _SWI_CPP2_PLX_H */ 576 | -------------------------------------------------------------------------------- /SWI-cpp2.cpp: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Jan Wielemaker and Peter Ludemann 4 | E-mail: J.Wielemaker@vu.nl 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2000-2024, University of Amsterdam 7 | VU University Amsterdam 8 | SWI-Prolog Solutions b.v. 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in 20 | the documentation and/or other materials provided with the 21 | distribution. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | /* If you wish, you can append SWI-cpp2.cpp file to SWI-pp2.h ... 38 | to do this, you need this definition: 39 | 40 | #define _SWI_CPP2_CPP_inline inline 41 | 42 | */ 43 | 44 | #ifndef _SWI_CPP2_CPP 45 | #define _SWI_CPP2_CPP 46 | 47 | #ifndef _SWI_CPP2_CPP_inline 48 | #define _SWI_CPP2_CPP_inline 49 | #endif 50 | 51 | #include "SWI-cpp2.h" 52 | 53 | 54 | _SWI_CPP2_CPP_inline 55 | static 56 | bool ex_is_resource_error(PlTerm ex) 57 | { // TODO: move the static PlFunctor to outside this function: https://github.com/SWI-Prolog/swipl-devel/issues/1155 58 | static PlFunctor FUNCTOR_error_2("error", 2); 59 | static PlFunctor FUNCTOR_resource_error_1("resource_error", 1); 60 | // The following doesn't check details of the resource error; if desired 61 | // these can be added by ex[1][1].unify_atom(ATOM_stack), ATOM_memory, etc 62 | return ( ex.is_functor(FUNCTOR_error_2) && 63 | ex[1].is_functor(FUNCTOR_resource_error_1) ); 64 | } 65 | 66 | 67 | _SWI_CPP2_CPP_inline 68 | void 69 | PlWrap_fail(qid_t qid) 70 | { PlTerm ex(PL_exception(qid)); 71 | if ( ex.not_null() ) 72 | { // The error(resource_error(stack), _) exception is special because 73 | // nothing can be put on the stack, so all we can do is report failure 74 | // to the Prolog engine, which will take care of things. 75 | // This means, of course, that a user catch(PlException&) won't catch 76 | // this particular exception. 77 | if ( ex_is_resource_error(ex) ) 78 | throw PlExceptionFail(); 79 | const PlException ex2(ex); 80 | Plx_clear_exception(); // See https://swi-prolog.discourse.group/t/cpp2-exceptions/6040/66 81 | throw ex2; 82 | } 83 | } 84 | 85 | 86 | _SWI_CPP2_CPP_inline 87 | void 88 | PlEx_fail(qid_t qid) 89 | { PlTerm ex(PL_exception(qid)); 90 | if ( ex.not_null() ) 91 | { // The error(resource_error(stack), _) exception is special because 92 | // nothing can be put on the stack, so all we can do is report failure 93 | // to the Prolog engine, which will take care of things. 94 | // This means, of course, that a user catch(PlException&) won't catch 95 | // this particular exception. 96 | if ( ex_is_resource_error(ex) ) 97 | throw PlExceptionFail(); 98 | const PlException ex2(ex); 99 | Plx_clear_exception(); // See https://swi-prolog.discourse.group/t/cpp2-exceptions/6040/66 100 | throw ex2; 101 | } else 102 | { // TODO: get the name of the PL_...() function that caused the problem: 103 | // assert(0); 104 | throw PlUnknownError("False return code without exception"); 105 | } 106 | } 107 | 108 | 109 | // TODO: add unit test for unrepresentable string - should throw error 110 | _SWI_CPP2_CPP_inline 111 | const std::string 112 | PlTerm::get_nchars(unsigned int flags) const 113 | { flags &= ~static_cast(BUF_STACK|BUF_MALLOC|BUF_ALLOW_STACK); 114 | flags |= static_cast(BUF_DISCARDABLE|CVT_EXCEPTION); 115 | char *s = nullptr; 116 | size_t len = 0; 117 | PlStringBuffers _string_buffers; 118 | if ( _get_nchars(&len, &s, flags) ) 119 | return std::string(s, len); 120 | PlEx_fail(); 121 | return "<---get_nchars error --->"; // Should never get here 122 | } 123 | 124 | _SWI_CPP2_CPP_inline 125 | const std::wstring 126 | PlTerm::get_wchars(unsigned int flags) const 127 | { flags &= ~static_cast(BUF_STACK|BUF_MALLOC|BUF_ALLOW_STACK); 128 | flags |= static_cast(BUF_DISCARDABLE|CVT_EXCEPTION); 129 | pl_wchar_t *s; 130 | size_t len; 131 | PlStringBuffers _string_buffers; 132 | if ( _get_wchars(&len, &s, flags) ) 133 | return std::wstring(s, len); 134 | PlEx_fail(); 135 | return L"<---get_wchars error --->"; // Should never get here 136 | } 137 | 138 | _SWI_CPP2_CPP_inline 139 | const std::string 140 | PlTerm::get_file_name(int flags) const 141 | { char *name = const_cast(""); 142 | PlCheckFail(get_file_name(&name, flags)); 143 | return name; 144 | } 145 | 146 | _SWI_CPP2_CPP_inline 147 | const std::wstring 148 | PlTerm::get_file_nameW(int flags) const 149 | { wchar_t *name = const_cast(L""); 150 | PlCheckFail(get_file_nameW(&name, flags)); 151 | return name; 152 | } 153 | 154 | #define _MUST_BE_TYPE(must_be_name, is_test, type_name) \ 155 | _SWI_CPP2_CPP_inline \ 156 | void \ 157 | PlTerm::must_be_name() const \ 158 | { if ( !is_test() ) \ 159 | throw PlTypeError(type_name, *this); \ 160 | } 161 | 162 | _MUST_BE_TYPE(must_be_attvar, is_attvar, "attvar") 163 | _MUST_BE_TYPE(must_be_variable, is_variable, "variable") 164 | _MUST_BE_TYPE(must_be_ground, is_ground, "ground") 165 | _MUST_BE_TYPE(must_be_atom, is_atom, "atom") 166 | _MUST_BE_TYPE(must_be_integer, is_integer, "integer") 167 | _MUST_BE_TYPE(must_be_string, is_string, "string") 168 | _MUST_BE_TYPE(must_be_atom_or_string, is_atom_or_string, "atom or string") 169 | _MUST_BE_TYPE(must_be_float, is_float, "float") 170 | _MUST_BE_TYPE(must_be_rational, is_rational, "rational") 171 | _MUST_BE_TYPE(must_be_compound, is_compound, "compound") 172 | _MUST_BE_TYPE(must_be_callable, is_callable, "callable") 173 | _MUST_BE_TYPE(must_be_list, is_list, "list") 174 | _MUST_BE_TYPE(must_be_dict, is_dict, "dict") 175 | _MUST_BE_TYPE(must_be_pair, is_pair, "pair") 176 | _MUST_BE_TYPE(must_be_atomic, is_atomic, "atomic") 177 | _MUST_BE_TYPE(must_be_number, is_number, "number") 178 | _MUST_BE_TYPE(must_be_acyclic, is_acyclic, "acyclic") 179 | 180 | #undef _MUST_BE_TYPE 181 | 182 | _SWI_CPP2_CPP_inline 183 | PlModule 184 | PlContext() 185 | { return PlModule(Plx_context()); 186 | } 187 | 188 | _SWI_CPP2_CPP_inline 189 | PlException 190 | PlGeneralError(PlTerm inside) 191 | { return PlException(PlCompound("error", PlTermv(inside, PlTerm_var()))); 192 | } 193 | 194 | _SWI_CPP2_CPP_inline 195 | PlException 196 | PlTypeError(const std::string& expected, PlTerm actual) 197 | { // See PL_type_error() 198 | return PlGeneralError(PlCompound("type_error", 199 | PlTermv(PlTerm_atom(expected), actual))); 200 | } 201 | 202 | _SWI_CPP2_CPP_inline 203 | PlException 204 | PlDomainError(const std::string& expected, PlTerm actual) 205 | { // See PL_domain_error() 206 | return PlGeneralError(PlCompound("domain_error", 207 | PlTermv(PlTerm_atom(expected), actual))); 208 | } 209 | 210 | _SWI_CPP2_CPP_inline 211 | PlException 212 | PlDomainError(PlTerm expected, PlTerm actual) 213 | { // See PL_domain_error() 214 | // This is used by 215 | // PlDomainError(PlCompound("argv", PlTermv(PlTerm_integer(size_))), ...) 216 | // for an out-of-bounds indexing error 217 | return PlGeneralError(PlCompound("domain_error", 218 | PlTermv(expected, actual))); 219 | } 220 | 221 | _SWI_CPP2_CPP_inline 222 | PlException 223 | PlInstantiationError(PlTerm t) 224 | { // See PL_instantiation_error() 225 | return PlGeneralError(PlCompound("instantiation_error", PlTermv(t))); 226 | } 227 | 228 | _SWI_CPP2_CPP_inline 229 | PlException 230 | PlUninstantiationError(PlTerm t) 231 | { // See PL_uninstantiation_error() 232 | return PlGeneralError(PlCompound("uninstantiation_error", PlTermv(t))); 233 | } 234 | 235 | _SWI_CPP2_CPP_inline 236 | PlException 237 | PlRepresentationError(const std::string& resource) 238 | { // See PL_representation_error() 239 | return PlGeneralError(PlCompound("representation_error", PlTermv(PlAtom(resource)))); 240 | 241 | } 242 | 243 | _SWI_CPP2_CPP_inline 244 | PlException 245 | PlExistenceError(const std::string& type, PlTerm actual) 246 | { // See PL_existence_error() 247 | return PlGeneralError(PlCompound("existence_error", 248 | PlTermv(PlTerm_atom(type), actual))); 249 | } 250 | 251 | _SWI_CPP2_CPP_inline 252 | PlException 253 | PlPermissionError(const std::string& op, const std::string& type, PlTerm obj) 254 | { // See: Use PL_permission_error() 255 | return PlGeneralError(PlCompound("permission_error", 256 | PlTermv(PlTerm_atom(op), PlTerm_atom(type), obj))); 257 | } 258 | 259 | _SWI_CPP2_CPP_inline 260 | PlException 261 | PlResourceError(const std::string& resource) 262 | { // See PL_resource_error() 263 | return PlGeneralError(PlCompound("resource_error", 264 | PlTermv(PlTerm_atom(resource)))); 265 | } 266 | 267 | _SWI_CPP2_CPP_inline 268 | PlException 269 | PlUnknownError(const std::string& description) 270 | { // For PlWrap() 271 | return PlGeneralError(PlCompound("unknown_error", 272 | PlTermv(PlTerm_atom(description)))); 273 | } 274 | 275 | 276 | 277 | 278 | /******************************* 279 | * ATOM IMPLEMENTATION * 280 | *******************************/ 281 | 282 | _SWI_CPP2_CPP_inline 283 | const std::string 284 | PlAtom::mbchars(unsigned int flags) const 285 | { PlStringBuffers _string_buffers; 286 | size_t len; 287 | char *s; 288 | Plx_atom_mbchars(unwrap(), &len, &s, CVT_EXCEPTION|flags); 289 | return std::string(s, len); 290 | } 291 | 292 | _SWI_CPP2_CPP_inline 293 | const std::wstring 294 | PlAtom::wchars() const 295 | { PlStringBuffers _string_buffers; 296 | size_t len; 297 | const wchar_t *s = Plx_atom_wchars(unwrap(), &len); 298 | return std::wstring(s, len); 299 | } 300 | 301 | 302 | _SWI_CPP2_CPP_inline 303 | bool PlBlob::write(IOSTREAM *s, int flags) const 304 | { if ( Sfprintf(s, "<%s>(%p", blob_t_->name, this) < 0 ) 305 | return false; 306 | { bool rc = true; 307 | try 308 | { if ( !write_fields(s, flags) ) 309 | return false; 310 | } PREDICATE_CATCH(rc = false) 311 | if ( !rc ) 312 | return false; 313 | } 314 | if ( Sfprintf(s, ")") < 0 ) 315 | return false; 316 | return true; 317 | } 318 | 319 | _SWI_CPP2_CPP_inline 320 | void PlBlob::save(IOSTREAM *fd) const 321 | { (void)PL_warning("Cannot save reference to <%s>(%p)", blob_t_->name, this); 322 | throw PlFail(); 323 | } 324 | 325 | _SWI_CPP2_CPP_inline 326 | PlAtom PlBlob::load(IOSTREAM *fd) 327 | { (void)PL_warning("Cannot load reference to <%s>", blob_t_->name); 328 | PL_system_error("Cannot load reference to <%s>", blob_t_->name); 329 | return PlAtom(PlAtom::null); 330 | } 331 | 332 | _SWI_CPP2_CPP_inline 333 | PlTerm PlBlob::symbol_term() const 334 | { if ( symbol_.not_null() ) 335 | return PlTerm_atom(symbol_); 336 | return PlTerm_var(); 337 | } 338 | 339 | _SWI_CPP2_CPP_inline 340 | bool PlTerm::unify_blob(const PlBlob* blob) const 341 | { return PlTerm::unify_blob(static_cast(blob), 342 | blob->blob_size_(), blob->blob_t_); 343 | } 344 | 345 | _SWI_CPP2_CPP_inline 346 | bool PlTerm::unify_blob(std::unique_ptr* b) const 347 | { std::unique_ptr blob(std::move(*b)); 348 | // if std::move is not supported, the above can be replaced by: 349 | // std:unique_ptr blob; 350 | // blob.swap(*b); 351 | if ( !unify_blob(blob.get()) ) 352 | return false; 353 | (void)blob.release(); // Pass ownership to the Prolog blob (`this`) 354 | return true; 355 | } 356 | 357 | 358 | 359 | /******************************* 360 | * TERM (BODY) * 361 | *******************************/ 362 | 363 | /* PlTerm --> C */ 364 | 365 | _SWI_CPP2_CPP_inline 366 | PlTerm 367 | PlTerm::copy_term_ref() const 368 | { return PlTerm(Plx_copy_term_ref(unwrap())); 369 | } 370 | 371 | _SWI_CPP2_CPP_inline 372 | void 373 | PlTerm::free_term_ref() 374 | { if ( not_null() ) 375 | Plx_free_term_ref(unwrap()); 376 | } 377 | 378 | _SWI_CPP2_CPP_inline 379 | void 380 | PlTerm::free_term_ref_reset() 381 | { free_term_ref(); 382 | reset(); 383 | } 384 | 385 | _SWI_CPP2_CPP_inline 386 | void 387 | PlTerm::as_nil() const 388 | { get_nil_ex(); 389 | } 390 | 391 | _SWI_CPP2_CPP_inline 392 | double 393 | PlTerm::as_float() const 394 | { double v; 395 | get_float_ex(&v); 396 | return v; 397 | } 398 | 399 | _SWI_CPP2_CPP_inline 400 | PlAtom 401 | PlTerm::as_atom() const 402 | { PlAtom v(PlAtom::null); 403 | get_atom_ex(&v); 404 | return v; 405 | } 406 | 407 | _SWI_CPP2_CPP_inline 408 | bool 409 | PlTerm::eq_if_atom(PlAtom a) const 410 | { PlAtom v(PlAtom::null); 411 | return get_atom(&v) && v == a; 412 | } 413 | 414 | _SWI_CPP2_CPP_inline 415 | void * 416 | PlTerm::as_pointer() const 417 | { void *ptr; 418 | get_pointer_ex(&ptr); 419 | return ptr; 420 | } 421 | 422 | _SWI_CPP2_CPP_inline 423 | PlRecord 424 | PlTerm::record() const 425 | { return PlRecord(*this); 426 | } 427 | 428 | _SWI_CPP2_CPP_inline 429 | PlTerm::PlTerm(const PlRecord& r) 430 | : WrappedC(r.term().unwrap()) 431 | { } 432 | 433 | 434 | /******************************* 435 | * LISTS * 436 | *******************************/ 437 | 438 | _SWI_CPP2_CPP_inline 439 | PlTerm_tail::PlTerm_tail(PlTerm l) 440 | { if ( l.is_variable() || l.is_list() ) 441 | reset(l.copy_term_ref()); 442 | else 443 | throw PlTypeError("list", l); 444 | } 445 | 446 | _SWI_CPP2_CPP_inline 447 | bool 448 | PlTerm_tail::append(PlTerm e) 449 | { PlTerm_var tmp; 450 | if ( unify_list(tmp, *this) && 451 | tmp.unify_term(e) ) 452 | { tmp.reset_term_refs(); 453 | return true; 454 | } 455 | 456 | return false; 457 | } 458 | 459 | _SWI_CPP2_CPP_inline 460 | bool PlTerm_tail::next(PlTerm& t) 461 | { if ( Plx_get_list(unwrap(), t.unwrap(), unwrap()) ) 462 | return true; 463 | 464 | if ( get_nil() ) 465 | return false; 466 | 467 | throw PlTypeError("list", *this); 468 | } 469 | 470 | _SWI_CPP2_CPP_inline 471 | bool 472 | PlRewindOnFail(std::function f) 473 | { PlFrame frame; 474 | bool rc = f(); 475 | if ( !rc ) 476 | frame.discard(); // Same as frame.rewind(); destructor's frame.close() 477 | return rc; 478 | } 479 | 480 | _SWI_CPP2_CPP_inline 481 | PlQuery 482 | PlCurrentQuery() 483 | { return PlQuery(Plx_current_query()); 484 | } 485 | 486 | _SWI_CPP2_CPP_inline 487 | int 488 | PlCall(const std::string& predicate, const PlTermv& args, int flags /* = PL_Q_PASS_EXCEPTION */ ) 489 | { PlQuery q(predicate, args, flags); 490 | return q.next_solution(); 491 | } 492 | 493 | _SWI_CPP2_CPP_inline 494 | int 495 | PlCall(const std::string& module, const std::string& predicate, const PlTermv& args, int flags /* = PL_Q_PASS_EXCEPTION */ ) 496 | { PlQuery q(module, predicate, args, flags); 497 | return q.next_solution(); 498 | } 499 | 500 | _SWI_CPP2_CPP_inline 501 | int 502 | PlCall(const std::string& goal, int flags /* = PL_Q_PASS_EXCEPTION */ ) 503 | { PlQuery q("call", PlTermv(PlCompound(goal)), flags); 504 | return q.next_solution(); 505 | } 506 | 507 | _SWI_CPP2_CPP_inline 508 | int 509 | PlCall(const std::wstring& goal, int flags /* = PL_Q_PASS_EXCEPTION */) 510 | { PlQuery q("call", PlTermv(PlCompound(goal)), flags); 511 | return q.next_solution(); 512 | } 513 | 514 | _SWI_CPP2_CPP_inline 515 | int 516 | PlCall(PlTerm goal, int flags /* = PL_Q_PASS_EXCEPTION */ ) 517 | { PlQuery q("call", PlTermv(goal), flags); 518 | return q.next_solution(); 519 | } 520 | 521 | 522 | 523 | /* compounds */ 524 | 525 | _SWI_CPP2_CPP_inline 526 | PlTerm 527 | PlTerm::operator [](size_t index) const 528 | { PlTerm t; 529 | 530 | if ( Plx_get_arg(index, unwrap(), t.unwrap()) ) 531 | return t; 532 | 533 | if ( !is_compound() ) 534 | throw PlTypeError("compound", *this); 535 | 536 | /* Construct error term and throw it */ 537 | Plx_put_uint64(t.unwrap(), index); 538 | if ( index < 1 ) 539 | throw PlDomainError("not_less_than_zero", t); 540 | else 541 | throw PlDomainError("arity", t); /* TODO: arity(t.unwrap()) - see PlTermv::operator[] */ 542 | } 543 | 544 | _SWI_CPP2_CPP_inline 545 | size_t 546 | PlTerm::arity() const 547 | { size_t arity; 548 | if ( get_name_arity(nullptr, &arity) ) 549 | return arity; 550 | throw PlTypeError("compound", *this); 551 | } 552 | 553 | _SWI_CPP2_CPP_inline 554 | PlAtom 555 | PlTerm::name() const 556 | { atom_t name; 557 | size_t arity; 558 | if ( Plx_get_name_arity(unwrap(), &name, &arity) ) 559 | return PlAtom(name); 560 | throw PlTypeError("compound", *this); 561 | } 562 | 563 | _SWI_CPP2_CPP_inline 564 | bool 565 | PlTerm::name_arity(PlAtom *name, size_t *arity) const 566 | { atom_t name_a; 567 | if ( Plx_get_name_arity(unwrap(), &name_a, arity) ) 568 | { if ( name ) 569 | *name = PlAtom(name_a); 570 | return true; 571 | } 572 | return false; 573 | } 574 | 575 | 576 | 577 | /* comparison */ 578 | 579 | _SWI_CPP2_CPP_inline 580 | bool 581 | PlTerm::operator ==(int64_t v) const 582 | { int64_t v0; 583 | get_int64_ex(&v0); 584 | return v0 == v; 585 | } 586 | 587 | _SWI_CPP2_CPP_inline 588 | bool 589 | PlTerm::operator !=(int64_t v) const 590 | { int64_t v0; 591 | get_int64_ex(&v0); 592 | return v0 != v; 593 | } 594 | 595 | _SWI_CPP2_CPP_inline 596 | bool 597 | PlTerm::operator <(int64_t v) const 598 | { int64_t v0; 599 | get_int64_ex(&v0); 600 | return v0 < v; 601 | } 602 | 603 | _SWI_CPP2_CPP_inline 604 | bool 605 | PlTerm::operator >(int64_t v) const 606 | { int64_t v0; 607 | get_int64_ex(&v0); 608 | return v0 > v; 609 | } 610 | 611 | _SWI_CPP2_CPP_inline 612 | bool 613 | PlTerm::operator <=(int64_t v) const 614 | { int64_t v0; 615 | get_int64_ex(&v0); 616 | return v0 <= v; 617 | } 618 | 619 | _SWI_CPP2_CPP_inline 620 | bool 621 | PlTerm::operator >=(int64_t v) const 622 | { int64_t v0; 623 | get_int64_ex(&v0); 624 | return v0 >= v; 625 | } 626 | 627 | /* comparison (string) */ 628 | 629 | _SWI_CPP2_CPP_inline 630 | bool 631 | PlTerm::eq(const char *s) const 632 | { char *s0; 633 | 634 | PlStringBuffers _string_buffers; 635 | if ( _get_chars(&s0, CVT_ALL) ) 636 | return strcmp(s0, s) == 0; 637 | 638 | throw PlTypeError("text", *this); 639 | } 640 | 641 | _SWI_CPP2_CPP_inline 642 | bool 643 | PlTerm::eq(const wchar_t *s) const 644 | { wchar_t *s0; 645 | 646 | PlStringBuffers _string_buffers; 647 | if ( _get_wchars(nullptr, &s0, CVT_ALL) ) 648 | return wcscmp(s0, s) == 0; 649 | 650 | throw PlTypeError("text", *this); 651 | } 652 | 653 | _SWI_CPP2_CPP_inline 654 | bool 655 | PlTerm::eq(const std::string& s) const 656 | { char *s0; 657 | 658 | PlStringBuffers _string_buffers; 659 | // Doesn't handle non-NUL terminated - but it's only used by deprecated operator == 660 | if ( _get_chars(&s0, CVT_ALL) ) 661 | return s.compare(s0) == 0; 662 | 663 | throw PlTypeError("text", *this); 664 | } 665 | 666 | _SWI_CPP2_CPP_inline 667 | bool 668 | PlTerm::eq(const std::wstring& s) const 669 | { // Doesn't handle non-NUL terminated - but it's only used by deprecated operator == 670 | return s.compare(get_wchars(CVT_ALL)) == 0; 671 | 672 | throw PlTypeError("text", *this); 673 | } 674 | 675 | _SWI_CPP2_CPP_inline 676 | bool 677 | PlTerm::eq(PlAtom a) const 678 | { atom_t v; 679 | 680 | if ( Plx_get_atom(unwrap(), &v) ) 681 | return v == a.unwrap(); 682 | 683 | throw PlTypeError("atom", *this); 684 | } 685 | 686 | 687 | /******************************* 688 | * COMPOUND (BODY) * 689 | *******************************/ 690 | 691 | _SWI_CPP2_CPP_inline 692 | PlCompound::PlCompound(const wchar_t *text) 693 | { term_t t = Plx_new_term_ref(); 694 | if ( !Plx_wchars_to_term(text, t) ) 695 | throw PlException(PlTerm(t)); 696 | Plx_put_term(unwrap(), t); 697 | } 698 | 699 | _SWI_CPP2_CPP_inline 700 | PlCompound::PlCompound(const std::string& text, PlEncoding enc) 701 | { term_t t = Plx_new_term_ref(); 702 | PlEx(t != (term_t)0); 703 | 704 | // TODO: PL_put_term_from_chars() should take an unsigned int flags 705 | PlEx(Plx_put_term_from_chars(t, static_cast(enc)|CVT_EXCEPTION, text.size(), text.data())); 706 | Plx_put_term(unwrap(), t); 707 | } 708 | 709 | _SWI_CPP2_CPP_inline 710 | PlCompound::PlCompound(const std::wstring& text) 711 | { term_t t = Plx_new_term_ref(); 712 | PlEx(t != (term_t)0); 713 | 714 | // TODO: what is wchar_t equivalent of PL_put_term_from_chars()? 715 | if ( !Plx_wchars_to_term(text.c_str(), t) ) // TODO: use text.size() 716 | throw PlException(PlTerm(t)); 717 | Plx_put_term(unwrap(), t); 718 | } 719 | 720 | _SWI_CPP2_CPP_inline 721 | PlCompound::PlCompound(const char *functor, const PlTermv& args) 722 | { functor_t f = Plx_new_functor(Plx_new_atom(functor), args.size()); 723 | PlEx(f != (functor_t)0); 724 | Plx_cons_functor_v(unwrap(), f, args.termv()); 725 | } 726 | 727 | _SWI_CPP2_CPP_inline 728 | PlCompound::PlCompound(const wchar_t *functor, const PlTermv& args) 729 | { functor_t f = Plx_new_functor(Plx_new_atom_wchars(wcslen(functor), functor), args.size()); 730 | PlEx(f != (functor_t)0); 731 | Plx_cons_functor_v(unwrap(), f, args.termv()); 732 | } 733 | 734 | _SWI_CPP2_CPP_inline 735 | PlCompound::PlCompound(const std::string& functor, const PlTermv& args) 736 | { functor_t f = Plx_new_functor(Plx_new_atom_nchars(functor.size(), functor.data()), args.size()); 737 | Plx_cons_functor_v(unwrap(), f, args.termv()); 738 | } 739 | 740 | _SWI_CPP2_CPP_inline 741 | PlCompound::PlCompound(const std::wstring& functor, const PlTermv& args) 742 | { functor_t f = Plx_new_functor(Plx_new_atom_wchars(functor.size(), functor.data()), args.size()); 743 | Plx_cons_functor_v(unwrap(), f, args.termv()); 744 | } 745 | 746 | /******************************* 747 | * TERMV (BODY) * 748 | *******************************/ 749 | 750 | _SWI_CPP2_CPP_inline 751 | PlTermv::PlTermv(PlAtom a) 752 | : size_(1), 753 | a0_(PlTerm_atom(a).unwrap()) 754 | { PlEx(a0_ != (term_t)0); 755 | } 756 | 757 | _SWI_CPP2_CPP_inline 758 | PlTermv::PlTermv(PlTerm m0) 759 | : size_(1), 760 | a0_(m0.unwrap()) 761 | { // Assume that m0 is valid 762 | } 763 | 764 | _SWI_CPP2_CPP_inline 765 | PlTermv::PlTermv(PlTerm m0, PlTerm m1) 766 | : size_(2), 767 | a0_(Plx_new_term_refs(2)) 768 | { PlEx(a0_ != (term_t)0); 769 | // Commented out code is possibly less efficient: 770 | // PlTerm(a0_+0).put_term(m0); // (*this)[0].put_term(m0) does an unnecessary range check 771 | // PlTerm(a0_+1).put_term(m1); 772 | Plx_put_term(a0_+0, m0.unwrap()); 773 | Plx_put_term(a0_+1, m1.unwrap()); 774 | } 775 | 776 | _SWI_CPP2_CPP_inline 777 | PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2) 778 | : size_(3), 779 | a0_(Plx_new_term_refs(3)) 780 | { PlEx(a0_ != (term_t)0); 781 | Plx_put_term(a0_+0, m0.unwrap()); 782 | Plx_put_term(a0_+1, m1.unwrap()); 783 | Plx_put_term(a0_+2, m2.unwrap()); 784 | } 785 | 786 | _SWI_CPP2_CPP_inline 787 | PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3) 788 | : size_(4), 789 | a0_(Plx_new_term_refs(4)) 790 | { PlEx(a0_ != (term_t)0); 791 | Plx_put_term(a0_+0, m0.unwrap()); 792 | Plx_put_term(a0_+1, m1.unwrap()); 793 | Plx_put_term(a0_+2, m2.unwrap()); 794 | Plx_put_term(a0_+3, m3.unwrap()); 795 | } 796 | 797 | _SWI_CPP2_CPP_inline 798 | PlTermv::PlTermv(PlTerm m0, PlTerm m1, PlTerm m2, PlTerm m3, PlTerm m4) 799 | : size_(5), 800 | a0_(Plx_new_term_refs(5)) 801 | { PlEx(a0_ != (term_t)0); 802 | Plx_put_term(a0_+0, m0.unwrap()); 803 | Plx_put_term(a0_+1, m1.unwrap()); 804 | Plx_put_term(a0_+2, m2.unwrap()); 805 | Plx_put_term(a0_+3, m3.unwrap()); 806 | Plx_put_term(a0_+4, m4.unwrap()); 807 | } 808 | 809 | _SWI_CPP2_CPP_inline 810 | PlTerm 811 | PlTermv::operator [](size_t n) const 812 | { if ( n >= size_ ) 813 | throw PlDomainError(PlCompound("argv", 814 | PlTermv(PlTerm_integer(size_))), 815 | PlTerm_integer(n)); 816 | 817 | return PlTerm(a0_+n); 818 | } 819 | 820 | 821 | /******************************* 822 | * EXCEPTIONS (BODY) * 823 | *******************************/ 824 | 825 | _SWI_CPP2_CPP_inline 826 | PlTerm 827 | PlException::string_term() const 828 | { PlFrame fr; 829 | // Note that the result is a *term*, so it's unencoded (wchar_t 830 | // or equivalent) and will be encoded when it's output. 831 | // TODO: remove USE_PRINT_MESSAGE code (obsolete) 832 | // - or use with_output_to(string(String), print_message(error, ...)) 833 | #ifdef USE_PRINT_MESSAGE 834 | PlTermv av(2); 835 | PlCheckFail(av[0].unify_term(PlCompound("print_message", 836 | PlTermv("error", term())))); 837 | PlQuery q("$write_on_string", av); 838 | if ( q.next_solution() ) 839 | return av[1]; 840 | #else 841 | // '$messages':message_to_string(error(existence_error(procedure,unknown_predicate/1),context(system:call/1,_)), Str). 842 | // Str = "call/1: Unknown procedure: unknown_predicate/1" 843 | PlTermv av(2); 844 | PlCheckFail(av[0].unify_term(term())); 845 | PlQuery q("$messages", "message_to_string", av); 846 | if ( q.next_solution() ) 847 | return av[1]; 848 | #endif 849 | // TODO: return term_.as_string() 850 | return PlTerm_string("[ERROR: Failed to generate message. Internal error]"); 851 | } 852 | 853 | _SWI_CPP2_CPP_inline 854 | const std::string 855 | PlException::as_string(PlEncoding enc) const 856 | { // Use what_str_ to hold the string so that c_str() doesn't return 857 | // a pointer into the stack. Note that as_string() can cause an 858 | // exception (out of memory, either in generating the string or in 859 | // allocating the std::string) even though we specify "throw()" - 860 | // telling the truth "noexcept(false)" results in a compilation 861 | // error. 862 | (void)enc; // TODO: use this 863 | const_cast(this)->set_what_str(); 864 | return what_str_; 865 | } 866 | 867 | _SWI_CPP2_CPP_inline 868 | const char* 869 | PlException::what() const throw() 870 | { const_cast(this)->set_what_str(); 871 | return what_str_.c_str(); 872 | } 873 | 874 | _SWI_CPP2_CPP_inline 875 | void 876 | PlException::set_what_str(PlEncoding enc) 877 | { if ( what_str_.empty() ) 878 | { what_str_ = term().as_string(enc); 879 | } 880 | } 881 | 882 | _SWI_CPP2_CPP_inline 883 | void 884 | PlException::erase() 885 | { if ( term_rec_.not_null() ) 886 | term_rec_.erase(); 887 | term_rec_.set_null(); 888 | } 889 | 890 | /******************************* 891 | * QUERY (BODY) * 892 | *******************************/ 893 | 894 | _SWI_CPP2_CPP_inline 895 | int 896 | PlQuery::next_solution() 897 | { int rval = PL_next_solution(unwrap()); 898 | 899 | if ( flags_ & PL_Q_EXT_STATUS ) 900 | { // values are: 901 | // PL_S_EXCEPTION, PL_S_FALSE PL_S_TRUE PL_S_LAST. PL_S_YIELD: 902 | return rval; 903 | } else 904 | { if ( rval ) 905 | return rval; 906 | } 907 | // If we get here, rval is "false". The user must specifically 908 | // request PL_Q_CATCH_EXCEPTION; otherwise exception_qid() won't 909 | // give an appropriate value. 910 | if ( flags_ & PL_Q_CATCH_EXCEPTION ) 911 | PlEx_fail(exception_qid()); 912 | close_destroy(); 913 | return rval; 914 | } 915 | 916 | _SWI_CPP2_CPP_inline 917 | PlEngineCleanupFailed::PlEngineCleanupFailed(int status_and_flags, int rc) 918 | : status_and_flags_(status_and_flags), 919 | rc_(rc), 920 | what_str_("PlEngineCleanupFailed(" + 921 | std::to_string(status_and_flags_) + "):") 922 | { // TODO: it would be better to build the string lazily in what(), 923 | // what_str_.empty(); but what() is a const method, so 924 | // requires ugly casts. 925 | switch( rc_ ) // See comment in ~PlEngine() 926 | { case PL_CLEANUP_SUCCESS: 927 | what_str_ += "success"; 928 | break; 929 | case PL_CLEANUP_CANCELED: 930 | what_str_ += "canceled"; 931 | break; 932 | case PL_CLEANUP_FAILED: 933 | what_str_ += "failed"; 934 | break; 935 | case PL_CLEANUP_RECURSIVE: 936 | what_str_ += "recursive"; 937 | break; 938 | default: // shouldn't happen 939 | what_str_ += "rc=" + std::to_string(rc_); 940 | } 941 | } 942 | 943 | 944 | /******************************* 945 | * DEBUG * 946 | *******************************/ 947 | 948 | // This is used in SWI-cpp2-plx.h - currently its action is commented out. 949 | // TODO: remove this when PlWrapDebug() is removed from SWI-cpp2-plx.h 950 | 951 | 952 | #ifdef O_DEBUG 953 | #include 954 | _SWI_CPP2_CPP_inline 955 | void PlWrapDebug(const char*msg) { 956 | // Sdprintf("***PlWrapDebug %s\n", msg); 957 | // PL_check_stacks(); 958 | } 959 | #endif 960 | 961 | /******************************* 962 | * PlString * 963 | *******************************/ 964 | 965 | _SWI_CPP2_CPP_inline 966 | PlStream::PlStream(PlTerm stream, int flags) 967 | { Plx_get_stream(stream.unwrap(), &s_, flags); 968 | check_stream(); // Shouldn't happen 969 | } 970 | 971 | _SWI_CPP2_CPP_inline 972 | PlStream::PlStream(IOSTREAM *s) 973 | : s_(Plx_acquire_stream(s)) 974 | { check_stream(); // Shouldn't happen 975 | } 976 | 977 | _SWI_CPP2_CPP_inline 978 | PlStream::~PlStream() noexcept 979 | { release(); 980 | } 981 | 982 | _SWI_CPP2_CPP_inline 983 | void PlStream::release() 984 | { if ( s_ ) 985 | Plx_release_stream(s_); 986 | s_ = nullptr; 987 | } 988 | 989 | _SWI_CPP2_CPP_inline 990 | void 991 | PlStream::check_stream() const 992 | { if ( ! s_ ) 993 | throw PlUnknownError("Stream not set"); 994 | } 995 | 996 | /* JW: was using check_rc(), but somehown Apple Clang thinks ssize_t 997 | maps both to int32_t and int64_t. 998 | */ 999 | #define _SWI_CPP2_CPP_check_rc(rc_t, defn, call) \ 1000 | _SWI_CPP2_CPP_inline \ 1001 | rc_t \ 1002 | PlStream::defn \ 1003 | { check_stream(); \ 1004 | rc_t rc = call; \ 1005 | if ( rc < 0 ) { release(); throw PlUnknownError("Stream error"); } \ 1006 | return rc; \ 1007 | } 1008 | 1009 | #define _SWI_CPP2_CPP_check_brc(rc_t, defn, call) \ 1010 | _SWI_CPP2_CPP_inline \ 1011 | rc_t \ 1012 | PlStream::defn \ 1013 | { check_stream(); \ 1014 | rc_t rc = call; \ 1015 | if ( !rc ) { release(); throw PlUnknownError("Stream error"); } \ 1016 | return rc; \ 1017 | } 1018 | 1019 | #define _SWI_CPP2_CPP_nocheck(rc_t, defn, call) \ 1020 | _SWI_CPP2_CPP_inline \ 1021 | rc_t \ 1022 | PlStream::defn \ 1023 | { check_stream(); \ 1024 | return call; \ 1025 | } 1026 | 1027 | _SWI_CPP2_CPP_check_rc(int, set_timeout(int tmo), Sset_timeout(s_, tmo)) 1028 | _SWI_CPP2_CPP_check_rc(int, unit_size(), Sunit_size(s_)) 1029 | _SWI_CPP2_CPP_nocheck(bool, canrepresent(int c), Scanrepresent(c, s_)) 1030 | _SWI_CPP2_CPP_check_rc(int, putcode(int c), Sputcode(c, s_)) 1031 | _SWI_CPP2_CPP_check_rc(int, getcode(), Sgetcode(s_)) 1032 | _SWI_CPP2_CPP_check_rc(int, peekcode(), Speekcode(s_)) 1033 | _SWI_CPP2_CPP_check_rc(int, putw(int w), Sputw(w, s_)) 1034 | _SWI_CPP2_CPP_check_rc(int, getw(), Sgetw(s_)) 1035 | _SWI_CPP2_CPP_nocheck(size_t, fread(void *data, size_t size, size_t elems), Sfread(data, size, elems, s_)) 1036 | _SWI_CPP2_CPP_nocheck(size_t, fwrite(const void *data, size_t size, size_t elems), Sfwrite(data, size, elems, s_)) 1037 | _SWI_CPP2_CPP_check_rc(int, feof(), Sfeof(s_)) 1038 | _SWI_CPP2_CPP_check_rc(int, fpasteof(), Sfpasteof(s_)) 1039 | _SWI_CPP2_CPP_check_rc(int, ferror(), Sferror(s_)) 1040 | _SWI_CPP2_CPP_check_rc(int, seterr(int which, const char *message), Sseterr(s_, which, message)) 1041 | _SWI_CPP2_CPP_check_rc(int, set_exception(term_t ex), Sset_exception(s_, ex)) 1042 | _SWI_CPP2_CPP_check_rc(int, setenc(IOENC new_enc, IOENC *old_enc), Ssetenc(s_, new_enc, old_enc)) 1043 | _SWI_CPP2_CPP_check_rc(int, setlocale(struct PL_locale *new_loc, struct PL_locale **old_loc), Ssetlocale(s_, new_loc, old_loc)) 1044 | _SWI_CPP2_CPP_check_rc(int, flush(), Sflush(s_)) 1045 | _SWI_CPP2_CPP_check_rc(int64_t, size(), Ssize(s_)) 1046 | _SWI_CPP2_CPP_check_rc(int, seek(int64_t pos, int whence), Sseek64(s_, pos, whence)) 1047 | _SWI_CPP2_CPP_check_rc(int64_t, tell(), Stell64(s_)) 1048 | _SWI_CPP2_CPP_check_rc(int, close(), Sclose(s_)) 1049 | _SWI_CPP2_CPP_check_rc(int, gcclose(int flags), Sgcclose(s_, flags)) 1050 | _SWI_CPP2_CPP_check_rc(ssize_t, read_pending(char *buf, size_t limit, int flags), Sread_pending(s_, buf, limit, flags)) 1051 | _SWI_CPP2_CPP_nocheck(size_t, pending(), Spending(s_)) 1052 | _SWI_CPP2_CPP_check_rc(int, fputs(const char *q), Sfputs(q, s_)) 1053 | _SWI_CPP2_CPP_check_rc(int, vprintf(const char *fm, va_list args), Svfprintf(s_, fm, args)) 1054 | _SWI_CPP2_CPP_check_rc(int, lock(), Slock(s_)) 1055 | _SWI_CPP2_CPP_check_rc(int, tryLock(), StryLock(s_)) 1056 | _SWI_CPP2_CPP_check_rc(int, unlock(), Sunlock(s_)) 1057 | _SWI_CPP2_CPP_check_rc(int, fileno(), Sfileno(s_)) 1058 | _SWI_CPP2_CPP_check_rc(int64_t, tell64(), Stell64(s_)) 1059 | _SWI_CPP2_CPP_check_rc(int, seek64(int64_t pos, int whence), Sseek64(s_, pos, whence)) 1060 | _SWI_CPP2_CPP_check_rc(int, checkBOM(), ScheckBOM(s_)) 1061 | _SWI_CPP2_CPP_check_rc(int, writeBOM(), SwriteBOM(s_)) 1062 | _SWI_CPP2_CPP_check_brc(bool, qlf_get_int64(int64_t *ip), PL_qlf_get_int64(s_, ip)) 1063 | _SWI_CPP2_CPP_check_brc(bool, qlf_get_int32(int32_t *ip), PL_qlf_get_int32(s_, ip)) 1064 | _SWI_CPP2_CPP_check_brc(bool, qlf_get_uint32(uint32_t *ip), PL_qlf_get_uint32(s_, ip)) 1065 | _SWI_CPP2_CPP_check_brc(bool, qlf_get_double(double *fp), PL_qlf_get_double(s_, fp)) 1066 | _SWI_CPP2_CPP_check_brc(bool, qlf_get_atom(atom_t *a), PL_qlf_get_atom(s_, a)) 1067 | _SWI_CPP2_CPP_check_brc(bool, qlf_put_int64(int64_t i), PL_qlf_put_int64(i, s_)) 1068 | _SWI_CPP2_CPP_check_brc(bool, qlf_put_int32(int32_t i), PL_qlf_put_int32(i, s_)) 1069 | _SWI_CPP2_CPP_check_brc(bool, qlf_put_uint32(uint32_t i), PL_qlf_put_uint32(i, s_)) 1070 | _SWI_CPP2_CPP_check_brc(bool, qlf_put_double(double f), PL_qlf_put_double(f, s_)) 1071 | _SWI_CPP2_CPP_check_brc(bool, qlf_put_atom(atom_t a), PL_qlf_put_atom(a, s_)) 1072 | 1073 | _SWI_CPP2_CPP_inline 1074 | void 1075 | PlStream::clearerr() 1076 | { check_stream(); 1077 | Sclearerr(s_); 1078 | } 1079 | 1080 | _SWI_CPP2_CPP_inline 1081 | char * 1082 | PlStream::gets(char *buf, int n) 1083 | { check_stream(); 1084 | return Sfgets(buf, n, s_); 1085 | } 1086 | 1087 | _SWI_CPP2_CPP_inline 1088 | void 1089 | PlStream::setbuffer(char *buf, size_t size) 1090 | { check_stream(); 1091 | Ssetbuffer(s_, buf, size); 1092 | } 1093 | 1094 | _SWI_CPP2_CPP_inline 1095 | int 1096 | PlStream::printf(const char *fm, ...) 1097 | { va_list args; 1098 | int rval; 1099 | va_start(args, fm); 1100 | rval = vprintf(fm, args); 1101 | va_end(args); 1102 | return rval; 1103 | } 1104 | 1105 | _SWI_CPP2_CPP_inline 1106 | int 1107 | PlStream::printfX(const char *fm, ...) 1108 | { va_list args; 1109 | int rval; 1110 | va_start(args, fm); 1111 | rval = vprintf(fm, args); 1112 | va_end(args); 1113 | return rval; 1114 | } 1115 | 1116 | 1117 | #undef _SWI_CPP2_CPP_check_rc 1118 | #undef _SWI_CPP2_CPP_nocheck 1119 | 1120 | #endif /*_SWI_CPP2_CPP*/ 1121 | -------------------------------------------------------------------------------- /calc.cpp: -------------------------------------------------------------------------------- 1 | /* Translation of calc.c example to C++ 2 | (the "-goal true" in the following turns off the banner) 3 | 4 | swipl-ld -o calc -goal true calc.cpp calc.pl && ./calc 1 + 2 + 3 5 | */ 6 | 7 | #include 8 | #include 9 | 10 | int main(int argc, char **argv) { 11 | 12 | PlEngine e(argv[0]); 13 | 14 | // combine all the arguments in a single string 15 | std::string expression; 16 | for (int n = 1; n < argc; n++) { 17 | if (n != 1) { 18 | expression.append(" "); 19 | } 20 | expression.append(argv[n]); 21 | } 22 | 23 | // Lookup calc/1 and make the arguments and call 24 | 25 | PlPredicate pred("calc", 1, "user"); 26 | PlTerm_string h0(expression); 27 | PlQuery q(pred, PlTermv(h0), PL_Q_NORMAL); 28 | 29 | return q.next_solution() ? 0 : 1; 30 | } 31 | -------------------------------------------------------------------------------- /calc.pl: -------------------------------------------------------------------------------- 1 | calc(Atom) :- 2 | term_to_atom(Expr, Atom), 3 | A is Expr, 4 | write(A), 5 | nl. 6 | -------------------------------------------------------------------------------- /config.h.cmake: -------------------------------------------------------------------------------- 1 | #cmakedefine HAVE_GETHOSTNAME @HAVE_GETHOSTNAME@ 2 | -------------------------------------------------------------------------------- /likes.cpp: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | This example code is in the public domain 4 | */ 5 | 6 | #include 7 | #include 8 | #include 9 | 10 | using namespace std; 11 | 12 | /* Usage: 13 | 14 | likes prints who likes what 15 | likes x prints what is liked by x 16 | likes x y Test whether x likes y 17 | likes -happy See who is happy 18 | 19 | Compile using: 20 | 21 | swipl-ld -o likes -ld g++ -goal true likes.cpp likes.pl 22 | */ 23 | 24 | int 25 | body(int argc, char **argv) 26 | { if ( argc == 1 ) 27 | { if ( strcmp(argv[0], "-happy") == 0 ) 28 | { PlTermv av(1); /* likes -happy */ 29 | 30 | cout << "Happy people:" << endl; 31 | PlQuery q("happy", av); 32 | while( q.next_solution() ) 33 | cout << "\t" << av[0].as_string() << endl; 34 | } else 35 | { PlTerm_var whom; 36 | PlQuery q("likes", PlTermv(PlTerm_atom(argv[0]), whom)); 37 | cout << argv[0] << " likes:" << endl; 38 | while( q.next_solution() ) 39 | cout << "\t" << whom.as_string() << endl; 40 | } 41 | } else if ( argc == 2 ) 42 | { bool likes = PlCall("likes", 43 | PlTermv(PlTerm_atom(argv[0]), PlTerm_atom(argv[1]))); 44 | 45 | cout << (likes ? "yes" : "no") << endl; 46 | } else 47 | cout << "Usage: likes x [y] or likes -happy" << endl; 48 | 49 | return 0; 50 | } 51 | 52 | 53 | int 54 | main(int argc, char **argv) 55 | { PlEngine e(argv[0]); 56 | 57 | try 58 | { return body(argc-1, argv+1); 59 | } catch ( const PlExceptionBase &ex ) 60 | { cerr << "Exception thrown: " << ex.what() << endl; 61 | exit(1); 62 | } 63 | 64 | return 0; 65 | } 66 | 67 | 68 | -------------------------------------------------------------------------------- /likes.pl: -------------------------------------------------------------------------------- 1 | likes(mary,john). 2 | likes(mary,potplants). 3 | likes(mary,jane). 4 | likes(mary,paul). 5 | likes(mary,'Heartbreak High'). 6 | likes(john,mary). 7 | likes(fidothedog,mary). 8 | likes(mary,sunbathing). 9 | likes(bugs,mary). 10 | likes(john,'The X files'). 11 | likes(paul,mary). 12 | likes(paul,sue). 13 | 14 | person(mary). 15 | person(john). 16 | person(sue). 17 | person(paul). 18 | person(jane). 19 | 20 | happy(X) :- 21 | person(X), 22 | likes(Y, X), 23 | person(Y). 24 | -------------------------------------------------------------------------------- /main.cpp: -------------------------------------------------------------------------------- 1 | #include "SWI-cpp2.h" 2 | #include 3 | 4 | int 5 | main(int argc, char **argv) // TODO: char *argv[] 6 | { PlEngine e(argv[0]); 7 | // PlEngine can throw PlEngineInitialisationFailed or 8 | // PlOpenForeignFrameFailed 9 | 10 | try 11 | { PlTermv av(1); 12 | PlTerm_tail l(av[0]); 13 | 14 | try 15 | { for(int i=0; i(q1.next_solution()) ) 25 | { std::cerr << "*** q1 failed" << std::endl; 26 | return 1; 27 | } 28 | if ( PlWrap(q1.next_solution()) ) // There should be just 1 solution 29 | { std::cerr << "*** q1 2nd solution should have failed" << std::endl; 30 | return 2; 31 | } 32 | } 33 | { PlQuery q3("fail", PlTermv()); 34 | if ( PlWrap(q3.next_solution()) ) 35 | { std::cerr << "*** q3 should have failed" << std::endl; 36 | return 3; 37 | } 38 | } 39 | { PlQuery q4("writelnx", av); 40 | if ( !PlWrap(q4.next_solution()) ) 41 | { std::cerr << "*** q4 failed" << std::endl; 42 | return 4; 43 | } 44 | return 5; // writelnx should have thrown an existence error 45 | } 46 | } catch ( const PlException &ex ) 47 | { std::cerr << "ERROR: " << ex.what() << std::endl; 48 | return 254; 49 | } 50 | return 0; 51 | } 52 | -------------------------------------------------------------------------------- /test_cpp.pl: -------------------------------------------------------------------------------- 1 | % -*- mode: Prolog; coding: utf-8 -*- 2 | 3 | /* Part of SWI-Prolog 4 | 5 | Author: Jan Wielemaker and Peter Ludemann 6 | E-mail: J.Wielemaker@vu.nl 7 | WWW: http://www.swi-prolog.org 8 | Copyright (c) 2022-2024, SWI-Prolog Solutions b.v. 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in 20 | the documentation and/or other materials provided with the 21 | distribution. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | /* This tests the examples in the SWI-cpp2.h documentation. */ 38 | 39 | :- module(test_cpp, 40 | [ test_cpp/0 41 | ]). 42 | :- use_module(library(debug)). 43 | :- use_module(library(lists)). 44 | :- use_module(library(apply)). 45 | :- autoload(library(aggregate)). 46 | :- use_module(library(plunit)). 47 | :- use_module(library(dcg/basics)). 48 | :- use_module(library(dcg/high_order)). 49 | 50 | :- encoding(utf8). 51 | 52 | :- use_foreign_library(foreign(test_cpp)). 53 | 54 | :- dynamic user:file_search_path/2. 55 | :- multifile user:file_search_path/2. 56 | 57 | :- prolog_load_context(directory, Dir), 58 | asserta(user:file_search_path(my_program_home, Dir)). 59 | 60 | :- multifile user:portray/1. 61 | 62 | user:portray(MyBlob) :- 63 | blob(MyBlob, my_blob), !, 64 | portray_my_blob(current_output, MyBlob). 65 | 66 | user:portray(MyFileBlob) :- 67 | blob(MyFileBlob, my_file_blob), !, 68 | my_file_blob_portray(current_output, MyFileBlob). 69 | 70 | % test_cpp :- 71 | % run_tests([ cpp, 72 | % cpp_atommap, 73 | % cpp_map_str_str 74 | % ]). 75 | 76 | test_cpp :- 77 | run_tests. 78 | 79 | % Some of the tests can result in crashes if there's a bug, so the 80 | % `output(on_failure)` option results in nothing being written. 81 | % If so, uncomment the following line 82 | % :- set_test_options([output(always), format(log)]). 83 | 84 | :- begin_tests(cpp). 85 | 86 | test(unwrap) :- 87 | unwrap(foo(1)), 88 | unwrap(bar), 89 | unwrap("qqsv"). 90 | 91 | test(hello, Out == "hello hello hello") :- 92 | % hello :- write('hello hello hello') 93 | with_output_to(string(Out), hello). 94 | 95 | test(hello, Out == "Hello WORLD\nHello WORLD\nHello WORLD\nHello WORLD\nHello WORLD\n") :- 96 | hello("WORLD", Out). 97 | test(hello, error(representation_error(encoding))) :- 98 | hello("世界", _Out). 99 | 100 | % The following might give a different result, depending on locale: 101 | test(hello2, Out == "Hello2 world2\nHello2 world2\nHello2 world2\nHello2 world2\nHello2 world2\n") :- 102 | hello2(world2, Out). 103 | 104 | test(hello3, Out == "Hello3 世界弐\n") :- 105 | hello3(世界弐, Out). 106 | 107 | test(hello4, Out == hello(world)) :- 108 | hello4(Out). 109 | 110 | test(call_cpp, Out == "hello(foo)\n") :- 111 | with_output_to(string(Out), call_cpp(writeln(hello(foo)))). 112 | test(call_cpp, Out == "hello(世界四)\n") :- 113 | with_output_to(string(Out), call_cpp(writeln(hello(世界四)))). 114 | test(call_cpp, error(existence_error(procedure,unknown_pred/1))) :- 115 | call_cpp(unknown_pred(hello(世界四))). 116 | test(call_cpp, fail) :- 117 | call_cpp(atom(hello(foo))). 118 | 119 | test(call_cpp, Ex == "no exception") :- 120 | call_cpp_ex(writeln(hello(世界四)), Ex). 121 | test(call_cpp) :- 122 | call_cpp_ex(unknown_pred(hello(世界四)), Ex), 123 | assertion(subsumes_term(error(existence_error(procedure, unknown_pred/1), _), Ex)). 124 | 125 | test(call_cpp, Out == "hello(世界四)\n") :- 126 | with_output_to(string(Out), call_cpp(writeln, hello(世界四))). 127 | test(call_cpp, error(existence_error(procedure,unknown_pred/1))) :- 128 | call_cpp(unknown_pred, hello(世界四)). 129 | test(call_cpp, fail) :- 130 | call_cpp(atom, hello(foo)). 131 | 132 | test(as_string, S == "foo") :- 133 | atom_to_string(foo, S). 134 | test(as_string, S == "foo(bar)") :- 135 | term_to_string(foo(bar), S). 136 | 137 | % Note: atom_to_string/2 and term_to_string/2 translate the data 138 | % to a UTF-8 string. We currenly do not support encoding for 139 | % PlTerm.unify_string(), so we get as result the byte encoding 140 | % of the UTF8 data. 141 | test(as_string, S == "ä¸\u0096ç\u0095\u008Cå\u009B\u009B") :- 142 | atom_to_string(世界四, S). 143 | test(as_string, S == "hello(ä¸\u0096ç\u0095\u008Cå\u009B\u009B)") :- 144 | term_to_string(hello(世界四), S). 145 | 146 | test(add_3, Result == 666) :- 147 | add(667, -1, Result). 148 | test(add_3, Result == 123) :- 149 | add(100, 23, Result). 150 | test(add_3_err, error(type_error(integer,0.1))) :- 151 | add(666, 0.1, _). 152 | 153 | test(add_num_3, Result == 666) :- 154 | add_num(555, 111, Result). 155 | test(add_num_3, Result == 666.6) :- 156 | add_num(555.2, 111.4, Result). 157 | test(add_num_3, error(type_error(float,"abc"))) :- 158 | add_num(123, "abc", _Result). 159 | 160 | testing:p(1). % For average/3 test 161 | testing:p(10). 162 | testing:p(20). 163 | 164 | test(average_3, Average =:= Expected) :- 165 | average(X, testing:p(X), Average), 166 | Expected is (1+10+20)/3 . 167 | test(average_3, Average =:= Expected) :- 168 | average(X, between(1,6,X), Average), 169 | aggregate(sum(X)/count, between(1,6,X), A), 170 | Expected is A. 171 | 172 | call_cut_test :- 173 | setup_call_cleanup(true, 174 | between(1, 5, _X), 175 | atom_codes(_,_)). 176 | 177 | test(call_cut, error(existence_error(procedure,call_cut_test/0))) :- 178 | % This tests that an error in ~PlQuery() is handled properly 179 | % See discussion: https://github.com/SWI-Prolog/packages-cpp/pull/27 180 | call_cut("call_cut_test"). 181 | 182 | test(term_1, Term == hello(world)) :- 183 | term(Term). 184 | 185 | test(term_2, Result == 'hello world') :- 186 | term(atom, Result). 187 | test(term_2, Result == "hello world") :- 188 | term(string, Result). 189 | test(term_2, Result == [104,101,108,108,111,32,119,111,114,108,100]) :- 190 | term(code_list, Result). 191 | test(term_2, Result == [h,e,l,l,o,' ',w,o,r,l,d]) :- 192 | term(char_list, Result). 193 | test(term_1, Result == hello(world)) :- 194 | term(term, Result). 195 | test(term_1, error(domain_error(type,foo))) :- 196 | term(foo, _Result). 197 | 198 | test(can_unify, [true(X\==Y)]) :- 199 | can_unify(f(X), f(Y)). 200 | test(can_unify) :- 201 | can_unify(a(X), a(1)), 202 | assertion(var(X)). 203 | test(can_unify, fail) :- 204 | can_unify(a(1), a(2)). 205 | 206 | test(can_unify_ffi, [true(X\==Y)]) :- 207 | can_unify_ffi(f(X), f(Y)). 208 | test(can_unify_ffi) :- 209 | can_unify_ffi(a(X), a(1)), 210 | assertion(var(X)). 211 | test(can_unify_ffi, fail) :- 212 | can_unify_ffi(a(1), a(2)). 213 | 214 | test(call_chars, Out=="1") :- 215 | with_output_to(string(Out), call_chars("X=1, write(X)")). 216 | test(call_chars, Out=="1") :- 217 | with_output_to(string(Out), call_chars('X=1, write(X)')). 218 | test(call_chars, fail) :- 219 | call_chars("1=2"). 220 | test(call_chars, error(syntax_error(operator_expected),string("1(2 . ",0))) :- 221 | call_chars("1(2"). 222 | 223 | % Note: unify_error has additional tests for eq1/2 224 | test(eq1_2, X == a) :- 225 | eq1(foo(X), foo(a)). 226 | test(eq1_2, fail) :- 227 | eq1(foo(_X), bar(a)). 228 | 229 | test(make_integer_2, X == 123) :- 230 | make_uint64(123, X). 231 | test(make_integer) :- 232 | X = 666, 233 | Y = 666, 234 | make_uint64(X, 666), 235 | make_uint64(666, 666), 236 | make_uint64(X, Y). 237 | test(make_integer_2, fail) :- 238 | make_uint64(123, 124). 239 | 240 | :- if(current_prolog_flag(bounded,false)). 241 | test(make_uint64_2, error(representation_error(uint64_t))) :- 242 | Val is 0xffffffffffffffff + 999, % uses extended integers 243 | make_uint64(Val, _Y). 244 | :- endif. 245 | 246 | test(make_uint64_2, error(domain_error(not_less_than_zero,-1))) :- 247 | make_uint64(-1, _Y). 248 | 249 | test(make_int64_2, X == 123) :- 250 | make_int64(123, X). 251 | test(make_int64_2) :- 252 | X = 666, 253 | Y = 666, 254 | make_int64(X, 666), 255 | make_int64(666, 666), 256 | make_int64(X, Y). 257 | test(make_int64_2, fail) :- 258 | make_int64(123, 124). 259 | test(make_int64_2, error(type_error(integer,abc))) :- 260 | make_int64(abc, _Y). 261 | 262 | :- if(current_prolog_flag(bounded,false)). 263 | test(make_int64_2, error(representation_error(int64_t))) :- 264 | Val is 0xffffffffffffffff + 999, % uses extended integers 265 | make_int64(Val, _Y). 266 | :- endif. 267 | 268 | test(make_int64_2, Y == -1) :- 269 | make_int64(-1, Y). 270 | 271 | test(hostname, [Host == Host2]) :- 272 | hostname(Host), 273 | hostname2(Host2). 274 | 275 | test(cappend, Result == [a,b,c,d,e]) :- 276 | cappend([a,b,c], [d,e], Result). 277 | test(cappend) :- 278 | cappend([a,b,c], [d,e], [a,b,c,d,e]). 279 | test(cappend, fail) :- 280 | cappend([a,b,c], [d,e], [a,b,c,d]). 281 | test(cappend, fail) :- 282 | cappend([a,b,c], [d,e], [a,b,c,d,e,f]). 283 | test(cappend, fail) :- 284 | cappend([a,b,c], [d,e], [a,b,c,d,e|f]). 285 | 286 | test(cpp_call, Out == "abc\n") :- 287 | with_output_to(string(Out), 288 | cpp_call(writeln(abc), [normal])). 289 | 290 | cpp_call(Goal, Flags) :- 291 | query_flags(Flags, CombinedFlag), 292 | cpp_call_(Goal, CombinedFlag, false). 293 | 294 | test(square_roots_2, Result == [0.0, 1.0, 1.4142135623730951, 1.7320508075688772, 2.0]) :- 295 | square_roots(4, Result). 296 | 297 | :- meta_predicate with_small_stacks(+, 0). 298 | with_small_stacks(Free, Goal) :- 299 | force_gc, 300 | statistics(globalused, G), 301 | statistics(trailused, T), 302 | statistics(localused, L), 303 | NewLimit is G+L+T+Free, 304 | current_prolog_flag(stack_limit, Old), 305 | setup_call_cleanup( 306 | set_prolog_flag(stack_limit, NewLimit), 307 | Goal, 308 | set_prolog_flag(stack_limit, Old)). 309 | 310 | test(square_roots_2, error(resource_error(stack))) :- 311 | with_small_stacks(5 000 000, % 400 000 seems to be about the smallest allowed value 312 | square_roots(1000000000, _)). 313 | 314 | test(malloc) :- 315 | malloc_new(1000, Result), % smoke test 316 | free_delete(Result). 317 | 318 | test(malloc) :- 319 | malloc_malloc(1000, Result), % smoke test 320 | free_malloc(Result). 321 | 322 | test(malloc) :- 323 | malloc_PL_malloc(1000, Result), % smoke test 324 | free_PL_malloc(Result). 325 | 326 | :- if(\+ current_prolog_flag(asan, true)). 327 | too_big_alloc_request(Request) :- 328 | current_prolog_flag(address_bits, Bits), 329 | ( Bits == 32 330 | -> Request = 0xffffffff 331 | ; Bits == 64 332 | -> Request = 0xffffffffffffffff 333 | % 0x10000000000 is ASAN maximum on 64-bit machines 334 | ; assertion(memberchk(Bits, [32,64])) 335 | ). 336 | 337 | :- if(current_prolog_flag(bounded,false)). 338 | 339 | too_many_bits_alloc_request(Request) :- 340 | % This assumes size_t is no more than 64 bits: 341 | current_prolog_flag(address_bits, Bits), 342 | ( Bits == 32 343 | -> Request is 0xffffffff + 1 344 | ; Bits == 64 345 | -> Request is 0xffffffffffffffff + 1 346 | ; assertion(memberchk(Bits, [32,64])) 347 | ). 348 | 349 | :- endif. 350 | 351 | test(malloc, error(resource_error(memory))) :- 352 | too_big_alloc_request(Request), 353 | malloc_new(Request, _Result). 354 | 355 | :- if(current_prolog_flag(bounded,false)). 356 | 357 | test(malloc) :- 358 | too_many_bits_alloc_request(Request), 359 | catch( ( malloc_new(Request, Result), 360 | free_delete(Result) 361 | ), 362 | error(E,_), true), 363 | assertion(memberchk(E, [representation_error(_), % representation_error(uint64_t) 364 | type_error(integer,_)])). 365 | 366 | 367 | :- endif. 368 | 369 | % ASAN has maximum 0x10000000000 370 | % see ASAN_OPTIONS=allocator_may_return_null=1:soft_rss_limit_mb=...:hard_rss_limit_mb=... 371 | % https://github.com/google/sanitizers/issues/295 372 | % https://github.com/google/sanitizers/issues/740 373 | 374 | test(new_chars_2, error(resource_error(memory))) :- 375 | too_big_alloc_request(Request), 376 | new_chars(Request, Result), 377 | delete_chars(Result). 378 | 379 | :- if(current_prolog_flag(bounded,false)). 380 | 381 | test(new_chars_2) :- 382 | too_many_bits_alloc_request(Request), 383 | catch( ( new_chars(Request, Result), 384 | delete_chars(Result) 385 | ), 386 | error(E,_), true), 387 | assertion(memberchk(E, [representation_error(_), 388 | type_error(integer,_)])). 389 | 390 | :- endif. 391 | :- endif. 392 | 393 | test(new_chars_2) :- 394 | new_chars(1000, Result), % smoke test 395 | delete_chars(Result). 396 | 397 | test(name_arity, Out == "name = foo, arity = 2\n") :- 398 | with_output_to(string(Out), 399 | name_arity(foo(bar,zot))). 400 | 401 | test(name_arity, Out == "name = foo, arity = 2\n") :- 402 | name_arity(foo(bar,zot), Out). 403 | 404 | test(name_arity) :- 405 | name_arity(foo(bar,zot), Name, Arity), 406 | assertion(Name == foo), 407 | assertion(Arity == 2). 408 | 409 | test(name_arity) :- 410 | name_arity_bool(foo(bar,zot), Name, Arity), 411 | assertion(Name == foo), 412 | assertion(Arity == 2). 413 | test(name_arity, error(type_error(compound,"foo"))) :- 414 | name_arity("foo", _, _). 415 | test(name_arity, fail) :- 416 | name_arity_bool("bar", _, _). 417 | 418 | test(list_modules_0) :- 419 | list_modules(Text), 420 | split_string(Text, "\n", "", Strings), 421 | forall(( member(S, Strings), S \== ""), 422 | ( atom_string(M, S), 423 | current_module(M))). 424 | 425 | test(my_object, Contents == "foo-bar") :- 426 | make_my_object(MyObject), 427 | my_object_contents(MyObject, Contents), 428 | free_my_object(MyObject). 429 | 430 | test(make_functor_3, F == foo(x)) :- 431 | make_functor(foo, x, F). 432 | test(make_functor_3, error(type_error(atom,123))) :- 433 | make_functor(123, x, _). 434 | test(make_functor_3) :- 435 | make_functor(bar, 123, bar(123)). 436 | test(make_functor_3, fail) :- 437 | make_functor(bar, 123, bar(666)). 438 | test(make_functor_3, fail) :- 439 | make_functor(bar, 123, qqsv(123)). 440 | test(make_functor_3, Z==6.66) :- 441 | make_functor(bbb, Z, F), 442 | F = bbb(6.66). 443 | 444 | test(cpp_arg, A == bar) :- 445 | cpp_arg(1, foo(bar,zot), A). 446 | test(cpp_arg, A == zot) :- 447 | cpp_arg(2, foo(bar,zot), A). 448 | test(cpp_arg, error(domain_error(arity,3))) :- 449 | cpp_arg(3, foo(bar,zot), _A). 450 | test(cpp_arg, error(domain_error(not_less_than_zero,0))) :- 451 | cpp_arg(0, foo(bar,zot), _A). 452 | test(cpp_arg, error(domain_error(not_less_than_zero,-2))) :- 453 | cpp_arg(-2, foo(bar,zot), _A). 454 | test(cpp_arg, error(type_error(compound,foo))) :- 455 | cpp_arg(1, foo, _A). 456 | 457 | % The following are for verifying some documentation details, and for 458 | % ensuring that various mechanisms for reporting failure and 459 | % exceptions behave as expected. 460 | 461 | test(c_PL_unify_nil, X == []) :- 462 | c_PL_unify_nil(X). 463 | test(c_PL_unify_nil) :- 464 | c_PL_unify_nil([]). 465 | test(c_PL_unify_nil, fail) :- 466 | c_PL_unify_nil(abc). 467 | 468 | test(c_PL_unify_nil_ex, X == []) :- 469 | c_PL_unify_nil_ex(X). 470 | test(c_PL_unify_nil_ex) :- 471 | c_PL_unify_nil_ex([]). 472 | test(c_PL_unify_nil_ex, error(type_error(list,abc))) :- 473 | c_PL_unify_nil_ex(abc). 474 | 475 | test(check_c_PL_unify_nil, X == []) :- 476 | check_c_PL_unify_nil(X). 477 | test(check_c_PL_unify_nil) :- 478 | check_c_PL_unify_nil([]). 479 | % The following error is subject to change: 480 | test(check_c_PL_unify_nil, error(unknown_error('False return code without exception'))) :- 481 | check_c_PL_unify_nil(abc). 482 | 483 | test(check_c_PL_unify_nil_ex, X == []) :- 484 | check_c_PL_unify_nil_ex(X). 485 | test(check_c_PL_unify_nil_ex) :- 486 | check_c_PL_unify_nil_ex([]). 487 | test(check_c_PL_unify_nil_ex, error(type_error(list,abc))) :- 488 | check_c_PL_unify_nil_ex(abc). 489 | 490 | test(cpp_unify_nil, X == []) :- 491 | cpp_unify_nil(X). 492 | test(cpp_unify_nil) :- 493 | cpp_unify_nil([]). 494 | test(cpp_unify_nil, fail) :- 495 | cpp_unify_nil(abc). 496 | 497 | test(cpp_unify_nil_ex, X == []) :- 498 | cpp_unify_nil_ex(X). 499 | test(cpp_unify_nil_ex) :- 500 | cpp_unify_nil_ex([]). 501 | test(cpp_unify_nil_ex, error(type_error(list,abc))) :- 502 | cpp_unify_nil_ex(abc). 503 | 504 | % The following are for verifying that an exception in 505 | % PL_occurs_term() is handled properly - exceptions such as 506 | % out-of-stack should behave the same way, if they don't result in a 507 | % fatal error. The same set of tests are repeated for eq1/2, eq2/2, 508 | % eq3/2. 509 | 510 | test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF), 511 | set_prolog_flag(occurs_check, error) )), 512 | cleanup( set_prolog_flag(occurs_check, OCF) ), 513 | error(occurs_check(B,f(B))) ]) :- 514 | eq1(X, f(X)). 515 | 516 | test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF), 517 | set_prolog_flag(occurs_check, true) )), 518 | cleanup( set_prolog_flag(occurs_check, OCF) ), 519 | fail]) :- 520 | eq1(X, f(X)). 521 | 522 | test(unify_error, [ setup(( prolog_flag(occurs_check, OCF), 523 | set_prolog_flag(occurs_check, false) )), 524 | cleanup( set_prolog_flag(occurs_check, OCF) ), 525 | true]) :- 526 | eq1(X, f(X)). 527 | 528 | % Repeat the unify_error test, using eq2/2: 529 | 530 | test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF), 531 | set_prolog_flag(occurs_check, error) )), 532 | cleanup( set_prolog_flag(occurs_check, OCF) ), 533 | error(occurs_check(B,f(B))) ]) :- 534 | eq2(X, f(X)). 535 | 536 | test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF), 537 | set_prolog_flag(occurs_check, true) )), 538 | cleanup( set_prolog_flag(occurs_check, OCF) ), 539 | fail]) :- 540 | eq2(X, f(X)). 541 | 542 | test(unify_error, [ setup(( prolog_flag(occurs_check, OCF), 543 | set_prolog_flag(occurs_check, false) )), 544 | cleanup( set_prolog_flag(occurs_check, OCF) ), 545 | true]) :- 546 | eq2(X, f(X)). 547 | 548 | % Repeat the unify_error test, using eq3/2: 549 | 550 | test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF), 551 | set_prolog_flag(occurs_check, error) )), 552 | cleanup( set_prolog_flag(occurs_check, OCF) ), 553 | error(occurs_check(B,f(B))) ]) :- 554 | eq3(X, f(X)). 555 | 556 | test(unify_error, [ setup(( current_prolog_flag(occurs_check, OCF), 557 | set_prolog_flag(occurs_check, true) )), 558 | cleanup( set_prolog_flag(occurs_check, OCF) ), 559 | fail]) :- 560 | eq3(X, f(X)). 561 | 562 | test(unify_error, [ setup(( prolog_flag(occurs_check, OCF), 563 | set_prolog_flag(occurs_check, false) )), 564 | cleanup( set_prolog_flag(occurs_check, OCF) ), 565 | true]) :- 566 | eq3(X, f(X)). 567 | 568 | % TODO: Add tests for as_string(enc), such as enc=EncLatin1 and atom is non-ascii 569 | % ... for PlTerm::as_string() where term isn't an atom 570 | 571 | 572 | % Tests from test_ffi.pl, for functions translated from ffi4pl.c: 573 | 574 | test(range_cpp, all(X == [1,2])) :- 575 | range_cpp(1, 3, X). 576 | test(range_cpp, all(X == [-2,-1,0,1,2])) :- 577 | range_cpp(-2, 3, X). 578 | test(range_cpp, all(X == [0])) :- 579 | range_cpp(0, 1, X). 580 | test(range_cpp, all(X == [10])) :- 581 | range_cpp(10, 11, X). 582 | test(range_cpp, all(X == [-2])) :- 583 | range_cpp(-2, -1, X). 584 | test(range_cpp, fail) :- 585 | range_cpp(1, 1, _X). 586 | test(range_cpp, fail) :- 587 | range_cpp(0, 0, _X). 588 | test(range_cpp, fail) :- 589 | range_cpp(-1, -1, _X). 590 | test(range_cpp, fail) :- 591 | range_cpp(1, 2, 2). 592 | test(range_cpp, X == 1) :- % Will produce warning if non-deterministic 593 | range_cpp(1, 2, X). 594 | test(range_cpp, error(type_error(integer,a))) :- 595 | range_cpp(a, 10, _). 596 | test(range_cpp, error(type_error(integer,foo))) :- 597 | range_cpp(1, foo, _). 598 | 599 | % TODO: not finished -- use nb_set and friends to preserve 600 | % first 2 results 601 | range_2(From, To, Result) :- 602 | ( range_cpp(From, To, _), 603 | fail 604 | *-> true 605 | ; range_cpp(From, To, Result) 606 | ). 607 | 608 | 609 | % This is test wchar_1 in test_ffi.pl: 610 | test(wchar_1, all(Result == ["//0", "/ /1", 611 | "/abC/3", 612 | "/Hello World!/12", 613 | "/хелло/5", 614 | "/хелло 世界/8", 615 | "/網目錦へび [àmímé níshíkíhéꜜbì]/26"])) :- 616 | ( w_atom_cpp('', Result) 617 | ; w_atom_cpp(' ', Result) 618 | ; w_atom_cpp('abC', Result) 619 | ; w_atom_cpp('Hello World!', Result) 620 | ; w_atom_cpp('хелло', Result) 621 | ; w_atom_cpp('хелло 世界', Result) 622 | ; w_atom_cpp('網目錦へび [àmímé níshíkíhéꜜbì]', Result) 623 | ). 624 | 625 | % TODO: decouple this test from message hooks 626 | % ('$messages':message_to_string/2 or print_message/'$write_on_string'/2): 627 | test(type_error_string) :- 628 | type_error_string('foo-bar', _S, T), 629 | assertion(unifiable(T, error(type_error(foofoo,'foo-bar'),A), [A=B])), 630 | % TODO: when PlException::string_term() is revived (using '$messages':message_to_string/2), 631 | % add the following assertion: 632 | % assertion(S == "Type error: `foofoo' expected, found `'foo-bar'' (an atom)"]) 633 | assertion(var(A)), 634 | assertion(var(B)), 635 | assertion(A\==B). 636 | 637 | :- if(\+ current_prolog_flag(asan, true)). 638 | 639 | % TODO: a better test that name_to_terms("two", X, "deux") cleans up `X` 640 | test(name_to_terms, [T1,T2] = [1,"eins"]) :- 641 | name_to_terms("one", T1, T2). 642 | test(name_to_terms, [T1,T2] = [2,"zwei"]) :- 643 | name_to_terms("two", T1, T2). 644 | test(name_to_terms, fail) :- 645 | name_to_terms("foo", _, _). 646 | test(name_to_terms, fail) :- 647 | name_to_terms("two", _, "deux"). 648 | test(name_to_terms, error(type_error('atom or string',A))) :- 649 | name_to_terms(A, 1, 2). 650 | 651 | test(name_to_terms2, [T1,T2] = [1,"eins"]) :- 652 | name_to_terms2("one", T1, T2). 653 | test(name_to_terms2, [T1,T2] = [2,"zwei"]) :- 654 | name_to_terms2("two", T1, T2). 655 | test(name_to_terms2, fail) :- 656 | name_to_terms2("foo", _, _). 657 | test(name_to_terms2, fail) :- 658 | name_to_terms2("two", _, "deux"). 659 | 660 | % test(int_info) causes a memory leak because the IntInfo map doesn't 661 | % destruct the elements on cleanup. (At least, I think that's the 662 | % cause of the memory leak.) 663 | 664 | test(int_info) :- 665 | findall(Name:Info, int_info(Name, Info), Infos), 666 | assertion(memberchk(uint32_t:int_info(uint32_t,4,0,4294967295), Infos)). 667 | test(int_info, [nondet, Name:Info == uint32_t:int_info(uint32_t,4,0,4294967295)]) :- 668 | Info = int_info(_,_,0,_), 669 | int_info(Name, Info), 670 | Info = int_info(uint32_t,_,_,_). 671 | test(int_info) :- 672 | Info = int_info(_,_,0,_), 673 | findall(Name:Info, int_info(Name, Info), Infos), 674 | assertion(memberchk(uint16_t:int_info(uint16_t,2,0,65535), Infos)). 675 | test(int_info) :- 676 | Info = int_info(_,_,-128,_), % skip over first result: int_info(bool,1,0,1) 677 | int_info(_Name, Info), 678 | !. 679 | test(int_info) :- 680 | int_info(_Name, Info), 681 | Info = int_info(_,_,-128,_), % force backtracking 682 | !. 683 | 684 | test(int_info2) :- 685 | findall(Name:Info, int_info2(Name, Info), Infos), 686 | assertion(memberchk(uint32_t:int_info(uint32_t,4,0,4294967295), Infos)). 687 | test(int_info2, [nondet, Name:Info == uint32_t:int_info(uint32_t,4,0,4294967295)]) :- 688 | Info = int_info(_,_,0,_), 689 | int_info2(Name, Info), 690 | Info = int_info(uint32_t,_,_,_). 691 | test(int_info2) :- 692 | Info = int_info(_,_,0,_), 693 | findall(Name:Info, int_info2(Name, Info), Infos), 694 | assertion(memberchk(uint16_t:int_info(uint16_t,2,0,65535), Infos)). 695 | test(int_info2) :- 696 | Info = int_info(_,_,-128,_), % skip over first result: int_info(bool,1,0,1) 697 | int_info2(_Name, Info), 698 | !. 699 | test(int_info2) :- 700 | int_info2(_Name, Info), 701 | Info = int_info(_,_,-128,_), % force backtracking 702 | !. 703 | 704 | :- endif. 705 | 706 | % int_info_cut test checks that PL_PRUNED works as expected: 707 | test(int_info_cut, Name:Info == bool:int_info(bool, 1, 0, 1)) :- 708 | int_info(Name, Info), !. 709 | 710 | test(cvt_i_bool, R == 1) :- cvt_i_bool(true, R). 711 | test(cvt_i_bool, R == 1) :- cvt_i_bool(on, R). 712 | test(cvt_i_bool, R == 1) :- cvt_i_bool(1, R). 713 | test(cvt_i_bool, error(type_error(bool,666))) :- cvt_i_bool(666, _R). 714 | test(cvt_i_bool, error(type_error(bool,-666))) :- cvt_i_bool(-666, _R). 715 | :- if(current_prolog_flag(bounded,false)). 716 | test(cvt_i_bool, error(type_error(bool,18446744073709552614))) :- 717 | Val is 0xffffffffffffffff + 999, % uses extended integers 718 | cvt_i_bool(Val, _R). 719 | :- endif. 720 | test(cvt_i_bool, R == 0) :- cvt_i_bool(false, R). 721 | test(cvt_i_bool, R == 0) :- cvt_i_bool(off, R). 722 | test(cvt_i_bool, R == 0) :- cvt_i_bool(0, R). 723 | test(cvt_i_bool, error(type_error(bool,'FALSE'))) :- cvt_i_bool('FALSE', _R). 724 | test(cvt_i_bool, error(type_error(bool,0.0))) :- cvt_i_bool(0.0, _R). 725 | test(cvt_i_bool, error(type_error(bool,"false"))) :- cvt_i_bool("false", _R). 726 | 727 | test(scan_options, [R =@= options(1, 5, foo(bar), _, "")]) :- % Note use of (=@=)/2 because of uninstantiated variable 728 | cpp_options([quoted(true), length(5), callback(foo(bar))], false, R). 729 | test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :- 730 | cpp_options([token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar))], false, R). 731 | test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :- 732 | cpp_options([token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar)), unknown_option(blah)], false, R). 733 | test(scan_options, [error(domain_error(cpp_options,unknown_option(blah)))]) :- 734 | cpp_options([token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar)), unknown_option(blah)], true, _). 735 | test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :- 736 | cpp_options(options{token:qqsv, descr:"DESCR", quoted:true, length:5, callback:foo(bar)}, false, R). 737 | test(scan_options, [R == options(1, 5, foo(bar), qqsv, "DESCR")]) :- 738 | cpp_options([token(qqsv), descr("DESCR"), quoted, length(5), callback(foo(bar))], false, R). 739 | test(scan_options, [R == options(0, 5, foo(bar), qqsv, "DESCR")]) :- 740 | cpp_options([token(qqsv), descr("DESCR"), length(5), callback(foo(bar))], false, R). 741 | test(scan_options, [error(instantiation_error)]) :- 742 | cpp_options([token(qqsv), _, descr("DESCR"), length(5), callback(foo(bar))], false, _). 743 | test(scan_options, [error(type_error(option,123))]) :- % TODO: is this intended behavior? 744 | cpp_options([token(qqsv), descr("DESCR"), 123, length(5), callback(foo(bar))], false, _R). 745 | test(scan_options, [error(type_error(option,123))]) :- % TODO: is this intended behavior? 746 | cpp_options([token(qqsv), 123, descr("DESCR"), length(5), callback(foo(bar))], false, _R). 747 | test(scan_options, [error(domain_error(cpp_options,unknown_option:blah))]) :- 748 | cpp_options(options{token:qqsv, descr:"DESCR", quoted:true, length:5, callback:foo(bar), unknown_option:blah}, true, _). 749 | 750 | test(error_term, error(domain_error(footype,qqsv("ABC")),context(throw_domain_cpp0/1,_Msg))) :- 751 | throw_domain_cpp0(qqsv("ABC")). 752 | 753 | test(error_term, [error(domain_error(footype,qqsv("ABC")),_)]) :- 754 | throw_domain_cpp1(qqsv("ABC")). 755 | 756 | test(error_term, error(domain_error(footype,qqsv("ABC")),context(throw_domain_cpp2/1,_Msg))) :- 757 | throw_domain_cpp2(qqsv("ABC")). 758 | 759 | test(error_term, error(domain_error(footype,qqsv("ABC")),context(throw_domain_cpp3/1,_Msg))) :- 760 | throw_domain_cpp3(qqsv("ABC")). 761 | 762 | test(error_term, [error(domain_error(footype,qqsv("ABC")),_)]) :- 763 | throw_domain_cpp4(qqsv("ABC")). 764 | 765 | test(throw, error(uninstantiation_error(abc),_)) :- 766 | throw_uninstantiation_error_cpp(abc). 767 | 768 | test(throw, error(representation_error(some_resource))) :- 769 | throw_representation_error_cpp(some_resource). 770 | 771 | test(throw, error(type_error(int, "abc"))) :- 772 | throw_type_error_cpp(int, "abc"). 773 | 774 | test(throw, error(type_error(float, abc))) :- 775 | throw_and_check_error_cpp(float, abc). 776 | 777 | test(throw, error(domain_error(positive, -5))) :- 778 | throw_domain_error_cpp(positive, -5). 779 | 780 | test(throw, error(existence_error(something_something, foo:bar/2))) :- 781 | throw_existence_error_cpp(something_something, foo:bar/2). 782 | 783 | test(throw, error(permission_error(operation, type, the(culprit)))) :- 784 | throw_permission_error_cpp(operation, type, the(culprit)). 785 | 786 | test(throw, error(resource_error('NO_RESOURCE'))) :- 787 | throw_resource_error_cpp('NO_RESOURCE'). 788 | 789 | test(compare) :- 790 | eq_int64(1, 1). 791 | test(compare, fail) :- 792 | eq_int64(1, 2). 793 | test(compare, error(type_error(integer,a))) :- 794 | eq_int64(1, a). 795 | test(compare, error(type_error(integer,b))) :- 796 | eq_int64(b, 1). 797 | test(compare) :- 798 | lt_int64(1, 2). 799 | test(compare, fail) :- 800 | lt_int64(2, 1). 801 | test(compare, error(type_error(integer,a))) :- 802 | lt_int64(1, a). 803 | test(compare, error(type_error(integer,b))) :- 804 | lt_int64(b, 1). 805 | 806 | test(get_atom, A == abc) :- 807 | get_atom_ex(abc, A). 808 | test(get_atom) :- 809 | get_atom_ex(abc, abc). 810 | test(get_atom, fail) :- 811 | get_atom_ex(abc, abcd). 812 | test(get_atom, error(type_error(atom,"abc"))) :- 813 | get_atom_ex("abc", _A). 814 | test(get_atom, error(type_error(atom,123))) :- 815 | get_atom_ex(123, _A). 816 | test(get_atom, error(type_error(atom,foo(bar)))) :- 817 | get_atom_ex(foo(bar), _A). 818 | 819 | test(ten, 820 | [[A1, A2, A3, A4, A5, A6, A7, A8, A9, A10] == 821 | [one, two, three, 4, 5.0, "six", seven("SEVEN"), [], true, [hd]]]) :- 822 | ten(A1, A2, A3, A4, A5, A6, A7, A8, A9, A10). 823 | 824 | test(blob) :- 825 | create_my_blob(foo, Blob), 826 | assertion(blob(Blob, my_blob)), 827 | close_my_blob(Blob). 828 | test(blob, error(my_blob_open_error(_),_)) :- 829 | create_my_blob('-FAIL_open-', _). 830 | test(blob, error(my_blob_close_error(Blob))) :- 831 | create_my_blob('-FAIL_close-', Blob), 832 | assertion(blob(Blob, my_blob)), 833 | close_my_blob(Blob). 834 | test(blob) :- 835 | create_my_blob('foo', A), 836 | with_output_to(string(Astr), write(current_output, A)), 837 | assertion(string_concat("(", _, Astr)), % The pointer part is implementation-defined 838 | free_blob(A), 839 | with_output_to(string(Astr_freed), write(current_output, A)), 840 | nil_repr(Nil), 841 | format(string(Rstr), ">(~w)", [Nil]), 842 | % The name part implementation-defined (e.g., mangled type name) 843 | assertion(string_concat("<", _, Astr_freed)), 844 | assertion(string_concat(_, Rstr, Astr_freed)). 845 | 846 | % The following attempts to test the handling of close errors in the 847 | % "release" callback, which calls ~MyBlob. It doesn't throw an error 848 | % (because it can't) but does output an error message. 849 | % You can run this test by hand: 850 | % ?- create_fail_close_blob. 851 | % ?- force_gc. 852 | % and that should print: 853 | % Close MyBlob failed: FAIL_close 854 | test(blob, [blocked(cant_throw_error), 855 | error(e), 856 | setup(force_gc(GC_thread)), 857 | cleanup(restore_gc(GC_thread))]) :- 858 | create_fail_close_blob, 859 | garbage_collect, 860 | garbage_collect_atoms. 861 | test(blob, blocked('throws std::runtime_error')) :- 862 | create_my_blob('-FAIL_connection-', _Blob). 863 | test(blob, error(my_blob_open_error(_))) :- 864 | create_my_blob('-FAIL_open-', _Blob). 865 | test(blob, error(my_blob_fail_new(_))) :- 866 | create_my_blob('-FAIL_new-', _Blob). 867 | test(blob, fail) :- 868 | create_my_blob('-FAIL_compare-1', Blob1), 869 | create_my_blob('-Fail_compare-2', Blob2), 870 | Blob1 = Blob2. 871 | test(blob, error(my_blob_write_error(_))) :- 872 | create_my_blob('-FAIL_write-', Blob), 873 | with_output_to(string(_), write(current_output, Blob)). 874 | 875 | create_fail_close_blob :- 876 | create_my_blob('-FAIL_close-', Blob), 877 | assertion(blob(Blob, my_blob)). 878 | 879 | test(blob, cleanup(close_my_blob(A))) :- 880 | create_my_blob('foobar', A), 881 | with_output_to(string(Astr), write(current_output, A)), 882 | assertion(my_blob_string(Astr, _, _)). 883 | 884 | test(blob_compare1, [cleanup((close_my_blob(A), 885 | close_my_blob(B)))]) :- 886 | force_gc, 887 | create_my_blob('A', A), 888 | create_my_blob('B', B), 889 | sort([A,B], Sorted), 890 | predsort(compare_write_form, [A,B], Sorted2), 891 | assertion(Sorted == Sorted2). 892 | test(blob_compare2, [cleanup((close_my_blob(A), 893 | close_my_blob(B)))]) :- 894 | % Create in the opposite order from the previous test, 895 | % because the addresses ought to be in ascending order. 896 | force_gc, 897 | create_my_blob('B', B), 898 | create_my_blob('A', A), 899 | % The blobs are repeated here, to verify that the equality check 900 | % is done by Prolog and never gets to my_data::compare_fields(), 901 | % which has an assertion check. 902 | sort([B,A,B,A], Sorted), 903 | predsort(compare_write_form, [B,A,B,A], Sorted2), 904 | assertion(Sorted == Sorted2). 905 | test(blob_compare3, [cleanup((close_my_blob(A1), 906 | close_my_blob(A2), 907 | close_my_blob(B)))]) :- 908 | force_gc, 909 | create_my_blob('A', A1), 910 | create_my_blob('A', A2), 911 | create_my_blob('B', B), 912 | sort([A2,A1,B], Sorted), 913 | predsort(compare_write_form, [A1,A2,B], Sorted2), 914 | assertion(Sorted == Sorted2). 915 | test(blob_compare4, [cleanup((close_my_blob(A1), 916 | close_my_blob(A2), 917 | close_my_blob(B))) 918 | ]) :- 919 | % Different ordering of creation, so that address order changes 920 | force_gc, 921 | create_my_blob('B', B), 922 | create_my_blob('A', A2), 923 | create_my_blob('A', A1), 924 | sort([A2,A1,B], Sorted), 925 | predsort(compare_write_form, [A2,A1,B], Sorted2), 926 | assertion(Sorted == Sorted2). 927 | 928 | test(blob_portray, S == "MyBlob(Connection(name=foo))") :- 929 | create_my_blob(foo, B), 930 | with_output_to(string(S), print(B)), 931 | close_my_blob(B). 932 | test(blob_portray, S == "MyBlob(closed)") :- 933 | create_my_blob(foo, B), 934 | close_my_blob(B), 935 | with_output_to(string(S), print(B)). 936 | 937 | expected_file_name_my_program_home(ShortPath, AbsPathOS) :- 938 | once(user:file_search_path(my_program_home, Home)), 939 | concat_atom([Home, '/', ShortPath], AbsPath0), 940 | prolog_to_os_filename(AbsPath0, AbsPathOS). 941 | 942 | expected_file_name_my_program_home_string(ShortPath, AbsPathOS) :- 943 | expected_file_name_my_program_home(ShortPath, AbsPathOS0), 944 | atom_string(AbsPathOS0, AbsPathOS). 945 | 946 | test(file_blob, Read == "% -*- mode: Prolog; coding: utf-8 -*-\n\n") :- 947 | my_file_open(File, my_program_home('test_cpp.pl'), 'r', [search,absolute,ospath]), 948 | print(File), nl, 949 | absolute_file_name(my_program_home('test_cpp.pl'), Abs, [access(read)]), 950 | expected_file_name_my_program_home('test_cpp.pl', AbsPathOS_atom), 951 | assertion(prolog_to_os_filename(Abs, AbsPathOS_atom)), 952 | my_file_filename_atom(File, Filename), 953 | assertion(Filename == Abs), 954 | my_file_read(File, 39, Read), 955 | my_file_close(File). 956 | % TODO: the following uses uninstantiated F, so explicit catch/3 is done 957 | % test(file_blob, error(existence_error(my_file_blob_open,F))) :- 958 | % expected_file_name_my_program_home('non-existent-file', F0), 959 | % atom_string(F0, F), 960 | % my_file_open(_File, my_program_home('non-existent-file'), 'r', [search,absolute,ospath]). 961 | test(file_blob, error((existence_error(my_file_blob_open,PlF)))) :- 962 | expected_file_name_my_program_home_string('non-existent-file', F), 963 | prolog_to_os_filename(PlF, F), 964 | my_file_open(_File, my_program_home('non-existent-file'), 'r', [search,absolute,ospath]). 965 | test(file_blob, error(existence_error(source_sink,my_program_home('non-existent-file')))) :- 966 | my_file_open(_File, my_program_home('non-existent-file'), 'r', [search,absolute,ospath,read]). 967 | test(file_blob, error(existence_error(source_sink,my_program_home('non-existent-file')))) :- 968 | absolute_file_name(my_program_home('non-existent-file'), _Abs, [access(read)]). 969 | 970 | test(option_flags, error(domain_error('MyFileBlob-options',foo))) :- 971 | my_file_open(_File, my_program_home('test_cpp.pl'), 'r', [foo,search,absolute,ospath,read]). 972 | test(option_flags, error(type_error('atom or string',access(read)))) :- 973 | my_file_open(_File, my_program_home('test_cpp.pl'), 'r', [search,absolute,ospath,access(read)]). 974 | 975 | test(nchars_flags, F-S == 0x43f-"xinteger,all") :- 976 | nchars_flags([xinteger,all,atomic,number], F), 977 | nchars_flags_string(F, S). 978 | test(nchars_flags, F-S == 0x37-"all") :- 979 | nchars_flags([all,atomic,number], F), 980 | nchars_flags_string(F, S). 981 | test(nchars_flags, F-S == 0x7ff-"xinteger,all,variable,write,write_canonical,writeq") :- 982 | nchars_flags([atom,string,integer,list,rational,float,variable,number,atomic,write,write_canonical,writeq,all,xinteger], F), 983 | nchars_flags_string(F, S). 984 | test(nchars_flags, F-S == 0x37-"all") :- 985 | nchars_flags([atomic,list], F), 986 | nchars_flags_string(F, S). 987 | test(nchars_flags, F-S == 0x33-"atomic") :- 988 | nchars_flags([number,atom,string], F), 989 | nchars_flags_string(F, S). 990 | 991 | test(nchars, S-FS-FS2 == "123"-"atomic"-"atomic") :- 992 | nchars_flags([atomic], F), 993 | nchars_flags_string(F, FS), 994 | get_nchars_string(123, F, S, FS2). 995 | test(nchars, S-F == "123"-"atomic") :- 996 | get_nchars_string(123, [atomic], S, F). 997 | test(nchars, error(type_error(atomic,f(a)))) :- 998 | get_nchars_string(f(a), [atomic], _, _). 999 | test(nchars, S-F == "+(a,b)"-"all,write_canonical") :- 1000 | get_nchars_string(a+b, [write_canonical,all], S, F). 1001 | 1002 | % The flags to PlTerm::as_string are [all,writeq]. 1003 | % TODO: try more flag combinations 1004 | 1005 | test(nchars, [S-F == "a b"-"all,writeq"]) :- 1006 | get_nchars_string('a b', [all,writeq], S, F). 1007 | test(nchars, [S-F == "a b"-"all,writeq"]) :- 1008 | get_nchars_string("a b", [all,writeq], S, F). 1009 | test(nchars, [S-F == "'a b'"-"writeq"]) :- 1010 | get_nchars_string('a b', [writeq], S, F). 1011 | test(nchars, [S-F == "\"a b\""-"writeq"]) :- 1012 | get_nchars_string("a b", [writeq], S, F). 1013 | test(nchars, S-F == "f('a b')"-"all,writeq") :- 1014 | get_nchars_string(f('a b'), [all,writeq], S, F). 1015 | test(nchars, S-F == "f(\"a b\")"-"all,writeq") :- 1016 | get_nchars_string(f("a b"), [all,writeq], S, F). 1017 | test(nchars, S-F == "f(A,_,b,A)"-"writeq") :- 1018 | get_nchars_string(f(X,_,b,X), [writeq], S, F). 1019 | 1020 | test(nchars, S-F == "an atom"-"atom") :- 1021 | get_nchars_string('an atom', [atom], S, F). 1022 | test(nchars, S-F == "a string"-"string") :- 1023 | get_nchars_string("a string", [string], S, F). 1024 | test(nchars, S-F == "abc"-"list") :- 1025 | get_nchars_string([a,b,c], [list], S, F). 1026 | test(nchars, S-F == "abcd"-"list") :- 1027 | get_nchars_string([0'a,0'b,0'c,0'd], [list], S, F). 1028 | test(nchars, S-F == "10r3"-"rational") :- 1029 | get_nchars_string(20r6, [rational], S, F). 1030 | test(nchars, S-F == "ar3"-"xinteger,rational") :- 1031 | get_nchars_string(20r6, [xinteger,rational], S, F). 1032 | test(nchars, S-F == "14"-"xinteger,rational") :- 1033 | get_nchars_string(20, [xinteger,rational], S, F). 1034 | test(nchars, S-F == "14"-"xinteger") :- 1035 | get_nchars_string(20, [xinteger], S, F). 1036 | test(nchars, S-F == "0.25"-"xinteger,float") :- 1037 | get_nchars_string(0.25, [xinteger,float], S, F). 1038 | 1039 | % TODO: the type_error always shows atom - but making it more accurate 1040 | % would be more work than it's worth. 1041 | test(nchars, error(type_error(atom,0.25))) :- 1042 | get_nchars_string(0.25, [xinteger], _S, _F). 1043 | 1044 | test(lookup_unify, N == 1) :- 1045 | lookup_unify(item(one, N)). 1046 | test(lookup_unify, S == three) :- 1047 | lookup_unify(item(S, 3)). 1048 | test(lookup_unify, fail) :- 1049 | lookup_unify(xxx). 1050 | 1051 | test(#, S == "abc") :- 1052 | #(abc, S). 1053 | test(#, S == "foo(abc)") :- 1054 | #(foo(abc), S). 1055 | 1056 | compare_write_form(Compare, A, B) :- 1057 | with_output_to(string(Astr), write(A)), 1058 | with_output_to(string(Bstr), write(B)), 1059 | my_blob_string(Astr, APtr, AName), 1060 | my_blob_string(Bstr, BPtr, BName), 1061 | compare(Compare, AName-APtr, BName-BPtr). 1062 | 1063 | my_blob_string(String, Ptr, Name) :- 1064 | atom_codes(String, Codes), 1065 | phrase(my_blob(Ptr, Name), Codes). 1066 | 1067 | my_blob(Ptr, Name) --> 1068 | "(", 1069 | optional("0x", []), 1070 | xinteger(Ptr), 1071 | ",Connection(name=", 1072 | string(NameS), 1073 | "))", 1074 | !, 1075 | { atom_codes(Name, NameS) }. 1076 | 1077 | force_gc :- 1078 | force_gc(GC_thread), 1079 | restore_gc(GC_thread). 1080 | 1081 | force_gc(GC_thread) :- 1082 | current_prolog_flag(gc_thread, GC_thread), 1083 | set_prolog_gc_thread(false), 1084 | garbage_collect, 1085 | garbage_collect_atoms. 1086 | 1087 | restore_gc(GC_thread) :- 1088 | set_prolog_gc_thread(GC_thread). 1089 | 1090 | 1091 | % TODO: 1092 | % test this (https://swi-prolog.discourse.group/t/cpp2-exceptions/6040/61): 1093 | % 1094 | % Now call this from C(++). The first PL_next_solution() says TRUE, 1095 | % but the cleanup is not executed. Now close the query. That runs the 1096 | % cleanup handler and should raise error. If the goal in the 1097 | % setup_call_cleanup/3 completed (fail, exception, deterministic 1098 | % true), the cleanup handler has done its work before control gets 1099 | % back to Prolog and thus PL_next_solution() already generates the 1100 | % exception. 1101 | 1102 | test_setup_call_cleanup(X) :- 1103 | setup_call_cleanup( 1104 | true, 1105 | between(1, 5, X), 1106 | throw(error)). 1107 | 1108 | % Experimental API tests 1109 | :- if((current_prolog_flag(version,V),V>=90308)). 1110 | % Scoped terms depend on a working PL_free_term_ref() 1111 | % implementation. 9.2.6 and up only provide a dummy. 1112 | test(plterm_scoped, R == []) :- 1113 | unify_atom_list([], R). 1114 | test(plterm_scoped, R == [a, foo]) :- 1115 | unify_atom_list(["a", foo], R). 1116 | test(plterm_scoped, error(type_error(list,foo))) :- 1117 | unify_atom_list(foo, _). 1118 | 1119 | test(plterm_scoped, R == []) :- 1120 | unify_atom_list_c([], R). 1121 | test(plterm_scoped, R == [a, foo]) :- 1122 | unify_atom_list_c(["a", foo], R). 1123 | test(plterm_scoped, error(type_error(list,foo))) :- 1124 | unify_atom_list_c(foo, _). 1125 | 1126 | test(plterm_scoped, [blocked('crashes in PL_free_term_ref')]) :- 1127 | term_release. 1128 | :- endif. 1129 | 1130 | test(record_ext, P == foo(bar,1,"a\0bc",'xy\0')) :- 1131 | record_ext(foo(bar,1,"a\0bc", 'xy\0'), Str), 1132 | record_ext(P, Str). 1133 | test(record_ext, P == foo(bar,1,"a\0bc世界",'\0xy\0')) :- 1134 | record_ext2(foo(bar,1,"a\0bc世界", '\0xy\0'), Str), 1135 | record_ext2(P, Str). 1136 | 1137 | :- end_tests(cpp). 1138 | 1139 | :- begin_tests(cpp_atommap). 1140 | 1141 | test(atom_atom_map) :- 1142 | atom_atom_add(foo, foo_value), 1143 | atom_atom_add(bar, bar_value), 1144 | atom_atom_add(bar, bar_value), % OK to add identical enntry 1145 | catch(atom_atom_add(foo, foo_value2), 1146 | error(permission_error(add,atom_atom,foo),_), 1147 | Exc = true), 1148 | assertion(Exc == true), 1149 | atom_atom_find(foo, F), 1150 | assertion(F == foo_value), 1151 | assertion(\+ atom_atom_find(foox, _)), 1152 | atom_atom_erase(foo), 1153 | assertion(\+ atom_atom_find(foo, _)), 1154 | atom_atom_erase(non_existent_key), 1155 | atom_atom_erase(bar), 1156 | atom_atom_size(Size), 1157 | assertion(Size == 0). 1158 | 1159 | test(atom_term_map) :- 1160 | % This test uses different keys from the other atom_term_map test. 1161 | % If it succeeds, it will have erased all the entries that were 1162 | % inserted. 1163 | atom_term_insert(foo, "foo_value"), 1164 | atom_term_insert(bar, bar_value), 1165 | atom_term_insert(bar, bar_value), % OK to add identical enntry 1166 | catch(atom_term_insert(foo, foo_value2), 1167 | error(permission_error(insert,atom_term,foo),_), 1168 | Exc = true), 1169 | assertion(Exc == true), 1170 | atom_term_find(foo, F), 1171 | assertion(F == "foo_value"), 1172 | assertion(\+ atom_term_find(foox, _)), 1173 | atom_term_erase(foo), 1174 | assertion(\+ atom_term_find(foo, _)), 1175 | atom_term_erase(non_existent_key), 1176 | atom_term_erase(bar), 1177 | atom_atom_size(Size), 1178 | assertion(Size == 0). 1179 | 1180 | test(atom_term_map) :- 1181 | % This test uses different keys from the other atom_term_map test. 1182 | % If it succeeds, it will have erased all the entries that were 1183 | % inserted. 1184 | atom_term_insert(foo2, foo2(value)), 1185 | atom_term_insert(bar2, 123), 1186 | atom_term_find(foo2, F), 1187 | assertion(F == foo2(value)), 1188 | atom_term_find(bar2, B), 1189 | assertion(B == 123), 1190 | assertion(\+ atom_term_find(foo2x, _)), 1191 | atom_term_erase(foo2), 1192 | assertion(\+ atom_term_find(foo2, _)), 1193 | atom_term_erase(non_existent_key), 1194 | atom_term_erase(bar2), 1195 | atom_atom_size(Size), 1196 | assertion(Size == 0). 1197 | 1198 | :- end_tests(cpp_atommap). 1199 | 1200 | :- begin_tests(cpp_map_str_str). 1201 | 1202 | test(map, KVs == ["b"-"two","c"-"three"]) :- 1203 | create_map_str_str(Map), 1204 | insert_or_assign_map_str_str(Map, "a", "one"), 1205 | insert_or_assign_map_str_str(Map, "c", "three"), 1206 | insert_or_assign_map_str_str(Map, "b", "two"), 1207 | find_map_str_str(Map, "a", One), 1208 | assertion(One == "one"), 1209 | assertion(find_map_str_str(Map, "a", "one")), 1210 | erase_if_present_map_str_str(Map, "a"), 1211 | erase_if_present_map_str_str(Map, "axx"), 1212 | assertion(\+ find_map_str_str(Map, "a", _)), 1213 | findall(K-V, enum_map_str_str(Map, "", K, V), KVs). 1214 | 1215 | test(map, KVs = ["ab"-"two","ac"-"three"]) :- 1216 | create_map_str_str(Map), 1217 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d"], ["two","three","four"]), 1218 | findall(K-V, enum_map_str_str(Map, "a", K, V), KVs). 1219 | 1220 | test(map) :- 1221 | create_map_str_str(Map), 1222 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d"], ["two","three","four"]), 1223 | enum_map_str_str(Map, "", K, V), 1224 | !, % cut after PL_FIRST_CALL 1225 | assertion(K == "ab"), 1226 | assertion(V == "two"), 1227 | enum_map_str_str(Map, "", K, V). % verify lookup with ground args, no choicepoint 1228 | test(map, [nondet, K-V == "ab"-"two"]) :- 1229 | create_map_str_str(Map), 1230 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d"], ["two","three","four"]), 1231 | enum_map_str_str(Map, "", K, V), 1232 | enum_map_str_str(Map, "", K, V). % verify lookup with ground args, no choicepoint 1233 | test(map, K-V == "ac"-"three") :- 1234 | create_map_str_str(Map), 1235 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d"], ["two","three","four"]), 1236 | enum_map_str_str(Map, "", K, V), 1237 | K \= "ab", 1238 | !, % cut after PL_REDO 1239 | assertion(K == "ac"), 1240 | assertion(V == "three"), 1241 | enum_map_str_str(Map, "", K, V). % verify lookup with ground args, no choicepoint 1242 | test(map) :- 1243 | create_map_str_str(Map), 1244 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d"], ["two","three","four"]), 1245 | enum_map_str_str(Map, "", K, V), 1246 | K \= "ab", 1247 | K \= "ac", 1248 | !, % cut after deterministic return 1249 | assertion(K == "d"), 1250 | assertion(V == "four"), 1251 | enum_map_str_str(Map, "", K, V). % verify lookup with ground args, no choicepoint 1252 | test(map, Ks == ["ab", "x"]) :- 1253 | create_map_str_str(Map), 1254 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d","x"], ["two","three","four","two"]), 1255 | findall(K, enum_map_str_str(Map, "", K, "two"), Ks). 1256 | test(map, Ks == ["ab"]) :- 1257 | create_map_str_str(Map), 1258 | maplist(insert_or_assign_map_str_str(Map), ["ab","ac","d","x"], ["two","three","four","two"]), 1259 | findall(K, enum_map_str_str(Map, "a", K, "two"), Ks). 1260 | 1261 | :- end_tests(cpp_map_str_str). 1262 | 1263 | w_atom_cpp(Atom, String) :- 1264 | with_output_to(string(String), w_atom_cpp_(current_output, Atom)). 1265 | 1266 | %! query_flag(?Name, ?Bit) 1267 | % 1268 | % Flags for PL_open_query(). Check with SWI-Prolog.h. Same code 1269 | % appears in test_ffi.pl. This is duplicated to simplify 1270 | % installation of these tests in the binary version. 1271 | % 1272 | % This code is mainly for debugging. 1273 | 1274 | query_flag(debug, I) => I = 0x0001. 1275 | query_flag(normal, I) => I = 0x0002. 1276 | query_flag(nodebug, I) => I = 0x0004. 1277 | query_flag(catch_exception, I) => I = 0x0008. 1278 | query_flag(pass_exception, I) => I = 0x0010. 1279 | query_flag(allow_yield, I) => I = 0x0020. 1280 | query_flag(ext_status, I) => I = 0x0040. 1281 | query_flag(deterministic, I) => I = 0x0100. 1282 | % and pseudo-flags (see XX_Q_* flags in test_ffi.c): 1283 | query_flag(clear_return_true, I) => I = 0x01000. 1284 | query_flag(close_query, I) => I = 0x02000. 1285 | query_flag(exc_term, I) => I = 0x04000. 1286 | 1287 | % This should give the same result as PlQuery::verify() 1288 | check_query_flag(Flags) :- 1289 | query_flag(normal, F1), 1290 | query_flag(catch_exception, F2), 1291 | query_flag(pass_exception, F3), 1292 | Mask is F1 \/ F2 \/ F3, 1293 | Bits is popcount(Flags /\ Mask), 1294 | ( Bits =< 1 1295 | -> true 1296 | ; domain_error(query_flags, Flags) 1297 | ). 1298 | 1299 | query_flags(Flags, CombinedFlag) :- 1300 | maplist(query_flag, Flags, Ints), 1301 | aggregate_all(sum(I), member(I, Ints), CombinedFlag), 1302 | check_query_flag(CombinedFlag). 1303 | 1304 | end_of_file. 1305 | -------------------------------------------------------------------------------- /test_ffi.c: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Peter Ludemann 4 | E-mail: peter.ludemann@gmail.com 5 | WWW: http://www.swi-prolog.org 6 | Copyright (c) 2022-2023, SWI-Prolog Solutions b.v. 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | 2. Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in 18 | the documentation and/or other materials provided with the 19 | distribution. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | */ 34 | 35 | /* This is used by test_ffi.pl */ 36 | 37 | /* This tests the C interface and not the C++ interface. 38 | But it was most convenient to put the test here. */ 39 | 40 | #define _CRT_SECURE_NO_WARNINGS 1 41 | #include 42 | #include 43 | #include 44 | #include 45 | #include 46 | 47 | #ifdef O_DEBUG 48 | #define DEBUG(g) g 49 | #else 50 | #define DEBUG(g) (void)0 51 | #endif 52 | 53 | /* range_ffi/3 is used in regression tests 54 | - PL_foreign_context() passing an int for the context. 55 | */ 56 | static foreign_t 57 | range_ffi(term_t t_low, term_t t_high, term_t t_result, control_t handle) 58 | { intptr_t result = 0; 59 | 60 | switch( PL_foreign_control(handle) ) 61 | { case PL_FIRST_CALL: 62 | { long r; 63 | if ( !PL_get_long_ex(t_low, &r) ) 64 | PL_fail; 65 | result = r; 66 | } 67 | break; 68 | case PL_REDO: 69 | result = PL_foreign_context(handle); 70 | break; 71 | case PL_PRUNED: 72 | PL_succeed; 73 | default: 74 | assert(0); 75 | } 76 | 77 | { long high; 78 | if ( !PL_get_long_ex(t_high, &high) || 79 | result >= high || 80 | !PL_unify_integer(t_result, result) ) 81 | PL_fail; 82 | if ( result + 1 == high ) 83 | PL_succeed; /* Last result: succeed without a choice point */ 84 | PL_retry(result + 1); /* Succeed with a choice point */ 85 | } 86 | } 87 | 88 | /* range_ffialloc/3 is used in regression tests: 89 | - PL_foreign_context_address() and malloc()-ed context. 90 | */ 91 | struct range_ctxt 92 | { long i; 93 | long high; 94 | }; 95 | 96 | static foreign_t 97 | range_ffialloc(term_t t_low, term_t t_high, term_t t_result, control_t handle) 98 | { struct range_ctxt *ctxt; 99 | 100 | switch( PL_foreign_control(handle) ) 101 | { case PL_FIRST_CALL: 102 | { long low, high; 103 | if ( !PL_get_long_ex(t_low, &low) || 104 | !PL_get_long_ex(t_high, &high) ) 105 | PL_fail; 106 | if ( !(ctxt = malloc(sizeof *ctxt) ) ) 107 | return (foreign_t)PL_resource_error("memory"); 108 | ctxt->i = low; 109 | ctxt->high = high; 110 | } 111 | break; 112 | case PL_REDO: 113 | ctxt = PL_foreign_context_address(handle); 114 | break; 115 | case PL_PRUNED: 116 | ctxt = PL_foreign_context_address(handle); 117 | free(ctxt); 118 | PL_succeed; 119 | default: 120 | assert(0); 121 | PL_fail; 122 | } 123 | 124 | if ( ctxt->i >= ctxt->high || 125 | !PL_unify_integer(t_result, ctxt->i) ) 126 | { free(ctxt); 127 | PL_fail; 128 | } 129 | 130 | ctxt->i += 1; 131 | if ( ctxt->i == ctxt->high ) 132 | { free(ctxt); 133 | PL_succeed; /* Last result: succeed without a choice point */ 134 | } 135 | PL_retry_address(ctxt); /* Succeed with a choice point */ 136 | } 137 | 138 | // Regression test for https://github.com/SWI-Prolog/packages-pcre/issues/20 139 | static foreign_t 140 | w_atom_ffi_(term_t stream, term_t t) 141 | { IOSTREAM* s; 142 | atom_t a; 143 | if ( !PL_get_stream(stream, &s, SIO_OUTPUT) || 144 | !PL_get_atom_ex(t, &a) ) 145 | return FALSE; 146 | PL_STRINGS_MARK(); 147 | size_t len; 148 | const pl_wchar_t *sa = PL_atom_wchars(a, &len); 149 | SfprintfX(s, "/%Ws/%zd", sa, len); 150 | PL_STRINGS_RELEASE(); 151 | return TRUE; 152 | } 153 | 154 | /* Regression test for https://github.com/SWI-Prolog/packages-pcre/issues/20 155 | * (big-endian, little-endian issues). */ 156 | static foreign_t 157 | atom_ffi_(term_t stream, term_t t) 158 | { IOSTREAM* s; 159 | atom_t a; 160 | if ( !PL_get_stream(stream, &s, SIO_INPUT) || 161 | !PL_get_atom_ex(t, &a) ) 162 | return FALSE; 163 | PL_STRINGS_MARK(); 164 | size_t len; 165 | const char *sa = PL_atom_nchars(a, &len); 166 | Sfprintf(s, "/%s/%zd", sa, len); 167 | PL_STRINGS_RELEASE(); 168 | return TRUE; 169 | } 170 | 171 | static PL_option_t ffi_options[] = 172 | { PL_OPTION("quoted", OPT_BOOL), 173 | PL_OPTION("length", OPT_SIZE), 174 | PL_OPTION("callback", OPT_TERM), 175 | PL_OPTION("token", OPT_ATOM), 176 | PL_OPTION("descr", OPT_STRING), 177 | PL_OPTIONS_END 178 | }; 179 | 180 | /* This is a slight variant of the example in foreign.doc - it unifies 181 | the callback value with the 1st argument and prints out the other 182 | values. 183 | TODO: make this compatible with cpp_options in test_cpp.c 184 | */ 185 | static foreign_t 186 | ffi_options_(term_t a1, term_t options) 187 | { int quoted = FALSE; 188 | size_t length = 10; 189 | term_t callback = PL_new_term_ref(); /* default is a variable */ 190 | atom_t token = ATOM_nil; 191 | const char *descr = ""; 192 | int rc; 193 | 194 | PL_STRINGS_MARK(); 195 | rc = PL_scan_options(options, 0, "ffi_options", ffi_options, 196 | "ed, &length, &callback, &token, &descr) && 197 | PL_unify_term(a1, 198 | PL_FUNCTOR_CHARS, "options", 5, 199 | PL_BOOL, quoted, 200 | PL_INT64, (int64_t)length, 201 | PL_TERM, callback, 202 | PL_ATOM, token, 203 | PL_UTF8_STRING, descr); 204 | PL_STRINGS_RELEASE(); 205 | return rc; 206 | } 207 | 208 | 209 | /* ffi_term_chars() must be done inside PL_STRINGS_{MARK,RELEASE} 210 | Besides (term_t)0, it also accepts (term_t)-1 for "no exception", 211 | which isn't part of SWI-Prolog, but is convenient for this code 212 | (and is also used in isCauthInOuterQuery() in pl-wam.c) 213 | */ 214 | static const char * 215 | ffi_term_chars(term_t t) 216 | { char *s; 217 | 218 | if ( t == (term_t)-1 ) 219 | return ""; 220 | if ( !t ) 221 | return ""; 222 | 223 | if ( PL_get_nchars(t, NULL, &s, CVT_ALL|CVT_WRITEQ|CVT_EXCEPTION) ) 224 | return s; 225 | 226 | return ""; 227 | } 228 | 229 | /* Unify A1 and A2 if use_unify, else 230 | Unify A2 with A1.as_string() */ 231 | static int 232 | unify_term_as_term_or_string(term_t A1, term_t A2, int use_unify) 233 | { if ( A1 && use_unify ) 234 | return PL_unify(A1, A2); 235 | 236 | char buf[1000]; /* TODO: malloc as big as needed */ 237 | int u_rc; 238 | 239 | PL_STRINGS_MARK(); 240 | if ( A1 ) 241 | { char *s; 242 | 243 | int nchars_rc = PL_get_nchars(A1, NULL, &s, 244 | CVT_ALL|CVT_WRITEQ|REP_UTF8|CVT_EXCEPTION); 245 | if ( nchars_rc ) 246 | SsnprintfX(buf, sizeof buf, "<%" PRIuPTR ">:%Us", A1, s); 247 | else 248 | Ssnprintf(buf, sizeof buf, "", A1); 249 | } else 250 | { Ssnprintf(buf, sizeof buf, "%s", ""); 251 | } 252 | u_rc = PL_unify_chars(A2, PL_STRING|REP_UTF8, (size_t)-1, buf); 253 | PL_STRINGS_RELEASE(); 254 | 255 | return u_rc; 256 | } 257 | 258 | /* Additional pseudo-flags for controlling what happens after 259 | PL_next_solution() in ffi_call_(). 260 | If this is updated, you must also update query_flag/2 in test_ffi.pl 261 | and query_flags_str() 262 | */ 263 | 264 | #define XX_Q_CLEAR_RETURN_TRUE 0x01000 265 | #define XX_Q_CLOSE_QUERY 0x02000 266 | #define XX_Q_EXC_TERM 0x04000 267 | 268 | /* For debugging: turn the query call flags into human-readable form. 269 | This is mainly intended for verifying that query_flags/2 has done 270 | what we expect. 271 | */ 272 | static foreign_t 273 | query_flags_str_(term_t flags_t, term_t flags_str_t) 274 | { char flags_str[200]; 275 | int flags; 276 | if ( !PL_get_integer_ex(flags_t, &flags) ) 277 | return FALSE; 278 | 279 | flags_str[0] = '\0'; 280 | flags_str[1] = '\0'; 281 | #ifdef PL_Q_DEBUG 282 | if ( flags&PL_Q_DEBUG ) strcat(flags_str, ",debug"); 283 | #endif 284 | #ifdef PL_Q_DETERMINITIC 285 | if ( flags&PL_Q_DETERMINISTIC ) strcat(flags_str, ",deterministic"); 286 | #endif 287 | if ( flags&PL_Q_NORMAL ) strcat(flags_str, ",normal"); 288 | if ( flags&PL_Q_NODEBUG ) strcat(flags_str, ",nodebug"); 289 | if ( flags&PL_Q_CATCH_EXCEPTION ) strcat(flags_str, ",catch_exception"); 290 | if ( flags&PL_Q_PASS_EXCEPTION ) strcat(flags_str, ",pass_exception"); 291 | if ( flags&PL_Q_ALLOW_YIELD ) strcat(flags_str, ",allow_yield"); 292 | if ( flags&PL_Q_EXT_STATUS ) strcat(flags_str, ",ext_status"); 293 | if ( flags&XX_Q_CLEAR_RETURN_TRUE ) strcat(flags_str, ",clear_return_true"); 294 | if ( flags&XX_Q_CLOSE_QUERY ) strcat(flags_str, ",close_query"); 295 | if ( flags&XX_Q_EXC_TERM ) strcat(flags_str, ",exc_term"); 296 | 297 | return PL_unify_string_chars(flags_str_t, &flags_str[1]); 298 | } 299 | 300 | static foreign_t 301 | query_rc_status_str_(term_t rc_t, term_t flags_t, term_t rc_bool_t, 302 | term_t status_str_t) 303 | { int rc, flags, rc_bool; 304 | const char* status_str; 305 | if ( !PL_get_integer_ex(rc_t, &rc) || 306 | !PL_get_integer_ex(flags_t, &flags) ) 307 | return FALSE; 308 | 309 | if ( flags&PL_Q_EXT_STATUS ) 310 | { switch ( rc ) 311 | { case PL_S_EXCEPTION: rc_bool = FALSE; status_str = "exception"; break; 312 | case PL_S_FALSE: rc_bool = FALSE; status_str = "false"; break; 313 | case PL_S_TRUE: rc_bool = TRUE; status_str = "true"; break; 314 | case PL_S_LAST: rc_bool = TRUE; status_str = "last"; break; 315 | case PL_S_YIELD: rc_bool = TRUE; status_str = "yield"; break; 316 | default: rc_bool = FALSE; status_str = "???"; break; 317 | } 318 | } else 319 | { if (rc ) 320 | { rc_bool = TRUE; 321 | status_str = "TRUE"; 322 | } else 323 | { rc_bool = FALSE; 324 | status_str = "FALSE"; 325 | } 326 | } 327 | 328 | return PL_unify_bool(rc_bool_t, rc_bool) && 329 | PL_unify_string_chars(status_str_t, status_str); 330 | } 331 | 332 | /** ffi_call_exc_(+Goal, +Flags, Exc_0, Exc_qid, Exc_0_2, NextRc) 333 | where Flags is an integer (see flags/2 for constructing this) 334 | and Exc_0, Exc_qid are unified with the string form of 335 | PL_exception(0), PL_exception(qid) after PL_next_solution() and 336 | Exc_0_2 is unified with the string form of PL_exception(0) after 337 | PL_cut_query() [in all cases, only if the exception isn't 0]. 338 | - if XX_Q_EXC_ERM, then Exc_0, Exc_qid, Exc_0_2 are unified as a term 339 | or "" 340 | The exceptions are returned as strings to get around problems 341 | with lifetimes of terms (probably only needed for 342 | PL_exception(qid), but done for all, for uniformity). Note the 343 | pseudo flag XX_Q_CLEAR_RETURN_TRUE - this is for getting the 344 | exceptions and return code on failure or when an exception 345 | happens. See the test code for examples of using it. 346 | */ 347 | static foreign_t 348 | ffi_call_exc_(term_t goal, term_t flags_t, 349 | term_t exc_0_t, term_t exc_qid_t, term_t exc_0_2_t, 350 | term_t next_rc_t) 351 | { /* Do not cache call_pred because the "current module" could 352 | be different with each call */ 353 | /* TODO: Using call/1 is a slightly inefficient way of doing things; 354 | better would be to use the functor in the goal and call it 355 | directly (I think) */ 356 | predicate_t call_pred = PL_predicate("call", 1, NULL); 357 | int flags; 358 | if ( !PL_get_integer_ex(flags_t, &flags) ) 359 | return FALSE; 360 | 361 | { qid_t qid; 362 | int next_rc, cut_rc; 363 | qid = PL_open_query(0, flags, call_pred, goal); 364 | if ( !qid ) 365 | return FALSE; 366 | next_rc = PL_next_solution(qid); 367 | if ( !PL_unify_integer(next_rc_t, next_rc) ) 368 | { PL_close_query(qid); 369 | return FALSE; 370 | } 371 | { term_t exc_0 = PL_exception(0); 372 | term_t exc_qid = PL_exception(qid); 373 | if ( ! unify_term_as_term_or_string(exc_0, exc_0_t, flags&XX_Q_EXC_TERM) || 374 | ! unify_term_as_term_or_string(exc_qid, exc_qid_t, flags&XX_Q_EXC_TERM) ) 375 | { PL_close_query(qid); 376 | return FALSE; 377 | } 378 | } 379 | cut_rc = (flags&XX_Q_CLOSE_QUERY) ? PL_close_query(qid) : PL_cut_query(qid); 380 | { term_t exc_0_2 = PL_exception(0); 381 | if ( !unify_term_as_term_or_string(exc_0_2, exc_0_2_t, flags&XX_Q_EXC_TERM) ) 382 | return FALSE; 383 | } 384 | if ( flags&XX_Q_CLEAR_RETURN_TRUE ) 385 | { PL_clear_exception(); 386 | return TRUE; 387 | } 388 | return next_rc && cut_rc; 389 | } 390 | } 391 | 392 | /* For debugging: unit tests can swallow debug output when there's 393 | a system crash, so use sdprintf_() or sdprintfnl_() instead. */ 394 | /* TODO: is this needed? :- set_test_options([output(always)]). */ 395 | static foreign_t 396 | sdprintf_(term_t t) 397 | { PL_STRINGS_MARK(); 398 | Sdprintf("%s", ffi_term_chars(t)); 399 | PL_STRINGS_RELEASE(); 400 | return TRUE; 401 | } 402 | 403 | /* Same as sdprintf_, but with a newline */ 404 | static foreign_t 405 | sdprintfnl_(term_t t) 406 | { PL_STRINGS_MARK(); 407 | Sdprintf("%s\n", ffi_term_chars(t)); 408 | PL_STRINGS_RELEASE(); 409 | return TRUE; 410 | } 411 | 412 | 413 | /* Fake values for extern char **environ, for testing */ 414 | static const char *test_environ[] = 415 | {"SHELL=/bin/bash", 416 | "TERMCAP=", 417 | "PWD=/home/programmer/src/swipl-devel", 418 | "LANG=en_US.UTF-8", 419 | NULL}; 420 | 421 | /* Get the values of `test_environ` into a Prolog list, building the 422 | list head-to-tail. Compared to ffi_get_environ2_(), this will be 423 | faster if the `env` argument is instantiated, but a bit slower if 424 | it is uninstantiated. */ 425 | static foreign_t 426 | ffi_get_environ1_(term_t env) 427 | { term_t tail = PL_copy_term_ref(env); 428 | term_t item = PL_new_term_ref(); 429 | 430 | // test_environ is used here instead of `extern char **environ` 431 | for(const char **e = test_environ; *e; e++) 432 | { if ( !PL_unify_list(tail, item, tail) || 433 | !PL_unify_atom_chars(item, *e) ) 434 | return FALSE; 435 | } 436 | return PL_unify_nil(tail); 437 | } 438 | 439 | /* This builds the list tail-to-head and then unifies it with the 440 | argument `env`. This will be slightly faster than 441 | ffi_get_environ1_() `env` is uninstantiated, but slightly slower 442 | otherwise. */ 443 | static foreign_t 444 | ffi_get_environ2_(term_t env) 445 | { term_t item = PL_new_term_ref(); 446 | term_t l = PL_new_term_ref(); 447 | 448 | PL_put_nil(l); 449 | // test_environ is used here instead of `extern char **environ` 450 | int n; 451 | for(n = 0; test_environ[n]; n++) { } // position to end 452 | while( --n >= 0 ) 453 | { if ( !PL_put_atom_chars(item, test_environ[n]) || 454 | !PL_cons_list(l, item, l) ) 455 | return FALSE; 456 | } 457 | return PL_unify(l, env); 458 | } 459 | 460 | static foreign_t 461 | ffi_write_atoms_(term_t Stream, term_t l) 462 | { term_t head = PL_new_term_ref(); /* the elements */ 463 | term_t tail = PL_copy_term_ref(l); /* copy (we modify tail) */ 464 | IOSTREAM* stream; 465 | int rc = TRUE; 466 | 467 | if ( !PL_get_stream(Stream, &stream, SIO_OUTPUT) ) 468 | return FALSE; 469 | 470 | while( rc && PL_get_list_ex(tail, head, tail) ) 471 | { PL_STRINGS_MARK(); 472 | char *s; 473 | if ( (rc=PL_get_chars(head, &s, CVT_ATOM|REP_UTF8|CVT_EXCEPTION)) ) 474 | Sfprintf(stream, "%s\n", s); 475 | PL_STRINGS_RELEASE(); 476 | } 477 | 478 | return ( PL_release_stream(stream) && 479 | rc && 480 | PL_get_nil_ex(tail) ); 481 | } 482 | 483 | 484 | static foreign_t 485 | ffi_write_int32_(term_t Stream, term_t i) 486 | { int32_t v; 487 | if ( ! PL_cvt_i_int32(i, &v) ) 488 | return FALSE; 489 | 490 | IOSTREAM* stream; 491 | if ( !PL_get_stream(Stream, &stream, SIO_OUTPUT) ) 492 | return FALSE; 493 | 494 | PL_qlf_put_int32(v, stream); 495 | return PL_release_stream(stream); 496 | } 497 | 498 | static foreign_t 499 | ffi_read_int32_(term_t Stream, term_t i) 500 | { IOSTREAM* stream; 501 | int32_t v; 502 | 503 | if ( !PL_get_stream(Stream, &stream, SIO_OUTPUT) ) 504 | return FALSE; 505 | 506 | PL_qlf_get_int32(stream, &v); 507 | 508 | int rc = PL_unify_integer(i, v); 509 | return PL_release_stream(stream) && rc; 510 | } 511 | 512 | static foreign_t 513 | ffi_write_int64_(term_t Stream, term_t i) 514 | { int64_t v; 515 | if ( ! PL_cvt_i_int64(i, &v) ) 516 | return FALSE; 517 | 518 | IOSTREAM* stream; 519 | if ( !PL_get_stream(Stream, &stream, SIO_OUTPUT) ) 520 | return FALSE; 521 | 522 | PL_qlf_put_int64(v, stream); 523 | return PL_release_stream(stream); 524 | } 525 | 526 | static foreign_t 527 | ffi_read_int64_(term_t Stream, term_t i) 528 | { IOSTREAM* stream; 529 | if ( !PL_get_stream(Stream, &stream, SIO_OUTPUT) ) 530 | return FALSE; 531 | 532 | int64_t v; 533 | PL_qlf_get_int64(stream, &v); 534 | 535 | int rc = PL_unify_int64(i, v); 536 | return PL_release_stream(stream) && rc; 537 | } 538 | 539 | static foreign_t 540 | throw_instantiation_error_ffi(term_t culprit) 541 | { return PL_instantiation_error(culprit); 542 | } 543 | 544 | static foreign_t 545 | throw_uninstantiation_error_ffi(term_t culprit) 546 | { return PL_uninstantiation_error(culprit); 547 | } 548 | 549 | static foreign_t 550 | throw_representation_error_ffi(term_t resource) 551 | { char *resource_s; 552 | if ( !PL_get_atom_chars(resource, &resource_s) ) 553 | return FALSE; 554 | return PL_representation_error(resource_s); 555 | } 556 | 557 | static foreign_t 558 | throw_type_error_ffi(term_t expected, term_t culprit) 559 | { char *expected_s; 560 | if ( !PL_get_atom_chars(expected, &expected_s) ) 561 | return FALSE; 562 | return PL_type_error(expected_s, culprit); 563 | } 564 | 565 | static foreign_t 566 | throw_domain_error_ffi(term_t expected, term_t culprit) 567 | { char *expected_s; 568 | if ( !PL_get_atom_chars(expected, &expected_s) ) 569 | return FALSE; 570 | return PL_domain_error(expected_s, culprit); 571 | } 572 | 573 | static foreign_t 574 | throw_existence_error_ffi(term_t type, term_t culprit) 575 | { char *type_s; 576 | if ( !PL_get_atom_chars(type, &type_s) ) 577 | return FALSE; 578 | return PL_existence_error(type_s, culprit); 579 | } 580 | 581 | static foreign_t 582 | throw_permission_error_ffi(term_t operation, 583 | term_t type, term_t culprit) 584 | { char *operation_s, *type_s; 585 | if ( !PL_get_atom_chars(operation, &operation_s) || 586 | !PL_get_atom_chars(type, &type_s) ) 587 | return FALSE; 588 | return PL_permission_error(operation_s, type_s, culprit); 589 | } 590 | 591 | static foreign_t 592 | throw_resource_error_ffi(term_t resource) 593 | { char *resource_s; 594 | if ( !PL_get_atom_chars(resource, &resource_s) ) 595 | return FALSE; 596 | return PL_resource_error(resource_s); 597 | } 598 | 599 | 600 | /* TODO: remove - this is for debugging int_info/2 in test_cpp.cpp */ 601 | static foreign_t 602 | int_info_ffi(term_t name_a, term_t i1_a, term_t i2_a, term_t i3_a, term_t tv) 603 | { char *name; 604 | int i1, i2, i3; 605 | if ( !PL_get_atom_chars(name_a, &name) || 606 | !PL_get_integer_ex(i1_a, &i1) || 607 | !PL_get_integer_ex(i2_a, &i2) || 608 | !PL_get_integer_ex(i3_a, &i3) ) 609 | return FALSE; 610 | term_t name_t = PL_new_term_ref(); 611 | term_t i1_t = PL_new_term_ref(); 612 | term_t i2_t = PL_new_term_ref(); 613 | term_t i3_t = PL_new_term_ref(); 614 | if ( !PL_put_atom_chars(name_t, name) || 615 | !PL_put_int64(i1_t, (int64_t)i1) || 616 | !PL_put_int64(i2_t, (int64_t)i2) || 617 | !PL_put_int64(i3_t, (int64_t)i3) ) 618 | return FALSE; 619 | term_t a0 = PL_new_term_refs(4); 620 | if ( !a0 || 621 | !PL_put_term(a0+0, name_t) || 622 | !PL_put_term(a0+1, i1_t) || 623 | !PL_put_term(a0+2, i2_t) || 624 | !PL_put_term(a0+3, i3_t) ) 625 | return FALSE; 626 | functor_t f = PL_new_functor(PL_new_atom("int_info"), 4); 627 | assert(f != 0); 628 | term_t c = PL_new_term_ref(); 629 | if ( !PL_cons_functor_v(c, f, a0) ) 630 | return FALSE; 631 | return PL_unify(c, tv); 632 | } 633 | 634 | 635 | /* These are used for testing install/uninstall */ 636 | static char* range_ffi_str; 637 | #define RANGE_FFI_STR_LEN 100 638 | #define RANGE_FFI_STR_CONTENTS "RANGE_FFI" 639 | 640 | 641 | install_t 642 | install_test_ffi(void) 643 | { PL_register_foreign("range_ffi", 3, range_ffi, PL_FA_NONDETERMINISTIC); 644 | PL_register_foreign("range_ffialloc", 3, range_ffialloc, PL_FA_NONDETERMINISTIC); 645 | range_ffi_str = malloc(RANGE_FFI_STR_LEN); 646 | assert(range_ffi_str); 647 | strncpy(range_ffi_str, RANGE_FFI_STR_CONTENTS, RANGE_FFI_STR_LEN); 648 | assert(0 == strncmp(range_ffi_str, RANGE_FFI_STR_CONTENTS, RANGE_FFI_STR_LEN)); 649 | DEBUG(Sdprintf("install_range_test_ffi %s\n", range_ffi_str)); 650 | 651 | PL_register_foreign("w_atom_ffi_", 2, w_atom_ffi_, 0); 652 | PL_register_foreign("atom_ffi_", 2, atom_ffi_, 0); 653 | PL_register_foreign("ffi_options", 2, ffi_options_, 0); 654 | PL_register_foreign("ffi_call_exc", 6, ffi_call_exc_, 0); /* TODO: PL_FA_META */ 655 | PL_register_foreign("sdprintf", 1, sdprintf_, 0); 656 | PL_register_foreign("sdprintfnl", 1, sdprintfnl_, 0); 657 | PL_register_foreign("query_flags_str", 2, query_flags_str_, 0); 658 | PL_register_foreign("query_rc_status_str", 4, query_rc_status_str_, 0); 659 | PL_register_foreign("ffi_get_environ1", 1, ffi_get_environ1_, 0); 660 | PL_register_foreign("ffi_get_environ2", 1, ffi_get_environ2_, 0); 661 | PL_register_foreign("ffi_write_atoms", 2, ffi_write_atoms_, 0); 662 | PL_register_foreign("ffi_write_int32", 2, ffi_write_int32_, 0); 663 | PL_register_foreign("ffi_read_int32", 2, ffi_read_int32_, 0); 664 | PL_register_foreign("ffi_write_int64", 2, ffi_write_int64_, 0); 665 | PL_register_foreign("ffi_read_int64", 2, ffi_read_int64_, 0); 666 | PL_register_foreign("throw_instantiation_error_ffi", 1, throw_instantiation_error_ffi, 0); 667 | PL_register_foreign("throw_uninstantiation_error_ffi", 1, throw_uninstantiation_error_ffi, 0); 668 | PL_register_foreign("throw_representation_error_ffi", 1, throw_representation_error_ffi, 0); 669 | PL_register_foreign("throw_type_error_ffi", 2, throw_type_error_ffi, 0); 670 | PL_register_foreign("throw_domain_error_ffi", 2, throw_domain_error_ffi, 0); 671 | PL_register_foreign("throw_existence_error_ffi", 2, throw_existence_error_ffi, 0); 672 | PL_register_foreign("throw_permission_error_ffi", 3, throw_permission_error_ffi, 0); 673 | PL_register_foreign("throw_resource_error_ffi", 1, throw_resource_error_ffi, 0); 674 | PL_register_foreign("int_info_ffi", 5, int_info_ffi, 0); 675 | } 676 | 677 | install_t 678 | uninstall_test_ffi(void) 679 | { /* If run with ASAN, this also tests that cleanup is done */ 680 | #ifdef O_DEBUG 681 | Sdprintf("uninstall_range_test_ffi %s\n", range_ffi_str); 682 | #endif 683 | assert(0 == strncmp(range_ffi_str, RANGE_FFI_STR_CONTENTS, RANGE_FFI_STR_LEN)); 684 | free(range_ffi_str); 685 | } 686 | -------------------------------------------------------------------------------- /test_ffi.pl: -------------------------------------------------------------------------------- 1 | % -*- mode: Prolog; coding: utf-8 -*- 2 | 3 | /* Part of SWI-Prolog 4 | 5 | Author: Peter Ludemann 6 | E-mail: peter.ludemann@gmail.com 7 | WWW: http://www.swi-prolog.org 8 | Copyright (c) 2022-2023, SWI-Prolog Solutions b.v. 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in 20 | the documentation and/or other materials provided with the 21 | distribution. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | */ 36 | 37 | % This tests the C interface and not the C++ interface. 38 | % But it was most convenient to put the test here. 39 | 40 | :- module(test_ffi, 41 | [ test_ffi/0 42 | ]). 43 | :- use_module(library(debug)). 44 | :- use_module(library(lists)). 45 | :- use_module(library(apply)). 46 | :- autoload(library(aggregate)). 47 | :- use_module(library(memfile)). 48 | :- use_module(library(readutil)). 49 | :- use_module(library(plunit)). 50 | :- use_module(library(dcg/basics)). 51 | 52 | :- use_foreign_library(foreign(test_ffi)). 53 | 54 | :- encoding(utf8). 55 | 56 | test_ffi :- 57 | run_tests([ ffi, 58 | wchar, 59 | scan, 60 | call 61 | ]). 62 | 63 | % Some of the tests can result in crashes if there's a bug, so the 64 | % `output(on_failure)` option results in nothing being written. 65 | :- set_test_options([output(always)]). 66 | 67 | :- begin_tests(ffi). 68 | 69 | test(range1, all(X == [1,2])) :- 70 | range_ffi(1, 3, X). 71 | test(range2, all(X == [-2,-1,0,1,2])) :- 72 | range_ffi(-2, 3, X). 73 | test(range3a, all(X == [-2])) :- 74 | range_ffi(-2, -1, X). 75 | test(range3b, all(X == [0])) :- 76 | range_ffi(0, 1, X). 77 | test(range3c, all(X == [10])) :- 78 | range_ffi(10, 11, X). 79 | test(range4a, fail) :- 80 | range_ffi(1, 1, _X). 81 | test(range4b, fail) :- 82 | range_ffi(0, 0, _X). 83 | test(range4c, fail) :- 84 | range_ffi(-1, -1, _X). 85 | test(range4d, fail) :- 86 | range_ffi(1, 2, 2). 87 | test(range_ffi5, X == 1) :- % Will produce warning if non-deterministic 88 | range_ffi(1, 2, X). 89 | 90 | test(range_ffialloc1, all(X == [1,2])) :- 91 | range_ffialloc(1, 3, X). 92 | test(range_ffialloc2, all(X == [-2,-1,0,1,2])) :- 93 | range_ffialloc(-2, 3, X). 94 | test(range_ffialloc3a, all(X == [0])) :- 95 | range_ffialloc(0, 1, X). 96 | test(range_ffialloc3b, all(X == [10])) :- 97 | range_ffialloc(10, 11, X). 98 | test(range_ffialloc3c, all(X == [-2])) :- 99 | range_ffi(-2, -1, X). 100 | test(range_ffialloc4a, fail) :- 101 | range_ffialloc(1, 1, _X). 102 | test(range_ffialloc4a, fail) :- 103 | range_ffialloc(0, 0, _X). 104 | test(range_ffialloc4a, fail) :- 105 | range_ffialloc(-1, -1, _X). 106 | test(range_ffialloc4d, fail) :- 107 | range_ffialloc(1, 2, 2). 108 | test(range_ffialloc5, X == 1) :- % Will produce warning if non-deterministic 109 | range_ffialloc(1, 2, X). 110 | test(range_ffialloc6a, error(type_error(integer,a))) :- 111 | range_ffialloc(a, 10, _). 112 | test(range_ffialloc6b, error(type_error(integer,foo))) :- 113 | range_ffialloc(1, foo, _). 114 | 115 | test(make_list, Env == ['SHELL=/bin/bash', 'TERMCAP=', 'PWD=/home/programmer/src/swipl-devel', 'LANG=en_US.UTF-8']) :- 116 | ffi_get_environ1(Env). 117 | test(make_list, Env == ['SHELL=/bin/bash', 'TERMCAP=', 'PWD=/home/programmer/src/swipl-devel', 'LANG=en_US.UTF-8']) :- 118 | ffi_get_environ2(Env). 119 | 120 | test(get_list, Output == "fred\ncharles\nmindy\n") :- 121 | with_output_to(string(Output), 122 | ffi_write_atoms(current_output, [fred,charles,mindy])). 123 | test(get_list, error(existence_error(stream,unknown_stream))) :- 124 | ffi_write_atoms(unknown_stream, [fred,charles,mindy]). 125 | test(get_list, error(type_error(list,x))) :- 126 | ffi_write_atoms(current_output, x). 127 | test(get_list, error(type_error(list,mindy))) :- 128 | % This will put "fred\ncharles\n" into Output, but that will be 129 | % undone by the error. (The behavior can be observed by outputting 130 | % to a stream, which doesn't backtrack) 131 | with_output_to(string(_Output), 132 | ffi_write_atoms(current_output, [fred,charles|mindy])). 133 | test(get_list, error(instantiation_error)) :- 134 | ffi_write_atoms(current_output, [_X]). 135 | test(get_list, error(type_error(atom,1.0))) :- 136 | ffi_write_atoms(current_output, [1.0]). 137 | test(get_list, error(type_error(atom,"foo"))) :- 138 | ffi_write_atoms(current_output, ["foo"]). 139 | 140 | test(save_load_int64, L == L2) :- 141 | Mx is (1<<63)-1, Mn is -(1<<63), 142 | L = [150, 0, -150, Mx, Mn], 143 | tmp_file_stream(TmpFile, OutStream, [encoding(binary)]), 144 | maplist(ffi_write_int64(OutStream), L), 145 | close(OutStream), 146 | same_length(L, L2), 147 | open(TmpFile, read, InStream, [type(binary)]), 148 | maplist(ffi_read_int64(InStream), L2), 149 | close(InStream), 150 | read_file_to_codes(TmpFile, Codes, [type(binary)]), 151 | % The following should be the same on both little- and big-endian machines. 152 | assertion(Codes == [0x2c,0x82,0x80,0x2b,0x82,0x7e,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x81,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x81]). 153 | test(save_load_int32, L == L2) :- 154 | L = [-1, 0, 0x010203fe, 0x7fffffff, -0x8000000], 155 | tmp_file_stream(TmpFile, OutStream, [encoding(binary)]), 156 | maplist(ffi_write_int32(OutStream), L), 157 | close(OutStream), 158 | same_length(L, L2), 159 | open(TmpFile, read, InStream, [type(binary)]), 160 | maplist(ffi_read_int32(InStream), L2), 161 | close(InStream), 162 | read_file_to_codes(TmpFile, Codes, [type(binary)]), 163 | % The following should be the same on both little- and big-endian machines. 164 | % assertion(Codes == [0xff,0xff,0xff,0xff,0,0,0,0,1,2,3,0xfe,0x7f,0xff,0xff,0xff,0xf8,0,0,0]). 165 | % If int32_t is encoded using zigzag, this is the result: 166 | assertion(Codes == [129,128,124,15,16,144,126,127,127,127,143,127,127,127,255]). 167 | 168 | test(save_load_int64, L == L2) :- 169 | Mx is (1<<63)-1, Mn is -(1<<63), 170 | L = [150, 0, -150, Mx, Mn], 171 | new_memory_file(MemFile), 172 | open_memory_file(MemFile, write, OutStream, [type(octet)]), 173 | maplist(ffi_write_int64(OutStream), L), 174 | close(OutStream), 175 | same_length(L, L2), 176 | open_memory_file(MemFile, read, InStream, [type(octet)]), 177 | maplist(ffi_read_int64(InStream), L2), 178 | close(InStream), 179 | memory_file_to_codes(MemFile, Codes, octet), 180 | % TODO: the following should be the same on both little- and 181 | % big-endian machines. 182 | assertion(Codes == [0x2c,0x82,0x80,0x2b,0x82,0x7e,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x81,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x7f,0x81]). 183 | 184 | test(throw, error(instantiation_error,context(test_ffi:throw_instantiation_error_ffi/1,_))) :- 185 | throw_instantiation_error_ffi(_X). 186 | test(throw, error(uninstantiation_error(abc),context(test_ffi:throw_uninstantiation_error_ffi/1,_))) :- 187 | throw_uninstantiation_error_ffi(abc). 188 | 189 | test(throw, error(representation_error(some_resource))) :- 190 | throw_representation_error_ffi(some_resource). 191 | 192 | test(throw, error(type_error(int,"abc"))) :- 193 | throw_type_error_ffi(int, "abc"). 194 | 195 | test(throw, error(domain_error(positive, -5))) :- 196 | throw_domain_error_ffi(positive, -5). 197 | 198 | test(throw, error(existence_error(something_something, foo:bar/2))) :- 199 | throw_existence_error_ffi(something_something, foo:bar/2). 200 | 201 | test(throw, error(permission_error(operation, type, the(culprit)))) :- 202 | throw_permission_error_ffi(operation, type, the(culprit)). 203 | 204 | test(throw, error(resource_error('NO_RESOURCE'))) :- 205 | throw_resource_error_ffi('NO_RESOURCE'). 206 | 207 | :- end_tests(ffi). 208 | 209 | 210 | :- begin_tests(wchar). 211 | 212 | % The following "wchar" tests are regression tests related 213 | % to https://github.com/SWI-Prolog/packages-pcre/issues/20 214 | 215 | test(wchar, all(Result == ["//0", 216 | "/ /1", 217 | "/abC/3", 218 | "/Hello World!/12", 219 | "/хелло/5", 220 | "/хелло 世界/8", 221 | "/網目錦へび [àmímé níshíkíhéꜜbì]/26"])) :- 222 | ( w_atom_ffi('', Result) 223 | ; w_atom_ffi(' ', Result) 224 | ; w_atom_ffi('abC', Result) 225 | ; w_atom_ffi('Hello World!', Result) 226 | ; w_atom_ffi('хелло', Result) 227 | ; w_atom_ffi('хелло 世界', Result) 228 | ; w_atom_ffi('網目錦へび [àmímé níshíkíhéꜜbì]', Result) 229 | ). 230 | 231 | test(wchar, 232 | [condition(\+ current_prolog_flag(windows, true)), % Windows doesn't like Unicode > 0xffff 233 | all(Result == ["/⛰⛱⛲⛾⛿/5","/\U0001FB00/1","/ᢰᢱ\x18FF\/3","/⻰⻱⻲⻳/4"])]) :- 234 | ( w_atom_ffi('⛰⛱⛲⛾⛿', Result) 235 | ; w_atom_ffi('\U0001FB00', Result) 236 | ; w_atom_ffi('ᢰᢱ\u18FF', Result) 237 | ; w_atom_ffi('⻰⻱⻲⻳', Result) 238 | ). 239 | 240 | test(wchar, % Same as wchar_2, but uses atom_codes 241 | [condition(\+ current_prolog_flag(windows, true)), % Windows doesn't like Unicode > 0xffff 242 | all(Result == [[47, 0x26f0, 0x26f1, 0x26f2, 0x26fe, 0x26ff, 47, 53], 243 | [47, 0x1FB00, 47, 49], 244 | [47, 0x18b0, 0x18b1, 0x18ff, 47, 51], 245 | [47, 0x2ef0, 0x2ef1, 0x2ef2, 0x2ef3, 47, 52]])]) :- 246 | ( atom_codes(A, [0x26f0, 0x26f1, 0x26f2, 0x26fe, 0x26ff]), 247 | w_atom_ffi(A, Result0), string_codes(Result0, Result) 248 | ; atom_codes(A, [0x1FB00]), 249 | w_atom_ffi(A, Result0), string_codes(Result0, Result) 250 | ; atom_codes(A, [0x18b0, 0x18b1, 0x18ff]), 251 | w_atom_ffi(A, Result0), string_codes(Result0, Result) 252 | ; atom_codes(A, [0x2ef0, 0x2ef1, 0x2ef2, 0x2ef3]), 253 | w_atom_ffi(A, Result0), string_codes(Result0, Result) 254 | ). 255 | 256 | test(char_1, all(Result == ["//0", "/ /1", "/abC/3", "/Hello World!/12"])) :- 257 | ( atom_ffi('', Result) 258 | ; atom_ffi(' ', Result) 259 | ; atom_ffi('abC', Result) 260 | ; atom_ffi('Hello World!', Result) 261 | ). 262 | 263 | w_atom_ffi(Atom, String) :- 264 | with_output_to(string(String), w_atom_ffi_(current_output, Atom)). 265 | 266 | atom_ffi(Atom, String) :- 267 | with_output_to(string(String), atom_ffi_(current_output, Atom)). 268 | 269 | :- end_tests(wchar). 270 | 271 | 272 | :- begin_tests(scan). 273 | 274 | test(scan_options, [Options == options(true, 5, foo(bar), [], "")]) :- 275 | ffi_options(Options, [quoted(true), length(5), callback(foo(bar))]). 276 | test(scan_options, [Options == options(true, 5, foo(bar), qqsv, "DESCR")]) :- 277 | ffi_options(Options, [token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar))]). 278 | test(scan_options, [Options == options(true, 5, foo(bar), qqsv, "DESCR")]) :- 279 | ffi_options(Options, [token(qqsv), descr("DESCR"), quoted(true), length(5), callback(foo(bar)), unknown_option(blah)]). 280 | test(scan_options, [Options == options(true, 5, foo(bar), qqsv, "DESCR")]) :- 281 | ffi_options(Options, options{token:qqsv, descr:"DESCR", quoted:true, length:5, callback:foo(bar)}). 282 | test(scan_options, [Options == options(true, 5, foo(bar), qqsv, "DESCR")]) :- 283 | ffi_options(Options, [token(qqsv), descr("DESCR"), quoted, length(5), callback(foo(bar))]). 284 | test(scan_options, [Options == options(false, 5, foo(bar), qqsv, "DESCR")]) :- 285 | ffi_options(Options, [token(qqsv), descr("DESCR"), length(5), callback(foo(bar))]). 286 | test(scan_options, [error(instantiation_error)]) :- 287 | ffi_options(_Options, [token(qqsv), _, descr("DESCR"), length(5), callback(foo(bar))]). 288 | test(scan_options, [error(type_error(option,123))]) :- % TODO: is this intended behavior? 289 | ffi_options(_Options, [token(qqsv), descr("DESCR"), 123, length(5), callback(foo(bar))]). 290 | test(scan_options, [error(type_error(option,123))]) :- % TODO: is this intended behavior? 291 | ffi_options(_Options, [token(qqsv), 123, descr("DESCR"), length(5), callback(foo(bar))]). 292 | 293 | :- end_tests(scan). 294 | 295 | 296 | :- begin_tests(call). 297 | 298 | % New code should use PL_Q_PASS_EXCEPTION or PL_Q_CATCH_EXCEPTION, so 299 | % there are only minimal tests for PL_Q_NORMAL or flags=0. 300 | 301 | % In the following tests, the `FlagsStr` is specified, as a 302 | % double-check that query_flags/2 has generated the correct bits in 303 | % the flag. 304 | 305 | test(ffi_call, X == a) :- 306 | ffi_call(X = a, [normal], "normal"). 307 | test(ffi_call, X == a) :- 308 | ffi_call(X = a, [pass_exception], "pass_exception"). 309 | test(ffi_call, X == a) :- 310 | ffi_call(X = a, [catch_exception], "catch_exception"). 311 | 312 | test(ffi_call) :- 313 | ffi_call(unknown_pred(foo), [nodebug,pass_exception,clear_return_true], 314 | "nodebug,pass_exception,clear_return_true", 315 | Exc_0, Exc_qid, Exc_0_2, NextRc), 316 | assertion(NextRc == 0), 317 | assertion(Exc_0 == Exc_0_2), 318 | ( match_existence_error_string(Exc_0, MatchExc_0), 319 | match_existence_error_string(Exc_qid, MatchExc_qid) 320 | -> % The terms from Exc_0 and Exc_qid are different 321 | assertion(MatchExc_0 \== MatchExc_qid) 322 | ; assertion(fail) 323 | ). 324 | test(ffi_call) :- 325 | ffi_call(unknown_pred(foo), [nodebug,catch_exception,clear_return_true], 326 | "nodebug,catch_exception,clear_return_true", 327 | Exc_0, Exc_qid, Exc_0_2, NextRc), 328 | assertion(NextRc == 0), 329 | assertion(Exc_0 == ""), 330 | assertion(Exc_0_2 == ""), 331 | assertion(match_existence_error_string(Exc_qid, _MatchExc_qid)). 332 | 333 | test(ffi_call) :- 334 | ffi_call(unknown_pred(foo), [nodebug,pass_exception,clear_return_true,exc_term], 335 | "nodebug,pass_exception,clear_return_true,exc_term", 336 | Exc_0, Exc_qid, Exc_0_2, NextRc), 337 | assertion(NextRc == 0), 338 | assertion(Exc_0 == Exc_0_2), 339 | match_existence_error_term(Exc_0), 340 | match_existence_error_term(Exc_qid). 341 | test(ffi_call) :- 342 | ffi_call(unknown_pred(foo), [nodebug,catch_exception,clear_return_true,exc_term], 343 | "nodebug,catch_exception,clear_return_true,exc_term", 344 | Exc_0, Exc_qid, Exc_0_2, NextRc), 345 | assertion(NextRc == 0), 346 | assertion(Exc_0 == ""), 347 | assertion(Exc_0_2 == ""), 348 | match_existence_error_term(Exc_qid). 349 | 350 | %! match_existence_error_string(+Str, -Qid). 351 | % Utility predicate for checking that a term, when turned into a string, 352 | % matches a particular existence error. 353 | % Str: the error term, as a string 354 | % Matches: gets a dict with: 355 | % 1: the term_t value as a string 356 | % 2: the contents of context(...) as a string 357 | match_existence_error_string(Str, Qid) :- 358 | string_codes(Str, Codes), 359 | phrase(("<", integer(Qid), ">:error(existence_error(procedure,test_ffi:unknown_pred/1"), Codes, _Rest), 360 | !. 361 | 362 | match_existence_error_term(Term) :- 363 | assertion(subsumes_term(error(existence_error(procedure, test_ffi:unknown_pred/1), 364 | context(_,_)), Term)). 365 | 366 | test(ffi_call_no_options, blocked('Activates trace/debug mode')) :- 367 | ffi_call(non_existant_pred(foo), [], ""). 368 | test(ffi_call_normal, blocked('Invokes debugger')) :- 369 | ffi_call(non_existant_pred(foo), [normal], "normal"). 370 | test(ffi_call_normal, blocked('Invokes debugger')) :- 371 | catch(ffi_call(non_existant_pred(foo), [normal], "normal"), _E, true). 372 | 373 | ffi_call(Goal, Flags) :- 374 | query_flags(Flags, CombinedFlag), 375 | ffi_call_exc(Goal, CombinedFlag, _, _, _, _). 376 | 377 | ffi_call(Goal, Flags, FlagsStr) :- 378 | query_flags(Flags, CombinedFlag), 379 | query_flags_str(CombinedFlag, FlagsStr), 380 | ffi_call_exc(Goal, CombinedFlag, _, _, _, _). 381 | 382 | ffi_call(Goal, Flags, FlagsStr, Exc_0, Exc_qid, Exc_0_2, Rc) :- 383 | query_flags(Flags, CombinedFlag), 384 | query_flags_str(CombinedFlag, FlagsStr), 385 | ffi_call_exc(Goal, CombinedFlag, Exc_0, Exc_qid, Exc_0_2, Rc). 386 | 387 | %! query_flag(?Name, ?Bit) 388 | % 389 | % Flags for PL_open_query(). Check with SWI-Prolog.h. Same code 390 | % appears in test_ffi.pl. This is duplicated to simplify 391 | % installation of these tests in the binary version. 392 | % 393 | % This code is mainly for debugging. 394 | 395 | query_flag(debug, I) => I = 0x0001. 396 | query_flag(normal, I) => I = 0x0002. 397 | query_flag(nodebug, I) => I = 0x0004. 398 | query_flag(catch_exception, I) => I = 0x0008. 399 | query_flag(pass_exception, I) => I = 0x0010. 400 | query_flag(allow_yield, I) => I = 0x0020. 401 | query_flag(ext_status, I) => I = 0x0040. 402 | query_flag(deterministic, I) => I = 0x0100. 403 | % and pseudo-flags (see XX_Q_* flags in test_ffi.c): 404 | query_flag(clear_return_true, I) => I = 0x01000. 405 | query_flag(close_query, I) => I = 0x02000. 406 | query_flag(exc_term, I) => I = 0x04000. 407 | 408 | check_query_flag(Flags) :- 409 | query_flag(normal, F1), 410 | query_flag(catch_exception, F2), 411 | query_flag(pass_exception, F3), 412 | Mask is F1 \/ F2 \/ F3, 413 | Bits is popcount(Flags /\ Mask), 414 | ( Bits =< 1 415 | -> true 416 | ; domain_error(query_flags, Flags) 417 | ). 418 | 419 | query_flags(Flags, CombinedFlag) :- 420 | maplist(query_flag, Flags, Ints), 421 | aggregate_all(sum(I), member(I, Ints), CombinedFlag), 422 | check_query_flag(CombinedFlag). 423 | 424 | ffi_p(a). 425 | ffi_p(foo(bar)). 426 | ffi_p(1). 427 | ffi_p("xyz"). 428 | 429 | ffi_findall_p(L) :- 430 | ffi_findall_(ffi_p(_), L). 431 | 432 | ffi_findall_bug_p(L) :- 433 | ffi_findall_bug_(ffi_p(_), L). 434 | 435 | :- end_tests(call). 436 | --------------------------------------------------------------------------------