1 /* perl.h 2 * 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 #ifndef H_PERL 12 #define H_PERL 1 13 14 #ifdef PERL_FOR_X2P 15 /* 16 * This file is being used for x2p stuff. 17 * Above symbol is defined via -D in 'x2p/Makefile.SH' 18 * Decouple x2p stuff from some of perls more extreme eccentricities. 19 */ 20 #undef MULTIPLICITY 21 #undef USE_STDIO 22 #define USE_STDIO 23 #endif /* PERL_FOR_X2P */ 24 25 #ifdef PERL_MICRO 26 # include "uconfig.h" 27 #else 28 # include "config.h" 29 #endif 30 31 /* 32 =for apidoc_section $debugging 33 =for apidoc CmnW ||_aDEPTH 34 Some functions when compiled under DEBUGGING take an extra final argument named 35 C<depth>, indicating the C stack depth. This argument is omitted otherwise. 36 This macro expands to either S<C<, depth>> under DEBUGGING, or to nothing at 37 all when not under DEBUGGING, reducing the number of C<#ifdef>'s in the code. 38 39 The program is responsible for maintaining the correct value for C<depth>. 40 41 =for apidoc CyW ||_pDEPTH 42 This is used in the prototype declarations for functions that take a L</C<_aDEPTH>> 43 final parameter, much like L<C<pTHX_>|perlguts/Background and MULTIPLICITY> 44 is used in functions that take a thread context initial parameter. 45 46 =cut 47 */ 48 49 #ifdef DEBUGGING 50 # define _pDEPTH ,U32 depth 51 # define _aDEPTH ,depth 52 #else 53 # define _pDEPTH 54 # define _aDEPTH 55 #endif 56 57 /* NOTE 1: that with gcc -std=c89 the __STDC_VERSION__ is *not* defined 58 * because the __STDC_VERSION__ became a thing only with C90. Therefore, 59 * with gcc, HAS_C99 will never become true as long as we use -std=c89. 60 61 * NOTE 2: headers lie. Do not expect that if HAS_C99 gets to be true, 62 * all the C99 features are there and are correct. */ 63 #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || \ 64 defined(_STDC_C99) || defined(__c99) 65 # define HAS_C99 1 66 #endif 67 68 /* See L<perlguts/"The Perl API"> for detailed notes on 69 * MULTIPLICITY and PERL_IMPLICIT_SYS */ 70 71 /* XXX NOTE that from here --> to <-- the same logic is 72 * repeated in makedef.pl, so be certain to update 73 * both places when editing. */ 74 75 #ifdef USE_ITHREADS 76 # if !defined(MULTIPLICITY) 77 # define MULTIPLICITY 78 # endif 79 #endif 80 81 /* PERL_IMPLICIT_CONTEXT is a legacy synonym for MULTIPLICITY */ 82 #ifdef MULTIPLICITY 83 # ifndef PERL_IMPLICIT_CONTEXT 84 # define PERL_IMPLICIT_CONTEXT 85 # endif 86 #endif 87 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(MULTIPLICITY) 88 # define MULTIPLICITY 89 #endif 90 91 /* undef WIN32 when building on Cygwin (for libwin32) - gph */ 92 #ifdef __CYGWIN__ 93 # undef WIN32 94 # undef _WIN32 95 #endif 96 97 /* Use the reentrant APIs like localtime_r and getpwent_r */ 98 /* Win32 has naturally threadsafe libraries, no need to use any _r variants. 99 * XXX KEEP makedef.pl copy of this code in sync */ 100 #if defined(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(WIN32) 101 # define USE_REENTRANT_API 102 #endif 103 104 /* <--- here ends the logic shared by perl.h and makedef.pl */ 105 106 /* 107 =for apidoc_section $directives 108 =for apidoc AmnUu|void|EXTERN_C 109 When not compiling using C++, expands to nothing. 110 Otherwise is used in a declaration of a function to indicate the function 111 should have external C linkage. This is required for things to work for just 112 about all functions with external linkage compiled into perl. 113 Often, you can use C<L</START_EXTERN_C>> ... C<L</END_EXTERN_C>> blocks 114 surrounding all your code that you need to have this linkage. 115 116 Example usage: 117 118 EXTERN_C int flock(int fd, int op); 119 120 =for apidoc Amnu||START_EXTERN_C 121 When not compiling using C++, expands to nothing. 122 Otherwise begins a section of code in which every function will effectively 123 have C<L</EXTERN_C>> applied to it, that is to have external C linkage. The 124 section is ended by a C<L</END_EXTERN_C>>. 125 126 =for apidoc Amnu||END_EXTERN_C 127 When not compiling using C++, expands to nothing. 128 Otherwise ends a section of code already begun by a C<L</START_EXTERN_C>>. 129 130 =cut 131 */ 132 133 #undef START_EXTERN_C 134 #undef END_EXTERN_C 135 #undef EXTERN_C 136 #ifdef __cplusplus 137 # define EXTERN_C extern "C" 138 # define START_EXTERN_C EXTERN_C { 139 # define END_EXTERN_C } 140 #else 141 # define START_EXTERN_C 142 # define END_EXTERN_C 143 # define EXTERN_C extern 144 #endif 145 146 /* Fallback definitions in case we don't have definitions from config.h. 147 This should only matter for systems that don't use Configure and 148 haven't been modified to define PERL_STATIC_INLINE yet. 149 */ 150 #if !defined(PERL_STATIC_INLINE) 151 # ifdef HAS_STATIC_INLINE 152 # define PERL_STATIC_INLINE static inline 153 # else 154 # define PERL_STATIC_INLINE static 155 # endif 156 #endif 157 158 /* 159 =for apidoc_section $concurrency 160 =for apidoc AmU|void|dTHXa|PerlInterpreter * a 161 On threaded perls, set C<pTHX> to C<a>; on unthreaded perls, do nothing 162 163 =for apidoc AmU|void|dTHXoa|PerlInterpreter * a 164 Now a synonym for C<L</dTHXa>>. 165 166 =cut 167 */ 168 169 #ifdef MULTIPLICITY 170 # define tTHX PerlInterpreter* 171 # define pTHX tTHX my_perl PERL_UNUSED_DECL 172 # define aTHX my_perl 173 # define aTHXa(a) aTHX = (tTHX)a 174 # define dTHXa(a) pTHX = (tTHX)a 175 # define dTHX pTHX = PERL_GET_THX 176 # define pTHX_ pTHX, 177 # define aTHX_ aTHX, 178 # define pTHX_1 2 179 # define pTHX_2 3 180 # define pTHX_3 4 181 # define pTHX_4 5 182 # define pTHX_5 6 183 # define pTHX_6 7 184 # define pTHX_7 8 185 # define pTHX_8 9 186 # define pTHX_9 10 187 # define pTHX_12 13 188 # if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL) 189 # define PERL_TRACK_MEMPOOL 190 # endif 191 #else 192 # undef PERL_TRACK_MEMPOOL 193 #endif 194 195 #ifdef DEBUGGING 196 # define dTHX_DEBUGGING dTHX 197 #else 198 # define dTHX_DEBUGGING dNOOP 199 #endif 200 201 #define STATIC static 202 203 #ifndef PERL_CORE 204 /* Do not use these macros. They were part of PERL_OBJECT, which was an 205 * implementation of multiplicity using C++ objects. They have been left 206 * here solely for the sake of XS code which has incorrectly 207 * cargo-culted them. 208 * 209 * The only one Devel::PPPort handles is this; list it as deprecated 210 211 =for apidoc_section $concurrency 212 =for apidoc AmD|void|CPERLscope|void x 213 Now a no-op. 214 215 =cut 216 */ 217 # define CPERLscope(x) x 218 # define CPERLarg void 219 # define CPERLarg_ 220 # define _CPERLarg 221 # define PERL_OBJECT_THIS 222 # define _PERL_OBJECT_THIS 223 # define PERL_OBJECT_THIS_ 224 # define CALL_FPTR(fptr) (*fptr) 225 # define MEMBER_TO_FPTR(name) name 226 #endif /* !PERL_CORE */ 227 228 #define CALLRUNOPS PL_runops 229 230 #define CALLREGCOMP(sv, flags) Perl_pregcomp(aTHX_ (sv),(flags)) 231 232 #define CALLREGCOMP_ENG(prog, sv, flags) (prog)->comp(aTHX_ sv, flags) 233 #define CALLREGEXEC(prog,stringarg,strend,strbeg,minend,sv,data,flags) \ 234 RX_ENGINE(prog)->exec(aTHX_ (prog),(stringarg),(strend), \ 235 (strbeg),(minend),(sv),(data),(flags)) 236 #define CALLREG_INTUIT_START(prog,sv,strbeg,strpos,strend,flags,data) \ 237 RX_ENGINE(prog)->intuit(aTHX_ (prog), (sv), (strbeg), (strpos), \ 238 (strend),(flags),(data)) 239 #define CALLREG_INTUIT_STRING(prog) \ 240 RX_ENGINE(prog)->checkstr(aTHX_ (prog)) 241 242 #define CALLREGFREE(prog) \ 243 Perl_pregfree(aTHX_ (prog)) 244 245 #define CALLREGFREE_PVT(prog) \ 246 if(prog && RX_ENGINE(prog)) RX_ENGINE(prog)->rxfree(aTHX_ (prog)) 247 248 #define CALLREG_NUMBUF_FETCH(rx,paren,usesv) \ 249 RX_ENGINE(rx)->numbered_buff_FETCH(aTHX_ (rx),(paren),(usesv)) 250 251 #define CALLREG_NUMBUF_STORE(rx,paren,value) \ 252 RX_ENGINE(rx)->numbered_buff_STORE(aTHX_ (rx),(paren),(value)) 253 254 #define CALLREG_NUMBUF_LENGTH(rx,sv,paren) \ 255 RX_ENGINE(rx)->numbered_buff_LENGTH(aTHX_ (rx),(sv),(paren)) 256 257 #define CALLREG_NAMED_BUFF_FETCH(rx, key, flags) \ 258 RX_ENGINE(rx)->named_buff(aTHX_ (rx), (key), NULL, ((flags) | RXapif_FETCH)) 259 260 #define CALLREG_NAMED_BUFF_STORE(rx, key, value, flags) \ 261 RX_ENGINE(rx)->named_buff(aTHX_ (rx), (key), (value), ((flags) | RXapif_STORE)) 262 263 #define CALLREG_NAMED_BUFF_DELETE(rx, key, flags) \ 264 RX_ENGINE(rx)->named_buff(aTHX_ (rx),(key), NULL, ((flags) | RXapif_DELETE)) 265 266 #define CALLREG_NAMED_BUFF_CLEAR(rx, flags) \ 267 RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_CLEAR)) 268 269 #define CALLREG_NAMED_BUFF_EXISTS(rx, key, flags) \ 270 RX_ENGINE(rx)->named_buff(aTHX_ (rx), (key), NULL, ((flags) | RXapif_EXISTS)) 271 272 #define CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags) \ 273 RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), NULL, ((flags) | RXapif_FIRSTKEY)) 274 275 #define CALLREG_NAMED_BUFF_NEXTKEY(rx, lastkey, flags) \ 276 RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), (lastkey), ((flags) | RXapif_NEXTKEY)) 277 278 #define CALLREG_NAMED_BUFF_SCALAR(rx, flags) \ 279 RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_SCALAR)) 280 281 #define CALLREG_NAMED_BUFF_COUNT(rx) \ 282 RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, RXapif_REGNAMES_COUNT) 283 284 #define CALLREG_NAMED_BUFF_ALL(rx, flags) \ 285 RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, flags) 286 287 #define CALLREG_PACKAGE(rx) \ 288 RX_ENGINE(rx)->qr_package(aTHX_ (rx)) 289 290 #if defined(USE_ITHREADS) 291 # define CALLREGDUPE(prog,param) \ 292 Perl_re_dup(aTHX_ (prog),(param)) 293 294 # define CALLREGDUPE_PVT(prog,param) \ 295 (prog ? RX_ENGINE(prog)->dupe(aTHX_ (prog),(param)) \ 296 : (REGEXP *)NULL) 297 #endif 298 299 /* some compilers impersonate gcc */ 300 #if defined(__GNUC__) && !defined(__clang__) && !defined(__INTEL_COMPILER) 301 # define PERL_IS_GCC 1 302 #endif 303 304 #define PERL_GCC_VERSION_GE(major,minor,patch) \ 305 (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \ 306 >= ((100000 * (major)) + (1000 * (minor)) + (patch))) 307 #define PERL_GCC_VERSION_GT(major,minor,patch) \ 308 (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \ 309 > ((100000 * (major)) + (1000 * (minor)) + (patch))) 310 #define PERL_GCC_VERSION_LE(major,minor,patch) \ 311 (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \ 312 <= ((100000 * (major)) + (1000 * (minor)) + (patch))) 313 #define PERL_GCC_VERSION_LT(major,minor,patch) \ 314 (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__) + __GNUC_PATCHLEVEL__) \ 315 < ((100000 * (major)) + (1000 * (minor)) + (patch))) 316 317 /* In case Configure was not used (we are using a "canned config" 318 * such as Win32, or a cross-compilation setup, for example) try going 319 * by the gcc major and minor versions. One useful URL is 320 * http://www.ohse.de/uwe/articles/gcc-attributes.html, 321 * but contrary to this information warn_unused_result seems 322 * not to be in gcc 3.3.5, at least. --jhi 323 * Also, when building extensions with an installed perl, this allows 324 * the user to upgrade gcc and get the right attributes, rather than 325 * relying on the list generated at Configure time. --AD 326 * Set these up now otherwise we get confused when some of the <*thread.h> 327 * includes below indirectly pull in <perlio.h> (which needs to know if we 328 * have HASATTRIBUTE_FORMAT). 329 */ 330 331 #ifndef PERL_MICRO 332 # if defined __GNUC__ && !defined(__INTEL_COMPILER) 333 # if PERL_GCC_VERSION_GE(3,1,0) 334 # define HASATTRIBUTE_DEPRECATED 335 # endif 336 # if PERL_GCC_VERSION_GE(3,0,0) /* XXX Verify this version */ 337 # define HASATTRIBUTE_FORMAT 338 # if defined __MINGW32__ 339 # define PRINTF_FORMAT_NULL_OK 340 # endif 341 # endif 342 # if PERL_GCC_VERSION_GE(3,0,0) 343 # define HASATTRIBUTE_MALLOC 344 # endif 345 # if PERL_GCC_VERSION_GE(3,3,0) 346 # define HASATTRIBUTE_NONNULL 347 # endif 348 # if PERL_GCC_VERSION_GE(2,5,0) 349 # define HASATTRIBUTE_NORETURN 350 # endif 351 # if PERL_GCC_VERSION_GE(3,0,0) 352 # define HASATTRIBUTE_PURE 353 # endif 354 # if PERL_GCC_VERSION_GE(3,4,0) 355 # define HASATTRIBUTE_UNUSED 356 # endif 357 # if __GNUC__ == 3 && __GNUC_MINOR__ == 3 && !defined(__cplusplus) 358 # define HASATTRIBUTE_UNUSED /* gcc-3.3, but not g++-3.3. */ 359 # endif 360 # if PERL_GCC_VERSION_GE(3,4,0) 361 # define HASATTRIBUTE_WARN_UNUSED_RESULT 362 # endif 363 /* always_inline is buggy in gcc <= 4.6 and causes compilation errors */ 364 # if PERL_GCC_VERSION_GE(4,7,0) 365 # define HASATTRIBUTE_ALWAYS_INLINE 366 # endif 367 # endif 368 #endif /* #ifndef PERL_MICRO */ 369 370 #ifdef HASATTRIBUTE_DEPRECATED 371 # define __attribute__deprecated__ __attribute__((deprecated)) 372 #endif 373 #ifdef HASATTRIBUTE_FORMAT 374 # define __attribute__format__(x,y,z) __attribute__((format(x,y,z))) 375 #endif 376 #ifdef HASATTRIBUTE_MALLOC 377 # define __attribute__malloc__ __attribute__((__malloc__)) 378 #endif 379 #ifdef HASATTRIBUTE_NONNULL 380 # define __attribute__nonnull__(a) __attribute__((nonnull(a))) 381 #endif 382 #ifdef HASATTRIBUTE_NORETURN 383 # define __attribute__noreturn__ __attribute__((noreturn)) 384 #endif 385 #ifdef HASATTRIBUTE_PURE 386 # define __attribute__pure__ __attribute__((pure)) 387 #endif 388 #ifdef HASATTRIBUTE_UNUSED 389 # define __attribute__unused__ __attribute__((unused)) 390 #endif 391 #ifdef HASATTRIBUTE_WARN_UNUSED_RESULT 392 # define __attribute__warn_unused_result__ __attribute__((warn_unused_result)) 393 #endif 394 #ifdef HASATTRIBUTE_ALWAYS_INLINE 395 /* always_inline is buggy in gcc <= 4.6 and causes compilation errors */ 396 # if !defined(PERL_IS_GCC) || PERL_GCC_VERSION_GE(4,7,0) 397 # define __attribute__always_inline__ __attribute__((always_inline)) 398 # endif 399 #endif 400 401 /* If we haven't defined the attributes yet, define them to blank. */ 402 #ifndef __attribute__deprecated__ 403 # define __attribute__deprecated__ 404 #endif 405 #ifndef __attribute__format__ 406 # define __attribute__format__(x,y,z) 407 #endif 408 #ifndef __attribute__malloc__ 409 # define __attribute__malloc__ 410 #endif 411 #ifndef __attribute__nonnull__ 412 # define __attribute__nonnull__(a) 413 #endif 414 #ifndef __attribute__noreturn__ 415 # define __attribute__noreturn__ 416 #endif 417 #ifndef __attribute__pure__ 418 # define __attribute__pure__ 419 #endif 420 #ifndef __attribute__unused__ 421 # define __attribute__unused__ 422 #endif 423 #ifndef __attribute__warn_unused_result__ 424 # define __attribute__warn_unused_result__ 425 #endif 426 #ifndef __attribute__always_inline__ 427 # define __attribute__always_inline__ 428 #endif 429 430 /* Some OS warn on NULL format to printf */ 431 #ifdef PRINTF_FORMAT_NULL_OK 432 # define __attribute__format__null_ok__(x,y,z) __attribute__format__(x,y,z) 433 #else 434 # define __attribute__format__null_ok__(x,y,z) 435 #endif 436 437 /* 438 * Because of backward compatibility reasons the PERL_UNUSED_DECL 439 * cannot be changed from postfix to PERL_UNUSED_DECL(x). Sigh. 440 * 441 * Note that there are C compilers such as MetroWerks CodeWarrior 442 * which do not have an "inlined" way (like the gcc __attribute__) of 443 * marking unused variables (they need e.g. a #pragma) and therefore 444 * cpp macros like PERL_UNUSED_DECL cannot work for this purpose, even 445 * if it were PERL_UNUSED_DECL(x), which it cannot be (see above). 446 447 =for apidoc_section $directives 448 =for apidoc AmnU||PERL_UNUSED_DECL 449 Tells the compiler that the parameter in the function prototype just before it 450 is not necessarily expected to be used in the function. Not that many 451 compilers understand this, so this should only be used in cases where 452 C<L</PERL_UNUSED_ARG>> can't conveniently be used. 453 454 Example usage: 455 456 =over 457 458 Signal_t 459 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, 460 void *uap PERL_UNUSED_DECL, bool safe) 461 462 =back 463 464 =cut 465 */ 466 467 #ifndef PERL_UNUSED_DECL 468 # define PERL_UNUSED_DECL __attribute__unused__ 469 #endif 470 471 /* gcc -Wall: 472 * for silencing unused variables that are actually used most of the time, 473 * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs, 474 * or variables/arguments that are used only in certain configurations. 475 476 =for apidoc Ams||PERL_UNUSED_ARG|void x 477 This is used to suppress compiler warnings that a parameter to a function is 478 not used. This situation can arise, for example, when a parameter is needed 479 under some configuration conditions, but not others, so that C preprocessor 480 conditional compilation causes it be used just some times. 481 482 =for apidoc Amns||PERL_UNUSED_CONTEXT 483 This is used to suppress compiler warnings that the thread context parameter to 484 a function is not used. This situation can arise, for example, when a 485 C preprocessor conditional compilation causes it be used just some times. 486 487 =for apidoc Ams||PERL_UNUSED_VAR|void x 488 This is used to suppress compiler warnings that the variable I<x> is not used. 489 This situation can arise, for example, when a C preprocessor conditional 490 compilation causes it be used just some times. 491 492 =cut 493 */ 494 #ifndef PERL_UNUSED_ARG 495 # define PERL_UNUSED_ARG(x) ((void)sizeof(x)) 496 #endif 497 #ifndef PERL_UNUSED_VAR 498 # define PERL_UNUSED_VAR(x) ((void)sizeof(x)) 499 #endif 500 501 #if defined(USE_ITHREADS) 502 # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) 503 #else 504 # define PERL_UNUSED_CONTEXT 505 #endif 506 507 /* gcc (-ansi) -pedantic doesn't allow gcc statement expressions, 508 * g++ allows them but seems to have problems with them 509 * (insane errors ensue). 510 * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2). 511 */ 512 #if defined(PERL_GCC_PEDANTIC) || \ 513 (defined(__GNUC__) && defined(__cplusplus) && \ 514 (PERL_GCC_VERSION_LT(4,2,0))) 515 # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN 516 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN 517 # endif 518 #endif 519 520 /* 521 522 =for apidoc Am||PERL_UNUSED_RESULT|void x 523 524 This macro indicates to discard the return value of the function call inside 525 it, I<e.g.>, 526 527 PERL_UNUSED_RESULT(foo(a, b)) 528 529 The main reason for this is that the combination of C<gcc -Wunused-result> 530 (part of C<-Wall>) and the C<__attribute__((warn_unused_result))> cannot 531 be silenced with casting to C<void>. This causes trouble when the system 532 header files use the attribute. 533 534 Use C<PERL_UNUSED_RESULT> sparingly, though, since usually the warning 535 is there for a good reason: you might lose success/failure information, 536 or leak resources, or changes in resources. 537 538 But sometimes you just want to ignore the return value, I<e.g.>, on 539 codepaths soon ending up in abort, or in "best effort" attempts, 540 or in situations where there is no good way to handle failures. 541 542 Sometimes C<PERL_UNUSED_RESULT> might not be the most natural way: 543 another possibility is that you can capture the return value 544 and use C<L</PERL_UNUSED_VAR>> on that. 545 546 =cut 547 548 The __typeof__() is used instead of typeof() since typeof() is not 549 available under strict C89, and because of compilers masquerading 550 as gcc (clang and icc), we want exactly the gcc extension 551 __typeof__ and nothing else. 552 553 */ 554 #ifndef PERL_UNUSED_RESULT 555 # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) 556 # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END 557 # else 558 # define PERL_UNUSED_RESULT(v) ((void)(v)) 559 # endif 560 #endif 561 562 /* on gcc (and clang), specify that a warning should be temporarily 563 * ignored; e.g. 564 * 565 * GCC_DIAG_IGNORE_DECL(-Wmultichar); 566 * char b = 'ab'; 567 * GCC_DIAG_RESTORE_DECL; 568 * 569 * based on http://dbp-consulting.com/tutorials/SuppressingGCCWarnings.html 570 * 571 * Note that "pragma GCC diagnostic push/pop" was added in GCC 4.6, Mar 2011; 572 * clang only pretends to be GCC 4.2, but still supports push/pop. 573 * 574 * Note on usage: all macros must be used at a place where a declaration 575 * or statement can occur, i.e., not in the middle of an expression. 576 * *_DIAG_IGNORE() and *_DIAG_RESTORE can be used in any such place, but 577 * must be used without a following semicolon. *_DIAG_IGNORE_DECL() and 578 * *_DIAG_RESTORE_DECL must be used with a following semicolon, and behave 579 * syntactically as declarations (like dNOOP). *_DIAG_IGNORE_STMT() 580 * and *_DIAG_RESTORE_STMT must be used with a following semicolon, 581 * and behave syntactically as statements (like NOOP). 582 * 583 */ 584 585 #if defined(__clang__) || defined(__clang) || PERL_GCC_VERSION_GE(4,6,0) 586 # define GCC_DIAG_PRAGMA(x) _Pragma (#x) 587 /* clang has "clang diagnostic" pragmas, but also understands gcc. */ 588 # define GCC_DIAG_IGNORE(x) _Pragma("GCC diagnostic push") \ 589 GCC_DIAG_PRAGMA(GCC diagnostic ignored #x) 590 # define GCC_DIAG_RESTORE _Pragma("GCC diagnostic pop") 591 #else 592 # define GCC_DIAG_IGNORE(w) 593 # define GCC_DIAG_RESTORE 594 #endif 595 #define GCC_DIAG_IGNORE_DECL(x) GCC_DIAG_IGNORE(x) dNOOP 596 #define GCC_DIAG_RESTORE_DECL GCC_DIAG_RESTORE dNOOP 597 #define GCC_DIAG_IGNORE_STMT(x) GCC_DIAG_IGNORE(x) NOOP 598 #define GCC_DIAG_RESTORE_STMT GCC_DIAG_RESTORE NOOP 599 /* for clang specific pragmas */ 600 #if defined(__clang__) || defined(__clang) 601 # define CLANG_DIAG_PRAGMA(x) _Pragma (#x) 602 # define CLANG_DIAG_IGNORE(x) _Pragma("clang diagnostic push") \ 603 CLANG_DIAG_PRAGMA(clang diagnostic ignored #x) 604 # define CLANG_DIAG_RESTORE _Pragma("clang diagnostic pop") 605 #else 606 # define CLANG_DIAG_IGNORE(w) 607 # define CLANG_DIAG_RESTORE 608 #endif 609 #define CLANG_DIAG_IGNORE_DECL(x) CLANG_DIAG_IGNORE(x) dNOOP 610 #define CLANG_DIAG_RESTORE_DECL CLANG_DIAG_RESTORE dNOOP 611 #define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP 612 #define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP 613 614 #if defined(_MSC_VER) 615 # define MSVC_DIAG_IGNORE(x) __pragma(warning(push)) \ 616 __pragma(warning(disable : x)) 617 # define MSVC_DIAG_RESTORE __pragma(warning(pop)) 618 #else 619 # define MSVC_DIAG_IGNORE(x) 620 # define MSVC_DIAG_RESTORE 621 #endif 622 #define MSVC_DIAG_IGNORE_DECL(x) MSVC_DIAG_IGNORE(x) dNOOP 623 #define MSVC_DIAG_RESTORE_DECL MSVC_DIAG_RESTORE dNOOP 624 #define MSVC_DIAG_IGNORE_STMT(x) MSVC_DIAG_IGNORE(x) NOOP 625 #define MSVC_DIAG_RESTORE_STMT MSVC_DIAG_RESTORE NOOP 626 627 /* 628 =for apidoc Amns||NOOP 629 Do nothing; typically used as a placeholder to replace something that used to 630 do something. 631 632 =for apidoc Amns||dNOOP 633 Declare nothing; typically used as a placeholder to replace something that used 634 to declare something. Works on compilers that require declarations before any 635 code. 636 637 =cut 638 */ 639 #define NOOP /*EMPTY*/(void)0 640 #define dNOOP struct Perl___notused_struct 641 642 #ifndef pTHX 643 /* Don't bother defining tTHX ; using it outside 644 * code guarded by MULTIPLICITY is an error. 645 */ 646 # define pTHX void 647 # define pTHX_ 648 # define aTHX 649 # define aTHX_ 650 # define aTHXa(a) NOOP 651 # define dTHXa(a) dNOOP 652 # define dTHX dNOOP 653 # define pTHX_1 1 654 # define pTHX_2 2 655 # define pTHX_3 3 656 # define pTHX_4 4 657 # define pTHX_5 5 658 # define pTHX_6 6 659 # define pTHX_7 7 660 # define pTHX_8 8 661 # define pTHX_9 9 662 # define pTHX_12 12 663 #endif 664 665 /* 666 =for apidoc_section $concurrency 667 =for apidoc AmnU||dVAR 668 This is now a synonym for dNOOP: declare nothing 669 670 =for apidoc_section $XS 671 =for apidoc Amns||dMY_CXT_SV 672 Now a placeholder that declares nothing 673 674 =cut 675 */ 676 677 #ifndef PERL_CORE 678 /* Backwards compatibility macro for XS code. It used to be part of the 679 * PERL_GLOBAL_STRUCT(_PRIVATE) feature, which no longer exists */ 680 # define dVAR dNOOP 681 682 /* these are only defined for compatibility; should not be used internally. 683 * */ 684 # define dMY_CXT_SV dNOOP 685 # ifndef pTHXo 686 # define pTHXo pTHX 687 # define pTHXo_ pTHX_ 688 # define aTHXo aTHX 689 # define aTHXo_ aTHX_ 690 # define dTHXo dTHX 691 # define dTHXoa(x) dTHXa(x) 692 # endif 693 #endif 694 695 #ifndef pTHXx 696 # define pTHXx PerlInterpreter *my_perl 697 # define pTHXx_ pTHXx, 698 # define aTHXx my_perl 699 # define aTHXx_ aTHXx, 700 # define dTHXx dTHX 701 #endif 702 703 /* Under PERL_IMPLICIT_SYS (used in Windows for fork emulation) 704 * PerlIO_foo() expands to PL_StdIO->pFOO(PL_StdIO, ...). 705 * dTHXs is therefore needed for all functions using PerlIO_foo(). */ 706 #ifdef PERL_IMPLICIT_SYS 707 # define dTHXs dTHX 708 #else 709 # define dTHXs dNOOP 710 #endif 711 712 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) 713 # ifndef PERL_USE_GCC_BRACE_GROUPS 714 # define PERL_USE_GCC_BRACE_GROUPS 715 # endif 716 #endif 717 718 /* 719 =for apidoc_section $directives 720 =for apidoc AmnUu|void|STMT_START 721 =for apidoc_item ||STMT_END 722 723 This allows a series of statements in a macro to be used as a single statement, 724 as in 725 726 if (x) STMT_START { ... } STMT_END else ... 727 728 Note that you can't return a value out of them, which limits their utility. 729 But see C<L</PERL_USE_GCC_BRACE_GROUPS>>. 730 731 =for apidoc AmnuU|bool|PERL_USE_GCC_BRACE_GROUPS 732 733 This C pre-processor value, if defined, indicates that it is permissible to use 734 the GCC brace groups extension. This extension, of the form 735 736 ({ statement ... }) 737 738 turns the block consisting of I<statements ...> into an expression with a 739 value, unlike plain C language blocks. This can present optimization 740 possibilities, B<BUT> you generally need to specify an alternative in case this 741 ability doesn't exist or has otherwise been forbidden. 742 743 Example usage: 744 745 =over 746 747 #ifdef PERL_USE_GCC_BRACE_GROUPS 748 ... 749 #else 750 ... 751 #endif 752 753 =back 754 755 =cut 756 757 Trying to select a version that gives no warnings... 758 */ 759 #if !(defined(STMT_START) && defined(STMT_END)) 760 # define STMT_START do 761 # define STMT_END while (0) 762 #endif 763 764 #ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */ 765 # define BYTEORDER 0x1234 766 #endif 767 768 #if 'A' == 65 && 'I' == 73 && 'J' == 74 && 'Z' == 90 769 #define ASCIIish 770 #else 771 #undef ASCIIish 772 #endif 773 774 /* 775 * The following contortions are brought to you on behalf of all the 776 * standards, semi-standards, de facto standards, not-so-de-facto standards 777 * of the world, as well as all the other botches anyone ever thought of. 778 * The basic theory is that if we work hard enough here, the rest of the 779 * code can be a lot prettier. Well, so much for theory. Sorry, Henry... 780 */ 781 782 /* define this once if either system, instead of cluttering up the src */ 783 #if defined(WIN32) 784 #define DOSISH 1 785 #endif 786 787 /* These exist only for back-compat with XS modules. */ 788 #ifndef PERL_CORE 789 #define VOL volatile 790 #define CAN_PROTOTYPE 791 #define _(args) args 792 #define I_LIMITS 793 #define I_STDARG 794 #define STANDARD_C 795 #endif 796 797 /* By compiling a perl with -DNO_TAINT_SUPPORT or -DSILENT_NO_TAINT_SUPPORT, 798 * you get a perl without taint support, but doubtlessly with a lesser 799 * degree of support. Do not do so unless you know exactly what it means 800 * technically, have a good reason to do so, and know exactly how the 801 * perl will be used. perls with -DSILENT_NO_TAINT_SUPPORT are considered 802 * a potential security risk due to flat out ignoring the security-relevant 803 * taint flags. This being said, a perl without taint support compiled in 804 * has marginal run-time performance benefits. 805 * SILENT_NO_TAINT_SUPPORT implies NO_TAINT_SUPPORT. 806 * SILENT_NO_TAINT_SUPPORT is the same as NO_TAINT_SUPPORT except it 807 * silently ignores -t/-T instead of throwing an exception. 808 * 809 * DANGER! Using NO_TAINT_SUPPORT or SILENT_NO_TAINT_SUPPORT 810 * voids your nonexistent warranty! 811 */ 812 #if defined(SILENT_NO_TAINT_SUPPORT) && !defined(NO_TAINT_SUPPORT) 813 # define NO_TAINT_SUPPORT 1 814 #endif 815 816 /* NO_TAINT_SUPPORT can be set to transform virtually all taint-related 817 * operations into no-ops for a very modest speed-up. Enable only if you 818 * know what you're doing: tests and CPAN modules' tests are bound to fail. 819 */ 820 #ifdef NO_TAINT_SUPPORT 821 # define TAINT NOOP 822 # define TAINT_NOT NOOP 823 # define TAINT_IF(c) NOOP 824 # define TAINT_ENV() NOOP 825 # define TAINT_PROPER(s) NOOP 826 # define TAINT_set(s) NOOP 827 # define TAINT_get 0 828 # define TAINTING_get 0 829 # define TAINTING_set(s) NOOP 830 # define TAINT_WARN_get 0 831 # define TAINT_WARN_set(s) NOOP 832 #else 833 834 /* 835 =for apidoc_section $tainting 836 =for apidoc Cm|void|TAINT 837 838 If we aren't in taint checking mode, do nothing; 839 otherwise indicate to L</C<TAINT_set>> and L</C<TAINT_PROPER>> that some 840 unspecified element is tainted. 841 842 =for apidoc Cm|void|TAINT_NOT 843 844 Remove any taintedness previously set by, I<e.g.>, C<TAINT>. 845 846 =for apidoc Cm|void|TAINT_IF|bool c 847 848 If C<c> evaluates to true, call L</C<TAINT>> to indicate that something is 849 tainted; otherwise do nothing. 850 851 =for apidoc Cmn|void|TAINT_ENV 852 853 Looks at several components of L<C<%ENV>|perlvar/%ENV> for taintedness, and 854 calls L</C<taint_proper>> if any are tainted. The components it searches are 855 things like C<$PATH>. 856 857 =for apidoc Cm|void|TAINT_PROPER|const char * s 858 859 If no element is tainted, do nothing; 860 otherwise output a message (containing C<s>) that indicates there is a 861 tainting violation. If such violations are fatal, it croaks. 862 863 =for apidoc Cm|void|TAINT_set|bool s 864 865 If C<s> is true, L</C<TAINT_get>> returns true; 866 If C<s> is false, L</C<TAINT_get>> returns false; 867 868 =for apidoc Cm|bool|TAINT_get 869 870 Returns a boolean as to whether some element is tainted or not. 871 872 =for apidoc Cm|bool|TAINTING_get 873 874 Returns a boolean as to whether taint checking is enabled or not. 875 876 =for apidoc Cm|void|TAINTING_set|bool s 877 878 Turn taint checking mode off/on 879 880 =for apidoc Cm|bool|TAINT_WARN_get 881 882 Returns false if tainting violations are fatal; 883 Returns true if they're just warnings 884 885 =for apidoc Cm|void|TAINT_WARN_set|bool s 886 887 C<s> being true indicates L</C<TAINT_WARN_get>> should return that tainting 888 violations are just warnings 889 890 C<s> being false indicates L</C<TAINT_WARN_get>> should return that tainting 891 violations are fatal. 892 893 =cut 894 */ 895 /* Set to tainted if we are running under tainting mode */ 896 # define TAINT (PL_tainted = PL_tainting) 897 898 # define TAINT_NOT (PL_tainted = FALSE) /* Untaint */ 899 # define TAINT_IF(c) if (UNLIKELY(c)) { TAINT; } /* Conditionally taint */ 900 # define TAINT_ENV() if (UNLIKELY(PL_tainting)) { taint_env(); } 901 /* croak or warn if tainting */ 902 # define TAINT_PROPER(s) if (UNLIKELY(PL_tainting)) { \ 903 taint_proper(NULL, s); \ 904 } 905 # define TAINT_set(s) (PL_tainted = cBOOL(s)) 906 # define TAINT_get (cBOOL(UNLIKELY(PL_tainted))) /* Is something tainted? */ 907 # define TAINTING_get (cBOOL(UNLIKELY(PL_tainting))) 908 # define TAINTING_set(s) (PL_tainting = cBOOL(s)) 909 # define TAINT_WARN_get (PL_taint_warn) 910 # define TAINT_WARN_set(s) (PL_taint_warn = cBOOL(s)) 911 #endif 912 913 /* flags used internally only within pp_subst and pp_substcont */ 914 #ifdef PERL_CORE 915 # define SUBST_TAINT_STR 1 /* string tainted */ 916 # define SUBST_TAINT_PAT 2 /* pattern tainted */ 917 # define SUBST_TAINT_REPL 4 /* replacement tainted */ 918 # define SUBST_TAINT_RETAINT 8 /* use re'taint' in scope */ 919 # define SUBST_TAINT_BOOLRET 16 /* return is boolean (don't taint) */ 920 #endif 921 922 /* XXX All process group stuff is handled in pp_sys.c. Should these 923 defines move there? If so, I could simplify this a lot. --AD 9/96. 924 */ 925 /* Process group stuff changed from traditional BSD to POSIX. 926 perlfunc.pod documents the traditional BSD-style syntax, so we'll 927 try to preserve that, if possible. 928 */ 929 #ifdef HAS_SETPGID 930 # define BSD_SETPGRP(pid, pgrp) setpgid((pid), (pgrp)) 931 #elif defined(HAS_SETPGRP) && defined(USE_BSD_SETPGRP) 932 # define BSD_SETPGRP(pid, pgrp) setpgrp((pid), (pgrp)) 933 #elif defined(HAS_SETPGRP2) 934 # define BSD_SETPGRP(pid, pgrp) setpgrp2((pid), (pgrp)) 935 #endif 936 #if defined(BSD_SETPGRP) && !defined(HAS_SETPGRP) 937 # define HAS_SETPGRP /* Well, effectively it does . . . */ 938 #endif 939 940 /* getpgid isn't POSIX, but at least Solaris and Linux have it, and it makes 941 our life easier :-) so we'll try it. 942 */ 943 #ifdef HAS_GETPGID 944 # define BSD_GETPGRP(pid) getpgid((pid)) 945 #elif defined(HAS_GETPGRP) && defined(USE_BSD_GETPGRP) 946 # define BSD_GETPGRP(pid) getpgrp((pid)) 947 #elif defined(HAS_GETPGRP2) 948 # define BSD_GETPGRP(pid) getpgrp2((pid)) 949 #endif 950 #if defined(BSD_GETPGRP) && !defined(HAS_GETPGRP) 951 # define HAS_GETPGRP /* Well, effectively it does . . . */ 952 #endif 953 954 /* These are not exact synonyms, since setpgrp() and getpgrp() may 955 have different behaviors, but perl.h used to define USE_BSDPGRP 956 (prior to 5.003_05) so some extension might depend on it. 957 */ 958 #if defined(USE_BSD_SETPGRP) || defined(USE_BSD_GETPGRP) 959 # ifndef USE_BSDPGRP 960 # define USE_BSDPGRP 961 # endif 962 #endif 963 964 /* HP-UX 10.X CMA (Common Multithreaded Architecture) insists that 965 pthread.h must be included before all other header files. 966 */ 967 #if defined(USE_ITHREADS) && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD) 968 # include <pthread.h> 969 #endif 970 971 #include <sys/types.h> 972 973 # ifdef I_WCHAR 974 # include <wchar.h> 975 # endif 976 977 # include <stdarg.h> 978 979 #ifdef I_STDINT 980 # include <stdint.h> 981 #endif 982 983 #include <ctype.h> 984 #include <float.h> 985 #include <limits.h> 986 987 #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ 988 #undef METHOD 989 #endif 990 991 #ifdef PERL_MICRO 992 # define NO_LOCALE 993 #endif 994 995 #ifdef I_LOCALE 996 # include <locale.h> 997 #endif 998 999 #ifdef NEED_XLOCALE_H 1000 # include <xlocale.h> 1001 #endif 1002 1003 /* If not forbidden, we enable locale handling if either 1) the POSIX 2008 1004 * functions are available, or 2) just the setlocale() function. This logic is 1005 * repeated in t/loc_tools.pl and makedef.pl; The three should be kept in 1006 * sync. */ 1007 #if ! defined(NO_LOCALE) 1008 1009 # if ! defined(NO_POSIX_2008_LOCALE) \ 1010 && defined(HAS_NEWLOCALE) \ 1011 && defined(HAS_USELOCALE) \ 1012 && defined(HAS_DUPLOCALE) \ 1013 && defined(HAS_FREELOCALE) \ 1014 && defined(LC_ALL_MASK) 1015 1016 /* For simplicity, the code is written to assume that any platform advanced 1017 * enough to have the Posix 2008 locale functions has LC_ALL. The final 1018 * test above makes sure that assumption is valid */ 1019 1020 # define HAS_POSIX_2008_LOCALE 1021 # define USE_LOCALE 1022 # elif defined(HAS_SETLOCALE) 1023 # define USE_LOCALE 1024 # endif 1025 #endif 1026 1027 #ifdef USE_LOCALE 1028 # define HAS_SKIP_LOCALE_INIT /* Solely for XS code to test for this 1029 #define */ 1030 # if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \ 1031 && defined(HAS_STRXFRM) 1032 # define USE_LOCALE_COLLATE 1033 # endif 1034 # if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE) 1035 # define USE_LOCALE_CTYPE 1036 # endif 1037 # if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC) 1038 # define USE_LOCALE_NUMERIC 1039 # endif 1040 # if !defined(NO_LOCALE_MESSAGES) && defined(LC_MESSAGES) 1041 # define USE_LOCALE_MESSAGES 1042 # endif 1043 # if !defined(NO_LOCALE_MONETARY) && defined(LC_MONETARY) 1044 # define USE_LOCALE_MONETARY 1045 # endif 1046 # if !defined(NO_LOCALE_TIME) && defined(LC_TIME) 1047 # define USE_LOCALE_TIME 1048 # endif 1049 # if !defined(NO_LOCALE_ADDRESS) && defined(LC_ADDRESS) 1050 # define USE_LOCALE_ADDRESS 1051 # endif 1052 # if !defined(NO_LOCALE_IDENTIFICATION) && defined(LC_IDENTIFICATION) 1053 # define USE_LOCALE_IDENTIFICATION 1054 # endif 1055 # if !defined(NO_LOCALE_MEASUREMENT) && defined(LC_MEASUREMENT) 1056 # define USE_LOCALE_MEASUREMENT 1057 # endif 1058 # if !defined(NO_LOCALE_PAPER) && defined(LC_PAPER) 1059 # define USE_LOCALE_PAPER 1060 # endif 1061 # if !defined(NO_LOCALE_TELEPHONE) && defined(LC_TELEPHONE) 1062 # define USE_LOCALE_TELEPHONE 1063 # endif 1064 # if !defined(NO_LOCALE_SYNTAX) && defined(LC_SYNTAX) 1065 # define USE_LOCALE_SYNTAX 1066 # endif 1067 # if !defined(NO_LOCALE_TOD) && defined(LC_TOD) 1068 # define USE_LOCALE_TOD 1069 # endif 1070 1071 /* XXX The next few defines are unfortunately duplicated in makedef.pl, and 1072 * changes here MUST also be made there */ 1073 1074 # if ! defined(HAS_SETLOCALE) && defined(HAS_POSIX_2008_LOCALE) 1075 # define USE_POSIX_2008_LOCALE 1076 # ifndef USE_THREAD_SAFE_LOCALE 1077 # define USE_THREAD_SAFE_LOCALE 1078 # endif 1079 /* If compiled with 1080 * -DUSE_THREAD_SAFE_LOCALE, will do so even 1081 * on unthreaded builds */ 1082 # elif (defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)) \ 1083 && ( defined(HAS_POSIX_2008_LOCALE) \ 1084 || (defined(WIN32) && defined(_MSC_VER))) \ 1085 && ! defined(NO_THREAD_SAFE_LOCALE) 1086 # ifndef USE_THREAD_SAFE_LOCALE 1087 # define USE_THREAD_SAFE_LOCALE 1088 # endif 1089 # ifdef HAS_POSIX_2008_LOCALE 1090 # define USE_POSIX_2008_LOCALE 1091 # endif 1092 # endif 1093 #endif 1094 1095 /* Microsoft documentation reads in the change log for VS 2015: 1096 * "The localeconv function declared in locale.h now works correctly when 1097 * per-thread locale is enabled. In previous versions of the library, this 1098 * function would return the lconv data for the global locale, not the 1099 * thread's locale." 1100 */ 1101 #if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE) && _MSC_VER < 1900 1102 # define TS_W32_BROKEN_LOCALECONV 1103 #endif 1104 1105 #include <setjmp.h> 1106 1107 #ifdef I_SYS_PARAM 1108 # ifdef PARAM_NEEDS_TYPES 1109 # include <sys/types.h> 1110 # endif 1111 # include <sys/param.h> 1112 #endif 1113 1114 /* On BSD-derived systems, <sys/param.h> defines BSD to a year-month 1115 value something like 199306. This may be useful if no more-specific 1116 feature test is available. 1117 */ 1118 #if defined(BSD) 1119 # ifndef BSDish 1120 # define BSDish 1121 # endif 1122 #endif 1123 1124 /* Use all the "standard" definitions */ 1125 #include <stdlib.h> 1126 1127 /* If this causes problems, set i_unistd=undef in the hint file. */ 1128 #ifdef I_UNISTD 1129 # if defined(__amigaos4__) 1130 # ifdef I_NETINET_IN 1131 # include <netinet/in.h> 1132 # endif 1133 # endif 1134 # include <unistd.h> 1135 # if defined(__amigaos4__) 1136 /* Under AmigaOS 4 newlib.library provides an environ. However using 1137 * it doesn't give us enough control over inheritance of variables by 1138 * subshells etc. so replace with custom version based on abc-shell 1139 * code. */ 1140 extern char **myenviron; 1141 # undef environ 1142 # define environ myenviron 1143 # endif 1144 #endif 1145 1146 /* for WCOREDUMP */ 1147 #ifdef I_SYS_WAIT 1148 # include <sys/wait.h> 1149 #endif 1150 1151 #if defined(HAS_SYSCALL) && !defined(HAS_SYSCALL_PROTO) 1152 EXTERN_C int syscall(int, ...); 1153 #endif 1154 1155 #if defined(HAS_USLEEP) && !defined(HAS_USLEEP_PROTO) 1156 EXTERN_C int usleep(unsigned int); 1157 #endif 1158 1159 /* Macros for correct constant construction. These are in C99 <stdint.h> 1160 * (so they will not be available in strict C89 mode), but they are nice, so 1161 * let's define them if necessary. 1162 =for apidoc_section $integer 1163 =for apidoc Am|I16|INT16_C|number 1164 =for apidoc_item |I32|INT32_C|number 1165 =for apidoc_item |I64|INT64_C|number 1166 1167 Returns a token the C compiler recognizes for the constant C<number> of the 1168 corresponding integer type on the machine. 1169 1170 If the machine does not have a 64-bit type, C<INT64_C> is undefined. 1171 Use C<L</INTMAX_C>> to get the largest type available on the platform. 1172 1173 =for apidoc Am|U16|UINT16_C|number 1174 =for apidoc_item |U32|UINT32_C|number 1175 =for apidoc_item |U64|UINT64_C|number 1176 1177 Returns a token the C compiler recognizes for the constant C<number> of the 1178 corresponding unsigned integer type on the machine. 1179 1180 If the machine does not have a 64-bit type, C<UINT64_C> is undefined. 1181 Use C<L</UINTMAX_C>> to get the largest type available on the platform. 1182 1183 1184 =cut 1185 */ 1186 #ifndef UINT16_C 1187 # if INTSIZE >= 2 1188 # define UINT16_C(x) ((U16_TYPE)x##U) 1189 # else 1190 # define UINT16_C(x) ((U16_TYPE)x##UL) 1191 # endif 1192 #endif 1193 1194 #ifndef UINT32_C 1195 # if INTSIZE >= 4 1196 # define UINT32_C(x) ((U32_TYPE)x##U) 1197 # else 1198 # define UINT32_C(x) ((U32_TYPE)x##UL) 1199 # endif 1200 #endif 1201 1202 #ifdef I_STDINT 1203 typedef intmax_t PERL_INTMAX_T; 1204 typedef uintmax_t PERL_UINTMAX_T; 1205 #endif 1206 1207 /* N.B. We use QUADKIND here instead of HAS_QUAD here, because that doesn't 1208 * actually mean what it has always been documented to mean (see RT #119753) 1209 * and is explicitly turned off outside of core with dire warnings about 1210 * removing the undef. */ 1211 1212 #if defined(QUADKIND) 1213 # undef PeRl_INT64_C 1214 # undef PeRl_UINT64_C 1215 /* Prefer the native integer types (int and long) over long long 1216 * (which is not C89) and Win32-specific __int64. */ 1217 # if QUADKIND == QUAD_IS_INT && INTSIZE == 8 1218 # define PeRl_INT64_C(c) (c) 1219 # define PeRl_UINT64_C(c) CAT2(c,U) 1220 # endif 1221 # if QUADKIND == QUAD_IS_LONG && LONGSIZE == 8 1222 # define PeRl_INT64_C(c) CAT2(c,L) 1223 # define PeRl_UINT64_C(c) CAT2(c,UL) 1224 # endif 1225 # if QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LONG_LONG) 1226 # define PeRl_INT64_C(c) CAT2(c,LL) 1227 # define PeRl_UINT64_C(c) CAT2(c,ULL) 1228 # endif 1229 # if QUADKIND == QUAD_IS___INT64 1230 # define PeRl_INT64_C(c) CAT2(c,I64) 1231 # define PeRl_UINT64_C(c) CAT2(c,UI64) 1232 # endif 1233 # ifndef PeRl_INT64_C 1234 # define PeRl_INT64_C(c) ((I64)(c)) /* last resort */ 1235 # define PeRl_UINT64_C(c) ((U64TYPE)(c)) 1236 # endif 1237 /* In OS X the INT64_C/UINT64_C are defined with LL/ULL, which will 1238 * not fly with C89-pedantic gcc, so let's undefine them first so that 1239 * we can redefine them with our native integer preferring versions. */ 1240 # if defined(PERL_DARWIN) && defined(PERL_GCC_PEDANTIC) 1241 # undef INT64_C 1242 # undef UINT64_C 1243 # endif 1244 # ifndef INT64_C 1245 # define INT64_C(c) PeRl_INT64_C(c) 1246 # endif 1247 # ifndef UINT64_C 1248 # define UINT64_C(c) PeRl_UINT64_C(c) 1249 # endif 1250 1251 /* 1252 =for apidoc_section $integer 1253 =for apidoc Am||INTMAX_C|number 1254 Returns a token the C compiler recognizes for the constant C<number> of the 1255 widest integer type on the machine. For example, if the machine has C<long 1256 long>s, C<INTMAX_C(-1)> would yield 1257 1258 -1LL 1259 1260 See also, for example, C<L</INT32_C>>. 1261 1262 Use L</IV> to declare variables of the maximum usable size on this platform. 1263 1264 =for apidoc Am||UINTMAX_C|number 1265 Returns a token the C compiler recognizes for the constant C<number> of the 1266 widest unsigned integer type on the machine. For example, if the machine has 1267 C<long>s, C<UINTMAX_C(1)> would yield 1268 1269 1UL 1270 1271 See also, for example, C<L</UINT32_C>>. 1272 1273 Use L</UV> to declare variables of the maximum usable size on this platform. 1274 1275 =cut 1276 */ 1277 1278 # ifndef I_STDINT 1279 typedef I64TYPE PERL_INTMAX_T; 1280 typedef U64TYPE PERL_UINTMAX_T; 1281 # endif 1282 # ifndef INTMAX_C 1283 # define INTMAX_C(c) INT64_C(c) 1284 # endif 1285 # ifndef UINTMAX_C 1286 # define UINTMAX_C(c) UINT64_C(c) 1287 # endif 1288 1289 #else /* below QUADKIND is undefined */ 1290 1291 /* Perl doesn't work on 16 bit systems, so must be 32 bit */ 1292 # ifndef I_STDINT 1293 typedef I32TYPE PERL_INTMAX_T; 1294 typedef U32TYPE PERL_UINTMAX_T; 1295 # endif 1296 # ifndef INTMAX_C 1297 # define INTMAX_C(c) INT32_C(c) 1298 # endif 1299 # ifndef UINTMAX_C 1300 # define UINTMAX_C(c) UINT32_C(c) 1301 # endif 1302 1303 #endif /* no QUADKIND */ 1304 1305 #ifdef PERL_CORE 1306 1307 /* byte-swapping functions for big-/little-endian conversion */ 1308 # define _swab_16_(x) ((U16)( \ 1309 (((U16)(x) & UINT16_C(0x00ff)) << 8) | \ 1310 (((U16)(x) & UINT16_C(0xff00)) >> 8) )) 1311 1312 # define _swab_32_(x) ((U32)( \ 1313 (((U32)(x) & UINT32_C(0x000000ff)) << 24) | \ 1314 (((U32)(x) & UINT32_C(0x0000ff00)) << 8) | \ 1315 (((U32)(x) & UINT32_C(0x00ff0000)) >> 8) | \ 1316 (((U32)(x) & UINT32_C(0xff000000)) >> 24) )) 1317 1318 # ifdef HAS_QUAD 1319 # define _swab_64_(x) ((U64)( \ 1320 (((U64)(x) & UINT64_C(0x00000000000000ff)) << 56) | \ 1321 (((U64)(x) & UINT64_C(0x000000000000ff00)) << 40) | \ 1322 (((U64)(x) & UINT64_C(0x0000000000ff0000)) << 24) | \ 1323 (((U64)(x) & UINT64_C(0x00000000ff000000)) << 8) | \ 1324 (((U64)(x) & UINT64_C(0x000000ff00000000)) >> 8) | \ 1325 (((U64)(x) & UINT64_C(0x0000ff0000000000)) >> 24) | \ 1326 (((U64)(x) & UINT64_C(0x00ff000000000000)) >> 40) | \ 1327 (((U64)(x) & UINT64_C(0xff00000000000000)) >> 56) )) 1328 # endif 1329 1330 /* Maximum level of recursion */ 1331 #ifndef PERL_SUB_DEPTH_WARN 1332 #define PERL_SUB_DEPTH_WARN 100 1333 #endif 1334 1335 #endif /* PERL_CORE */ 1336 1337 /* Maximum number of args that may be passed to an OP_MULTICONCAT op. 1338 * It determines the size of local arrays in S_maybe_multiconcat() and 1339 * pp_multiconcat(). 1340 */ 1341 #define PERL_MULTICONCAT_MAXARG 64 1342 1343 /* The indexes of fields of a multiconcat aux struct. 1344 * The fixed fields are followed by nargs+1 const segment lengths, 1345 * and if utf8 and non-utf8 differ, a second nargs+1 set for utf8. 1346 */ 1347 1348 #define PERL_MULTICONCAT_IX_NARGS 0 /* number of arguments */ 1349 #define PERL_MULTICONCAT_IX_PLAIN_PV 1 /* non-utf8 constant string */ 1350 #define PERL_MULTICONCAT_IX_PLAIN_LEN 2 /* non-utf8 constant string length */ 1351 #define PERL_MULTICONCAT_IX_UTF8_PV 3 /* utf8 constant string */ 1352 #define PERL_MULTICONCAT_IX_UTF8_LEN 4 /* utf8 constant string length */ 1353 #define PERL_MULTICONCAT_IX_LENGTHS 5 /* first of nargs+1 const segment lens */ 1354 #define PERL_MULTICONCAT_HEADER_SIZE 5 /* The number of fields of a 1355 multiconcat header */ 1356 1357 /* We no longer default to creating a new SV for GvSV. 1358 Do this before embed. */ 1359 #ifndef PERL_CREATE_GVSV 1360 # ifndef PERL_DONT_CREATE_GVSV 1361 # define PERL_DONT_CREATE_GVSV 1362 # endif 1363 #endif 1364 1365 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 1366 #define PERL_USES_PL_PIDSTATUS 1367 #endif 1368 1369 #if !defined(OS2) && !defined(WIN32) 1370 #define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION 1371 #endif 1372 1373 #define MEM_SIZE Size_t 1374 1375 /* Round all values passed to malloc up, by default to a multiple of 1376 sizeof(size_t) 1377 */ 1378 #ifndef PERL_STRLEN_ROUNDUP_QUANTUM 1379 #define PERL_STRLEN_ROUNDUP_QUANTUM Size_t_size 1380 #endif 1381 1382 /* sv_grow() will expand strings by at least a certain percentage of 1383 the previously *used* length to avoid excessive calls to realloc(). 1384 The default is 25% of the current length. 1385 */ 1386 #ifndef PERL_STRLEN_EXPAND_SHIFT 1387 # define PERL_STRLEN_EXPAND_SHIFT 2 1388 #endif 1389 1390 /* This use of offsetof() requires /Zc:offsetof- for VS2017 (and presumably 1391 * onwards) when building Socket.xs, but we can just use a different definition 1392 * for STRUCT_OFFSET instead. */ 1393 #if defined(WIN32) && defined(_MSC_VER) && _MSC_VER >= 1910 1394 # define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) 1395 #else 1396 # include <stddef.h> 1397 # define STRUCT_OFFSET(s,m) offsetof(s,m) 1398 #endif 1399 1400 /* ptrdiff_t is C11, so undef it under pedantic builds. (Actually it is 1401 * in C89, but apparently there are platforms where it doesn't exist. See 1402 * thread beginning at http://nntp.perl.org/group/perl.perl5.porters/251541.) 1403 * */ 1404 #ifdef PERL_GCC_PEDANTIC 1405 # undef HAS_PTRDIFF_T 1406 #endif 1407 1408 #ifdef HAS_PTRDIFF_T 1409 # define Ptrdiff_t ptrdiff_t 1410 #else 1411 # define Ptrdiff_t SSize_t 1412 #endif 1413 1414 # include <string.h> 1415 1416 /* This comes after <stdlib.h> so we don't try to change the standard 1417 * library prototypes; we'll use our own in proto.h instead. */ 1418 1419 #ifdef MYMALLOC 1420 # ifdef PERL_POLLUTE_MALLOC 1421 # ifndef PERL_EXTMALLOC_DEF 1422 # define Perl_malloc malloc 1423 # define Perl_calloc calloc 1424 # define Perl_realloc realloc 1425 # define Perl_mfree free 1426 # endif 1427 # else 1428 # define EMBEDMYMALLOC /* for compatibility */ 1429 # endif 1430 1431 # define safemalloc Perl_malloc 1432 # define safecalloc Perl_calloc 1433 # define saferealloc Perl_realloc 1434 # define safefree Perl_mfree 1435 # define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \ 1436 if (!TAINTING_get && MallocCfg_ptr[MallocCfg_cfg_env_read]) \ 1437 code; \ 1438 } STMT_END 1439 # define CHECK_MALLOC_TOO_LATE_FOR(ch) \ 1440 CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch)) 1441 # define panic_write2(s) write(2, s, strlen(s)) 1442 # define CHECK_MALLOC_TAINT(newval) \ 1443 CHECK_MALLOC_TOO_LATE_FOR_( \ 1444 if (newval) { \ 1445 PERL_UNUSED_RESULT(panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n"));\ 1446 exit(1); }) 1447 # define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \ 1448 if (doing_taint(argc,argv,env)) { \ 1449 MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \ 1450 }} STMT_END; 1451 #else /* MYMALLOC */ 1452 # define safemalloc safesysmalloc 1453 # define safecalloc safesyscalloc 1454 # define saferealloc safesysrealloc 1455 # define safefree safesysfree 1456 # define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0) 1457 # define CHECK_MALLOC_TAINT(newval) ((void)0) 1458 # define MALLOC_CHECK_TAINT(argc,argv,env) 1459 #endif /* MYMALLOC */ 1460 1461 /* diag_listed_as: "-T" is on the #! line, it must also be used on the command line */ 1462 #define TOO_LATE_FOR_(ch,what) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), what) 1463 #define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "") 1464 #define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") 1465 #define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL) 1466 1467 /* 1468 =for apidoc Am|void|memzero|void * d|Size_t l 1469 Set the C<l> bytes starting at C<*d> to all zeroes. 1470 1471 =cut 1472 */ 1473 #ifndef memzero 1474 # define memzero(d,l) memset(d,0,l) 1475 #endif 1476 1477 #ifdef I_NETINET_IN 1478 # include <netinet/in.h> 1479 #endif 1480 1481 #ifdef I_ARPA_INET 1482 # include <arpa/inet.h> 1483 #endif 1484 1485 #ifdef I_SYS_STAT 1486 # include <sys/stat.h> 1487 #endif 1488 1489 /* Microsoft VC's sys/stat.h defines all S_Ixxx macros except S_IFIFO. 1490 This definition should ideally go into win32/win32.h, but S_IFIFO is 1491 used later here in perl.h before win32/win32.h is being included. */ 1492 #if !defined(S_IFIFO) && defined(_S_IFIFO) 1493 # define S_IFIFO _S_IFIFO 1494 #endif 1495 1496 /* The stat macros for Unisoft System V/88 (and derivatives 1497 like UTekV) are broken, sometimes giving false positives. Undefine 1498 them here and let the code below set them to proper values. 1499 1500 The ghs macro stands for GreenHills Software C-1.8.5 which 1501 is the C compiler for sysV88 and the various derivatives. 1502 This header file bug is corrected in gcc-2.5.8 and later versions. 1503 --Kaveh Ghazi (ghazi@noc.rutgers.edu) 10/3/94. */ 1504 1505 #if defined(m88k) && defined(ghs) 1506 # undef S_ISDIR 1507 # undef S_ISCHR 1508 # undef S_ISBLK 1509 # undef S_ISREG 1510 # undef S_ISFIFO 1511 # undef S_ISLNK 1512 #endif 1513 1514 #include <time.h> 1515 1516 #ifdef I_SYS_TIME 1517 # ifdef I_SYS_TIME_KERNEL 1518 # define KERNEL 1519 # endif 1520 # include <sys/time.h> 1521 # ifdef I_SYS_TIME_KERNEL 1522 # undef KERNEL 1523 # endif 1524 #endif 1525 1526 #if defined(HAS_TIMES) && defined(I_SYS_TIMES) 1527 # include <sys/times.h> 1528 #endif 1529 1530 #include <errno.h> 1531 1532 #if defined(WIN32) && defined(PERL_IMPLICIT_SYS) 1533 # define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */ 1534 #endif 1535 1536 #if defined(HAS_SOCKET) && !defined(WIN32) /* WIN32 handles sockets via win32.h */ 1537 # include <sys/socket.h> 1538 # if defined(USE_SOCKS) && defined(I_SOCKS) 1539 # if !defined(INCLUDE_PROTOTYPES) 1540 # define INCLUDE_PROTOTYPES /* for <socks.h> */ 1541 # define PERL_SOCKS_NEED_PROTOTYPES 1542 # endif 1543 # include <socks.h> 1544 # ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */ 1545 # undef INCLUDE_PROTOTYPES 1546 # undef PERL_SOCKS_NEED_PROTOTYPES 1547 # endif 1548 # endif 1549 # ifdef I_NETDB 1550 # include <netdb.h> 1551 # endif 1552 # ifndef ENOTSOCK 1553 # ifdef I_NET_ERRNO 1554 # include <net/errno.h> 1555 # endif 1556 # endif 1557 #endif 1558 1559 /* sockatmark() is so new (2001) that many places might have it hidden 1560 * behind some -D_BLAH_BLAH_SOURCE guard. The __THROW magic is required 1561 * e.g. in Gentoo, see http://bugs.gentoo.org/show_bug.cgi?id=12605 */ 1562 #if defined(HAS_SOCKATMARK) && !defined(HAS_SOCKATMARK_PROTO) 1563 # if defined(__THROW) && defined(__GLIBC__) 1564 int sockatmark(int) __THROW; 1565 # else 1566 int sockatmark(int); 1567 # endif 1568 #endif 1569 1570 #if defined(__osf__) && defined(__cplusplus) && !defined(_XOPEN_SOURCE_EXTENDED) /* Tru64 "cxx" (C++), see hints/dec_osf.sh for why the _XOPEN_SOURCE_EXTENDED cannot be defined. */ 1571 EXTERN_C int fchdir(int); 1572 EXTERN_C int flock(int, int); 1573 EXTERN_C int fseeko(FILE *, off_t, int); 1574 EXTERN_C off_t ftello(FILE *); 1575 #endif 1576 1577 #if defined(__SUNPRO_CC) /* SUNWspro CC (C++) */ 1578 EXTERN_C char *crypt(const char *, const char *); 1579 #endif 1580 1581 #if defined(__cplusplus) && defined(__CYGWIN__) 1582 EXTERN_C char *crypt(const char *, const char *); 1583 #endif 1584 1585 /* 1586 =for apidoc_section $errno 1587 1588 =for apidoc m|void|SETERRNO|int errcode|int vmserrcode 1589 1590 Set C<errno>, and on VMS set C<vaxc$errno>. 1591 1592 =for apidoc mn|void|dSAVEDERRNO 1593 1594 Declare variables needed to save C<errno> and any operating system 1595 specific error number. 1596 1597 =for apidoc mn|void|dSAVE_ERRNO 1598 1599 Declare variables needed to save C<errno> and any operating system 1600 specific error number, and save them for optional later restoration 1601 by C<RESTORE_ERRNO>. 1602 1603 =for apidoc mn|void|SAVE_ERRNO 1604 1605 Save C<errno> and any operating system specific error number for 1606 optional later restoration by C<RESTORE_ERRNO>. Requires 1607 C<dSAVEDERRNO> or C<dSAVE_ERRNO> in scope. 1608 1609 =for apidoc mn|void|RESTORE_ERRNO 1610 1611 Restore C<errno> and any operating system specific error number that 1612 was saved by C<dSAVE_ERRNO> or C<RESTORE_ERRNO>. 1613 1614 =cut 1615 */ 1616 1617 #ifdef SETERRNO 1618 # undef SETERRNO /* SOCKS might have defined this */ 1619 #endif 1620 1621 #ifdef VMS 1622 # define SETERRNO(errcode,vmserrcode) \ 1623 STMT_START { \ 1624 set_errno(errcode); \ 1625 set_vaxc_errno(vmserrcode); \ 1626 } STMT_END 1627 # define dSAVEDERRNO int saved_errno; unsigned saved_vms_errno 1628 # define dSAVE_ERRNO int saved_errno = errno; unsigned saved_vms_errno = vaxc$errno 1629 # define SAVE_ERRNO ( saved_errno = errno, saved_vms_errno = vaxc$errno ) 1630 # define RESTORE_ERRNO SETERRNO(saved_errno, saved_vms_errno) 1631 1632 # define LIB_INVARG LIB$_INVARG 1633 # define RMS_DIR RMS$_DIR 1634 # define RMS_FAC RMS$_FAC 1635 # define RMS_FEX RMS$_FEX 1636 # define RMS_FNF RMS$_FNF 1637 # define RMS_IFI RMS$_IFI 1638 # define RMS_ISI RMS$_ISI 1639 # define RMS_PRV RMS$_PRV 1640 # define SS_ACCVIO SS$_ACCVIO 1641 # define SS_DEVOFFLINE SS$_DEVOFFLINE 1642 # define SS_IVCHAN SS$_IVCHAN 1643 # define SS_NORMAL SS$_NORMAL 1644 # define SS_NOPRIV SS$_NOPRIV 1645 # define SS_BUFFEROVF SS$_BUFFEROVF 1646 #else 1647 # define LIB_INVARG 0 1648 # define RMS_DIR 0 1649 # define RMS_FAC 0 1650 # define RMS_FEX 0 1651 # define RMS_FNF 0 1652 # define RMS_IFI 0 1653 # define RMS_ISI 0 1654 # define RMS_PRV 0 1655 # define SS_ACCVIO 0 1656 # define SS_DEVOFFLINE 0 1657 # define SS_IVCHAN 0 1658 # define SS_NORMAL 0 1659 # define SS_NOPRIV 0 1660 # define SS_BUFFEROVF 0 1661 #endif 1662 1663 #ifdef WIN32 1664 # define dSAVEDERRNO int saved_errno; DWORD saved_win32_errno 1665 # define dSAVE_ERRNO int saved_errno = errno; DWORD saved_win32_errno = GetLastError() 1666 # define SAVE_ERRNO ( saved_errno = errno, saved_win32_errno = GetLastError() ) 1667 # define RESTORE_ERRNO ( errno = saved_errno, SetLastError(saved_win32_errno) ) 1668 #endif 1669 1670 #ifdef OS2 1671 # define dSAVEDERRNO int saved_errno; unsigned long saved_os2_errno 1672 # define dSAVE_ERRNO int saved_errno = errno; unsigned long saved_os2_errno = Perl_rc 1673 # define SAVE_ERRNO ( saved_errno = errno, saved_os2_errno = Perl_rc ) 1674 # define RESTORE_ERRNO ( errno = saved_errno, Perl_rc = saved_os2_errno ) 1675 #endif 1676 1677 #ifndef SETERRNO 1678 # define SETERRNO(errcode,vmserrcode) (errno = (errcode)) 1679 #endif 1680 1681 #ifndef dSAVEDERRNO 1682 # define dSAVEDERRNO int saved_errno 1683 # define dSAVE_ERRNO int saved_errno = errno 1684 # define SAVE_ERRNO (saved_errno = errno) 1685 # define RESTORE_ERRNO (errno = saved_errno) 1686 #endif 1687 1688 /* 1689 =for apidoc_section $warning 1690 1691 =for apidoc Amn|SV *|ERRSV 1692 1693 Returns the SV for C<$@>, creating it if needed. 1694 1695 =for apidoc Am|void|CLEAR_ERRSV 1696 1697 Clear the contents of C<$@>, setting it to the empty string. 1698 1699 This replaces any read-only SV with a fresh SV and removes any magic. 1700 1701 =for apidoc Am|void|SANE_ERRSV 1702 1703 Clean up ERRSV so we can safely set it. 1704 1705 This replaces any read-only SV with a fresh writable copy and removes 1706 any magic. 1707 1708 =cut 1709 */ 1710 1711 #define ERRSV GvSVn(PL_errgv) 1712 1713 /* contains inlined gv_add_by_type */ 1714 #define CLEAR_ERRSV() STMT_START { \ 1715 SV ** const svp = &GvSV(PL_errgv); \ 1716 if (!*svp) { \ 1717 *svp = newSVpvs(""); \ 1718 } else if (SvREADONLY(*svp)) { \ 1719 SvREFCNT_dec_NN(*svp); \ 1720 *svp = newSVpvs(""); \ 1721 } else { \ 1722 SV *const errsv = *svp; \ 1723 SvPVCLEAR(errsv); \ 1724 SvPOK_only(errsv); \ 1725 if (SvMAGICAL(errsv)) { \ 1726 mg_free(errsv); \ 1727 } \ 1728 } \ 1729 } STMT_END 1730 1731 /* contains inlined gv_add_by_type */ 1732 #define SANE_ERRSV() STMT_START { \ 1733 SV ** const svp = &GvSV(PL_errgv); \ 1734 if (!*svp) { \ 1735 *svp = newSVpvs(""); \ 1736 } else if (SvREADONLY(*svp)) { \ 1737 SV *dupsv = newSVsv(*svp); \ 1738 SvREFCNT_dec_NN(*svp); \ 1739 *svp = dupsv; \ 1740 } else { \ 1741 SV *const errsv = *svp; \ 1742 if (SvMAGICAL(errsv)) { \ 1743 mg_free(errsv); \ 1744 } \ 1745 } \ 1746 } STMT_END 1747 1748 1749 #ifdef PERL_CORE 1750 # define DEFSV (0 + GvSVn(PL_defgv)) 1751 # define DEFSV_set(sv) \ 1752 (SvREFCNT_dec(GvSV(PL_defgv)), GvSV(PL_defgv) = SvREFCNT_inc(sv)) 1753 # define SAVE_DEFSV \ 1754 ( \ 1755 save_gp(PL_defgv, 0), \ 1756 GvINTRO_off(PL_defgv), \ 1757 SAVEGENERICSV(GvSV(PL_defgv)), \ 1758 GvSV(PL_defgv) = NULL \ 1759 ) 1760 #else 1761 # define DEFSV GvSVn(PL_defgv) 1762 # define DEFSV_set(sv) (GvSV(PL_defgv) = (sv)) 1763 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) 1764 #endif 1765 1766 /* 1767 =for apidoc_section $SV 1768 =for apidoc Amn|SV *|DEFSV 1769 Returns the SV associated with C<$_> 1770 1771 =for apidoc Am|void|DEFSV_set|SV * sv 1772 Associate C<sv> with C<$_> 1773 1774 =for apidoc Amn|void|SAVE_DEFSV 1775 Localize C<$_>. See L<perlguts/Localizing changes>. 1776 1777 =cut 1778 */ 1779 1780 #ifndef errno 1781 extern int errno; /* ANSI allows errno to be an lvalue expr. 1782 * For example in multithreaded environments 1783 * something like this might happen: 1784 * extern int *_errno(void); 1785 * #define errno (*_errno()) */ 1786 #endif 1787 1788 #define UNKNOWN_ERRNO_MSG "(unknown)" 1789 1790 #ifdef VMS 1791 #define Strerror(e) strerror((e), vaxc$errno) 1792 #else 1793 #define Strerror(e) strerror(e) 1794 #endif 1795 1796 #ifdef I_SYS_IOCTL 1797 # ifndef _IOCTL_ 1798 # include <sys/ioctl.h> 1799 # endif 1800 #endif 1801 1802 #if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000) 1803 # ifdef HAS_SOCKETPAIR 1804 # undef HAS_SOCKETPAIR 1805 # endif 1806 # ifdef I_NDBM 1807 # undef I_NDBM 1808 # endif 1809 #endif 1810 1811 #ifndef HAS_SOCKETPAIR 1812 # ifdef HAS_SOCKET 1813 # define socketpair Perl_my_socketpair 1814 # endif 1815 #endif 1816 1817 #if INTSIZE == 2 1818 # define htoni htons 1819 # define ntohi ntohs 1820 #else 1821 # define htoni htonl 1822 # define ntohi ntohl 1823 #endif 1824 1825 /* Configure already sets Direntry_t */ 1826 #if defined(I_DIRENT) 1827 # include <dirent.h> 1828 #elif defined(I_SYS_NDIR) 1829 # include <sys/ndir.h> 1830 #elif defined(I_SYS_DIR) 1831 # include <sys/dir.h> 1832 #endif 1833 1834 /* 1835 * The following gobbledygook brought to you on behalf of __STDC__. 1836 * (I could just use #ifndef __STDC__, but this is more bulletproof 1837 * in the face of half-implementations.) 1838 */ 1839 1840 #if defined(I_SYSMODE) 1841 #include <sys/mode.h> 1842 #endif 1843 1844 #ifndef S_IFMT 1845 # ifdef _S_IFMT 1846 # define S_IFMT _S_IFMT 1847 # else 1848 # define S_IFMT 0170000 1849 # endif 1850 #endif 1851 1852 #ifndef S_ISDIR 1853 # define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR) 1854 #endif 1855 1856 #ifndef S_ISCHR 1857 # define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR) 1858 #endif 1859 1860 #ifndef S_ISBLK 1861 # ifdef S_IFBLK 1862 # define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK) 1863 # else 1864 # define S_ISBLK(m) (0) 1865 # endif 1866 #endif 1867 1868 #ifndef S_ISREG 1869 # define S_ISREG(m) ((m & S_IFMT) == S_IFREG) 1870 #endif 1871 1872 #ifndef S_ISFIFO 1873 # ifdef S_IFIFO 1874 # define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO) 1875 # else 1876 # define S_ISFIFO(m) (0) 1877 # endif 1878 #endif 1879 1880 #ifndef S_ISLNK 1881 # ifdef _S_ISLNK 1882 # define S_ISLNK(m) _S_ISLNK(m) 1883 # elif defined(_S_IFLNK) 1884 # define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK) 1885 # elif defined(S_IFLNK) 1886 # define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK) 1887 # else 1888 # define S_ISLNK(m) (0) 1889 # endif 1890 #endif 1891 1892 #ifndef S_ISSOCK 1893 # ifdef _S_ISSOCK 1894 # define S_ISSOCK(m) _S_ISSOCK(m) 1895 # elif defined(_S_IFSOCK) 1896 # define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK) 1897 # elif defined(S_IFSOCK) 1898 # define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK) 1899 # else 1900 # define S_ISSOCK(m) (0) 1901 # endif 1902 #endif 1903 1904 #ifndef S_IRUSR 1905 # ifdef S_IREAD 1906 # define S_IRUSR S_IREAD 1907 # define S_IWUSR S_IWRITE 1908 # define S_IXUSR S_IEXEC 1909 # else 1910 # define S_IRUSR 0400 1911 # define S_IWUSR 0200 1912 # define S_IXUSR 0100 1913 # endif 1914 #endif 1915 1916 #ifndef S_IRGRP 1917 # ifdef S_IRUSR 1918 # define S_IRGRP (S_IRUSR>>3) 1919 # define S_IWGRP (S_IWUSR>>3) 1920 # define S_IXGRP (S_IXUSR>>3) 1921 # else 1922 # define S_IRGRP 0040 1923 # define S_IWGRP 0020 1924 # define S_IXGRP 0010 1925 # endif 1926 #endif 1927 1928 #ifndef S_IROTH 1929 # ifdef S_IRUSR 1930 # define S_IROTH (S_IRUSR>>6) 1931 # define S_IWOTH (S_IWUSR>>6) 1932 # define S_IXOTH (S_IXUSR>>6) 1933 # else 1934 # define S_IROTH 0040 1935 # define S_IWOTH 0020 1936 # define S_IXOTH 0010 1937 # endif 1938 #endif 1939 1940 #ifndef S_ISUID 1941 # define S_ISUID 04000 1942 #endif 1943 1944 #ifndef S_ISGID 1945 # define S_ISGID 02000 1946 #endif 1947 1948 #ifndef S_IRWXU 1949 # define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) 1950 #endif 1951 1952 #ifndef S_IRWXG 1953 # define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) 1954 #endif 1955 1956 #ifndef S_IRWXO 1957 # define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) 1958 #endif 1959 1960 /* Haiku R1 seems to define S_IREAD and S_IWRITE in <posix/fcntl.h> 1961 * which would get included through <sys/file.h >, but that is 3000 1962 * lines in the future. --jhi */ 1963 1964 #if !defined(S_IREAD) && !defined(__HAIKU__) 1965 # define S_IREAD S_IRUSR 1966 #endif 1967 1968 #if !defined(S_IWRITE) && !defined(__HAIKU__) 1969 # define S_IWRITE S_IWUSR 1970 #endif 1971 1972 #ifndef S_IEXEC 1973 # define S_IEXEC S_IXUSR 1974 #endif 1975 1976 #if defined(cray) || defined(gould) || defined(i860) || defined(pyr) 1977 # define SLOPPYDIVIDE 1978 #endif 1979 1980 #ifdef UV 1981 #undef UV 1982 #endif 1983 1984 /* This used to be conditionally defined based on whether we had a sprintf() 1985 * that correctly returns the string length (as required by C89), but we no 1986 * longer need that. XS modules can (and do) use this name, so it must remain 1987 * a part of the API that's visible to modules. 1988 1989 =for apidoc_section $string 1990 =for apidoc ATmD|int|my_sprintf|NN char *buffer|NN const char *pat|... 1991 1992 Do NOT use this due to the possibility of overflowing C<buffer>. Instead use 1993 my_snprintf() 1994 1995 =cut 1996 */ 1997 #define my_sprintf sprintf 1998 1999 /* 2000 * If we have v?snprintf() and the C99 variadic macros, we can just 2001 * use just the v?snprintf(). It is nice to try to trap the buffer 2002 * overflow, however, so if we are DEBUGGING, and we cannot use the 2003 * gcc statement expressions, then use the function wrappers which try 2004 * to trap the overflow. If we can use the gcc statement expressions, 2005 * we can try that even with the version that uses the C99 variadic 2006 * macros. 2007 */ 2008 2009 /* Note that we do not check against snprintf()/vsnprintf() returning 2010 * negative values because that is non-standard behaviour and we use 2011 * snprintf/vsnprintf only iff HAS_VSNPRINTF has been defined, and 2012 * that should be true only if the snprintf()/vsnprintf() are true 2013 * to the standard. */ 2014 2015 #define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len > (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END 2016 2017 #ifdef USE_QUADMATH 2018 # define my_snprintf Perl_my_snprintf 2019 # define PERL_MY_SNPRINTF_GUARDED 2020 #elif defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) 2021 # ifdef PERL_USE_GCC_BRACE_GROUPS 2022 # define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; }) 2023 # define PERL_MY_SNPRINTF_GUARDED 2024 # else 2025 # define my_snprintf(buffer, max, ...) snprintf(buffer, max, __VA_ARGS__) 2026 # endif 2027 #else 2028 # define my_snprintf Perl_my_snprintf 2029 # define PERL_MY_SNPRINTF_GUARDED 2030 #endif 2031 2032 /* There is no quadmath_vsnprintf, and therefore my_vsnprintf() 2033 * dies if called under USE_QUADMATH. */ 2034 #if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) 2035 # ifdef PERL_USE_GCC_BRACE_GROUPS 2036 # define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; }) 2037 # define PERL_MY_VSNPRINTF_GUARDED 2038 # else 2039 # define my_vsnprintf(buffer, max, ...) vsnprintf(buffer, max, __VA_ARGS__) 2040 # endif 2041 #else 2042 # define my_vsnprintf Perl_my_vsnprintf 2043 # define PERL_MY_VSNPRINTF_GUARDED 2044 #endif 2045 2046 /* You will definitely need to use the PERL_MY_SNPRINTF_POST_GUARD() 2047 * or PERL_MY_VSNPRINTF_POST_GUARD() if you otherwise decide to ignore 2048 * the result of my_snprintf() or my_vsnprintf(). (No, you should not 2049 * completely ignore it: otherwise you cannot know whether your output 2050 * was too long.) 2051 * 2052 * int len = my_sprintf(buf, max, ...); 2053 * PERL_MY_SNPRINTF_POST_GUARD(len, max); 2054 * 2055 * The trick is that in certain platforms [a] the my_sprintf() already 2056 * contains the sanity check, while in certain platforms [b] it needs 2057 * to be done as a separate step. The POST_GUARD is that step-- in [a] 2058 * platforms the POST_GUARD actually does nothing since the check has 2059 * already been done. Watch out for the max being the same in both calls. 2060 * 2061 * If you actually use the snprintf/vsnprintf return value already, 2062 * you assumedly are checking its validity somehow. But you can 2063 * insert the POST_GUARD() also in that case. */ 2064 2065 #ifndef PERL_MY_SNPRINTF_GUARDED 2066 # define PERL_MY_SNPRINTF_POST_GUARD(len, max) PERL_SNPRINTF_CHECK(len, max, snprintf) 2067 #else 2068 # define PERL_MY_SNPRINTF_POST_GUARD(len, max) PERL_UNUSED_VAR(len) 2069 #endif 2070 2071 #ifndef PERL_MY_VSNPRINTF_GUARDED 2072 # define PERL_MY_VSNPRINTF_POST_GUARD(len, max) PERL_SNPRINTF_CHECK(len, max, vsnprintf) 2073 #else 2074 # define PERL_MY_VSNPRINTF_POST_GUARD(len, max) PERL_UNUSED_VAR(len) 2075 #endif 2076 2077 #ifdef HAS_STRLCAT 2078 # define my_strlcat strlcat 2079 #endif 2080 2081 #if defined(PERL_CORE) || defined(PERL_EXT) 2082 # ifdef HAS_MEMRCHR 2083 # define my_memrchr memrchr 2084 # else 2085 # define my_memrchr S_my_memrchr 2086 # endif 2087 #endif 2088 2089 #ifdef HAS_STRLCPY 2090 # define my_strlcpy strlcpy 2091 #endif 2092 2093 #ifdef HAS_STRNLEN 2094 # define my_strnlen strnlen 2095 #endif 2096 2097 /* 2098 The IV type is supposed to be long enough to hold any integral 2099 value or a pointer. 2100 --Andy Dougherty August 1996 2101 */ 2102 2103 typedef IVTYPE IV; 2104 typedef UVTYPE UV; 2105 2106 #if defined(USE_64_BIT_INT) && defined(HAS_QUAD) 2107 # if QUADKIND == QUAD_IS_INT64_T && defined(INT64_MAX) 2108 # define IV_MAX ((IV)INT64_MAX) 2109 # define IV_MIN ((IV)INT64_MIN) 2110 # define UV_MAX ((UV)UINT64_MAX) 2111 # ifndef UINT64_MIN 2112 # define UINT64_MIN 0 2113 # endif 2114 # define UV_MIN ((UV)UINT64_MIN) 2115 # else 2116 # define IV_MAX PERL_QUAD_MAX 2117 # define IV_MIN PERL_QUAD_MIN 2118 # define UV_MAX PERL_UQUAD_MAX 2119 # define UV_MIN PERL_UQUAD_MIN 2120 # endif 2121 # define IV_IS_QUAD 2122 # define UV_IS_QUAD 2123 #else 2124 # if defined(INT32_MAX) && IVSIZE == 4 2125 # define IV_MAX ((IV)INT32_MAX) 2126 # define IV_MIN ((IV)INT32_MIN) 2127 # ifndef UINT32_MAX_BROKEN /* e.g. HP-UX with gcc messes this up */ 2128 # define UV_MAX ((UV)UINT32_MAX) 2129 # else 2130 # define UV_MAX ((UV)4294967295U) 2131 # endif 2132 # ifndef UINT32_MIN 2133 # define UINT32_MIN 0 2134 # endif 2135 # define UV_MIN ((UV)UINT32_MIN) 2136 # else 2137 # define IV_MAX PERL_LONG_MAX 2138 # define IV_MIN PERL_LONG_MIN 2139 # define UV_MAX PERL_ULONG_MAX 2140 # define UV_MIN PERL_ULONG_MIN 2141 # endif 2142 # if IVSIZE == 8 2143 # define IV_IS_QUAD 2144 # define UV_IS_QUAD 2145 # ifndef HAS_QUAD 2146 # define HAS_QUAD 2147 # endif 2148 # else 2149 # undef IV_IS_QUAD 2150 # undef UV_IS_QUAD 2151 #if !defined(PERL_CORE) 2152 /* We think that removing this decade-old undef this will cause too much 2153 breakage on CPAN for too little gain. (See RT #119753) 2154 However, we do need HAS_QUAD in the core for use by the drand48 code. */ 2155 # undef HAS_QUAD 2156 #endif 2157 # endif 2158 #endif 2159 2160 #define Size_t_MAX (~(Size_t)0) 2161 #define SSize_t_MAX (SSize_t)(~(Size_t)0 >> 1) 2162 2163 #define IV_DIG (BIT_DIGITS(IVSIZE * 8)) 2164 #define UV_DIG (BIT_DIGITS(UVSIZE * 8)) 2165 2166 #ifndef NO_PERL_PRESERVE_IVUV 2167 #define PERL_PRESERVE_IVUV /* We like our integers to stay integers. */ 2168 #endif 2169 2170 /* 2171 * The macros INT2PTR and NUM2PTR are (despite their names) 2172 * bi-directional: they will convert int/float to or from pointers. 2173 * However the conversion to int/float are named explicitly: 2174 * PTR2IV, PTR2UV, PTR2NV. 2175 * 2176 * For int conversions we do not need two casts if pointers are 2177 * the same size as IV and UV. Otherwise we need an explicit 2178 * cast (PTRV) to avoid compiler warnings. 2179 * 2180 * These are mentioned in perlguts 2181 */ 2182 #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) 2183 # define PTRV UV 2184 # define INT2PTR(any,d) (any)(d) 2185 #elif PTRSIZE == LONGSIZE 2186 # define PTRV unsigned long 2187 # define PTR2ul(p) (unsigned long)(p) 2188 #else 2189 # define PTRV unsigned 2190 #endif 2191 2192 #ifndef INT2PTR 2193 # define INT2PTR(any,d) (any)(PTRV)(d) 2194 #endif 2195 2196 #ifndef PTR2ul 2197 # define PTR2ul(p) INT2PTR(unsigned long,p) 2198 #endif 2199 2200 /* 2201 =for apidoc_section $casting 2202 =for apidoc Cyh|type|NUM2PTR|type|int value 2203 You probably want to be using L<C</INT2PTR>> instead. 2204 2205 =cut 2206 */ 2207 2208 #define NUM2PTR(any,d) (any)(PTRV)(d) 2209 #define PTR2IV(p) INT2PTR(IV,p) 2210 #define PTR2UV(p) INT2PTR(UV,p) 2211 #define PTR2NV(p) NUM2PTR(NV,p) 2212 #define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */ 2213 2214 /* According to strict ANSI C89 one cannot freely cast between 2215 * data pointers and function (code) pointers. There are at least 2216 * two ways around this. One (used below) is to do two casts, 2217 * first the other pointer to an (unsigned) integer, and then 2218 * the integer to the other pointer. The other way would be 2219 * to use unions to "overlay" the pointers. For an example of 2220 * the latter technique, see union dirpu in struct xpvio in sv.h. 2221 * The only feasible use is probably temporarily storing 2222 * function pointers in a data pointer (such as a void pointer). */ 2223 2224 #define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */ 2225 #define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */ 2226 2227 #ifdef USE_LONG_DOUBLE 2228 # if LONG_DOUBLESIZE == DOUBLESIZE 2229 # define LONG_DOUBLE_EQUALS_DOUBLE 2230 # undef USE_LONG_DOUBLE /* Ouch! */ 2231 # endif 2232 #endif 2233 2234 /* The following is all to get LDBL_DIG, in order to pick a nice 2235 default value for printing floating point numbers in Gconvert. 2236 (see config.h) 2237 */ 2238 #ifndef HAS_LDBL_DIG 2239 # if LONG_DOUBLESIZE == 10 2240 # define LDBL_DIG 18 /* assume IEEE */ 2241 # elif LONG_DOUBLESIZE == 12 2242 # define LDBL_DIG 18 /* gcc? */ 2243 # elif LONG_DOUBLESIZE == 16 2244 # define LDBL_DIG 33 /* assume IEEE */ 2245 # elif LONG_DOUBLESIZE == DOUBLESIZE 2246 # define LDBL_DIG DBL_DIG /* bummer */ 2247 # endif 2248 #endif 2249 2250 /* On MS Windows,with 64-bit mingw-w64 compilers, we 2251 need to attend to a __float128 alignment issue if 2252 USE_QUADMATH is defined. Otherwise we simply: 2253 typedef NVTYPE NV 2254 32-bit mingw.org compilers might also require 2255 aligned(32) - at least that's what I found with my 2256 Math::Foat128 module. But this is as yet untested 2257 here, so no allowance is being made for mingw.org 2258 compilers at this stage. -- sisyphus January 2021 2259 */ 2260 #if (defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)) && defined(__MINGW64__) 2261 /* 64-bit build, mingw-w64 compiler only */ 2262 typedef NVTYPE NV __attribute__ ((aligned(8))); 2263 #else 2264 typedef NVTYPE NV; 2265 #endif 2266 2267 #ifdef I_IEEEFP 2268 # include <ieeefp.h> 2269 #endif 2270 2271 #if defined(__DECC) && defined(__osf__) 2272 /* Also Tru64 cc has broken NaN comparisons. */ 2273 # define NAN_COMPARE_BROKEN 2274 #endif 2275 #if defined(__sgi) 2276 # define NAN_COMPARE_BROKEN 2277 #endif 2278 2279 #ifdef USE_LONG_DOUBLE 2280 # ifdef I_SUNMATH 2281 # include <sunmath.h> 2282 # endif 2283 # if defined(LDBL_DIG) 2284 # define NV_DIG LDBL_DIG 2285 # ifdef LDBL_MANT_DIG 2286 # define NV_MANT_DIG LDBL_MANT_DIG 2287 # endif 2288 # ifdef LDBL_MIN 2289 # define NV_MIN LDBL_MIN 2290 # endif 2291 # ifdef LDBL_MAX 2292 # define NV_MAX LDBL_MAX 2293 # endif 2294 # ifdef LDBL_MIN_EXP 2295 # define NV_MIN_EXP LDBL_MIN_EXP 2296 # endif 2297 # ifdef LDBL_MAX_EXP 2298 # define NV_MAX_EXP LDBL_MAX_EXP 2299 # endif 2300 # ifdef LDBL_MIN_10_EXP 2301 # define NV_MIN_10_EXP LDBL_MIN_10_EXP 2302 # endif 2303 # ifdef LDBL_MAX_10_EXP 2304 # define NV_MAX_10_EXP LDBL_MAX_10_EXP 2305 # endif 2306 # ifdef LDBL_EPSILON 2307 # define NV_EPSILON LDBL_EPSILON 2308 # endif 2309 # ifdef LDBL_MAX 2310 # define NV_MAX LDBL_MAX 2311 /* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */ 2312 # elif defined(HUGE_VALL) 2313 # define NV_MAX HUGE_VALL 2314 # endif 2315 # endif 2316 # if defined(HAS_SQRTL) 2317 # define Perl_acos acosl 2318 # define Perl_asin asinl 2319 # define Perl_atan atanl 2320 # define Perl_atan2 atan2l 2321 # define Perl_ceil ceill 2322 # define Perl_cos cosl 2323 # define Perl_cosh coshl 2324 # define Perl_exp expl 2325 # define Perl_fabs fabsl 2326 # define Perl_floor floorl 2327 # define Perl_fmod fmodl 2328 # define Perl_log logl 2329 # define Perl_log10 log10l 2330 # define Perl_pow powl 2331 # define Perl_sin sinl 2332 # define Perl_sinh sinhl 2333 # define Perl_sqrt sqrtl 2334 # define Perl_tan tanl 2335 # define Perl_tanh tanhl 2336 # endif 2337 /* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ 2338 # ifndef Perl_modf 2339 # ifdef HAS_MODFL 2340 # define Perl_modf(x,y) modfl(x,y) 2341 /* eg glibc 2.2 series seems to provide modfl on ppc and arm, but has no 2342 prototype in <math.h> */ 2343 # ifndef HAS_MODFL_PROTO 2344 EXTERN_C long double modfl(long double, long double *); 2345 # endif 2346 # elif (defined(HAS_TRUNCL) || defined(HAS_AINTL)) && defined(HAS_COPYSIGNL) 2347 extern long double Perl_my_modfl(long double x, long double *ip); 2348 # define Perl_modf(x,y) Perl_my_modfl(x,y) 2349 # endif 2350 # endif 2351 # ifndef Perl_frexp 2352 # ifdef HAS_FREXPL 2353 # define Perl_frexp(x,y) frexpl(x,y) 2354 # elif defined(HAS_ILOGBL) && defined(HAS_SCALBNL) 2355 extern long double Perl_my_frexpl(long double x, int *e); 2356 # define Perl_frexp(x,y) Perl_my_frexpl(x,y) 2357 # endif 2358 # endif 2359 # ifndef Perl_ldexp 2360 # ifdef HAS_LDEXPL 2361 # define Perl_ldexp(x, y) ldexpl(x,y) 2362 # elif defined(HAS_SCALBNL) && FLT_RADIX == 2 2363 # define Perl_ldexp(x,y) scalbnl(x,y) 2364 # endif 2365 # endif 2366 # ifndef Perl_isnan 2367 # if defined(HAS_ISNANL) && !(defined(isnan) && defined(HAS_C99)) 2368 # define Perl_isnan(x) isnanl(x) 2369 # elif defined(__sgi) && defined(__c99) /* XXX Configure test needed */ 2370 # define Perl_isnan(x) isnan(x) 2371 # endif 2372 # endif 2373 # ifndef Perl_isinf 2374 # if defined(HAS_ISINFL) && !(defined(isinf) && defined(HAS_C99)) 2375 # define Perl_isinf(x) isinfl(x) 2376 # elif defined(__sgi) && defined(__c99) /* XXX Configure test needed */ 2377 # define Perl_isinf(x) isinf(x) 2378 # elif defined(LDBL_MAX) && !defined(NAN_COMPARE_BROKEN) 2379 # define Perl_isinf(x) ((x) > LDBL_MAX || (x) < -LDBL_MAX) 2380 # endif 2381 # endif 2382 # ifndef Perl_isfinite 2383 # define Perl_isfinite(x) Perl_isfinitel(x) 2384 # endif 2385 #elif defined(USE_QUADMATH) && defined(I_QUADMATH) 2386 # include <quadmath.h> 2387 # define NV_DIG FLT128_DIG 2388 # define NV_MANT_DIG FLT128_MANT_DIG 2389 # define NV_MIN FLT128_MIN 2390 # define NV_MAX FLT128_MAX 2391 # define NV_MIN_EXP FLT128_MIN_EXP 2392 # define NV_MAX_EXP FLT128_MAX_EXP 2393 # define NV_EPSILON FLT128_EPSILON 2394 # define NV_MIN_10_EXP FLT128_MIN_10_EXP 2395 # define NV_MAX_10_EXP FLT128_MAX_10_EXP 2396 # define Perl_acos acosq 2397 # define Perl_asin asinq 2398 # define Perl_atan atanq 2399 # define Perl_atan2 atan2q 2400 # define Perl_ceil ceilq 2401 # define Perl_cos cosq 2402 # define Perl_cosh coshq 2403 # define Perl_exp expq 2404 # define Perl_fabs fabsq 2405 # define Perl_floor floorq 2406 # define Perl_fmod fmodq 2407 # define Perl_log logq 2408 # define Perl_log10 log10q 2409 # define Perl_signbit signbitq 2410 # define Perl_pow powq 2411 # define Perl_sin sinq 2412 # define Perl_sinh sinhq 2413 # define Perl_sqrt sqrtq 2414 # define Perl_tan tanq 2415 # define Perl_tanh tanhq 2416 # define Perl_modf(x,y) modfq(x,y) 2417 # define Perl_frexp(x,y) frexpq(x,y) 2418 # define Perl_ldexp(x, y) ldexpq(x,y) 2419 # define Perl_isinf(x) isinfq(x) 2420 # define Perl_isnan(x) isnanq(x) 2421 # define Perl_isfinite(x) !(isnanq(x) || isinfq(x)) 2422 # define Perl_fp_class(x) ((x) == 0.0Q ? 0 : isinfq(x) ? 3 : isnanq(x) ? 4 : PERL_ABS(x) < FLT128_MIN ? 2 : 1) 2423 # define Perl_fp_class_inf(x) (Perl_fp_class(x) == 3) 2424 # define Perl_fp_class_nan(x) (Perl_fp_class(x) == 4) 2425 # define Perl_fp_class_norm(x) (Perl_fp_class(x) == 1) 2426 # define Perl_fp_class_denorm(x) (Perl_fp_class(x) == 2) 2427 # define Perl_fp_class_zero(x) (Perl_fp_class(x) == 0) 2428 #else 2429 # define NV_DIG DBL_DIG 2430 # define NV_MANT_DIG DBL_MANT_DIG 2431 # define NV_MIN DBL_MIN 2432 # define NV_MAX DBL_MAX 2433 # define NV_MIN_EXP DBL_MIN_EXP 2434 # define NV_MAX_EXP DBL_MAX_EXP 2435 # define NV_MIN_10_EXP DBL_MIN_10_EXP 2436 # define NV_MAX_10_EXP DBL_MAX_10_EXP 2437 # define NV_EPSILON DBL_EPSILON 2438 # define NV_MAX DBL_MAX 2439 # define NV_MIN DBL_MIN 2440 2441 /* These math interfaces are C89. */ 2442 # define Perl_acos acos 2443 # define Perl_asin asin 2444 # define Perl_atan atan 2445 # define Perl_atan2 atan2 2446 # define Perl_ceil ceil 2447 # define Perl_cos cos 2448 # define Perl_cosh cosh 2449 # define Perl_exp exp 2450 # define Perl_fabs fabs 2451 # define Perl_floor floor 2452 # define Perl_fmod fmod 2453 # define Perl_log log 2454 # define Perl_log10 log10 2455 # define Perl_pow pow 2456 # define Perl_sin sin 2457 # define Perl_sinh sinh 2458 # define Perl_sqrt sqrt 2459 # define Perl_tan tan 2460 # define Perl_tanh tanh 2461 2462 # define Perl_modf(x,y) modf(x,y) 2463 # define Perl_frexp(x,y) frexp(x,y) 2464 # define Perl_ldexp(x,y) ldexp(x,y) 2465 2466 # ifndef Perl_isnan 2467 # ifdef HAS_ISNAN 2468 # define Perl_isnan(x) isnan(x) 2469 # endif 2470 # endif 2471 # ifndef Perl_isinf 2472 # if defined(HAS_ISINF) 2473 # define Perl_isinf(x) isinf(x) 2474 # elif defined(DBL_MAX) && !defined(NAN_COMPARE_BROKEN) 2475 # define Perl_isinf(x) ((x) > DBL_MAX || (x) < -DBL_MAX) 2476 # endif 2477 # endif 2478 # ifndef Perl_isfinite 2479 # ifdef HAS_ISFINITE 2480 # define Perl_isfinite(x) isfinite(x) 2481 # elif defined(HAS_FINITE) 2482 # define Perl_isfinite(x) finite(x) 2483 # endif 2484 # endif 2485 #endif 2486 2487 /* fpclassify(): C99. It is supposed to be a macro that switches on 2488 * the sizeof() of its argument, so there's no need for e.g. fpclassifyl().*/ 2489 #if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY) 2490 # include <math.h> 2491 # if defined(FP_INFINITE) && defined(FP_NAN) 2492 # define Perl_fp_class(x) fpclassify(x) 2493 # define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE) 2494 # define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN) 2495 # define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL) 2496 # define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL) 2497 # define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO) 2498 # elif defined(FP_PLUS_INF) && defined(FP_QNAN) 2499 /* Some versions of HP-UX (10.20) have (only) fpclassify() but which is 2500 * actually not the C99 fpclassify, with its own set of return defines. */ 2501 # define Perl_fp_class(x) fpclassify(x) 2502 # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) 2503 # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) 2504 # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) 2505 # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) 2506 # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) 2507 # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) 2508 # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) 2509 # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) 2510 # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) 2511 # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) 2512 # else 2513 # undef Perl_fp_class /* Unknown set of defines */ 2514 # endif 2515 #endif 2516 2517 /* fp_classify(): Legacy: VMS, maybe Unicos? The values, however, 2518 * are identical to the C99 fpclassify(). */ 2519 #if !defined(Perl_fp_class) && defined(HAS_FP_CLASSIFY) 2520 # include <math.h> 2521 # ifdef __VMS 2522 /* FP_INFINITE and others are here rather than in math.h as C99 stipulates */ 2523 # include <fp.h> 2524 /* oh, and the isnormal macro has a typo in it! */ 2525 # undef isnormal 2526 # define isnormal(x) Perl_fp_class_norm(x) 2527 # endif 2528 # if defined(FP_INFINITE) && defined(FP_NAN) 2529 # define Perl_fp_class(x) fp_classify(x) 2530 # define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE) 2531 # define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN) 2532 # define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL) 2533 # define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL) 2534 # define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO) 2535 # else 2536 # undef Perl_fp_class /* Unknown set of defines */ 2537 # endif 2538 #endif 2539 2540 /* Feel free to check with me for the SGI manpages, SGI testing, 2541 * etcetera, if you want to try getting this to work with IRIX. 2542 * 2543 * - Allen <allens@cpan.org> */ 2544 2545 /* fpclass(): SysV, at least Solaris and some versions of IRIX. */ 2546 #if !defined(Perl_fp_class) && (defined(HAS_FPCLASS)||defined(HAS_FPCLASSL)) 2547 /* Solaris and IRIX have fpclass/fpclassl, but they are using 2548 * an enum typedef, not cpp symbols, and Configure doesn't detect that. 2549 * Define some symbols also as cpp symbols so we can detect them. */ 2550 # if defined(__sun) || defined(__sgi) /* XXX Configure test instead */ 2551 # define FP_PINF FP_PINF 2552 # define FP_QNAN FP_QNAN 2553 # endif 2554 # include <math.h> 2555 # ifdef I_IEEEFP 2556 # include <ieeefp.h> 2557 # endif 2558 # ifdef I_FP 2559 # include <fp.h> 2560 # endif 2561 # if defined(USE_LONG_DOUBLE) && defined(HAS_FPCLASSL) 2562 # define Perl_fp_class(x) fpclassl(x) 2563 # else 2564 # define Perl_fp_class(x) fpclass(x) 2565 # endif 2566 # if defined(FP_CLASS_PINF) && defined(FP_CLASS_SNAN) 2567 # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN) 2568 # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN) 2569 # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF) 2570 # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF) 2571 # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM) 2572 # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM) 2573 # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM) 2574 # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM) 2575 # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO) 2576 # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO) 2577 # elif defined(FP_PINF) && defined(FP_QNAN) 2578 # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) 2579 # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) 2580 # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NINF) 2581 # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PINF) 2582 # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NNORM) 2583 # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PNORM) 2584 # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NDENORM) 2585 # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PDENORM) 2586 # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NZERO) 2587 # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PZERO) 2588 # else 2589 # undef Perl_fp_class /* Unknown set of defines */ 2590 # endif 2591 #endif 2592 2593 /* fp_class(): Legacy: at least Tru64, some versions of IRIX. */ 2594 #if !defined(Perl_fp_class) && (defined(HAS_FP_CLASS)||defined(HAS_FP_CLASSL)) 2595 # include <math.h> 2596 # if !defined(FP_SNAN) && defined(I_FP_CLASS) 2597 # include <fp_class.h> 2598 # endif 2599 # if defined(FP_POS_INF) && defined(FP_QNAN) 2600 # ifdef __sgi /* XXX Configure test instead */ 2601 # ifdef USE_LONG_DOUBLE 2602 # define Perl_fp_class(x) fp_class_l(x) 2603 # else 2604 # define Perl_fp_class(x) fp_class_d(x) 2605 # endif 2606 # else 2607 # if defined(USE_LONG_DOUBLE) && defined(HAS_FP_CLASSL) 2608 # define Perl_fp_class(x) fp_classl(x) 2609 # else 2610 # define Perl_fp_class(x) fp_class(x) 2611 # endif 2612 # endif 2613 # if defined(FP_POS_INF) && defined(FP_QNAN) 2614 # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) 2615 # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) 2616 # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NEG_INF) 2617 # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_POS_INF) 2618 # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NEG_NORM) 2619 # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_POS_NORM) 2620 # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NEG_DENORM) 2621 # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_POS_DENORM) 2622 # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NEG_ZERO) 2623 # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_POS_ZERO) 2624 # else 2625 # undef Perl_fp_class /* Unknown set of defines */ 2626 # endif 2627 # endif 2628 #endif 2629 2630 /* class(), _class(): Legacy: AIX. */ 2631 #if !defined(Perl_fp_class) && defined(HAS_CLASS) 2632 # include <math.h> 2633 # if defined(FP_PLUS_NORM) && defined(FP_PLUS_INF) 2634 # ifndef _cplusplus 2635 # define Perl_fp_class(x) class(x) 2636 # else 2637 # define Perl_fp_class(x) _class(x) 2638 # endif 2639 # if defined(FP_PLUS_INF) && defined(FP_NANQ) 2640 # define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS) 2641 # define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ) 2642 # define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) 2643 # define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) 2644 # define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) 2645 # define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) 2646 # define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) 2647 # define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) 2648 # define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) 2649 # define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) 2650 # else 2651 # undef Perl_fp_class /* Unknown set of defines */ 2652 # endif 2653 # endif 2654 #endif 2655 2656 /* Win32: _fpclass(), _isnan(), _finite(). */ 2657 #ifdef _MSC_VER 2658 # ifndef Perl_isnan 2659 # define Perl_isnan(x) _isnan(x) 2660 # endif 2661 # ifndef Perl_isfinite 2662 # define Perl_isfinite(x) _finite(x) 2663 # endif 2664 # ifndef Perl_fp_class_snan 2665 /* No simple way to #define Perl_fp_class because _fpclass() 2666 * returns a set of bits. */ 2667 # define Perl_fp_class_snan(x) (_fpclass(x) & _FPCLASS_SNAN) 2668 # define Perl_fp_class_qnan(x) (_fpclass(x) & _FPCLASS_QNAN) 2669 # define Perl_fp_class_nan(x) (_fpclass(x) & (_FPCLASS_SNAN|_FPCLASS_QNAN)) 2670 # define Perl_fp_class_ninf(x) (_fpclass(x) & _FPCLASS_NINF) 2671 # define Perl_fp_class_pinf(x) (_fpclass(x) & _FPCLASS_PINF) 2672 # define Perl_fp_class_inf(x) (_fpclass(x) & (_FPCLASS_NINF|_FPCLASS_PINF)) 2673 # define Perl_fp_class_nnorm(x) (_fpclass(x) & _FPCLASS_NN) 2674 # define Perl_fp_class_pnorm(x) (_fpclass(x) & _FPCLASS_PN) 2675 # define Perl_fp_class_norm(x) (_fpclass(x) & (_FPCLASS_NN|_FPCLASS_PN)) 2676 # define Perl_fp_class_ndenorm(x) (_fpclass(x) & _FPCLASS_ND) 2677 # define Perl_fp_class_pdenorm(x) (_fpclass(x) & _FPCLASS_PD) 2678 # define Perl_fp_class_denorm(x) (_fpclass(x) & (_FPCLASS_ND|_FPCLASS_PD)) 2679 # define Perl_fp_class_nzero(x) (_fpclass(x) & _FPCLASS_NZ) 2680 # define Perl_fp_class_pzero(x) (_fpclass(x) & _FPCLASS_PZ) 2681 # define Perl_fp_class_zero(x) (_fpclass(x) & (_FPCLASS_NZ|_FPCLASS_PZ)) 2682 # endif 2683 #endif 2684 2685 #if !defined(Perl_fp_class_inf) && \ 2686 defined(Perl_fp_class_pinf) && defined(Perl_fp_class_ninf) 2687 # define Perl_fp_class_inf(x) \ 2688 (Perl_fp_class_pinf(x) || Perl_fp_class_ninf(x)) 2689 #endif 2690 2691 #if !defined(Perl_fp_class_nan) && \ 2692 defined(Perl_fp_class_snan) && defined(Perl_fp_class_qnan) 2693 # define Perl_fp_class_nan(x) \ 2694 (Perl_fp_class_snan(x) || Perl_fp_class_qnan(x)) 2695 #endif 2696 2697 #if !defined(Perl_fp_class_zero) && \ 2698 defined(Perl_fp_class_pzero) && defined(Perl_fp_class_nzero) 2699 # define Perl_fp_class_zero(x) \ 2700 (Perl_fp_class_pzero(x) || Perl_fp_class_nzero(x)) 2701 #endif 2702 2703 #if !defined(Perl_fp_class_norm) && \ 2704 defined(Perl_fp_class_pnorm) && defined(Perl_fp_class_nnorm) 2705 # define Perl_fp_class_norm(x) \ 2706 (Perl_fp_class_pnorm(x) || Perl_fp_class_nnorm(x)) 2707 #endif 2708 2709 #if !defined(Perl_fp_class_denorm) && \ 2710 defined(Perl_fp_class_pdenorm) && defined(Perl_fp_class_ndenorm) 2711 # define Perl_fp_class_denorm(x) \ 2712 (Perl_fp_class_pdenorm(x) || Perl_fp_class_ndenorm(x)) 2713 #endif 2714 2715 #ifndef Perl_isnan 2716 # ifdef Perl_fp_class_nan 2717 # define Perl_isnan(x) Perl_fp_class_nan(x) 2718 # elif defined(HAS_UNORDERED) 2719 # define Perl_isnan(x) unordered((x), 0.0) 2720 # else 2721 # define Perl_isnan(x) ((x)!=(x)) 2722 # endif 2723 #endif 2724 2725 #ifndef Perl_isinf 2726 # ifdef Perl_fp_class_inf 2727 # define Perl_isinf(x) Perl_fp_class_inf(x) 2728 # endif 2729 #endif 2730 2731 #ifndef Perl_isfinite 2732 # if defined(HAS_ISFINITE) && !defined(isfinite) 2733 # define Perl_isfinite(x) isfinite((double)(x)) 2734 # elif defined(HAS_FINITE) 2735 # define Perl_isfinite(x) finite((double)(x)) 2736 # elif defined(Perl_fp_class_finite) 2737 # define Perl_isfinite(x) Perl_fp_class_finite(x) 2738 # else 2739 /* For the infinities the multiplication returns nan, 2740 * for the nan the multiplication also returns nan, 2741 * for everything else (that is, finite) zero should be returned. */ 2742 # define Perl_isfinite(x) (((x) * 0) == 0) 2743 # endif 2744 #endif 2745 2746 #ifndef Perl_isinf 2747 # if defined(Perl_isfinite) && defined(Perl_isnan) 2748 # define Perl_isinf(x) !(Perl_isfinite(x)||Perl_isnan(x)) 2749 # endif 2750 #endif 2751 2752 /* We need Perl_isfinitel (ends with ell) (if available) even when 2753 * not USE_LONG_DOUBLE because the printf code (sv_catpvfn_flags) 2754 * needs that. */ 2755 #if defined(HAS_LONG_DOUBLE) && !defined(Perl_isfinitel) 2756 /* If isfinite() is a macro and looks like we have C99, 2757 * we assume it's the type-aware C99 isfinite(). */ 2758 # if defined(HAS_ISFINITE) && defined(isfinite) && defined(HAS_C99) 2759 # define Perl_isfinitel(x) isfinite(x) 2760 # elif defined(HAS_ISFINITEL) 2761 # define Perl_isfinitel(x) isfinitel(x) 2762 # elif defined(HAS_FINITEL) 2763 # define Perl_isfinitel(x) finitel(x) 2764 # elif defined(HAS_ISINFL) && defined(HAS_ISNANL) 2765 # define Perl_isfinitel(x) !(isinfl(x)||isnanl(x)) 2766 # else 2767 # define Perl_isfinitel(x) ((x) * 0 == 0) /* See Perl_isfinite. */ 2768 # endif 2769 #endif 2770 2771 /* The default is to use Perl's own atof() implementation (in numeric.c). 2772 * Usually that is the one to use but for some platforms (e.g. UNICOS) 2773 * it is however best to use the native implementation of atof. 2774 * You can experiment with using your native one by -DUSE_PERL_ATOF=0. 2775 * Some good tests to try out with either setting are t/base/num.t, 2776 * t/op/numconvert.t, and t/op/pack.t. Note that if using long doubles 2777 * you may need to be using a different function than atof! */ 2778 2779 #ifndef USE_PERL_ATOF 2780 # ifndef _UNICOS 2781 # define USE_PERL_ATOF 2782 # endif 2783 #else 2784 # if USE_PERL_ATOF == 0 2785 # undef USE_PERL_ATOF 2786 # endif 2787 #endif 2788 2789 #ifdef USE_PERL_ATOF 2790 # define Perl_atof(s) Perl_my_atof(s) 2791 # define Perl_atof2(s, n) Perl_my_atof3(aTHX_ (s), &(n), 0) 2792 #else 2793 # define Perl_atof(s) (NV)atof(s) 2794 # define Perl_atof2(s, n) ((n) = atof(s)) 2795 #endif 2796 #define my_atof2(a,b) my_atof3(a,b,0) 2797 2798 /* 2799 =for apidoc_section $numeric 2800 =for apidoc AmT|NV|Perl_acos|NV x 2801 =for apidoc_item |NV|Perl_asin|NV x 2802 =for apidoc_item |NV|Perl_atan|NV x 2803 =for apidoc_item |NV|Perl_atan2|NV x|NV y 2804 =for apidoc_item |NV|Perl_ceil|NV x 2805 =for apidoc_item |NV|Perl_cos|NV x 2806 =for apidoc_item |NV|Perl_cosh|NV x 2807 =for apidoc_item |NV|Perl_exp|NV x 2808 =for apidoc_item |NV|Perl_floor|NV x 2809 =for apidoc_item |NV|Perl_fmod|NV x|NV y 2810 =for apidoc_item |NV|Perl_frexp|NV x|int *exp 2811 =for apidoc_item |IV|Perl_isfinite|NV x 2812 =for apidoc_item |IV|Perl_isinf|NV x 2813 =for apidoc_item |IV|Perl_isnan|NV x 2814 =for apidoc_item |NV|Perl_ldexp|NV x|int exp 2815 =for apidoc_item |NV|Perl_log|NV x 2816 =for apidoc_item |NV|Perl_log10|NV x 2817 =for apidoc_item |NV|Perl_modf|NV x|NV *iptr 2818 =for apidoc_item |NV|Perl_pow|NV x|NV y 2819 =for apidoc_item |NV|Perl_sin|NV x 2820 =for apidoc_item |NV|Perl_sinh|NV x 2821 =for apidoc_item |NV|Perl_sqrt|NV x 2822 =for apidoc_item |NV|Perl_tan|NV x 2823 =for apidoc_item |NV|Perl_tanh|NV x 2824 2825 These perform the corresponding mathematical operation on the operand(s), using 2826 the libc function designed for the task that has just enough precision for an 2827 NV on this platform. If no such function with sufficient precision exists, 2828 the highest precision one available is used. 2829 2830 =cut 2831 */ 2832 2833 /* 2834 * CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be 2835 * ambiguous. It may be equivalent to (signed char) or (unsigned char) 2836 * depending on local options. Until Configure detects this (or at least 2837 * detects whether the "signed" keyword is available) the CHAR ranges 2838 * will not be included. UCHAR functions normally. 2839 * - kja 2840 */ 2841 2842 #define PERL_UCHAR_MIN ((unsigned char)0) 2843 #define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) 2844 2845 #define PERL_USHORT_MIN ((unsigned short)0) 2846 #define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) 2847 2848 #define PERL_SHORT_MAX ((short)SHRT_MAX) 2849 #define PERL_SHORT_MIN ((short)SHRT_MIN) 2850 2851 #define PERL_UINT_MAX ((unsigned int)UINT_MAX) 2852 #define PERL_UINT_MIN ((unsigned int)0) 2853 2854 #define PERL_INT_MAX ((int)INT_MAX) 2855 #define PERL_INT_MIN ((int)INT_MIN) 2856 2857 #define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) 2858 #define PERL_ULONG_MIN ((unsigned long)0L) 2859 2860 #define PERL_LONG_MAX ((long)LONG_MAX) 2861 #define PERL_LONG_MIN ((long)LONG_MIN) 2862 2863 #ifdef UV_IS_QUAD 2864 # define PERL_UQUAD_MAX (~(UV)0) 2865 # define PERL_UQUAD_MIN ((UV)0) 2866 # define PERL_QUAD_MAX ((IV) (PERL_UQUAD_MAX >> 1)) 2867 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) 2868 #endif 2869 2870 /* 2871 =for apidoc_section $integer 2872 2873 =for apidoc AmnU||PERL_INT_MAX 2874 =for apidoc_item ||PERL_INT_MIN 2875 =for apidoc_item ||PERL_LONG_MAX 2876 =for apidoc_item ||PERL_LONG_MIN 2877 =for apidoc_item ||PERL_SHORT_MAX 2878 =for apidoc_item ||PERL_SHORT_MIN 2879 =for apidoc_item ||PERL_UCHAR_MAX 2880 =for apidoc_item ||PERL_UCHAR_MIN 2881 =for apidoc_item ||PERL_UINT_MAX 2882 =for apidoc_item ||PERL_UINT_MIN 2883 =for apidoc_item ||PERL_ULONG_MAX 2884 =for apidoc_item ||PERL_ULONG_MIN 2885 =for apidoc_item ||PERL_USHORT_MAX 2886 =for apidoc_item ||PERL_USHORT_MIN 2887 =for apidoc_item ||PERL_QUAD_MAX 2888 =for apidoc_item ||PERL_QUAD_MIN 2889 =for apidoc_item ||PERL_UQUAD_MAX 2890 =for apidoc_item ||PERL_UQUAD_MIN 2891 2892 These give the largest and smallest number representable in the current 2893 platform in variables of the corresponding types. 2894 2895 For signed types, the smallest representable number is the most negative 2896 number, the one furthest away from zero. 2897 2898 For C99 and later compilers, these correspond to things like C<INT_MAX>, which 2899 are available to the C code. But these constants, furnished by Perl, 2900 allow code compiled on earlier compilers to portably have access to the same 2901 constants. 2902 2903 =cut 2904 2905 */ 2906 2907 typedef MEM_SIZE STRLEN; 2908 2909 typedef struct op OP; 2910 typedef struct cop COP; 2911 typedef struct unop UNOP; 2912 typedef struct unop_aux UNOP_AUX; 2913 typedef struct binop BINOP; 2914 typedef struct listop LISTOP; 2915 typedef struct logop LOGOP; 2916 typedef struct pmop PMOP; 2917 typedef struct svop SVOP; 2918 typedef struct padop PADOP; 2919 typedef struct pvop PVOP; 2920 typedef struct loop LOOP; 2921 typedef struct methop METHOP; 2922 2923 #ifdef PERL_CORE 2924 typedef struct opslab OPSLAB; 2925 typedef struct opslot OPSLOT; 2926 #endif 2927 2928 typedef struct block_hooks BHK; 2929 typedef struct custom_op XOP; 2930 2931 typedef struct interpreter PerlInterpreter; 2932 2933 /* SGI's <sys/sema.h> has struct sv */ 2934 #if defined(__sgi) 2935 # define STRUCT_SV perl_sv 2936 #else 2937 # define STRUCT_SV sv 2938 #endif 2939 typedef struct STRUCT_SV SV; 2940 typedef struct av AV; 2941 typedef struct hv HV; 2942 typedef struct cv CV; 2943 typedef struct p5rx REGEXP; 2944 typedef struct gp GP; 2945 typedef struct gv GV; 2946 typedef struct io IO; 2947 typedef struct context PERL_CONTEXT; 2948 typedef struct block BLOCK; 2949 typedef struct invlist INVLIST; 2950 2951 typedef struct magic MAGIC; 2952 typedef struct xpv XPV; 2953 typedef struct xpviv XPVIV; 2954 typedef struct xpvuv XPVUV; 2955 typedef struct xpvnv XPVNV; 2956 typedef struct xpvmg XPVMG; 2957 typedef struct xpvlv XPVLV; 2958 typedef struct xpvinvlist XINVLIST; 2959 typedef struct xpvav XPVAV; 2960 typedef struct xpvhv XPVHV; 2961 typedef struct xpvgv XPVGV; 2962 typedef struct xpvcv XPVCV; 2963 typedef struct xpvbm XPVBM; 2964 typedef struct xpvfm XPVFM; 2965 typedef struct xpvio XPVIO; 2966 typedef struct mgvtbl MGVTBL; 2967 typedef union any ANY; 2968 typedef struct ptr_tbl_ent PTR_TBL_ENT_t; 2969 typedef struct ptr_tbl PTR_TBL_t; 2970 typedef struct clone_params CLONE_PARAMS; 2971 2972 /* a pad is currently just an AV; but that might change, 2973 * so hide the type. */ 2974 typedef struct padlist PADLIST; 2975 typedef AV PAD; 2976 typedef struct padnamelist PADNAMELIST; 2977 typedef struct padname PADNAME; 2978 2979 /* always enable PERL_OP_PARENT */ 2980 #if !defined(PERL_OP_PARENT) 2981 # define PERL_OP_PARENT 2982 #endif 2983 2984 /* enable PERL_COPY_ON_WRITE by default */ 2985 #if !defined(PERL_COPY_ON_WRITE) && !defined(PERL_NO_COW) 2986 # define PERL_COPY_ON_WRITE 2987 #endif 2988 2989 #ifdef PERL_COPY_ON_WRITE 2990 # define PERL_ANY_COW 2991 #else 2992 # define PERL_SAWAMPERSAND 2993 #endif 2994 2995 #if defined(PERL_DEBUG_READONLY_OPS) && !defined(USE_ITHREADS) 2996 # error PERL_DEBUG_READONLY_OPS only works with ithreads 2997 #endif 2998 2999 #include "handy.h" 3000 #include "charclass_invlists.h" 3001 3002 #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO) 3003 # if LSEEKSIZE == 8 && !defined(USE_64_BIT_RAWIO) 3004 # define USE_64_BIT_RAWIO /* implicit */ 3005 # endif 3006 #endif 3007 3008 /* Notice the use of HAS_FSEEKO: now we are obligated to always use 3009 * fseeko/ftello if possible. Don't go #defining ftell to ftello yourself, 3010 * however, because operating systems like to do that themself. */ 3011 #ifndef FSEEKSIZE 3012 # ifdef HAS_FSEEKO 3013 # define FSEEKSIZE LSEEKSIZE 3014 # else 3015 # define FSEEKSIZE LONGSIZE 3016 # endif 3017 #endif 3018 3019 #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO) 3020 # if FSEEKSIZE == 8 && !defined(USE_64_BIT_STDIO) 3021 # define USE_64_BIT_STDIO /* implicit */ 3022 # endif 3023 #endif 3024 3025 #ifdef USE_64_BIT_RAWIO 3026 # ifdef HAS_OFF64_T 3027 # undef Off_t 3028 # define Off_t off64_t 3029 # undef LSEEKSIZE 3030 # define LSEEKSIZE 8 3031 # endif 3032 /* Most 64-bit environments have defines like _LARGEFILE_SOURCE that 3033 * will trigger defines like the ones below. Some 64-bit environments, 3034 * however, do not. Therefore we have to explicitly mix and match. */ 3035 # if defined(USE_OPEN64) 3036 # define open open64 3037 # endif 3038 # if defined(USE_LSEEK64) 3039 # define lseek lseek64 3040 # else 3041 # if defined(USE_LLSEEK) 3042 # define lseek llseek 3043 # endif 3044 # endif 3045 # if defined(USE_STAT64) 3046 # define stat stat64 3047 # endif 3048 # if defined(USE_FSTAT64) 3049 # define fstat fstat64 3050 # endif 3051 # if defined(USE_LSTAT64) 3052 # define lstat lstat64 3053 # endif 3054 # if defined(USE_FLOCK64) 3055 # define flock flock64 3056 # endif 3057 # if defined(USE_LOCKF64) 3058 # define lockf lockf64 3059 # endif 3060 # if defined(USE_FCNTL64) 3061 # define fcntl fcntl64 3062 # endif 3063 # if defined(USE_TRUNCATE64) 3064 # define truncate truncate64 3065 # endif 3066 # if defined(USE_FTRUNCATE64) 3067 # define ftruncate ftruncate64 3068 # endif 3069 #endif 3070 3071 #ifdef USE_64_BIT_STDIO 3072 # ifdef HAS_FPOS64_T 3073 # undef Fpos_t 3074 # define Fpos_t fpos64_t 3075 # endif 3076 /* Most 64-bit environments have defines like _LARGEFILE_SOURCE that 3077 * will trigger defines like the ones below. Some 64-bit environments, 3078 * however, do not. */ 3079 # if defined(USE_FOPEN64) 3080 # define fopen fopen64 3081 # endif 3082 # if defined(USE_FSEEK64) 3083 # define fseek fseek64 /* don't do fseeko here, see perlio.c */ 3084 # endif 3085 # if defined(USE_FTELL64) 3086 # define ftell ftell64 /* don't do ftello here, see perlio.c */ 3087 # endif 3088 # if defined(USE_FSETPOS64) 3089 # define fsetpos fsetpos64 3090 # endif 3091 # if defined(USE_FGETPOS64) 3092 # define fgetpos fgetpos64 3093 # endif 3094 # if defined(USE_TMPFILE64) 3095 # define tmpfile tmpfile64 3096 # endif 3097 # if defined(USE_FREOPEN64) 3098 # define freopen freopen64 3099 # endif 3100 #endif 3101 3102 #if defined(OS2) 3103 # include "iperlsys.h" 3104 #endif 3105 3106 #ifdef DOSISH 3107 # if defined(OS2) 3108 # include "os2ish.h" 3109 # else 3110 # include "dosish.h" 3111 # endif 3112 #elif defined(VMS) 3113 # include "vmsish.h" 3114 #elif defined(PLAN9) 3115 # include "./plan9/plan9ish.h" 3116 #elif defined(__VOS__) 3117 # ifdef __GNUC__ 3118 # include "./vos/vosish.h" 3119 # else 3120 # include "vos/vosish.h" 3121 # endif 3122 #elif defined(__HAIKU__) 3123 # include "haiku/haikuish.h" 3124 #else 3125 # include "unixish.h" 3126 #endif 3127 3128 #ifdef __amigaos4__ 3129 # include "amigaos.h" 3130 # undef FD_CLOEXEC /* a lie in AmigaOS */ 3131 #endif 3132 3133 /* NSIG logic from Configure --> */ 3134 #ifndef NSIG 3135 # ifdef _NSIG 3136 # define NSIG (_NSIG) 3137 # elif defined(SIGMAX) 3138 # define NSIG (SIGMAX+1) 3139 # elif defined(SIG_MAX) 3140 # define NSIG (SIG_MAX+1) 3141 # elif defined(_SIG_MAX) 3142 # define NSIG (_SIG_MAX+1) 3143 # elif defined(MAXSIG) 3144 # define NSIG (MAXSIG+1) 3145 # elif defined(MAX_SIG) 3146 # define NSIG (MAX_SIG+1) 3147 # elif defined(SIGARRAYSIZE) 3148 # define NSIG SIGARRAYSIZE /* Assume ary[SIGARRAYSIZE] */ 3149 # elif defined(_sys_nsig) 3150 # define NSIG (_sys_nsig) /* Solaris 2.5 */ 3151 # else 3152 /* Default to some arbitrary number that's big enough to get most 3153 * of the common signals. */ 3154 # define NSIG 50 3155 # endif 3156 #endif 3157 /* <-- NSIG logic from Configure */ 3158 3159 #ifndef NO_ENVIRON_ARRAY 3160 # define USE_ENVIRON_ARRAY 3161 #endif 3162 3163 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 3164 /* having sigaction(2) means that the OS supports both 1-arg and 3-arg 3165 * signal handlers. But the perl core itself only fully supports 1-arg 3166 * handlers, so don't enable for now. 3167 * NB: POSIX::sigaction() supports both. 3168 * 3169 * # define PERL_USE_3ARG_SIGHANDLER 3170 */ 3171 #endif 3172 3173 /* Siginfo_t: 3174 * This is an alias for the OS's siginfo_t, except that where the OS 3175 * doesn't support it, declare a dummy version instead. This allows us to 3176 * have signal handler functions which always have a Siginfo_t parameter 3177 * regardless of platform, (and which will just be passed a NULL value 3178 * where the OS doesn't support HAS_SIGACTION). 3179 */ 3180 3181 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 3182 typedef siginfo_t Siginfo_t; 3183 #else 3184 #ifdef si_signo /* minix */ 3185 #undef si_signo 3186 #endif 3187 typedef struct { 3188 int si_signo; 3189 } Siginfo_t; 3190 #endif 3191 3192 3193 /* 3194 * initialise to avoid floating-point exceptions from overflow, etc 3195 */ 3196 #ifndef PERL_FPU_INIT 3197 # ifdef HAS_FPSETMASK 3198 # if HAS_FLOATINGPOINT_H 3199 # include <floatingpoint.h> 3200 # endif 3201 /* Some operating systems have this as a macro, which in turn expands to a comma 3202 expression, and the last sub-expression is something that gets calculated, 3203 and then they have the gall to warn that a value computed is not used. Hence 3204 cast to void. */ 3205 # define PERL_FPU_INIT (void)fpsetmask(0) 3206 # elif defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO) 3207 # define PERL_FPU_INIT PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN) 3208 # define PERL_FPU_PRE_EXEC { Sigsave_t xfpe; rsignal_save(SIGFPE, PL_sigfpe_saved, &xfpe); 3209 # define PERL_FPU_POST_EXEC rsignal_restore(SIGFPE, &xfpe); } 3210 # else 3211 # define PERL_FPU_INIT 3212 # endif 3213 #endif 3214 #ifndef PERL_FPU_PRE_EXEC 3215 # define PERL_FPU_PRE_EXEC { 3216 # define PERL_FPU_POST_EXEC } 3217 #endif 3218 3219 /* In Tru64 the cc -ieee enables the IEEE math but disables traps. 3220 * We need to reenable the "invalid" trap because otherwise generation 3221 * of NaN values leaves the IEEE fp flags in bad state, leaving any further 3222 * fp ops behaving strangely (Inf + 1 resulting in zero, for example). */ 3223 #ifdef __osf__ 3224 # include <machine/fpu.h> 3225 # define PERL_SYS_FPU_INIT \ 3226 STMT_START { \ 3227 ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); \ 3228 signal(SIGFPE, SIG_IGN); \ 3229 } STMT_END 3230 #endif 3231 /* In IRIX the default for Flush to Zero bit is true, 3232 * which means that results going below the minimum of normal 3233 * floating points go to zero, instead of going denormal/subnormal. 3234 * This is unlike almost any other system running Perl, so let's clear it. 3235 * [perl #123767] IRIX64 blead (ddce084a) opbasic/arith.t failure, originally 3236 * [perl #120426] small numbers shouldn't round to zero if they have extra floating digits 3237 * 3238 * XXX The flush-to-zero behaviour should be a Configure scan. 3239 * To change the behaviour usually requires some system-specific 3240 * incantation, though, like the below. */ 3241 #ifdef __sgi 3242 # include <sys/fpu.h> 3243 # define PERL_SYS_FPU_INIT \ 3244 STMT_START { \ 3245 union fpc_csr csr; \ 3246 csr.fc_word = get_fpc_csr(); \ 3247 csr.fc_struct.flush = 0; \ 3248 set_fpc_csr(csr.fc_word); \ 3249 } STMT_END 3250 #endif 3251 3252 #ifndef PERL_SYS_FPU_INIT 3253 # define PERL_SYS_FPU_INIT NOOP 3254 #endif 3255 3256 #ifndef PERL_SYS_INIT3_BODY 3257 # define PERL_SYS_INIT3_BODY(argvp,argcp,envp) PERL_SYS_INIT_BODY(argvp,argcp) 3258 #endif 3259 3260 /* 3261 =for apidoc_section $embedding 3262 3263 =for apidoc Am|void|PERL_SYS_INIT |int *argc|char*** argv 3264 =for apidoc_item| |PERL_SYS_INIT3|int *argc|char*** argv|char*** env 3265 3266 These provide system-specific tune up of the C runtime environment necessary to 3267 run Perl interpreters. Only one should be used, and it should be called only 3268 once, before creating any Perl interpreters. 3269 3270 They differ in that C<PERL_SYS_INIT3> also initializes C<env>. 3271 3272 =for apidoc Am|void|PERL_SYS_TERM| 3273 Provides system-specific clean up of the C runtime environment after 3274 running Perl interpreters. This should be called only once, after 3275 freeing any remaining Perl interpreters. 3276 3277 =cut 3278 */ 3279 3280 #define PERL_SYS_INIT(argc, argv) Perl_sys_init(argc, argv) 3281 #define PERL_SYS_INIT3(argc, argv, env) Perl_sys_init3(argc, argv, env) 3282 #define PERL_SYS_TERM() Perl_sys_term() 3283 3284 #ifndef PERL_WRITE_MSG_TO_CONSOLE 3285 # define PERL_WRITE_MSG_TO_CONSOLE(io, msg, len) PerlIO_write(io, msg, len) 3286 #endif 3287 3288 #ifndef MAXPATHLEN 3289 # ifdef PATH_MAX 3290 # ifdef _POSIX_PATH_MAX 3291 # if PATH_MAX > _POSIX_PATH_MAX 3292 /* POSIX 1990 (and pre) was ambiguous about whether PATH_MAX 3293 * included the null byte or not. Later amendments of POSIX, 3294 * XPG4, the Austin Group, and the Single UNIX Specification 3295 * all explicitly include the null byte in the PATH_MAX. 3296 * Ditto for _POSIX_PATH_MAX. */ 3297 # define MAXPATHLEN PATH_MAX 3298 # else 3299 # define MAXPATHLEN _POSIX_PATH_MAX 3300 # endif 3301 # else 3302 # define MAXPATHLEN (PATH_MAX+1) 3303 # endif 3304 # else 3305 # define MAXPATHLEN 1024 /* Err on the large side. */ 3306 # endif 3307 #endif 3308 3309 /* clang Thread Safety Analysis/Annotations/Attributes 3310 * http://clang.llvm.org/docs/ThreadSafetyAnalysis.html 3311 * 3312 * Available since clang 3.6-ish (appeared in 3.4, but shaky still in 3.5). 3313 * Apple XCode hijacks __clang_major__ and __clang_minor__ 3314 * (6.1 means really clang 3.6), so needs extra hijinks 3315 * (could probably also test the contents of __apple_build_version__). 3316 */ 3317 #if defined(USE_ITHREADS) && defined(I_PTHREAD) && \ 3318 defined(__clang__) && \ 3319 !defined(SWIG) && \ 3320 ((!defined(__apple_build_version__) && \ 3321 ((__clang_major__ == 3 && __clang_minor__ >= 6) || \ 3322 (__clang_major__ >= 4))) || \ 3323 (defined(__apple_build_version__) && \ 3324 ((__clang_major__ == 6 && __clang_minor__ >= 1) || \ 3325 (__clang_major__ >= 7)))) 3326 # define PERL_TSA__(x) __attribute__((x)) 3327 # define PERL_TSA_ACTIVE 3328 #else 3329 # define PERL_TSA__(x) /* No TSA, make TSA attributes no-ops. */ 3330 # undef PERL_TSA_ACTIVE 3331 #endif 3332 3333 /* PERL_TSA_CAPABILITY() is used to annotate typedefs. 3334 * typedef old_type PERL_TSA_CAPABILITY("mutex") new_type; 3335 */ 3336 #define PERL_TSA_CAPABILITY(x) \ 3337 PERL_TSA__(capability(x)) 3338 3339 /* In the below examples the mutex must be lexically visible, usually 3340 * either as global variables, or as function arguments. */ 3341 3342 /* PERL_TSA_GUARDED_BY() is used to annotate global variables. 3343 * 3344 * Foo foo PERL_TSA_GUARDED_BY(mutex); 3345 */ 3346 #define PERL_TSA_GUARDED_BY(x) \ 3347 PERL_TSA__(guarded_by(x)) 3348 3349 /* PERL_TSA_PT_GUARDED_BY() is used to annotate global pointers. 3350 * The data _behind_ the pointer is guarded. 3351 * 3352 * Foo* ptr PERL_TSA_PT_GUARDED_BY(mutex); 3353 */ 3354 #define PERL_TSA_PT_GUARDED_BY(x) \ 3355 PERL_TSA__(pt_guarded_by(x)) 3356 3357 /* PERL_TSA_REQUIRES() is used to annotate functions. 3358 * The caller MUST hold the resource when calling the function. 3359 * 3360 * void Foo() PERL_TSA_REQUIRES(mutex); 3361 */ 3362 #define PERL_TSA_REQUIRES(x) \ 3363 PERL_TSA__(requires_capability(x)) 3364 3365 /* PERL_TSA_EXCLUDES() is used to annotate functions. 3366 * The caller MUST NOT hold resource when calling the function. 3367 * 3368 * EXCLUDES should be used when the function first acquires 3369 * the resource and then releases it. Use to avoid deadlock. 3370 * 3371 * void Foo() PERL_TSA_EXCLUDES(mutex); 3372 */ 3373 #define PERL_TSA_EXCLUDES(x) \ 3374 PERL_TSA__(locks_excluded(x)) 3375 3376 /* PERL_TSA_ACQUIRE() is used to annotate functions. 3377 * The caller MUST NOT hold the resource when calling the function, 3378 * and the function will acquire the resource. 3379 * 3380 * void Foo() PERL_TSA_ACQUIRE(mutex); 3381 */ 3382 #define PERL_TSA_ACQUIRE(x) \ 3383 PERL_TSA__(acquire_capability(x)) 3384 3385 /* PERL_TSA_RELEASE() is used to annotate functions. 3386 * The caller MUST hold the resource when calling the function, 3387 * and the function will release the resource. 3388 * 3389 * void Foo() PERL_TSA_RELEASE(mutex); 3390 */ 3391 #define PERL_TSA_RELEASE(x) \ 3392 PERL_TSA__(release_capability(x)) 3393 3394 /* PERL_TSA_NO_TSA is used to annotate functions. 3395 * Used when being intentionally unsafe, or when the code is too 3396 * complicated for the analysis. Use sparingly. 3397 * 3398 * void Foo() PERL_TSA_NO_TSA; 3399 */ 3400 #define PERL_TSA_NO_TSA \ 3401 PERL_TSA__(no_thread_safety_analysis) 3402 3403 /* There are more annotations/attributes available, see the clang 3404 * documentation for details. */ 3405 3406 #if defined(USE_ITHREADS) 3407 # if defined(WIN32) 3408 # include <win32thread.h> 3409 # elif defined(OS2) 3410 # include "os2thread.h" 3411 # elif defined(I_MACH_CTHREADS) 3412 # include <mach/cthreads.h> 3413 typedef cthread_t perl_os_thread; 3414 typedef mutex_t perl_mutex; 3415 typedef condition_t perl_cond; 3416 typedef void * perl_key; 3417 # elif defined(I_PTHREAD) /* Posix threads */ 3418 # include <pthread.h> 3419 typedef pthread_t perl_os_thread; 3420 typedef pthread_mutex_t PERL_TSA_CAPABILITY("mutex") perl_mutex; 3421 typedef pthread_cond_t perl_cond; 3422 typedef pthread_key_t perl_key; 3423 # endif 3424 3425 /* Many readers; single writer */ 3426 typedef struct { 3427 perl_mutex lock; 3428 perl_cond wakeup; 3429 SSize_t readers_count; 3430 } perl_RnW1_mutex_t; 3431 3432 3433 #endif /* USE_ITHREADS */ 3434 3435 #ifdef PERL_TSA_ACTIVE 3436 /* Since most pthread mutex interfaces have not been annotated, we 3437 * need to have these wrappers. The NO_TSA annotation is quite ugly 3438 * but it cannot be avoided in plain C, unlike in C++, where one could 3439 * e.g. use ACQUIRE() with no arg on a mutex lock method. 3440 * 3441 * The bodies of these wrappers are in util.c 3442 * 3443 * TODO: however, some platforms are starting to get these clang 3444 * thread safety annotations for pthreads, for example FreeBSD. 3445 * Do we need a way to a bypass these wrappers? */ 3446 EXTERN_C int perl_tsa_mutex_lock(perl_mutex* mutex) 3447 PERL_TSA_ACQUIRE(*mutex) 3448 PERL_TSA_NO_TSA; 3449 EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) 3450 PERL_TSA_RELEASE(*mutex) 3451 PERL_TSA_NO_TSA; 3452 #endif 3453 3454 #if defined(WIN32) 3455 # include "win32.h" 3456 #endif 3457 3458 #define STATUS_UNIX PL_statusvalue 3459 #ifdef VMS 3460 # define STATUS_NATIVE PL_statusvalue_vms 3461 /* 3462 * vaxc$errno is only guaranteed to be valid if errno == EVMSERR, otherwise 3463 * its contents can not be trusted. Unfortunately, Perl seems to check 3464 * it on exit, so it when PL_statusvalue_vms is updated, vaxc$errno should 3465 * be updated also. 3466 */ 3467 # include <stsdef.h> 3468 # include <ssdef.h> 3469 /* Presume this because if VMS changes it, it will require a new 3470 * set of APIs for waiting on children for binary compatibility. 3471 */ 3472 # define child_offset_bits (8) 3473 # ifndef C_FAC_POSIX 3474 # define C_FAC_POSIX 0x35A000 3475 # endif 3476 3477 /* STATUS_EXIT - validates and returns a NATIVE exit status code for the 3478 * platform from the existing UNIX or Native status values. 3479 */ 3480 3481 # define STATUS_EXIT \ 3482 (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \ 3483 (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0)) 3484 3485 3486 /* STATUS_NATIVE_CHILD_SET - Calculate UNIX status that matches the child 3487 * exit code and shifts the UNIX value over the correct number of bits to 3488 * be a child status. Usually the number of bits is 8, but that could be 3489 * platform dependent. The NATIVE status code is presumed to have either 3490 * from a child process. 3491 */ 3492 3493 /* This is complicated. The child processes return a true native VMS 3494 status which must be saved. But there is an assumption in Perl that 3495 the UNIX child status has some relationship to errno values, so 3496 Perl tries to translate it to text in some of the tests. 3497 In order to get the string translation correct, for the error, errno 3498 must be EVMSERR, but that generates a different text message 3499 than what the test programs are expecting. So an errno value must 3500 be derived from the native status value when an error occurs. 3501 That will hide the true native status message. With this version of 3502 perl, the true native child status can always be retrieved so that 3503 is not a problem. But in this case, Pl_statusvalue and errno may 3504 have different values in them. 3505 */ 3506 3507 # define STATUS_NATIVE_CHILD_SET(n) \ 3508 STMT_START { \ 3509 I32 evalue = (I32)n; \ 3510 if (evalue == EVMSERR) { \ 3511 PL_statusvalue_vms = vaxc$errno; \ 3512 PL_statusvalue = evalue; \ 3513 } else { \ 3514 PL_statusvalue_vms = evalue; \ 3515 if (evalue == -1) { \ 3516 PL_statusvalue = -1; \ 3517 PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \ 3518 } else \ 3519 PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \ 3520 set_vaxc_errno(evalue); \ 3521 if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \ 3522 set_errno(EVMSERR); \ 3523 else set_errno(Perl_vms_status_to_unix(evalue, 0)); \ 3524 PL_statusvalue = PL_statusvalue << child_offset_bits; \ 3525 } \ 3526 } STMT_END 3527 3528 # ifdef VMSISH_STATUS 3529 # define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX) 3530 # else 3531 # define STATUS_CURRENT STATUS_UNIX 3532 # endif 3533 3534 /* STATUS_UNIX_SET - takes a UNIX/POSIX errno value and attempts to update 3535 * the NATIVE status to an equivalent value. Can not be used to translate 3536 * exit code values as exit code values are not guaranteed to have any 3537 * relationship at all to errno values. 3538 * This is used when Perl is forcing errno to have a specific value. 3539 */ 3540 # define STATUS_UNIX_SET(n) \ 3541 STMT_START { \ 3542 I32 evalue = (I32)n; \ 3543 PL_statusvalue = evalue; \ 3544 if (PL_statusvalue != -1) { \ 3545 if (PL_statusvalue != EVMSERR) { \ 3546 PL_statusvalue &= 0xFFFF; \ 3547 if (MY_POSIX_EXIT) \ 3548 PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\ 3549 else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \ 3550 } \ 3551 else { \ 3552 PL_statusvalue_vms = vaxc$errno; \ 3553 } \ 3554 } \ 3555 else PL_statusvalue_vms = SS$_ABORT; \ 3556 set_vaxc_errno(PL_statusvalue_vms); \ 3557 } STMT_END 3558 3559 /* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets 3560 * the NATIVE error status based on it. 3561 * 3562 * When in the default mode to comply with the Perl VMS documentation, 3563 * 0 is a success and any other code sets the NATIVE status to a failure 3564 * code of SS$_ABORT. 3565 * 3566 * In the new POSIX EXIT mode, native status will be set so that the 3567 * actual exit code will can be retrieved by the calling program or 3568 * shell. 3569 * 3570 * If the exit code is not clearly a UNIX parent or child exit status, 3571 * it will be passed through as a VMS status. 3572 */ 3573 3574 # define STATUS_UNIX_EXIT_SET(n) \ 3575 STMT_START { \ 3576 I32 evalue = (I32)n; \ 3577 PL_statusvalue = evalue; \ 3578 if (MY_POSIX_EXIT) { \ 3579 if (evalue <= 0xFF00) { \ 3580 if (evalue > 0xFF) \ 3581 evalue = ((U8) (evalue >> child_offset_bits)); \ 3582 PL_statusvalue_vms = \ 3583 (C_FAC_POSIX | (evalue << 3 ) | \ 3584 ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ 3585 } else /* forgive them Perl, for they have sinned */ \ 3586 PL_statusvalue_vms = evalue; \ 3587 } else { \ 3588 if (evalue == 0) \ 3589 PL_statusvalue_vms = SS$_NORMAL; \ 3590 else if (evalue <= 0xFF00) \ 3591 PL_statusvalue_vms = SS$_ABORT; \ 3592 else { /* forgive them Perl, for they have sinned */ \ 3593 if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \ 3594 else PL_statusvalue_vms = vaxc$errno; \ 3595 /* And obviously used a VMS status value instead of UNIX */ \ 3596 PL_statusvalue = EVMSERR; \ 3597 } \ 3598 set_vaxc_errno(PL_statusvalue_vms); \ 3599 } \ 3600 } STMT_END 3601 3602 3603 /* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code 3604 * and sets the NATIVE error status based on it. This special case 3605 * is needed to maintain compatibility with past VMS behavior. 3606 * 3607 * In the default mode on VMS, this number is passed through as 3608 * both the NATIVE and UNIX status. Which makes it different 3609 * that the STATUS_UNIX_EXIT_SET. 3610 * 3611 * In the new POSIX EXIT mode, native status will be set so that the 3612 * actual exit code will can be retrieved by the calling program or 3613 * shell. 3614 * 3615 * A POSIX exit code is from 0 to 255. If the exit code is higher 3616 * than this, it needs to be assumed that it is a VMS exit code and 3617 * passed through. 3618 */ 3619 3620 # define STATUS_EXIT_SET(n) \ 3621 STMT_START { \ 3622 I32 evalue = (I32)n; \ 3623 PL_statusvalue = evalue; \ 3624 if (MY_POSIX_EXIT) \ 3625 if (evalue > 255) PL_statusvalue_vms = evalue; else { \ 3626 PL_statusvalue_vms = \ 3627 (C_FAC_POSIX | (evalue << 3 ) | \ 3628 ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1));} \ 3629 else \ 3630 PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \ 3631 set_vaxc_errno(PL_statusvalue_vms); \ 3632 } STMT_END 3633 3634 3635 /* This macro forces a success status */ 3636 # define STATUS_ALL_SUCCESS \ 3637 (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL) 3638 3639 /* This macro forces a failure status */ 3640 # define STATUS_ALL_FAILURE (PL_statusvalue = 1, \ 3641 vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \ 3642 (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT) 3643 3644 #elif defined(__amigaos4__) 3645 /* A somewhat experimental attempt to simulate posix return code values */ 3646 # define STATUS_NATIVE PL_statusvalue_posix 3647 # define STATUS_NATIVE_CHILD_SET(n) \ 3648 STMT_START { \ 3649 PL_statusvalue_posix = (n); \ 3650 if (PL_statusvalue_posix < 0) { \ 3651 PL_statusvalue = -1; \ 3652 } \ 3653 else { \ 3654 PL_statusvalue = n << 8; \ 3655 } \ 3656 } STMT_END 3657 # define STATUS_UNIX_SET(n) \ 3658 STMT_START { \ 3659 PL_statusvalue = (n); \ 3660 if (PL_statusvalue != -1) \ 3661 PL_statusvalue &= 0xFFFF; \ 3662 } STMT_END 3663 # define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n) 3664 # define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n) 3665 # define STATUS_CURRENT STATUS_UNIX 3666 # define STATUS_EXIT STATUS_UNIX 3667 # define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_posix = 0) 3668 # define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_posix = 1) 3669 3670 #else 3671 # define STATUS_NATIVE PL_statusvalue_posix 3672 # if defined(WCOREDUMP) 3673 # define STATUS_NATIVE_CHILD_SET(n) \ 3674 STMT_START { \ 3675 PL_statusvalue_posix = (n); \ 3676 if (PL_statusvalue_posix == -1) \ 3677 PL_statusvalue = -1; \ 3678 else { \ 3679 PL_statusvalue = \ 3680 (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) | \ 3681 (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0) | \ 3682 (WIFSIGNALED(PL_statusvalue_posix) && WCOREDUMP(PL_statusvalue_posix) ? 0x80 : 0); \ 3683 } \ 3684 } STMT_END 3685 # elif defined(WIFEXITED) 3686 # define STATUS_NATIVE_CHILD_SET(n) \ 3687 STMT_START { \ 3688 PL_statusvalue_posix = (n); \ 3689 if (PL_statusvalue_posix == -1) \ 3690 PL_statusvalue = -1; \ 3691 else { \ 3692 PL_statusvalue = \ 3693 (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) | \ 3694 (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0); \ 3695 } \ 3696 } STMT_END 3697 # else 3698 # define STATUS_NATIVE_CHILD_SET(n) \ 3699 STMT_START { \ 3700 PL_statusvalue_posix = (n); \ 3701 if (PL_statusvalue_posix == -1) \ 3702 PL_statusvalue = -1; \ 3703 else { \ 3704 PL_statusvalue = \ 3705 PL_statusvalue_posix & 0xFFFF; \ 3706 } \ 3707 } STMT_END 3708 # endif 3709 # define STATUS_UNIX_SET(n) \ 3710 STMT_START { \ 3711 PL_statusvalue = (n); \ 3712 if (PL_statusvalue != -1) \ 3713 PL_statusvalue &= 0xFFFF; \ 3714 } STMT_END 3715 # define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n) 3716 # define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n) 3717 # define STATUS_CURRENT STATUS_UNIX 3718 # define STATUS_EXIT STATUS_UNIX 3719 # define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_posix = 0) 3720 # define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_posix = 1) 3721 #endif 3722 3723 /* flags in PL_exit_flags for nature of exit() */ 3724 #define PERL_EXIT_EXPECTED 0x01 3725 #define PERL_EXIT_DESTRUCT_END 0x02 /* Run END in perl_destruct */ 3726 #define PERL_EXIT_WARN 0x04 /* Warn if Perl_my_exit() or Perl_my_failure_exit() called */ 3727 #define PERL_EXIT_ABORT 0x08 /* Call abort() if Perl_my_exit() or Perl_my_failure_exit() called */ 3728 3729 #ifndef PERL_CORE 3730 /* format to use for version numbers in file/directory names */ 3731 /* XXX move to Configure? */ 3732 /* This was only ever used for the current version, and that can be done at 3733 compile time, as PERL_FS_VERSION, so should we just delete it? */ 3734 # ifndef PERL_FS_VER_FMT 3735 # define PERL_FS_VER_FMT "%d.%d.%d" 3736 # endif 3737 #endif 3738 3739 #ifndef PERL_FS_VERSION 3740 # define PERL_FS_VERSION PERL_VERSION_STRING 3741 #endif 3742 3743 /* 3744 3745 =for apidoc_section $io 3746 =for apidoc Amn|void|PERL_FLUSHALL_FOR_CHILD 3747 3748 This defines a way to flush all output buffers. This may be a 3749 performance issue, so we allow people to disable it. Also, if 3750 we are using stdio, there are broken implementations of fflush(NULL) 3751 out there, Solaris being the most prominent. 3752 3753 =cut 3754 */ 3755 3756 #ifndef PERL_FLUSHALL_FOR_CHILD 3757 # if defined(USE_PERLIO) || defined(FFLUSH_NULL) 3758 # define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL) 3759 # elif defined(FFLUSH_ALL) 3760 # define PERL_FLUSHALL_FOR_CHILD my_fflush_all() 3761 # else 3762 # define PERL_FLUSHALL_FOR_CHILD NOOP 3763 # endif 3764 #endif 3765 3766 #ifndef PERL_WAIT_FOR_CHILDREN 3767 # define PERL_WAIT_FOR_CHILDREN NOOP 3768 #endif 3769 3770 /* the traditional thread-unsafe notion of "current interpreter". */ 3771 #ifndef PERL_SET_INTERP 3772 # define PERL_SET_INTERP(i) (PL_curinterp = (PerlInterpreter*)(i)) 3773 #endif 3774 3775 #ifndef PERL_GET_INTERP 3776 # define PERL_GET_INTERP (PL_curinterp) 3777 #endif 3778 3779 #if defined(MULTIPLICITY) && !defined(PERL_GET_THX) 3780 # define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT) 3781 # define PERL_SET_THX(t) PERL_SET_CONTEXT(t) 3782 #endif 3783 3784 /* 3785 This replaces the previous %_ "hack" by the "%p" hacks. 3786 All that is required is that the perl source does not 3787 use "%-p" or "%-<number>p" or "%<number>p" formats. 3788 These formats will still work in perl code. 3789 See comments in sv.c for further details. 3790 3791 Robin Barker 2005-07-14 3792 3793 No longer use %1p for VDf = %vd. RMB 2007-10-19 3794 */ 3795 3796 #ifndef SVf_ 3797 # define SVf_(n) "-" STRINGIFY(n) "p" 3798 #endif 3799 3800 #ifndef SVf 3801 # define SVf "-p" 3802 #endif 3803 3804 #ifndef SVf32 3805 # define SVf32 SVf_(32) 3806 #endif 3807 3808 #ifndef SVf256 3809 # define SVf256 SVf_(256) 3810 #endif 3811 3812 #define SVfARG(p) ((void*)(p)) 3813 3814 #ifndef HEKf 3815 # define HEKf "2p" 3816 #endif 3817 3818 /* Not ideal, but we cannot easily include a number in an already-numeric 3819 * format sequence. */ 3820 #ifndef HEKf256 3821 # define HEKf256 "3p" 3822 #endif 3823 3824 #define HEKfARG(p) ((void*)(p)) 3825 3826 /* Documented in perlguts 3827 * 3828 * %4p is a custom format 3829 */ 3830 #ifndef UTF8f 3831 # define UTF8f "d%" UVuf "%4p" 3832 #endif 3833 #define UTF8fARG(u,l,p) (int)cBOOL(u), (UV)(l), (void*)(p) 3834 3835 #define PNf UTF8f 3836 #define PNfARG(pn) (int)1, (UV)PadnameLEN(pn), (void *)PadnamePV(pn) 3837 3838 #ifdef PERL_CORE 3839 /* not used; but needed for backward compatibility with XS code? - RMB 3840 =for apidoc_section $io_formats 3841 =for apidoc AmnD|const char *|UVf 3842 3843 Obsolete form of C<UVuf>, which you should convert to instead use 3844 3845 =cut 3846 */ 3847 # undef UVf 3848 #elif !defined(UVf) 3849 # define UVf UVuf 3850 #endif 3851 3852 #if !defined(DEBUGGING) && !defined(NDEBUG) 3853 # define NDEBUG 1 3854 #endif 3855 #include <assert.h> 3856 3857 /* For functions that are marked as __attribute__noreturn__, it's not 3858 appropriate to call return. In either case, include the lint directive. 3859 */ 3860 #ifdef HASATTRIBUTE_NORETURN 3861 # define NORETURN_FUNCTION_END NOT_REACHED; 3862 #else 3863 # define NORETURN_FUNCTION_END NOT_REACHED; return 0 3864 #endif 3865 3866 #ifdef HAS_BUILTIN_EXPECT 3867 # define EXPECT(expr,val) __builtin_expect(expr,val) 3868 #else 3869 # define EXPECT(expr,val) (expr) 3870 #endif 3871 3872 /* 3873 =for apidoc_section $directives 3874 3875 =for apidoc Am||LIKELY|bool expr 3876 3877 Returns the input unchanged, but at the same time it gives a branch prediction 3878 hint to the compiler that this condition is likely to be true. 3879 3880 =for apidoc Am||UNLIKELY|bool expr 3881 3882 Returns the input unchanged, but at the same time it gives a branch prediction 3883 hint to the compiler that this condition is likely to be false. 3884 3885 =cut 3886 */ 3887 #define LIKELY(cond) EXPECT(cBOOL(cond),TRUE) 3888 #define UNLIKELY(cond) EXPECT(cBOOL(cond),FALSE) 3889 3890 #ifdef HAS_BUILTIN_CHOOSE_EXPR 3891 /* placeholder */ 3892 #endif 3893 3894 /* STATIC_ASSERT_DECL/STATIC_ASSERT_STMT are like assert(), but for compile 3895 time invariants. That is, their argument must be a constant expression that 3896 can be verified by the compiler. This expression can contain anything that's 3897 known to the compiler, e.g. #define constants, enums, or sizeof (...). If 3898 the expression evaluates to 0, compilation fails. 3899 Because they generate no runtime code (i.e. their use is "free"), they're 3900 always active, even under non-DEBUGGING builds. 3901 STATIC_ASSERT_DECL expands to a declaration and is suitable for use at 3902 file scope (outside of any function). 3903 STATIC_ASSERT_STMT expands to a statement and is suitable for use inside a 3904 function. 3905 */ 3906 #if (! defined(__IBMC__) || __IBMC__ >= 1210) \ 3907 && (( defined(static_assert) && ( defined(_ISOC11_SOURCE) \ 3908 || (__STDC_VERSION__ - 0) >= 201101L)) \ 3909 || (defined(__cplusplus) && __cplusplus >= 201103L)) 3910 /* XXX static_assert is a macro defined in <assert.h> in C11 or a compiler 3911 builtin in C++11. But IBM XL C V11 does not support _Static_assert, no 3912 matter what <assert.h> says. 3913 */ 3914 # define STATIC_ASSERT_DECL(COND) static_assert(COND, #COND) 3915 #else 3916 /* We use a bit-field instead of an array because gcc accepts 3917 'typedef char x[n]' where n is not a compile-time constant. 3918 We want to enforce constantness. 3919 */ 3920 # define STATIC_ASSERT_2(COND, SUFFIX) \ 3921 typedef struct { \ 3922 unsigned int _static_assertion_failed_##SUFFIX : (COND) ? 1 : -1; \ 3923 } _static_assertion_failed_##SUFFIX PERL_UNUSED_DECL 3924 # define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX) 3925 # define STATIC_ASSERT_DECL(COND) STATIC_ASSERT_1(COND, __LINE__) 3926 #endif 3927 /* We need this wrapper even in C11 because 'case X: static_assert(...);' is an 3928 error (static_assert is a declaration, and only statements can have labels). 3929 */ 3930 #define STATIC_ASSERT_STMT(COND) STMT_START { STATIC_ASSERT_DECL(COND); } STMT_END 3931 3932 #ifndef __has_builtin 3933 # define __has_builtin(x) 0 /* not a clang style compiler */ 3934 #endif 3935 3936 /* 3937 =for apidoc Am||ASSUME|bool expr 3938 C<ASSUME> is like C<assert()>, but it has a benefit in a release build. It is a 3939 hint to a compiler about a statement of fact in a function call free 3940 expression, which allows the compiler to generate better machine code. In a 3941 debug build, C<ASSUME(x)> is a synonym for C<assert(x)>. C<ASSUME(0)> means the 3942 control path is unreachable. In a for loop, C<ASSUME> can be used to hint that 3943 a loop will run at least X times. C<ASSUME> is based off MSVC's C<__assume> 3944 intrinsic function, see its documents for more details. 3945 3946 =cut 3947 */ 3948 3949 #if __has_builtin(__builtin_unreachable) 3950 # define HAS_BUILTIN_UNREACHABLE 3951 #elif PERL_GCC_VERSION_GE(4,5,0) 3952 # define HAS_BUILTIN_UNREACHABLE 3953 #endif 3954 3955 #ifdef DEBUGGING 3956 # define ASSUME(x) assert(x) 3957 #elif defined(_MSC_VER) 3958 # define ASSUME(x) __assume(x) 3959 #elif defined(__ARMCC_VERSION) /* untested */ 3960 # define ASSUME(x) __promise(x) 3961 #elif defined(HAS_BUILTIN_UNREACHABLE) 3962 /* Compilers can take the hint from something being unreachable */ 3963 # define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable()) 3964 #else 3965 /* Not DEBUGGING, so assert() is a no-op, but a random compiler might 3966 * define assert() to its own special optimization token so pass it through 3967 * to C lib as a last resort */ 3968 # define ASSUME(x) assert(x) 3969 #endif 3970 3971 #ifdef HAS_BUILTIN_UNREACHABLE 3972 # define NOT_REACHED \ 3973 STMT_START { \ 3974 ASSUME(!"UNREACHABLE"); __builtin_unreachable(); \ 3975 } STMT_END 3976 # undef HAS_BUILTIN_UNREACHABLE /* Don't leak out this internal symbol */ 3977 #elif ! defined(__GNUC__) && (defined(__sun) || defined(__hpux)) 3978 /* These just complain that NOT_REACHED isn't reached */ 3979 # define NOT_REACHED 3980 #else 3981 # define NOT_REACHED ASSUME(!"UNREACHABLE") 3982 #endif 3983 3984 /* Some unistd.h's give a prototype for pause() even though 3985 HAS_PAUSE ends up undefined. This causes the #define 3986 below to be rejected by the compiler. Sigh. 3987 */ 3988 #ifdef HAS_PAUSE 3989 #define Pause pause 3990 #else 3991 #define Pause() sleep((32767<<16)+32767) 3992 #endif 3993 3994 #ifndef IOCPARM_LEN 3995 # ifdef IOCPARM_MASK 3996 /* on BSDish systems we're safe */ 3997 # define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) 3998 # elif defined(_IOC_SIZE) && defined(__GLIBC__) 3999 /* on Linux systems we're safe; except when we're not [perl #38223] */ 4000 # define IOCPARM_LEN(x) (_IOC_SIZE(x) < 256 ? 256 : _IOC_SIZE(x)) 4001 # else 4002 /* otherwise guess at what's safe */ 4003 # define IOCPARM_LEN(x) 256 4004 # endif 4005 #endif 4006 4007 #if defined(__CYGWIN__) 4008 /* USEMYBINMODE 4009 * This symbol, if defined, indicates that the program should 4010 * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure 4011 * that a file is in "binary" mode -- that is, that no translation 4012 * of bytes occurs on read or write operations. 4013 */ 4014 # define USEMYBINMODE /**/ 4015 # include <io.h> /* for setmode() prototype */ 4016 # define my_binmode(fp, iotype, mode) \ 4017 cBOOL(PerlLIO_setmode(fileno(fp), mode) != -1) 4018 #endif 4019 4020 #ifdef __CYGWIN__ 4021 void init_os_extras(void); 4022 #endif 4023 4024 #ifdef UNION_ANY_DEFINITION 4025 UNION_ANY_DEFINITION; 4026 #else 4027 union any { 4028 void* any_ptr; 4029 SV* any_sv; 4030 SV** any_svp; 4031 GV* any_gv; 4032 AV* any_av; 4033 HV* any_hv; 4034 OP* any_op; 4035 char* any_pv; 4036 char** any_pvp; 4037 I32 any_i32; 4038 U32 any_u32; 4039 IV any_iv; 4040 UV any_uv; 4041 long any_long; 4042 bool any_bool; 4043 void (*any_dptr) (void*); 4044 void (*any_dxptr) (pTHX_ void*); 4045 }; 4046 #endif 4047 4048 typedef I32 (*filter_t) (pTHX_ int, SV *, int); 4049 4050 #define FILTER_READ(idx, sv, len) filter_read(idx, sv, len) 4051 #define FILTER_DATA(idx) \ 4052 (PL_parser ? AvARRAY(PL_parser->rsfp_filters)[idx] : NULL) 4053 #define FILTER_ISREADER(idx) \ 4054 (PL_parser && PL_parser->rsfp_filters \ 4055 && idx >= AvFILLp(PL_parser->rsfp_filters)) 4056 #define PERL_FILTER_EXISTS(i) \ 4057 (PL_parser && PL_parser->rsfp_filters \ 4058 && (Size_t) (i) < av_count(PL_parser->rsfp_filters)) 4059 4060 #if defined(_AIX) && !defined(_AIX43) 4061 #if defined(USE_REENTRANT) || defined(_REENTRANT) || defined(_THREAD_SAFE) 4062 /* We cannot include <crypt.h> to get the struct crypt_data 4063 * because of setkey prototype problems when threading */ 4064 typedef struct crypt_data { /* straight from /usr/include/crypt.h */ 4065 /* From OSF, Not needed in AIX 4066 char C[28], D[28]; 4067 */ 4068 char E[48]; 4069 char KS[16][48]; 4070 char block[66]; 4071 char iobuf[16]; 4072 } CRYPTD; 4073 #endif /* threading */ 4074 #endif /* AIX */ 4075 4076 #ifndef PERL_CALLCONV 4077 # ifdef __cplusplus 4078 # define PERL_CALLCONV EXTERN_C 4079 # else 4080 # define PERL_CALLCONV 4081 # endif 4082 #endif 4083 #ifndef PERL_CALLCONV_NO_RET 4084 # define PERL_CALLCONV_NO_RET PERL_CALLCONV 4085 #endif 4086 4087 /* PERL_STATIC_NO_RET is supposed to be equivalent to STATIC on builds that 4088 dont have a noreturn as a declaration specifier 4089 */ 4090 #ifndef PERL_STATIC_NO_RET 4091 # define PERL_STATIC_NO_RET STATIC 4092 #endif 4093 4094 /* PERL_STATIC_INLINE_NO_RET is supposed to be equivalent to PERL_STATIC_INLINE 4095 * on builds that dont have a noreturn as a declaration specifier 4096 */ 4097 #ifndef PERL_STATIC_INLINE_NO_RET 4098 # define PERL_STATIC_INLINE_NO_RET PERL_STATIC_INLINE 4099 #endif 4100 4101 #ifndef PERL_STATIC_FORCE_INLINE 4102 # define PERL_STATIC_FORCE_INLINE PERL_STATIC_INLINE 4103 #endif 4104 4105 #ifndef PERL_STATIC_FORCE_INLINE_NO_RET 4106 # define PERL_STATIC_FORCE_INLINE_NO_RET PERL_STATIC_INLINE 4107 #endif 4108 4109 #if !defined(OS2) 4110 # include "iperlsys.h" 4111 #endif 4112 4113 #ifdef __LIBCATAMOUNT__ 4114 #undef HAS_PASSWD /* unixish.h but not unixish enough. */ 4115 #undef HAS_GROUP 4116 #define FAKE_BIT_BUCKET 4117 #endif 4118 4119 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0. 4120 * Note that the USE_HASH_SEED and similar defines are *NOT* defined by 4121 * Configure, despite their names being similar to other defines like 4122 * USE_ITHREADS. Configure in fact knows nothing about the randomised 4123 * hashes. Therefore to enable/disable the hash randomisation defines 4124 * use the Configure -Accflags=... instead. */ 4125 #if !defined(NO_HASH_SEED) && !defined(USE_HASH_SEED) 4126 # define USE_HASH_SEED 4127 #endif 4128 4129 #include "perly.h" 4130 4131 4132 /* macros to define bit-fields in structs. */ 4133 #ifndef PERL_BITFIELD8 4134 # ifdef HAS_NON_INT_BITFIELDS 4135 # define PERL_BITFIELD8 U8 4136 # else 4137 # define PERL_BITFIELD8 unsigned 4138 # endif 4139 #endif 4140 #ifndef PERL_BITFIELD16 4141 # ifdef HAS_NON_INT_BITFIELDS 4142 # define PERL_BITFIELD16 U16 4143 # else 4144 # define PERL_BITFIELD16 unsigned 4145 # endif 4146 #endif 4147 #ifndef PERL_BITFIELD32 4148 # ifdef HAS_NON_INT_BITFIELDS 4149 # define PERL_BITFIELD32 U32 4150 # else 4151 # define PERL_BITFIELD32 unsigned 4152 # endif 4153 #endif 4154 4155 #include "sv.h" 4156 #include "regexp.h" 4157 #include "util.h" 4158 #include "form.h" 4159 #include "gv.h" 4160 #include "pad.h" 4161 #include "cv.h" 4162 #include "opnames.h" 4163 #include "op.h" 4164 #include "hv.h" 4165 #include "cop.h" 4166 #include "av.h" 4167 #include "mg.h" 4168 #include "scope.h" 4169 #include "warnings.h" 4170 #include "utf8.h" 4171 4172 /* these would be in doio.h if there was such a file */ 4173 #define my_stat() my_stat_flags(SV_GMAGIC) 4174 #define my_lstat() my_lstat_flags(SV_GMAGIC) 4175 4176 /* defined in sv.c, but also used in [ach]v.c */ 4177 #undef _XPV_HEAD 4178 #undef _XPVMG_HEAD 4179 #undef _XPVCV_COMMON 4180 4181 #include "parser.h" 4182 4183 typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ 4184 4185 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) \ 4186 || defined(PERL_EXT_RE_BUILD) 4187 4188 /* These have to be predeclared, as they are used in proto.h which is #included 4189 * before their definitions in regcomp.h. */ 4190 4191 struct scan_data_t; 4192 typedef struct regnode_charclass regnode_charclass; 4193 4194 /* A hopefully less confusing name. The sub-classes are all Posix classes only 4195 * used under /l matching */ 4196 typedef struct regnode_charclass_posixl regnode_charclass_class; 4197 typedef struct regnode_charclass_posixl regnode_charclass_posixl; 4198 4199 typedef struct regnode_ssc regnode_ssc; 4200 typedef struct RExC_state_t RExC_state_t; 4201 struct _reg_trie_data; 4202 4203 #endif 4204 4205 struct ptr_tbl_ent { 4206 struct ptr_tbl_ent* next; 4207 const void* oldval; 4208 void* newval; 4209 }; 4210 4211 struct ptr_tbl { 4212 struct ptr_tbl_ent** tbl_ary; 4213 UV tbl_max; 4214 UV tbl_items; 4215 struct ptr_tbl_arena *tbl_arena; 4216 struct ptr_tbl_ent *tbl_arena_next; 4217 struct ptr_tbl_ent *tbl_arena_end; 4218 }; 4219 4220 #if defined(htonl) && !defined(HAS_HTONL) 4221 #define HAS_HTONL 4222 #endif 4223 #if defined(htons) && !defined(HAS_HTONS) 4224 #define HAS_HTONS 4225 #endif 4226 #if defined(ntohl) && !defined(HAS_NTOHL) 4227 #define HAS_NTOHL 4228 #endif 4229 #if defined(ntohs) && !defined(HAS_NTOHS) 4230 #define HAS_NTOHS 4231 #endif 4232 #ifndef HAS_HTONL 4233 #define HAS_HTONS 4234 #define HAS_HTONL 4235 #define HAS_NTOHS 4236 #define HAS_NTOHL 4237 # if (BYTEORDER & 0xffff) == 0x4321 4238 /* Big endian system, so ntohl, ntohs, htonl and htons do not need to 4239 re-order their values. However, to behave identically to the alternative 4240 implementations, they should truncate to the correct size. */ 4241 # define ntohl(x) ((x)&0xFFFFFFFF) 4242 # define htonl(x) ntohl(x) 4243 # define ntohs(x) ((x)&0xFFFF) 4244 # define htons(x) ntohs(x) 4245 # elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 4246 4247 /* Note that we can't straight out declare our own htonl and htons because 4248 the Win32 build process forcibly undefines HAS_HTONL etc for its miniperl, 4249 to avoid the overhead of initialising the socket subsystem, but the headers 4250 that *declare* the various functions are still seen. If we declare our own 4251 htonl etc they will clash with the declarations in the Win32 headers. */ 4252 4253 PERL_STATIC_INLINE U32 4254 my_swap32(const U32 x) { 4255 return ((x & 0xFF) << 24) | ((x >> 24) & 0xFF) 4256 | ((x & 0x0000FF00) << 8) | ((x & 0x00FF0000) >> 8); 4257 } 4258 4259 PERL_STATIC_INLINE U16 4260 my_swap16(const U16 x) { 4261 return ((x & 0xFF) << 8) | ((x >> 8) & 0xFF); 4262 } 4263 4264 # define htonl(x) my_swap32(x) 4265 # define ntohl(x) my_swap32(x) 4266 # define ntohs(x) my_swap16(x) 4267 # define htons(x) my_swap16(x) 4268 # else 4269 # error "Unsupported byteorder" 4270 /* The C pre-processor doesn't let us return the value of BYTEORDER as part of 4271 the error message. Please check the value of the macro BYTEORDER, as defined 4272 in config.h. The values of BYTEORDER we expect are 4273 4274 big endian little endian 4275 32 bit 0x4321 0x1234 4276 64 bit 0x87654321 0x12345678 4277 4278 If you have a system with a different byte order, please see 4279 pod/perlhack.pod for how to submit a patch to add supporting code. 4280 */ 4281 # endif 4282 #endif 4283 4284 /* 4285 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. 4286 * -DWS 4287 */ 4288 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 4289 /* Little endian system, so vtohl, vtohs, htovl and htovs do not need to 4290 re-order their values. However, to behave identically to the alternative 4291 implementations, they should truncate to the correct size. */ 4292 # define vtohl(x) ((x)&0xFFFFFFFF) 4293 # define vtohs(x) ((x)&0xFFFF) 4294 # define htovl(x) vtohl(x) 4295 # define htovs(x) vtohs(x) 4296 #elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 4297 # define vtohl(x) ((((x)&0xFF)<<24) \ 4298 +(((x)>>24)&0xFF) \ 4299 +(((x)&0x0000FF00)<<8) \ 4300 +(((x)&0x00FF0000)>>8) ) 4301 # define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF)) 4302 # define htovl(x) vtohl(x) 4303 # define htovs(x) vtohs(x) 4304 #else 4305 # error "Unsupported byteorder" 4306 /* If you have need for current perl on PDP-11 or similar, and can help test 4307 that blead keeps working on a mixed-endian system, then see 4308 pod/perlhack.pod for how to submit patches to things working again. */ 4309 #endif 4310 4311 /* *MAX Plus 1. A floating point value. 4312 Hopefully expressed in a way that dodgy floating point can't mess up. 4313 >> 2 rather than 1, so that value is safely less than I32_MAX after 1 4314 is added to it 4315 May find that some broken compiler will want the value cast to I32. 4316 [after the shift, as signed >> may not be as secure as unsigned >>] 4317 */ 4318 #define I32_MAX_P1 (2.0 * (1 + (((U32)I32_MAX) >> 1))) 4319 #define U32_MAX_P1 (4.0 * (1 + ((U32_MAX) >> 2))) 4320 /* For compilers that can't correctly cast NVs over 0x7FFFFFFF (or 4321 0x7FFFFFFFFFFFFFFF) to an unsigned integer. In the future, sizeof(UV) 4322 may be greater than sizeof(IV), so don't assume that half max UV is max IV. 4323 */ 4324 #define U32_MAX_P1_HALF (2.0 * (1 + ((U32_MAX) >> 2))) 4325 4326 #define UV_MAX_P1 (4.0 * (1 + ((UV_MAX) >> 2))) 4327 #define IV_MAX_P1 (2.0 * (1 + (((UV)IV_MAX) >> 1))) 4328 #define UV_MAX_P1_HALF (2.0 * (1 + ((UV_MAX) >> 2))) 4329 4330 /* This may look like unnecessary jumping through hoops, but converting 4331 out of range floating point values to integers *is* undefined behaviour, 4332 and it is starting to bite. 4333 4334 =for apidoc_section $casting 4335 =for apidoc Am|I32|I_32|NV what 4336 Cast an NV to I32 while avoiding undefined C behavior 4337 4338 =for apidoc Am|U32|U_32|NV what 4339 Cast an NV to U32 while avoiding undefined C behavior 4340 4341 =for apidoc Am|IV|I_V|NV what 4342 Cast an NV to IV while avoiding undefined C behavior 4343 4344 =for apidoc Am|UV|U_V|NV what 4345 Cast an NV to UV while avoiding undefined C behavior 4346 4347 =cut 4348 */ 4349 #ifndef CAST_INLINE 4350 #define I_32(what) (cast_i32((NV)(what))) 4351 #define U_32(what) (cast_ulong((NV)(what))) 4352 #define I_V(what) (cast_iv((NV)(what))) 4353 #define U_V(what) (cast_uv((NV)(what))) 4354 #else 4355 #define I_32(n) ((n) < I32_MAX_P1 ? ((n) < I32_MIN ? I32_MIN : (I32) (n)) \ 4356 : ((n) < U32_MAX_P1 ? (I32)(U32) (n) \ 4357 : ((n) > 0 ? (I32) U32_MAX : 0 /* NaN */))) 4358 #define U_32(n) ((n) < 0.0 ? ((n) < I32_MIN ? (UV) I32_MIN : (U32)(I32) (n)) \ 4359 : ((n) < U32_MAX_P1 ? (U32) (n) \ 4360 : ((n) > 0 ? U32_MAX : 0 /* NaN */))) 4361 #define I_V(n) (LIKELY((n) < IV_MAX_P1) ? (UNLIKELY((n) < IV_MIN) ? IV_MIN : (IV) (n)) \ 4362 : (LIKELY((n) < UV_MAX_P1) ? (IV)(UV) (n) \ 4363 : ((n) > 0 ? (IV)UV_MAX : 0 /* NaN */))) 4364 #define U_V(n) ((n) < 0.0 ? (UNLIKELY((n) < IV_MIN) ? (UV) IV_MIN : (UV)(IV) (n)) \ 4365 : (LIKELY((n) < UV_MAX_P1) ? (UV) (n) \ 4366 : ((n) > 0 ? UV_MAX : 0 /* NaN */))) 4367 #endif 4368 4369 #define U_S(what) ((U16)U_32(what)) 4370 #define U_I(what) ((unsigned int)U_32(what)) 4371 #define U_L(what) U_32(what) 4372 4373 /* 4374 =for apidoc_section $integer 4375 =for apidoc Amn|IV|IV_MAX 4376 The largest signed integer that fits in an IV on this platform. 4377 4378 =for apidoc Amn|IV|IV_MIN 4379 The negative signed integer furthest away from 0 that fits in an IV on this 4380 platform. 4381 4382 =for apidoc Amn|UV|UV_MAX 4383 The largest unsigned integer that fits in a UV on this platform. 4384 4385 =for apidoc Amn|UV|UV_MIN 4386 The smallest unsigned integer that fits in a UV on this platform. It should 4387 equal zero. 4388 4389 =cut 4390 */ 4391 4392 #ifdef HAS_SIGNBIT 4393 # ifndef Perl_signbit 4394 # define Perl_signbit signbit 4395 # endif 4396 #endif 4397 4398 /* These do not care about the fractional part, only about the range. */ 4399 #define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX) 4400 #define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX) 4401 4402 /* Used with UV/IV arguments: */ 4403 /* XXXX: need to speed it up */ 4404 #define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv)) 4405 #define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv)) 4406 4407 #ifndef MAXSYSFD 4408 # define MAXSYSFD 2 4409 #endif 4410 4411 #ifndef __cplusplus 4412 #if !defined(WIN32) 4413 Uid_t getuid (void); 4414 Uid_t geteuid (void); 4415 Gid_t getgid (void); 4416 Gid_t getegid (void); 4417 #endif 4418 #endif 4419 4420 #ifndef Perl_debug_log 4421 # define Perl_debug_log PerlIO_stderr() 4422 #endif 4423 4424 #ifndef Perl_error_log 4425 # define Perl_error_log (PL_stderrgv \ 4426 && isGV(PL_stderrgv) \ 4427 && GvIOp(PL_stderrgv) \ 4428 && IoOFP(GvIOp(PL_stderrgv)) \ 4429 ? IoOFP(GvIOp(PL_stderrgv)) \ 4430 : PerlIO_stderr()) 4431 #endif 4432 4433 4434 #define DEBUG_p_FLAG 0x00000001 /* 1 */ 4435 #define DEBUG_s_FLAG 0x00000002 /* 2 */ 4436 #define DEBUG_l_FLAG 0x00000004 /* 4 */ 4437 #define DEBUG_t_FLAG 0x00000008 /* 8 */ 4438 #define DEBUG_o_FLAG 0x00000010 /* 16 */ 4439 #define DEBUG_c_FLAG 0x00000020 /* 32 */ 4440 #define DEBUG_P_FLAG 0x00000040 /* 64 */ 4441 #define DEBUG_m_FLAG 0x00000080 /* 128 */ 4442 #define DEBUG_f_FLAG 0x00000100 /* 256 */ 4443 #define DEBUG_r_FLAG 0x00000200 /* 512 */ 4444 #define DEBUG_x_FLAG 0x00000400 /* 1024 */ 4445 #define DEBUG_u_FLAG 0x00000800 /* 2048 */ 4446 /* U is reserved for Unofficial, exploratory hacking */ 4447 #define DEBUG_U_FLAG 0x00001000 /* 4096 */ 4448 #define DEBUG_h_FLAG 0x00002000 /* 8192 */ 4449 #define DEBUG_X_FLAG 0x00004000 /* 16384 */ 4450 #define DEBUG_D_FLAG 0x00008000 /* 32768 */ 4451 #define DEBUG_S_FLAG 0x00010000 /* 65536 */ 4452 #define DEBUG_T_FLAG 0x00020000 /* 131072 */ 4453 #define DEBUG_R_FLAG 0x00040000 /* 262144 */ 4454 #define DEBUG_J_FLAG 0x00080000 /* 524288 */ 4455 #define DEBUG_v_FLAG 0x00100000 /*1048576 */ 4456 #define DEBUG_C_FLAG 0x00200000 /*2097152 */ 4457 #define DEBUG_A_FLAG 0x00400000 /*4194304 */ 4458 #define DEBUG_q_FLAG 0x00800000 /*8388608 */ 4459 #define DEBUG_M_FLAG 0x01000000 /*16777216*/ 4460 #define DEBUG_B_FLAG 0x02000000 /*33554432*/ 4461 #define DEBUG_L_FLAG 0x04000000 /*67108864*/ 4462 #define DEBUG_i_FLAG 0x08000000 /*134217728*/ 4463 #define DEBUG_y_FLAG 0x10000000 /*268435456*/ 4464 #define DEBUG_MASK 0x1FFFEFFF /* mask of all the standard flags */ 4465 4466 #define DEBUG_DB_RECURSE_FLAG 0x40000000 4467 #define DEBUG_TOP_FLAG 0x80000000 /* -D was given --> PL_debug |= FLAG */ 4468 4469 /* Both flags have to be set */ 4470 # define DEBUG_BOTH_FLAGS_TEST_(flag1, flag2) \ 4471 UNLIKELY((PL_debug & ((flag1)|(flag2))) \ 4472 == ((flag1)|(flag2))) 4473 4474 # define DEBUG_p_TEST_ UNLIKELY(PL_debug & DEBUG_p_FLAG) 4475 # define DEBUG_s_TEST_ UNLIKELY(PL_debug & DEBUG_s_FLAG) 4476 # define DEBUG_l_TEST_ UNLIKELY(PL_debug & DEBUG_l_FLAG) 4477 # define DEBUG_t_TEST_ UNLIKELY(PL_debug & DEBUG_t_FLAG) 4478 # define DEBUG_o_TEST_ UNLIKELY(PL_debug & DEBUG_o_FLAG) 4479 # define DEBUG_c_TEST_ UNLIKELY(PL_debug & DEBUG_c_FLAG) 4480 # define DEBUG_P_TEST_ UNLIKELY(PL_debug & DEBUG_P_FLAG) 4481 # define DEBUG_m_TEST_ UNLIKELY(PL_debug & DEBUG_m_FLAG) 4482 # define DEBUG_f_TEST_ UNLIKELY(PL_debug & DEBUG_f_FLAG) 4483 # define DEBUG_r_TEST_ UNLIKELY(PL_debug & DEBUG_r_FLAG) 4484 # define DEBUG_x_TEST_ UNLIKELY(PL_debug & DEBUG_x_FLAG) 4485 # define DEBUG_u_TEST_ UNLIKELY(PL_debug & DEBUG_u_FLAG) 4486 # define DEBUG_U_TEST_ UNLIKELY(PL_debug & DEBUG_U_FLAG) 4487 # define DEBUG_h_TEST_ UNLIKELY(PL_debug & DEBUG_h_FLAG) 4488 # define DEBUG_X_TEST_ UNLIKELY(PL_debug & DEBUG_X_FLAG) 4489 # define DEBUG_D_TEST_ UNLIKELY(PL_debug & DEBUG_D_FLAG) 4490 # define DEBUG_S_TEST_ UNLIKELY(PL_debug & DEBUG_S_FLAG) 4491 # define DEBUG_T_TEST_ UNLIKELY(PL_debug & DEBUG_T_FLAG) 4492 # define DEBUG_R_TEST_ UNLIKELY(PL_debug & DEBUG_R_FLAG) 4493 # define DEBUG_J_TEST_ UNLIKELY(PL_debug & DEBUG_J_FLAG) 4494 # define DEBUG_v_TEST_ UNLIKELY(PL_debug & DEBUG_v_FLAG) 4495 # define DEBUG_C_TEST_ UNLIKELY(PL_debug & DEBUG_C_FLAG) 4496 # define DEBUG_A_TEST_ UNLIKELY(PL_debug & DEBUG_A_FLAG) 4497 # define DEBUG_q_TEST_ UNLIKELY(PL_debug & DEBUG_q_FLAG) 4498 # define DEBUG_M_TEST_ UNLIKELY(PL_debug & DEBUG_M_FLAG) 4499 # define DEBUG_B_TEST_ UNLIKELY(PL_debug & DEBUG_B_FLAG) 4500 # define DEBUG_L_TEST_ UNLIKELY(PL_debug & DEBUG_L_FLAG) 4501 # define DEBUG_i_TEST_ UNLIKELY(PL_debug & DEBUG_i_FLAG) 4502 # define DEBUG_y_TEST_ UNLIKELY(PL_debug & DEBUG_y_FLAG) 4503 # define DEBUG_Xv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_X_FLAG, DEBUG_v_FLAG) 4504 # define DEBUG_Uv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_U_FLAG, DEBUG_v_FLAG) 4505 # define DEBUG_Pv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_P_FLAG, DEBUG_v_FLAG) 4506 # define DEBUG_Lv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_L_FLAG, DEBUG_v_FLAG) 4507 # define DEBUG_yv_TEST_ DEBUG_BOTH_FLAGS_TEST_(DEBUG_y_FLAG, DEBUG_v_FLAG) 4508 4509 #ifdef DEBUGGING 4510 4511 # define DEBUG_p_TEST DEBUG_p_TEST_ 4512 # define DEBUG_s_TEST DEBUG_s_TEST_ 4513 # define DEBUG_l_TEST DEBUG_l_TEST_ 4514 # define DEBUG_t_TEST DEBUG_t_TEST_ 4515 # define DEBUG_o_TEST DEBUG_o_TEST_ 4516 # define DEBUG_c_TEST DEBUG_c_TEST_ 4517 # define DEBUG_P_TEST DEBUG_P_TEST_ 4518 # define DEBUG_m_TEST DEBUG_m_TEST_ 4519 # define DEBUG_f_TEST DEBUG_f_TEST_ 4520 # define DEBUG_r_TEST DEBUG_r_TEST_ 4521 # define DEBUG_x_TEST DEBUG_x_TEST_ 4522 # define DEBUG_u_TEST DEBUG_u_TEST_ 4523 # define DEBUG_U_TEST DEBUG_U_TEST_ 4524 # define DEBUG_h_TEST DEBUG_h_TEST_ 4525 # define DEBUG_X_TEST DEBUG_X_TEST_ 4526 # define DEBUG_D_TEST DEBUG_D_TEST_ 4527 # define DEBUG_S_TEST DEBUG_S_TEST_ 4528 # define DEBUG_T_TEST DEBUG_T_TEST_ 4529 # define DEBUG_R_TEST DEBUG_R_TEST_ 4530 # define DEBUG_J_TEST DEBUG_J_TEST_ 4531 # define DEBUG_v_TEST DEBUG_v_TEST_ 4532 # define DEBUG_C_TEST DEBUG_C_TEST_ 4533 # define DEBUG_A_TEST DEBUG_A_TEST_ 4534 # define DEBUG_q_TEST DEBUG_q_TEST_ 4535 # define DEBUG_M_TEST DEBUG_M_TEST_ 4536 # define DEBUG_B_TEST DEBUG_B_TEST_ 4537 # define DEBUG_L_TEST DEBUG_L_TEST_ 4538 # define DEBUG_i_TEST DEBUG_i_TEST_ 4539 # define DEBUG_y_TEST DEBUG_y_TEST_ 4540 # define DEBUG_Xv_TEST DEBUG_Xv_TEST_ 4541 # define DEBUG_Uv_TEST DEBUG_Uv_TEST_ 4542 # define DEBUG_Pv_TEST DEBUG_Pv_TEST_ 4543 # define DEBUG_Lv_TEST DEBUG_Lv_TEST_ 4544 # define DEBUG_yv_TEST DEBUG_yv_TEST_ 4545 4546 # define PERL_DEB(a) a 4547 # define PERL_DEB2(a,b) a 4548 # define PERL_DEBUG(a) if (PL_debug) a 4549 # define DEBUG_p(a) if (DEBUG_p_TEST) a 4550 # define DEBUG_s(a) if (DEBUG_s_TEST) a 4551 # define DEBUG_l(a) if (DEBUG_l_TEST) a 4552 # define DEBUG_t(a) if (DEBUG_t_TEST) a 4553 # define DEBUG_o(a) if (DEBUG_o_TEST) a 4554 # define DEBUG_c(a) if (DEBUG_c_TEST) a 4555 # define DEBUG_P(a) if (DEBUG_P_TEST) a 4556 4557 /* Temporarily turn off memory debugging in case the a 4558 * does memory allocation, either directly or indirectly. */ 4559 # define DEBUG_m(a) \ 4560 STMT_START { \ 4561 if (PERL_GET_INTERP) { \ 4562 dTHX; \ 4563 if (DEBUG_m_TEST) { \ 4564 PL_debug &= ~DEBUG_m_FLAG; \ 4565 a; \ 4566 PL_debug |= DEBUG_m_FLAG; \ 4567 } \ 4568 } \ 4569 } STMT_END 4570 4571 /* These allow you to customize your debugging output for specialized, 4572 * generally temporary ad-hoc purposes. For example, if you need 'errno' 4573 * preserved, you can add definitions to these macros (either in this file for 4574 * the whole program, or before the #include "perl.h" in a particular .c file 4575 * you're trying to debug) and recompile: 4576 * 4577 * #define DEBUG_PRE_STMTS dSAVE_ERRNO; 4578 * #define DEBUG_POST_STMTS RESTORE_ERRNO; 4579 * 4580 * Other potential things include displaying timestamps, location information, 4581 * which thread, etc. Heres an example with both errno and location info: 4582 * 4583 * #define DEBUG_PRE_STMTS dSAVE_ERRNO; \ 4584 * PerlIO_printf(Perl_debug_log, "%s:%d: ", __FILE__, __LINE__); 4585 * #define DEBUG_POST RESTORE_ERRNO; 4586 * 4587 * All DEBUG statements in the compiled scope will be have these extra 4588 * statements compiled in; they will be executed only for the DEBUG statements 4589 * whose flags are turned on. 4590 */ 4591 #ifndef DEBUG_PRE_STMTS 4592 # define DEBUG_PRE_STMTS 4593 #endif 4594 #ifndef DEBUG_POST_STMTS 4595 # define DEBUG_POST_STMTS 4596 #endif 4597 4598 # define DEBUG__(t, a) \ 4599 STMT_START { \ 4600 if (t) STMT_START { \ 4601 DEBUG_PRE_STMTS a; DEBUG_POST_STMTS \ 4602 } STMT_END; \ 4603 } STMT_END 4604 4605 # define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a) 4606 4607 /* For re_comp.c, re_exec.c, assume -Dr has been specified */ 4608 # ifdef PERL_EXT_RE_BUILD 4609 # define DEBUG_r(a) STMT_START { \ 4610 DEBUG_PRE_STMTS a; DEBUG_POST_STMTS \ 4611 } STMT_END; 4612 # else 4613 # define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a) 4614 # endif /* PERL_EXT_RE_BUILD */ 4615 4616 # define DEBUG_x(a) DEBUG__(DEBUG_x_TEST, a) 4617 # define DEBUG_u(a) DEBUG__(DEBUG_u_TEST, a) 4618 # define DEBUG_U(a) DEBUG__(DEBUG_U_TEST, a) 4619 # define DEBUG_X(a) DEBUG__(DEBUG_X_TEST, a) 4620 # define DEBUG_D(a) DEBUG__(DEBUG_D_TEST, a) 4621 # define DEBUG_Xv(a) DEBUG__(DEBUG_Xv_TEST, a) 4622 # define DEBUG_Uv(a) DEBUG__(DEBUG_Uv_TEST, a) 4623 # define DEBUG_Pv(a) DEBUG__(DEBUG_Pv_TEST, a) 4624 # define DEBUG_Lv(a) DEBUG__(DEBUG_Lv_TEST, a) 4625 # define DEBUG_yv(a) DEBUG__(DEBUG_yv_TEST, a) 4626 4627 # define DEBUG_S(a) DEBUG__(DEBUG_S_TEST, a) 4628 # define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a) 4629 # define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a) 4630 # define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a) 4631 # define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a) 4632 # define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a) 4633 # define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a) 4634 # define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a) 4635 # define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a) 4636 # define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a) 4637 # define DEBUG_i(a) DEBUG__(DEBUG_i_TEST, a) 4638 # define DEBUG_y(a) DEBUG__(DEBUG_y_TEST, a) 4639 4640 #else /* ! DEBUGGING below */ 4641 4642 # define DEBUG_p_TEST (0) 4643 # define DEBUG_s_TEST (0) 4644 # define DEBUG_l_TEST (0) 4645 # define DEBUG_t_TEST (0) 4646 # define DEBUG_o_TEST (0) 4647 # define DEBUG_c_TEST (0) 4648 # define DEBUG_P_TEST (0) 4649 # define DEBUG_m_TEST (0) 4650 # define DEBUG_f_TEST (0) 4651 # define DEBUG_r_TEST (0) 4652 # define DEBUG_x_TEST (0) 4653 # define DEBUG_u_TEST (0) 4654 # define DEBUG_U_TEST (0) 4655 # define DEBUG_h_TEST (0) 4656 # define DEBUG_X_TEST (0) 4657 # define DEBUG_D_TEST (0) 4658 # define DEBUG_S_TEST (0) 4659 # define DEBUG_T_TEST (0) 4660 # define DEBUG_R_TEST (0) 4661 # define DEBUG_J_TEST (0) 4662 # define DEBUG_v_TEST (0) 4663 # define DEBUG_C_TEST (0) 4664 # define DEBUG_A_TEST (0) 4665 # define DEBUG_q_TEST (0) 4666 # define DEBUG_M_TEST (0) 4667 # define DEBUG_B_TEST (0) 4668 # define DEBUG_L_TEST (0) 4669 # define DEBUG_i_TEST (0) 4670 # define DEBUG_y_TEST (0) 4671 # define DEBUG_Xv_TEST (0) 4672 # define DEBUG_Uv_TEST (0) 4673 # define DEBUG_Pv_TEST (0) 4674 # define DEBUG_Lv_TEST (0) 4675 # define DEBUG_yv_TEST (0) 4676 4677 # define PERL_DEB(a) 4678 # define PERL_DEB2(a,b) b 4679 # define PERL_DEBUG(a) 4680 # define DEBUG_p(a) 4681 # define DEBUG_s(a) 4682 # define DEBUG_l(a) 4683 # define DEBUG_t(a) 4684 # define DEBUG_o(a) 4685 # define DEBUG_c(a) 4686 # define DEBUG_P(a) 4687 # define DEBUG_m(a) 4688 # define DEBUG_f(a) 4689 # define DEBUG_r(a) 4690 # define DEBUG_x(a) 4691 # define DEBUG_u(a) 4692 # define DEBUG_U(a) 4693 # define DEBUG_X(a) 4694 # define DEBUG_D(a) 4695 # define DEBUG_S(a) 4696 # define DEBUG_T(a) 4697 # define DEBUG_R(a) 4698 # define DEBUG_v(a) 4699 # define DEBUG_C(a) 4700 # define DEBUG_A(a) 4701 # define DEBUG_q(a) 4702 # define DEBUG_M(a) 4703 # define DEBUG_B(a) 4704 # define DEBUG_L(a) 4705 # define DEBUG_i(a) 4706 # define DEBUG_y(a) 4707 # define DEBUG_Xv(a) 4708 # define DEBUG_Uv(a) 4709 # define DEBUG_Pv(a) 4710 # define DEBUG_Lv(a) 4711 # define DEBUG_yv(a) 4712 #endif /* DEBUGGING */ 4713 4714 4715 #define DEBUG_SCOPE(where) \ 4716 DEBUG_l( \ 4717 Perl_deb(aTHX_ "%s scope %ld (savestack=%ld) at %s:%d\n", \ 4718 where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \ 4719 __FILE__, __LINE__)); 4720 4721 /* Keep the old croak based assert for those who want it, and as a fallback if 4722 the platform is so heretically non-ANSI that it can't assert. */ 4723 4724 #define Perl_assert(what) PERL_DEB2( \ 4725 ((what) ? ((void) 0) : \ 4726 (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ 4727 "\", line %d", STRINGIFY(what), __LINE__), \ 4728 (void) 0)), ((void)0)) 4729 4730 /* assert() gets defined if DEBUGGING. 4731 * If no DEBUGGING, the <assert.h> has not been included. */ 4732 #ifndef assert 4733 # define assert(what) Perl_assert(what) 4734 #endif 4735 #ifdef DEBUGGING 4736 # define assert_(what) assert(what), 4737 #else 4738 # define assert_(what) 4739 #endif 4740 4741 struct ufuncs { 4742 I32 (*uf_val)(pTHX_ IV, SV*); 4743 I32 (*uf_set)(pTHX_ IV, SV*); 4744 IV uf_index; 4745 }; 4746 4747 /* In pre-5.7-Perls the PERL_MAGIC_uvar magic didn't get the thread context. 4748 * XS code wanting to be backward compatible can do something 4749 * like the following: 4750 4751 #ifndef PERL_MG_UFUNC 4752 #define PERL_MG_UFUNC(name,ix,sv) I32 name(IV ix, SV *sv) 4753 #endif 4754 4755 static PERL_MG_UFUNC(foo_get, index, val) 4756 { 4757 sv_setsv(val, ...); 4758 return TRUE; 4759 } 4760 4761 -- Doug MacEachern 4762 4763 */ 4764 4765 #ifndef PERL_MG_UFUNC 4766 #define PERL_MG_UFUNC(name,ix,sv) I32 name(pTHX_ IV ix, SV *sv) 4767 #endif 4768 4769 #include <math.h> 4770 #ifdef __VMS 4771 /* isfinite and others are here rather than in math.h as C99 stipulates */ 4772 # include <fp.h> 4773 #endif 4774 4775 #ifndef __cplusplus 4776 # if !defined(WIN32) && !defined(VMS) 4777 #ifndef crypt 4778 char *crypt (const char*, const char*); 4779 #endif 4780 # endif /* !WIN32 */ 4781 # ifndef WIN32 4782 # ifndef getlogin 4783 char *getlogin (void); 4784 # endif 4785 # endif /* !WIN32 */ 4786 #endif /* !__cplusplus */ 4787 4788 /* Fixme on VMS. This needs to be a run-time, not build time options */ 4789 /* Also rename() is affected by this */ 4790 #ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */ 4791 #define UNLINK unlnk 4792 I32 unlnk (pTHX_ const char*); 4793 #else 4794 #define UNLINK PerlLIO_unlink 4795 #endif 4796 4797 /* some versions of glibc are missing the setresuid() proto */ 4798 #if defined(HAS_SETRESUID) && !defined(HAS_SETRESUID_PROTO) 4799 int setresuid(uid_t ruid, uid_t euid, uid_t suid); 4800 #endif 4801 /* some versions of glibc are missing the setresgid() proto */ 4802 #if defined(HAS_SETRESGID) && !defined(HAS_SETRESGID_PROTO) 4803 int setresgid(gid_t rgid, gid_t egid, gid_t sgid); 4804 #endif 4805 4806 #ifndef HAS_SETREUID 4807 # ifdef HAS_SETRESUID 4808 # define setreuid(r,e) setresuid(r,e,(Uid_t)-1) 4809 # define HAS_SETREUID 4810 # endif 4811 #endif 4812 #ifndef HAS_SETREGID 4813 # ifdef HAS_SETRESGID 4814 # define setregid(r,e) setresgid(r,e,(Gid_t)-1) 4815 # define HAS_SETREGID 4816 # endif 4817 #endif 4818 4819 /* Sighandler_t defined in iperlsys.h */ 4820 4821 #ifdef HAS_SIGACTION 4822 typedef struct sigaction Sigsave_t; 4823 #else 4824 typedef Sighandler_t Sigsave_t; 4825 #endif 4826 4827 #define SCAN_DEF 0 4828 #define SCAN_TR 1 4829 #define SCAN_REPL 2 4830 4831 #ifdef DEBUGGING 4832 # ifndef register 4833 # define register 4834 # endif 4835 # define RUNOPS_DEFAULT Perl_runops_debug 4836 #else 4837 # define RUNOPS_DEFAULT Perl_runops_standard 4838 #endif 4839 4840 #if defined(USE_PERLIO) 4841 EXTERN_C void PerlIO_teardown(void); 4842 # ifdef USE_ITHREADS 4843 # define PERLIO_INIT MUTEX_INIT(&PL_perlio_mutex) 4844 # define PERLIO_TERM \ 4845 STMT_START { \ 4846 PerlIO_teardown(); \ 4847 MUTEX_DESTROY(&PL_perlio_mutex);\ 4848 } STMT_END 4849 # else 4850 # define PERLIO_INIT 4851 # define PERLIO_TERM PerlIO_teardown() 4852 # endif 4853 #else 4854 # define PERLIO_INIT 4855 # define PERLIO_TERM 4856 #endif 4857 4858 #ifdef MYMALLOC 4859 # ifdef MUTEX_INIT_CALLS_MALLOC 4860 # define MALLOC_INIT \ 4861 STMT_START { \ 4862 PL_malloc_mutex = NULL; \ 4863 MUTEX_INIT(&PL_malloc_mutex); \ 4864 } STMT_END 4865 # define MALLOC_TERM \ 4866 STMT_START { \ 4867 perl_mutex tmp = PL_malloc_mutex; \ 4868 PL_malloc_mutex = NULL; \ 4869 MUTEX_DESTROY(&tmp); \ 4870 } STMT_END 4871 # else 4872 # define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex) 4873 # define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex) 4874 # endif 4875 #else 4876 # define MALLOC_INIT 4877 # define MALLOC_TERM 4878 #endif 4879 4880 #if defined(MULTIPLICITY) 4881 4882 struct perl_memory_debug_header; 4883 struct perl_memory_debug_header { 4884 tTHX interpreter; 4885 # if defined(PERL_POISON) || defined(PERL_DEBUG_READONLY_COW) 4886 MEM_SIZE size; 4887 # endif 4888 struct perl_memory_debug_header *prev; 4889 struct perl_memory_debug_header *next; 4890 # ifdef PERL_DEBUG_READONLY_COW 4891 bool readonly; 4892 # endif 4893 }; 4894 4895 #elif defined(PERL_DEBUG_READONLY_COW) 4896 4897 struct perl_memory_debug_header; 4898 struct perl_memory_debug_header { 4899 MEM_SIZE size; 4900 }; 4901 4902 #endif 4903 4904 #if defined (PERL_TRACK_MEMPOOL) || defined (PERL_DEBUG_READONLY_COW) 4905 4906 # define PERL_MEMORY_DEBUG_HEADER_SIZE \ 4907 (sizeof(struct perl_memory_debug_header) + \ 4908 (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \ 4909 %MEM_ALIGNBYTES) % MEM_ALIGNBYTES) 4910 4911 #else 4912 # define PERL_MEMORY_DEBUG_HEADER_SIZE 0 4913 #endif 4914 4915 #ifdef PERL_TRACK_MEMPOOL 4916 # ifdef PERL_DEBUG_READONLY_COW 4917 # define INIT_TRACK_MEMPOOL(header, interp) \ 4918 STMT_START { \ 4919 (header).interpreter = (interp); \ 4920 (header).prev = (header).next = &(header); \ 4921 (header).readonly = 0; \ 4922 } STMT_END 4923 # else 4924 # define INIT_TRACK_MEMPOOL(header, interp) \ 4925 STMT_START { \ 4926 (header).interpreter = (interp); \ 4927 (header).prev = (header).next = &(header); \ 4928 } STMT_END 4929 # endif 4930 # else 4931 # define INIT_TRACK_MEMPOOL(header, interp) 4932 #endif 4933 4934 #ifdef I_MALLOCMALLOC 4935 /* Needed for malloc_size(), malloc_good_size() on some systems */ 4936 # include <malloc/malloc.h> 4937 #endif 4938 4939 #ifdef MYMALLOC 4940 # define Perl_safesysmalloc_size(where) Perl_malloced_size(where) 4941 #else 4942 # if defined(HAS_MALLOC_SIZE) && !defined(PERL_DEBUG_READONLY_COW) 4943 # ifdef PERL_TRACK_MEMPOOL 4944 # define Perl_safesysmalloc_size(where) \ 4945 (malloc_size(((char *)(where)) - PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) 4946 # else 4947 # define Perl_safesysmalloc_size(where) malloc_size(where) 4948 # endif 4949 # endif 4950 # ifdef HAS_MALLOC_GOOD_SIZE 4951 # ifdef PERL_TRACK_MEMPOOL 4952 # define Perl_malloc_good_size(how_much) \ 4953 (malloc_good_size((how_much) + PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) 4954 # else 4955 # define Perl_malloc_good_size(how_much) malloc_good_size(how_much) 4956 # endif 4957 # else 4958 /* Having this as the identity operation makes some code simpler. */ 4959 # define Perl_malloc_good_size(how_much) (how_much) 4960 # endif 4961 #endif 4962 4963 typedef int (*runops_proc_t)(pTHX); 4964 typedef void (*share_proc_t) (pTHX_ SV *sv); 4965 typedef int (*thrhook_proc_t) (pTHX); 4966 typedef OP* (*PPADDR_t[]) (pTHX); 4967 typedef bool (*destroyable_proc_t) (pTHX_ SV *sv); 4968 typedef void (*despatch_signals_proc_t) (pTHX); 4969 4970 #if defined(__DYNAMIC__) && defined(PERL_DARWIN) && defined(PERL_CORE) 4971 # include <crt_externs.h> /* for the env array */ 4972 # define environ (*_NSGetEnviron()) 4973 #elif defined(USE_ENVIRON_ARRAY) && !defined(environ) 4974 /* VMS and some other platforms don't use the environ array */ 4975 EXTERN_C char **environ; /* environment variables supplied via exec */ 4976 #endif 4977 4978 #define PERL_PATCHLEVEL_H_IMPLICIT 4979 #include "patchlevel.h" 4980 #undef PERL_PATCHLEVEL_H_IMPLICIT 4981 4982 #define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \ 4983 STRINGIFY(PERL_VERSION) "." \ 4984 STRINGIFY(PERL_SUBVERSION) 4985 4986 #define PERL_API_VERSION_STRING STRINGIFY(PERL_API_REVISION) "." \ 4987 STRINGIFY(PERL_API_VERSION) "." \ 4988 STRINGIFY(PERL_API_SUBVERSION) 4989 4990 START_EXTERN_C 4991 4992 /* handy constants */ 4993 EXTCONST char PL_warn_uninit[] 4994 INIT("Use of uninitialized value%s%s%s"); 4995 EXTCONST char PL_warn_uninit_sv[] 4996 INIT("Use of uninitialized value%" SVf "%s%s"); 4997 EXTCONST char PL_warn_nosemi[] 4998 INIT("Semicolon seems to be missing"); 4999 EXTCONST char PL_warn_reserved[] 5000 INIT("Unquoted string \"%s\" may clash with future reserved word"); 5001 EXTCONST char PL_warn_nl[] 5002 INIT("Unsuccessful %s on filename containing newline"); 5003 EXTCONST char PL_no_wrongref[] 5004 INIT("Can't use %s ref as %s ref"); 5005 /* The core no longer needs this here. If you require the string constant, 5006 please inline a copy into your own code. */ 5007 EXTCONST char PL_no_symref[] __attribute__deprecated__ 5008 INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"); 5009 EXTCONST char PL_no_symref_sv[] 5010 INIT("Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use"); 5011 5012 EXTCONST char PL_no_usym[] 5013 INIT("Can't use an undefined value as %s reference"); 5014 EXTCONST char PL_no_aelem[] 5015 INIT("Modification of non-creatable array value attempted, subscript %d"); 5016 EXTCONST char PL_no_helem_sv[] 5017 INIT("Modification of non-creatable hash value attempted, subscript \"%" SVf "\""); 5018 EXTCONST char PL_no_modify[] 5019 INIT("Modification of a read-only value attempted"); 5020 EXTCONST char PL_no_mem[sizeof("Out of memory!\n")] 5021 INIT("Out of memory!\n"); 5022 EXTCONST char PL_no_security[] 5023 INIT("Insecure dependency in %s%s"); 5024 EXTCONST char PL_no_sock_func[] 5025 INIT("Unsupported socket function \"%s\" called"); 5026 EXTCONST char PL_no_dir_func[] 5027 INIT("Unsupported directory function \"%s\" called"); 5028 EXTCONST char PL_no_func[] 5029 INIT("The %s function is unimplemented"); 5030 EXTCONST char PL_no_myglob[] 5031 INIT("\"%s\" %s %s can't be in a package"); 5032 EXTCONST char PL_no_localize_ref[] 5033 INIT("Can't localize through a reference"); 5034 EXTCONST char PL_memory_wrap[] 5035 INIT("panic: memory wrap"); 5036 EXTCONST char PL_extended_cp_format[] 5037 INIT("Code point 0x%" UVXf " is not Unicode, requires a Perl extension," 5038 " and so is not portable"); 5039 EXTCONST char PL_Yes[] 5040 INIT("1"); 5041 EXTCONST char PL_No[] 5042 INIT(""); 5043 EXTCONST char PL_Zero[] 5044 INIT("0"); 5045 5046 /* 5047 =for apidoc_section $numeric 5048 =for apidoc AmTuU|const char *|PL_hexdigit|U8 value 5049 5050 This array, indexed by an integer, converts that value into the character that 5051 represents it. For example, if the input is 8, the return will be a string 5052 whose first character is '8'. What is actually returned is a pointer into a 5053 string. All you are interested in is the first character of that string. To 5054 get uppercase letters (for the values 10..15), add 16 to the index. Hence, 5055 C<PL_hexdigit[11]> is C<'b'>, and C<PL_hexdigit[11+16]> is C<'B'>. Adding 16 5056 to an index whose representation is '0'..'9' yields the same as not adding 16. 5057 Indices outside the range 0..31 result in (bad) undedefined behavior. 5058 5059 =cut 5060 */ 5061 EXTCONST char PL_hexdigit[] 5062 INIT("0123456789abcdef0123456789ABCDEF"); 5063 5064 EXTCONST STRLEN PL_WARN_ALL 5065 INIT(0); 5066 EXTCONST STRLEN PL_WARN_NONE 5067 INIT(0); 5068 5069 /* This is constant on most architectures, a global on OS/2 */ 5070 #ifndef OS2 5071 EXTCONST char PL_sh_path[] 5072 INIT(SH_PATH); /* full path of shell */ 5073 #endif 5074 5075 #ifdef CSH 5076 EXTCONST char PL_cshname[] 5077 INIT(CSH); 5078 # define PL_cshlen (sizeof(CSH "") - 1) 5079 #endif 5080 5081 /* These are baked at compile time into any shared perl library. 5082 In future releases this will allow us in main() to sanity test the 5083 library we're linking against. */ 5084 5085 EXTCONST U8 PL_revision 5086 INIT(PERL_REVISION); 5087 EXTCONST U8 PL_version 5088 INIT(PERL_VERSION); 5089 EXTCONST U8 PL_subversion 5090 INIT(PERL_SUBVERSION); 5091 5092 EXTCONST char PL_uuemap[65] 5093 INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"); 5094 5095 /* a special string address whose value is "isa", but which perl knows 5096 * to treat as if it were really "DOES" when printing the method name in 5097 * the "Can't call method '%s'" error message */ 5098 EXTCONST char PL_isa_DOES[] 5099 INIT("isa"); 5100 5101 #ifdef DOINIT 5102 EXTCONST char PL_uudmap[256] = 5103 # ifdef PERL_MICRO 5104 # include "uuudmap.h" 5105 # else 5106 # include "uudmap.h" 5107 # endif 5108 ; 5109 EXTCONST char PL_bitcount[256] = 5110 # ifdef PERL_MICRO 5111 # include "ubitcount.h" 5112 #else 5113 # include "bitcount.h" 5114 # endif 5115 ; 5116 EXTCONST char* const PL_sig_name[] = { SIG_NAME }; 5117 EXTCONST int PL_sig_num[] = { SIG_NUM }; 5118 #else 5119 EXTCONST char PL_uudmap[256]; 5120 EXTCONST char PL_bitcount[256]; 5121 EXTCONST char* const PL_sig_name[]; 5122 EXTCONST int PL_sig_num[]; 5123 #endif 5124 5125 /* fast conversion and case folding tables. The folding tables complement the 5126 * fold, so that 'a' maps to 'A' and 'A' maps to 'a', ignoring more complicated 5127 * folds such as outside the range or to multiple characters. */ 5128 5129 #ifdef DOINIT 5130 # ifndef EBCDIC 5131 5132 /* The EBCDIC fold table depends on the code page, and hence is found in 5133 * ebcdic_tables.h */ 5134 5135 EXTCONST unsigned char PL_fold[] = { 5136 0, 1, 2, 3, 4, 5, 6, 7, 5137 8, 9, 10, 11, 12, 13, 14, 15, 5138 16, 17, 18, 19, 20, 21, 22, 23, 5139 24, 25, 26, 27, 28, 29, 30, 31, 5140 32, 33, 34, 35, 36, 37, 38, 39, 5141 40, 41, 42, 43, 44, 45, 46, 47, 5142 48, 49, 50, 51, 52, 53, 54, 55, 5143 56, 57, 58, 59, 60, 61, 62, 63, 5144 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 5145 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 5146 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 5147 'x', 'y', 'z', 91, 92, 93, 94, 95, 5148 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 5149 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 5150 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 5151 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 5152 128, 129, 130, 131, 132, 133, 134, 135, 5153 136, 137, 138, 139, 140, 141, 142, 143, 5154 144, 145, 146, 147, 148, 149, 150, 151, 5155 152, 153, 154, 155, 156, 157, 158, 159, 5156 160, 161, 162, 163, 164, 165, 166, 167, 5157 168, 169, 170, 171, 172, 173, 174, 175, 5158 176, 177, 178, 179, 180, 181, 182, 183, 5159 184, 185, 186, 187, 188, 189, 190, 191, 5160 192, 193, 194, 195, 196, 197, 198, 199, 5161 200, 201, 202, 203, 204, 205, 206, 207, 5162 208, 209, 210, 211, 212, 213, 214, 215, 5163 216, 217, 218, 219, 220, 221, 222, 223, 5164 224, 225, 226, 227, 228, 229, 230, 231, 5165 232, 233, 234, 235, 236, 237, 238, 239, 5166 240, 241, 242, 243, 244, 245, 246, 247, 5167 248, 249, 250, 251, 252, 253, 254, 255 5168 }; 5169 5170 EXT unsigned char PL_fold_locale[] = { /* Unfortunately not EXTCONST. */ 5171 0, 1, 2, 3, 4, 5, 6, 7, 5172 8, 9, 10, 11, 12, 13, 14, 15, 5173 16, 17, 18, 19, 20, 21, 22, 23, 5174 24, 25, 26, 27, 28, 29, 30, 31, 5175 32, 33, 34, 35, 36, 37, 38, 39, 5176 40, 41, 42, 43, 44, 45, 46, 47, 5177 48, 49, 50, 51, 52, 53, 54, 55, 5178 56, 57, 58, 59, 60, 61, 62, 63, 5179 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 5180 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 5181 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 5182 'x', 'y', 'z', 91, 92, 93, 94, 95, 5183 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 5184 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 5185 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 5186 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 5187 128, 129, 130, 131, 132, 133, 134, 135, 5188 136, 137, 138, 139, 140, 141, 142, 143, 5189 144, 145, 146, 147, 148, 149, 150, 151, 5190 152, 153, 154, 155, 156, 157, 158, 159, 5191 160, 161, 162, 163, 164, 165, 166, 167, 5192 168, 169, 170, 171, 172, 173, 174, 175, 5193 176, 177, 178, 179, 180, 181, 182, 183, 5194 184, 185, 186, 187, 188, 189, 190, 191, 5195 192, 193, 194, 195, 196, 197, 198, 199, 5196 200, 201, 202, 203, 204, 205, 206, 207, 5197 208, 209, 210, 211, 212, 213, 214, 215, 5198 216, 217, 218, 219, 220, 221, 222, 223, 5199 224, 225, 226, 227, 228, 229, 230, 231, 5200 232, 233, 234, 235, 236, 237, 238, 239, 5201 240, 241, 242, 243, 244, 245, 246, 247, 5202 248, 249, 250, 251, 252, 253, 254, 255 5203 }; 5204 5205 EXTCONST unsigned char PL_fold_latin1[] = { 5206 /* Full latin1 complement folding, except for three problematic code points: 5207 * Micro sign (181 = 0xB5) and y with diearesis (255 = 0xFF) have their 5208 * fold complements outside the Latin1 range, so can't match something 5209 * that isn't in utf8. 5210 * German lower case sharp s (223 = 0xDF) folds to two characters, 'ss', 5211 * not one, so can't be represented in this table. 5212 * 5213 * All have to be specially handled */ 5214 0, 1, 2, 3, 4, 5, 6, 7, 5215 8, 9, 10, 11, 12, 13, 14, 15, 5216 16, 17, 18, 19, 20, 21, 22, 23, 5217 24, 25, 26, 27, 28, 29, 30, 31, 5218 32, 33, 34, 35, 36, 37, 38, 39, 5219 40, 41, 42, 43, 44, 45, 46, 47, 5220 48, 49, 50, 51, 52, 53, 54, 55, 5221 56, 57, 58, 59, 60, 61, 62, 63, 5222 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 5223 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 5224 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 5225 'x', 'y', 'z', 91, 92, 93, 94, 95, 5226 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 5227 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 5228 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 5229 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 5230 128, 129, 130, 131, 132, 133, 134, 135, 5231 136, 137, 138, 139, 140, 141, 142, 143, 5232 144, 145, 146, 147, 148, 149, 150, 151, 5233 152, 153, 154, 155, 156, 157, 158, 159, 5234 160, 161, 162, 163, 164, 165, 166, 167, 5235 168, 169, 170, 171, 172, 173, 174, 175, 5236 176, 177, 178, 179, 180, 181 /*micro */, 182, 183, 5237 184, 185, 186, 187, 188, 189, 190, 191, 5238 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, 5239 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, 5240 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, 5241 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223 /* ss */, 5242 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, 5243 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, 5244 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, 5245 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 5246 255 /* y with diaeresis */ 5247 }; 5248 5249 /* If these tables are accessed through ebcdic, the access will be converted to 5250 * latin1 first */ 5251 EXTCONST unsigned char PL_latin1_lc[] = { /* lowercasing */ 5252 0, 1, 2, 3, 4, 5, 6, 7, 5253 8, 9, 10, 11, 12, 13, 14, 15, 5254 16, 17, 18, 19, 20, 21, 22, 23, 5255 24, 25, 26, 27, 28, 29, 30, 31, 5256 32, 33, 34, 35, 36, 37, 38, 39, 5257 40, 41, 42, 43, 44, 45, 46, 47, 5258 48, 49, 50, 51, 52, 53, 54, 55, 5259 56, 57, 58, 59, 60, 61, 62, 63, 5260 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 5261 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 5262 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 5263 'x', 'y', 'z', 91, 92, 93, 94, 95, 5264 96, 97, 98, 99, 100, 101, 102, 103, 5265 104, 105, 106, 107, 108, 109, 110, 111, 5266 112, 113, 114, 115, 116, 117, 118, 119, 5267 120, 121, 122, 123, 124, 125, 126, 127, 5268 128, 129, 130, 131, 132, 133, 134, 135, 5269 136, 137, 138, 139, 140, 141, 142, 143, 5270 144, 145, 146, 147, 148, 149, 150, 151, 5271 152, 153, 154, 155, 156, 157, 158, 159, 5272 160, 161, 162, 163, 164, 165, 166, 167, 5273 168, 169, 170, 171, 172, 173, 174, 175, 5274 176, 177, 178, 179, 180, 181, 182, 183, 5275 184, 185, 186, 187, 188, 189, 190, 191, 5276 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, 5277 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, 5278 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, 5279 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223, 5280 224, 225, 226, 227, 228, 229, 230, 231, 5281 232, 233, 234, 235, 236, 237, 238, 239, 5282 240, 241, 242, 243, 244, 245, 246, 247, 5283 248, 249, 250, 251, 252, 253, 254, 255 5284 }; 5285 5286 /* upper and title case of latin1 characters, modified so that the three tricky 5287 * ones are mapped to 255 (which is one of the three) */ 5288 EXTCONST unsigned char PL_mod_latin1_uc[] = { 5289 0, 1, 2, 3, 4, 5, 6, 7, 5290 8, 9, 10, 11, 12, 13, 14, 15, 5291 16, 17, 18, 19, 20, 21, 22, 23, 5292 24, 25, 26, 27, 28, 29, 30, 31, 5293 32, 33, 34, 35, 36, 37, 38, 39, 5294 40, 41, 42, 43, 44, 45, 46, 47, 5295 48, 49, 50, 51, 52, 53, 54, 55, 5296 56, 57, 58, 59, 60, 61, 62, 63, 5297 64, 65, 66, 67, 68, 69, 70, 71, 5298 72, 73, 74, 75, 76, 77, 78, 79, 5299 80, 81, 82, 83, 84, 85, 86, 87, 5300 88, 89, 90, 91, 92, 93, 94, 95, 5301 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 5302 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 5303 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 5304 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 5305 128, 129, 130, 131, 132, 133, 134, 135, 5306 136, 137, 138, 139, 140, 141, 142, 143, 5307 144, 145, 146, 147, 148, 149, 150, 151, 5308 152, 153, 154, 155, 156, 157, 158, 159, 5309 160, 161, 162, 163, 164, 165, 166, 167, 5310 168, 169, 170, 171, 172, 173, 174, 175, 5311 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183, 5312 184, 185, 186, 187, 188, 189, 190, 191, 5313 192, 193, 194, 195, 196, 197, 198, 199, 5314 200, 201, 202, 203, 204, 205, 206, 207, 5315 208, 209, 210, 211, 212, 213, 214, 215, 5316 216, 217, 218, 219, 220, 221, 222, 5317 # if UNICODE_MAJOR_VERSION > 2 \ 5318 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ 5319 && UNICODE_DOT_DOT_VERSION >= 8) 5320 255 /*sharp s*/, 5321 # else /* uc(sharp s) is 'sharp s' itself in early unicode */ 5322 223, 5323 # endif 5324 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, 5325 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, 5326 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, 5327 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255 5328 }; 5329 # endif /* !EBCDIC, but still in DOINIT */ 5330 #else /* ! DOINIT */ 5331 # ifndef EBCDIC 5332 EXTCONST unsigned char PL_fold[]; 5333 EXTCONST unsigned char PL_fold_latin1[]; 5334 EXTCONST unsigned char PL_mod_latin1_uc[]; 5335 EXTCONST unsigned char PL_latin1_lc[]; 5336 EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */ 5337 # endif 5338 #endif 5339 5340 /* Although only used for debugging, these constants must be available in 5341 * non-debugging builds too, since they're used in ext/re/re_exec.c, 5342 * which has DEBUGGING enabled always */ 5343 #ifdef DOINIT 5344 EXTCONST char* const PL_block_type[] = { 5345 "NULL", 5346 "WHEN", 5347 "BLOCK", 5348 "GIVEN", 5349 "LOOP_ARY", 5350 "LOOP_LAZYSV", 5351 "LOOP_LAZYIV", 5352 "LOOP_LIST", 5353 "LOOP_PLAIN", 5354 "SUB", 5355 "FORMAT", 5356 "EVAL", 5357 "SUBST", 5358 "DEFER" 5359 }; 5360 #else 5361 EXTCONST char* PL_block_type[]; 5362 #endif 5363 5364 /* These are all the compile time options that affect binary compatibility. 5365 Other compile time options that are binary compatible are in perl.c 5366 (in S_Internals_V()). Both are combined for the output of perl -V 5367 However, this string will be embedded in any shared perl library, which will 5368 allow us add a comparison check in perlmain.c in the near future. */ 5369 #ifdef DOINIT 5370 EXTCONST char PL_bincompat_options[] = 5371 # ifdef DEBUG_LEAKING_SCALARS 5372 " DEBUG_LEAKING_SCALARS" 5373 # endif 5374 # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 5375 " DEBUG_LEAKING_SCALARS_FORK_DUMP" 5376 # endif 5377 # ifdef HAS_TIMES 5378 " HAS_TIMES" 5379 # endif 5380 # ifdef HAVE_INTERP_INTERN 5381 " HAVE_INTERP_INTERN" 5382 # endif 5383 # ifdef MULTIPLICITY 5384 " MULTIPLICITY" 5385 # endif 5386 # ifdef MYMALLOC 5387 " MYMALLOC" 5388 # endif 5389 # ifdef PERLIO_LAYERS 5390 " PERLIO_LAYERS" 5391 # endif 5392 # ifdef PERL_DEBUG_READONLY_COW 5393 " PERL_DEBUG_READONLY_COW" 5394 # endif 5395 # ifdef PERL_DEBUG_READONLY_OPS 5396 " PERL_DEBUG_READONLY_OPS" 5397 # endif 5398 # ifdef PERL_IMPLICIT_SYS 5399 " PERL_IMPLICIT_SYS" 5400 # endif 5401 # ifdef PERL_MICRO 5402 " PERL_MICRO" 5403 # endif 5404 # ifdef PERL_POISON 5405 " PERL_POISON" 5406 # endif 5407 # ifdef PERL_SAWAMPERSAND 5408 " PERL_SAWAMPERSAND" 5409 # endif 5410 # ifdef PERL_TRACK_MEMPOOL 5411 " PERL_TRACK_MEMPOOL" 5412 # endif 5413 # ifdef PERL_USES_PL_PIDSTATUS 5414 " PERL_USES_PL_PIDSTATUS" 5415 # endif 5416 # ifdef USE_64_BIT_ALL 5417 " USE_64_BIT_ALL" 5418 # endif 5419 # ifdef USE_64_BIT_INT 5420 " USE_64_BIT_INT" 5421 # endif 5422 # ifdef USE_IEEE 5423 " USE_IEEE" 5424 # endif 5425 # ifdef USE_ITHREADS 5426 " USE_ITHREADS" 5427 # endif 5428 # ifdef USE_LARGE_FILES 5429 " USE_LARGE_FILES" 5430 # endif 5431 # ifdef USE_LOCALE_COLLATE 5432 " USE_LOCALE_COLLATE" 5433 # endif 5434 # ifdef USE_LOCALE_NUMERIC 5435 " USE_LOCALE_NUMERIC" 5436 # endif 5437 # ifdef USE_LOCALE_TIME 5438 " USE_LOCALE_TIME" 5439 # endif 5440 # ifdef USE_LONG_DOUBLE 5441 " USE_LONG_DOUBLE" 5442 # endif 5443 # ifdef USE_PERLIO 5444 " USE_PERLIO" 5445 # endif 5446 # ifdef USE_QUADMATH 5447 " USE_QUADMATH" 5448 # endif 5449 # ifdef USE_REENTRANT_API 5450 " USE_REENTRANT_API" 5451 # endif 5452 # ifdef USE_SOCKS 5453 " USE_SOCKS" 5454 # endif 5455 # ifdef VMS_DO_SOCKETS 5456 " VMS_DO_SOCKETS" 5457 # endif 5458 # ifdef VMS_SHORTEN_LONG_SYMBOLS 5459 " VMS_SHORTEN_LONG_SYMBOLS" 5460 # endif 5461 # ifdef VMS_WE_ARE_CASE_SENSITIVE 5462 " VMS_SYMBOL_CASE_AS_IS" 5463 # endif 5464 ""; 5465 #else 5466 EXTCONST char PL_bincompat_options[]; 5467 #endif 5468 5469 #ifndef PERL_SET_PHASE 5470 # define PERL_SET_PHASE(new_phase) \ 5471 PERL_DTRACE_PROBE_PHASE(new_phase); \ 5472 PL_phase = new_phase; 5473 #endif 5474 5475 /* The interpreter phases. If these ever change, PL_phase_names right below will 5476 * need to be updated accordingly. */ 5477 enum perl_phase { 5478 PERL_PHASE_CONSTRUCT = 0, 5479 PERL_PHASE_START = 1, 5480 PERL_PHASE_CHECK = 2, 5481 PERL_PHASE_INIT = 3, 5482 PERL_PHASE_RUN = 4, 5483 PERL_PHASE_END = 5, 5484 PERL_PHASE_DESTRUCT = 6 5485 }; 5486 5487 #ifdef DOINIT 5488 EXTCONST char *const PL_phase_names[] = { 5489 "CONSTRUCT", 5490 "START", 5491 "CHECK", 5492 "INIT", 5493 "RUN", 5494 "END", 5495 "DESTRUCT" 5496 }; 5497 #else 5498 EXTCONST char *const PL_phase_names[]; 5499 #endif 5500 5501 /* 5502 =for apidoc_section $utility 5503 5504 =for apidoc phase_name 5505 5506 Returns the given phase's name as a NUL-terminated string. 5507 5508 For example, to print a stack trace that includes the current 5509 interpreter phase you might do: 5510 5511 const char* phase_name = phase_name(PL_phase); 5512 mess("This is weird. (Perl phase: %s)", phase_name); 5513 5514 =cut 5515 */ 5516 5517 #define phase_name(phase) (PL_phase_names[phase]) 5518 5519 #ifndef PERL_CORE 5520 /* Do not use this macro. It only exists for extensions that rely on PL_dirty 5521 * instead of using the newer PL_phase, which provides everything PL_dirty 5522 * provided, and more. */ 5523 # define PL_dirty cBOOL(PL_phase == PERL_PHASE_DESTRUCT) 5524 5525 # define PL_amagic_generation PL_na 5526 # define PL_encoding ((SV *)NULL) 5527 #endif /* !PERL_CORE */ 5528 5529 #define PL_hints PL_compiling.cop_hints 5530 #define PL_maxo MAXO 5531 5532 END_EXTERN_C 5533 5534 /*****************************************************************************/ 5535 /* This lexer/parser stuff is currently global since yacc is hard to reenter */ 5536 /*****************************************************************************/ 5537 /* XXX This needs to be revisited, since BEGIN makes yacc re-enter... */ 5538 5539 #ifdef __Lynx__ 5540 /* LynxOS defines these in scsi.h which is included via ioctl.h */ 5541 #ifdef FORMAT 5542 #undef FORMAT 5543 #endif 5544 #ifdef SPACE 5545 #undef SPACE 5546 #endif 5547 #endif 5548 5549 #define LEX_NOTPARSING 11 /* borrowed from toke.c */ 5550 5551 typedef enum { 5552 XOPERATOR, 5553 XTERM, 5554 XREF, 5555 XSTATE, 5556 XBLOCK, 5557 XATTRBLOCK, /* next token should be an attribute or block */ 5558 XATTRTERM, /* next token should be an attribute, or block in a term */ 5559 XTERMBLOCK, 5560 XBLOCKTERM, 5561 XPOSTDEREF, 5562 XTERMORDORDOR /* evil hack */ 5563 /* update exp_name[] in toke.c if adding to this enum */ 5564 } expectation; 5565 5566 #define KEY_sigvar 0xFFFF /* fake keyword representing a signature var */ 5567 5568 /* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer 5569 special and there is no need for HINT_PRIVATE_MASK for COPs. 5570 5571 NOTE: The typical module using these has the bit value hard-coded, so don't 5572 blindly change the values of these. 5573 5574 If we run out of bits, the 2 locale ones could be combined. The PARTIAL one 5575 is for "use locale 'FOO'" which excludes some categories. It requires going 5576 to %^H to find out which are in and which are out. This could be extended 5577 for the normal case of a plain HINT_LOCALE, so that %^H would be used for 5578 any locale form. */ 5579 #define HINT_INTEGER 0x00000001 /* integer pragma */ 5580 #define HINT_STRICT_REFS 0x00000002 /* strict pragma */ 5581 #define HINT_LOCALE 0x00000004 /* locale pragma */ 5582 #define HINT_BYTES 0x00000008 /* bytes pragma */ 5583 #define HINT_LOCALE_PARTIAL 0x00000010 /* locale, but a subset of categories */ 5584 5585 #define HINT_EXPLICIT_STRICT_REFS 0x00000020 /* strict.pm */ 5586 #define HINT_EXPLICIT_STRICT_SUBS 0x00000040 /* strict.pm */ 5587 #define HINT_EXPLICIT_STRICT_VARS 0x00000080 /* strict.pm */ 5588 5589 #define HINT_BLOCK_SCOPE 0x00000100 5590 #define HINT_STRICT_SUBS 0x00000200 /* strict pragma */ 5591 #define HINT_STRICT_VARS 0x00000400 /* strict pragma */ 5592 #define HINT_UNI_8_BIT 0x00000800 /* unicode_strings feature */ 5593 5594 /* The HINT_NEW_* constants are used by the overload pragma */ 5595 #define HINT_NEW_INTEGER 0x00001000 5596 #define HINT_NEW_FLOAT 0x00002000 5597 #define HINT_NEW_BINARY 0x00004000 5598 #define HINT_NEW_STRING 0x00008000 5599 #define HINT_NEW_RE 0x00010000 5600 #define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */ 5601 #define HINT_LEXICAL_IO_IN 0x00040000 /* ${^OPEN} is set for input */ 5602 #define HINT_LEXICAL_IO_OUT 0x00080000 /* ${^OPEN} is set for output */ 5603 5604 #define HINT_RE_TAINT 0x00100000 /* re pragma */ 5605 #define HINT_RE_EVAL 0x00200000 /* re pragma */ 5606 5607 #define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */ 5608 #define HINT_UTF8 0x00800000 /* utf8 pragma */ 5609 5610 #define HINT_NO_AMAGIC 0x01000000 /* overloading pragma */ 5611 5612 #define HINT_RE_FLAGS 0x02000000 /* re '/xism' pragma */ 5613 5614 #define HINT_FEATURE_MASK 0x3c000000 /* 4 bits for feature bundles */ 5615 5616 /* Note: Used for HINT_M_VMSISH_*, 5617 currently defined by vms/vmsish.h: 5618 0x40000000 5619 0x80000000 5620 */ 5621 5622 #define HINT_ALL_STRICT HINT_STRICT_REFS \ 5623 | HINT_STRICT_SUBS \ 5624 | HINT_STRICT_VARS 5625 5626 #ifdef USE_STRICT_BY_DEFAULT 5627 #define HINTS_DEFAULT HINT_ALL_STRICT 5628 #else 5629 #define HINTS_DEFAULT 0 5630 #endif 5631 5632 /* flags for PL_sawampersand */ 5633 5634 #define SAWAMPERSAND_LEFT 1 /* saw $` */ 5635 #define SAWAMPERSAND_MIDDLE 2 /* saw $& */ 5636 #define SAWAMPERSAND_RIGHT 4 /* saw $' */ 5637 5638 #ifndef PERL_SAWAMPERSAND 5639 # define PL_sawampersand \ 5640 (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT) 5641 #endif 5642 5643 /* Used for debugvar magic */ 5644 #define DBVARMG_SINGLE 0 5645 #define DBVARMG_TRACE 1 5646 #define DBVARMG_SIGNAL 2 5647 #define DBVARMG_COUNT 3 5648 5649 #define PL_DBsingle_iv (PL_DBcontrol[DBVARMG_SINGLE]) 5650 #define PL_DBtrace_iv (PL_DBcontrol[DBVARMG_TRACE]) 5651 #define PL_DBsignal_iv (PL_DBcontrol[DBVARMG_SIGNAL]) 5652 5653 /* Various states of the input record separator SV (rs) */ 5654 #define RsSNARF(sv) (! SvOK(sv)) 5655 #define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv))) 5656 #define RsPARA(sv) (SvPOK(sv) && ! SvCUR(sv)) 5657 #define RsRECORD(sv) (SvROK(sv) && (SvIV(SvRV(sv)) > 0)) 5658 5659 /* A struct for keeping various DEBUGGING related stuff, 5660 * neatly packed. Currently only scratch variables for 5661 * constructing debug output are included. Needed always, 5662 * not just when DEBUGGING, though, because of the re extension. c*/ 5663 struct perl_debug_pad { 5664 SV pad[3]; 5665 }; 5666 5667 #define PERL_DEBUG_PAD(i) &(PL_debug_pad.pad[i]) 5668 #define PERL_DEBUG_PAD_ZERO(i) (SvPVX(PERL_DEBUG_PAD(i))[0] = 0, \ 5669 (((XPV*) SvANY(PERL_DEBUG_PAD(i)))->xpv_cur = 0), \ 5670 PERL_DEBUG_PAD(i)) 5671 5672 /* Enable variables which are pointers to functions */ 5673 typedef void (*peep_t)(pTHX_ OP* o); 5674 typedef regexp* (*regcomp_t) (pTHX_ char* exp, char* xend, PMOP* pm); 5675 typedef I32 (*regexec_t) (pTHX_ regexp* prog, char* stringarg, 5676 char* strend, char* strbeg, I32 minend, 5677 SV* screamer, void* data, U32 flags); 5678 typedef char* (*re_intuit_start_t) (pTHX_ regexp *prog, SV *sv, 5679 char *strpos, char *strend, 5680 U32 flags, 5681 re_scream_pos_data *d); 5682 typedef SV* (*re_intuit_string_t) (pTHX_ regexp *prog); 5683 typedef void (*regfree_t) (pTHX_ struct regexp* r); 5684 typedef regexp* (*regdupe_t) (pTHX_ const regexp* r, CLONE_PARAMS *param); 5685 typedef I32 (*re_fold_t)(const char *, char const *, I32); 5686 5687 typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); 5688 typedef void (*DESTRUCTORFUNC_t) (pTHX_ void*); 5689 typedef void (*SVFUNC_t) (pTHX_ SV* const); 5690 typedef I32 (*SVCOMPARE_t) (pTHX_ SV* const, SV* const); 5691 typedef void (*XSINIT_t) (pTHX); 5692 typedef void (*ATEXIT_t) (pTHX_ void*); 5693 typedef void (*XSUBADDR_t) (pTHX_ CV *); 5694 5695 typedef OP* (*Perl_ppaddr_t)(pTHX); 5696 typedef OP* (*Perl_check_t) (pTHX_ OP*); 5697 typedef void(*Perl_ophook_t)(pTHX_ OP*); 5698 typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**); 5699 typedef void(*Perl_cpeep_t)(pTHX_ OP *, OP *); 5700 5701 typedef void(*globhook_t)(pTHX); 5702 5703 #define KEYWORD_PLUGIN_DECLINE 0 5704 #define KEYWORD_PLUGIN_STMT 1 5705 #define KEYWORD_PLUGIN_EXPR 2 5706 5707 /* Interpreter exitlist entry */ 5708 typedef struct exitlistentry { 5709 void (*fn) (pTHX_ void*); 5710 void *ptr; 5711 } PerlExitListEntry; 5712 5713 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */ 5714 /* These have to be before perlvars.h */ 5715 #if !defined(HAS_SIGACTION) && defined(VMS) 5716 # define FAKE_PERSISTENT_SIGNAL_HANDLERS 5717 #endif 5718 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */ 5719 #if defined(KILL_BY_SIGPRC) 5720 # define FAKE_DEFAULT_SIGNAL_HANDLERS 5721 #endif 5722 5723 #if !defined(MULTIPLICITY) 5724 5725 struct interpreter { 5726 char broiled; 5727 }; 5728 5729 #else 5730 5731 /* If we have multiple interpreters define a struct 5732 holding variables which must be per-interpreter 5733 If we don't have threads anything that would have 5734 be per-thread is per-interpreter. 5735 */ 5736 5737 /* Set up PERLVAR macros for populating structs */ 5738 # define PERLVAR(prefix,var,type) type prefix##var; 5739 5740 /* 'var' is an array of length 'n' */ 5741 # define PERLVARA(prefix,var,n,type) type prefix##var[n]; 5742 5743 /* initialize 'var' to init' */ 5744 # define PERLVARI(prefix,var,type,init) type prefix##var; 5745 5746 /* like PERLVARI, but make 'var' a const */ 5747 # define PERLVARIC(prefix,var,type,init) type prefix##var; 5748 5749 struct interpreter { 5750 # include "intrpvar.h" 5751 }; 5752 5753 EXTCONST U16 PL_interp_size 5754 INIT(sizeof(struct interpreter)); 5755 5756 # define PERL_INTERPRETER_SIZE_UPTO_MEMBER(member) \ 5757 STRUCT_OFFSET(struct interpreter, member) + \ 5758 sizeof(((struct interpreter*)0)->member) 5759 5760 /* This will be useful for subsequent releases, because this has to be the 5761 same in your libperl as in main(), else you have a mismatch and must abort. 5762 */ 5763 EXTCONST U16 PL_interp_size_5_18_0 5764 INIT(PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_18_0_INTERP_MEMBER)); 5765 5766 5767 /* Done with PERLVAR macros for now ... */ 5768 # undef PERLVAR 5769 # undef PERLVARA 5770 # undef PERLVARI 5771 # undef PERLVARIC 5772 5773 #endif /* MULTIPLICITY */ 5774 5775 struct tempsym; /* defined in pp_pack.c */ 5776 5777 #include "thread.h" 5778 #include "pp.h" 5779 5780 #undef PERL_CKDEF 5781 #undef PERL_PPDEF 5782 #define PERL_CKDEF(s) PERL_CALLCONV OP *s (pTHX_ OP *o); 5783 #define PERL_PPDEF(s) PERL_CALLCONV OP *s (pTHX); 5784 5785 #ifdef MYMALLOC 5786 # include "malloc_ctl.h" 5787 #endif 5788 5789 /* 5790 * This provides a layer of functions and macros to ensure extensions will 5791 * get to use the same RTL functions as the core. 5792 */ 5793 #if defined(WIN32) 5794 # include "win32iop.h" 5795 #endif 5796 5797 5798 #include "proto.h" 5799 5800 /* this has structure inits, so it cannot be included before here */ 5801 #include "opcode.h" 5802 5803 /* The following must follow proto.h as #defines mess up syntax */ 5804 5805 #if !defined(PERL_FOR_X2P) 5806 # include "embedvar.h" 5807 #endif 5808 5809 /* Now include all the 'global' variables 5810 * If we don't have threads or multiple interpreters 5811 * these include variables that would have been their struct-s 5812 */ 5813 5814 #define PERLVAR(prefix,var,type) EXT type PL_##var; 5815 #define PERLVARA(prefix,var,n,type) EXT type PL_##var[n]; 5816 #define PERLVARI(prefix,var,type,init) EXT type PL_##var INIT(init); 5817 #define PERLVARIC(prefix,var,type,init) EXTCONST type PL_##var INIT(init); 5818 5819 #if !defined(MULTIPLICITY) 5820 START_EXTERN_C 5821 # include "intrpvar.h" 5822 END_EXTERN_C 5823 # define PL_sv_yes (PL_sv_immortals[0]) 5824 # define PL_sv_undef (PL_sv_immortals[1]) 5825 # define PL_sv_no (PL_sv_immortals[2]) 5826 # define PL_sv_zero (PL_sv_immortals[3]) 5827 #endif 5828 5829 #ifdef PERL_CORE 5830 /* All core uses now exterminated. Ensure no zombies can return: */ 5831 # undef PL_na 5832 #endif 5833 5834 /* Now all the config stuff is setup we can include embed.h 5835 In particular, need the relevant *ish file included already, as it may 5836 define HAVE_INTERP_INTERN */ 5837 #include "embed.h" 5838 5839 START_EXTERN_C 5840 5841 # include "perlvars.h" 5842 5843 END_EXTERN_C 5844 5845 #undef PERLVAR 5846 #undef PERLVARA 5847 #undef PERLVARI 5848 #undef PERLVARIC 5849 5850 #if !defined(MULTIPLICITY) 5851 /* Set up PERLVAR macros for populating structs */ 5852 # define PERLVAR(prefix,var,type) type prefix##var; 5853 /* 'var' is an array of length 'n' */ 5854 # define PERLVARA(prefix,var,n,type) type prefix##var[n]; 5855 /* initialize 'var' to init' */ 5856 # define PERLVARI(prefix,var,type,init) type prefix##var; 5857 /* like PERLVARI, but make 'var' a const */ 5858 # define PERLVARIC(prefix,var,type,init) type prefix##var; 5859 5860 /* this is never instantiated, is it just used for sizeof(struct PerlHandShakeInterpreter) */ 5861 struct PerlHandShakeInterpreter { 5862 # include "intrpvar.h" 5863 }; 5864 # undef PERLVAR 5865 # undef PERLVARA 5866 # undef PERLVARI 5867 # undef PERLVARIC 5868 #endif 5869 5870 START_EXTERN_C 5871 5872 /* dummy variables that hold pointers to both runops functions, thus forcing 5873 * them *both* to get linked in (useful for Peek.xs, debugging etc) */ 5874 5875 EXTCONST runops_proc_t PL_runops_std 5876 INIT(Perl_runops_standard); 5877 EXTCONST runops_proc_t PL_runops_dbg 5878 INIT(Perl_runops_debug); 5879 5880 #define EXT_MGVTBL EXTCONST MGVTBL 5881 5882 #define PERL_MAGIC_READONLY_ACCEPTABLE 0x40 5883 #define PERL_MAGIC_VALUE_MAGIC 0x80 5884 #define PERL_MAGIC_VTABLE_MASK 0x3F 5885 5886 /* can this type of magic be attached to a readonly SV? */ 5887 #define PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(t) \ 5888 (PL_magic_data[(U8)(t)] & PERL_MAGIC_READONLY_ACCEPTABLE) 5889 5890 /* Is this type of magic container magic (%ENV, $1 etc), 5891 * or value magic (pos, taint etc)? 5892 */ 5893 #define PERL_MAGIC_TYPE_IS_VALUE_MAGIC(t) \ 5894 (PL_magic_data[(U8)(t)] & PERL_MAGIC_VALUE_MAGIC) 5895 5896 #include "mg_vtable.h" 5897 5898 #ifdef DOINIT 5899 EXTCONST U8 PL_magic_data[256] = 5900 # ifdef PERL_MICRO 5901 # include "umg_data.h" 5902 # else 5903 # include "mg_data.h" 5904 # endif 5905 ; 5906 #else 5907 EXTCONST U8 PL_magic_data[256]; 5908 #endif 5909 5910 #ifdef DOINIT 5911 /* NL IV NV PV INV PI PN MG RX GV LV AV HV CV FM IO */ 5912 EXTCONST bool 5913 PL_valid_types_IVX[] = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 }; 5914 EXTCONST bool 5915 PL_valid_types_NVX[] = { 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 }; 5916 EXTCONST bool 5917 PL_valid_types_PVX[] = { 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1 }; 5918 EXTCONST bool 5919 PL_valid_types_RV[] = { 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1 }; 5920 EXTCONST bool 5921 PL_valid_types_IV_set[] = { 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1 }; 5922 EXTCONST bool 5923 PL_valid_types_NV_set[] = { 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 }; 5924 5925 EXTCONST U8 5926 PL_deBruijn_bitpos_tab32[] = { 5927 /* https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn */ 5928 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 5929 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 5930 }; 5931 5932 EXTCONST U8 5933 PL_deBruijn_bitpos_tab64[] = { 5934 /* https://stackoverflow.com/questions/11376288/fast-computing-of-log2-for-64-bit-integers */ 5935 63, 0, 58, 1, 59, 47, 53, 2, 60, 39, 48, 27, 54, 33, 42, 3, 5936 61, 51, 37, 40, 49, 18, 28, 20, 55, 30, 34, 11, 43, 14, 22, 4, 5937 62, 57, 46, 52, 38, 26, 32, 41, 50, 36, 17, 19, 29, 10, 13, 21, 5938 56, 45, 25, 31, 35, 16, 9, 12, 44, 24, 15, 8, 23, 7, 6, 5 5939 }; 5940 5941 #else 5942 5943 EXTCONST bool PL_valid_types_IVX[]; 5944 EXTCONST bool PL_valid_types_NVX[]; 5945 EXTCONST bool PL_valid_types_PVX[]; 5946 EXTCONST bool PL_valid_types_RV[]; 5947 EXTCONST bool PL_valid_types_IV_set[]; 5948 EXTCONST bool PL_valid_types_NV_set[]; 5949 EXTCONST U8 PL_deBruijn_bitpos_tab32[]; 5950 EXTCONST U8 PL_deBruijn_bitpos_tab64[]; 5951 5952 #endif 5953 5954 /* The constants for using PL_deBruijn_bitpos_tab */ 5955 #define PERL_deBruijnMagic32_ 0x077CB531 5956 #define PERL_deBruijnShift32_ 27 5957 #define PERL_deBruijnMagic64_ 0x07EDD5E59A4E28C2 5958 #define PERL_deBruijnShift64_ 58 5959 5960 /* In C99 we could use designated (named field) union initializers. 5961 * In C89 we need to initialize the member declared first. 5962 * In C++ we need extern C initializers. 5963 * 5964 * With the U8_NV version you will want to have inner braces, 5965 * while with the NV_U8 use just the NV. */ 5966 5967 #define INFNAN_U8_NV_DECL EXTCONST union { U8 u8[NVSIZE]; NV nv; } 5968 #define INFNAN_NV_U8_DECL EXTCONST union { NV nv; U8 u8[NVSIZE]; } 5969 5970 /* if these never got defined, they need defaults */ 5971 #ifndef PERL_SET_CONTEXT 5972 # define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i) 5973 #endif 5974 5975 #ifndef PERL_GET_CONTEXT 5976 # define PERL_GET_CONTEXT PERL_GET_INTERP 5977 #endif 5978 5979 #ifndef PERL_GET_THX 5980 # define PERL_GET_THX ((void*)NULL) 5981 #endif 5982 5983 #ifndef PERL_SET_THX 5984 # define PERL_SET_THX(t) NOOP 5985 #endif 5986 5987 #ifndef EBCDIC 5988 5989 /* The tables below are adapted from 5990 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this copyright 5991 * notice: 5992 5993 Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de> 5994 5995 Permission is hereby granted, free of charge, to any person obtaining a copy of 5996 this software and associated documentation files (the "Software"), to deal in 5997 the Software without restriction, including without limitation the rights to 5998 use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 5999 of the Software, and to permit persons to whom the Software is furnished to do 6000 so, subject to the following conditions: 6001 6002 The above copyright notice and this permission notice shall be included in all 6003 copies or substantial portions of the Software. 6004 6005 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 6006 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 6007 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 6008 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 6009 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 6010 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 6011 SOFTWARE. 6012 6013 */ 6014 6015 # ifdef DOINIT 6016 # if 0 /* This is the original table given in 6017 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/ */ 6018 static U8 utf8d_C9[] = { 6019 /* The first part of the table maps bytes to character classes that 6020 * to reduce the size of the transition table and create bitmasks. */ 6021 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-1F*/ 6022 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-3F*/ 6023 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-5F*/ 6024 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-7F*/ 6025 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, /*-9F*/ 6026 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, /*-BF*/ 6027 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /*-DF*/ 6028 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, /*-FF*/ 6029 6030 /* The second part is a transition table that maps a combination 6031 * of a state of the automaton and a character class to a state. */ 6032 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, 6033 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, 6034 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, 6035 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, 6036 12,36,12,12,12,12,12,12,12,12,12,12 6037 }; 6038 6039 # endif 6040 6041 /* This is a version of the above table customized for Perl that doesn't 6042 * exclude surrogates and accepts start bytes up through FD (FE on 64-bit 6043 * machines). The classes have been renumbered so that the patterns are more 6044 * evident in the table. The class numbers are structured so the values are: 6045 * 6046 * a) UTF-8 invariant code points 6047 * 0 6048 * b) Start bytes that always lead to either overlongs or some class of code 6049 * point that needs outside intervention for handling (such as to raise a 6050 * warning) 6051 * 1 6052 * c) Start bytes that never lead to one of the above 6053 * number of bytes in complete sequence 6054 * d) Rest of start bytes (they can be resolved through this algorithm) and 6055 * continuation bytes 6056 * arbitrary class number chosen to not conflict with the above 6057 * classes, and to index into the remaining table 6058 * 6059 * It would make the code simpler if start byte FF could also be handled, but 6060 * doing so would mean adding two more classes (one from splitting 80 from 81, 6061 * and one for FF), and nodes for each of 6 new continuation bytes. The 6062 * current table has 436 entries; the new one would require 140 more = 576 (2 6063 * additional classes for each of the 10 existing nodes, and 20 for each of 6 6064 * new nodes. The array would have to be made U16 instead of U8, not worth it 6065 * for this rarely encountered case 6066 * 6067 * The classes are 6068 * 00-7F 0 Always legal, single byte sequence 6069 * 80-81 7 Not legal immediately after start bytes E0 F0 F8 FC 6070 * FE 6071 * 82-83 8 Not legal immediately after start bytes E0 F0 F8 FC 6072 * 84-87 9 Not legal immediately after start bytes E0 F0 F8 6073 * 88-8F 10 Not legal immediately after start bytes E0 F0 6074 * 90-9F 11 Not legal immediately after start byte E0 6075 * A0-BF 12 Always legal continuation byte 6076 * C0,C1 1 Not legal: overlong 6077 * C2-DF 2 Legal start byte for two byte sequences 6078 * E0 13 Some sequences are overlong; others legal 6079 * E1-EF 3 Legal start byte for three byte sequences 6080 * F0 14 Some sequences are overlong; others legal 6081 * F1-F7 4 Legal start byte for four byte sequences 6082 * F8 15 Some sequences are overlong; others legal 6083 * F9-FB 5 Legal start byte for five byte sequences 6084 * FC 16 Some sequences are overlong; others legal 6085 * FD 6 Legal start byte for six byte sequences 6086 * FE 17 Some sequences are overlong; others legal 6087 * (is 1 on 32-bit machines, since it overflows) 6088 * FF 1 Need to handle specially 6089 */ 6090 6091 EXTCONST U8 PL_extended_utf8_dfa_tab[] = { 6092 /* The first part of the table maps bytes to character classes to reduce 6093 * the size of the transition table and create bitmasks. */ 6094 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*00-0F*/ 6095 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*10-1F*/ 6096 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*20-2F*/ 6097 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*30-3F*/ 6098 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*40-4F*/ 6099 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*50-5F*/ 6100 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*60-6F*/ 6101 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*70-7F*/ 6102 7, 7, 8, 8, 9, 9, 9, 9,10,10,10,10,10,10,10,10, /*80-8F*/ 6103 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, /*90-9F*/ 6104 12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12, /*A0-AF*/ 6105 12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12, /*B0-BF*/ 6106 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /*C0-CF*/ 6107 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /*D0-DF*/ 6108 13, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, /*E0-EF*/ 6109 14, 4, 4, 4, 4, 4, 4, 4,15, 5, 5, 5,16, 6, /*F0-FD*/ 6110 # ifdef UV_IS_QUAD 6111 17, /*FE*/ 6112 # else 6113 1, /*FE*/ 6114 # endif 6115 1, /*FF*/ 6116 6117 /* The second part is a transition table that maps a combination 6118 * of a state of the automaton and a character class to a new state, called a 6119 * node. The nodes are: 6120 * N0 The initial state, and final accepting one. 6121 * N1 Any one continuation byte (80-BF) left. This is transitioned to 6122 * immediately when the start byte indicates a two-byte sequence 6123 * N2 Any two continuation bytes left. 6124 * N3 Any three continuation bytes left. 6125 * N4 Any four continuation bytes left. 6126 * N5 Any five continuation bytes left. 6127 * N6 Start byte is E0. Continuation bytes 80-9F are illegal (overlong); 6128 * the other continuations transition to N1 6129 * N7 Start byte is F0. Continuation bytes 80-8F are illegal (overlong); 6130 * the other continuations transition to N2 6131 * N8 Start byte is F8. Continuation bytes 80-87 are illegal (overlong); 6132 * the other continuations transition to N3 6133 * N9 Start byte is FC. Continuation bytes 80-83 are illegal (overlong); 6134 * the other continuations transition to N4 6135 * N10 Start byte is FE. Continuation bytes 80-81 are illegal (overlong); 6136 * the other continuations transition to N5 6137 * 1 Reject. All transitions not mentioned above (except the single 6138 * byte ones (as they are always legal)) are to this state. 6139 */ 6140 6141 # if defined(PERL_CORE) 6142 # define NUM_CLASSES 18 6143 # define N0 0 6144 # define N1 ((N0) + NUM_CLASSES) 6145 # define N2 ((N1) + NUM_CLASSES) 6146 # define N3 ((N2) + NUM_CLASSES) 6147 # define N4 ((N3) + NUM_CLASSES) 6148 # define N5 ((N4) + NUM_CLASSES) 6149 # define N6 ((N5) + NUM_CLASSES) 6150 # define N7 ((N6) + NUM_CLASSES) 6151 # define N8 ((N7) + NUM_CLASSES) 6152 # define N9 ((N8) + NUM_CLASSES) 6153 # define N10 ((N9) + NUM_CLASSES) 6154 6155 /*Class: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 */ 6156 /*N0*/ 0, 1,N1,N2,N3,N4,N5, 1, 1, 1, 1, 1, 1,N6,N7,N8,N9,N10, 6157 /*N1*/ 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 6158 /*N2*/ 1, 1, 1, 1, 1, 1, 1,N1,N1,N1,N1,N1,N1, 1, 1, 1, 1, 1, 6159 /*N3*/ 1, 1, 1, 1, 1, 1, 1,N2,N2,N2,N2,N2,N2, 1, 1, 1, 1, 1, 6160 /*N4*/ 1, 1, 1, 1, 1, 1, 1,N3,N3,N3,N3,N3,N3, 1, 1, 1, 1, 1, 6161 /*N5*/ 1, 1, 1, 1, 1, 1, 1,N4,N4,N4,N4,N4,N4, 1, 1, 1, 1, 1, 6162 6163 /*N6*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,N1, 1, 1, 1, 1, 1, 6164 /*N7*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,N2,N2, 1, 1, 1, 1, 1, 6165 /*N8*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,N3,N3,N3, 1, 1, 1, 1, 1, 6166 /*N9*/ 1, 1, 1, 1, 1, 1, 1, 1, 1,N4,N4,N4,N4, 1, 1, 1, 1, 1, 6167 /*N10*/ 1, 1, 1, 1, 1, 1, 1, 1,N5,N5,N5,N5,N5, 1, 1, 1, 1, 1, 6168 }; 6169 6170 /* And below is a version of the above table that accepts only strict UTF-8. 6171 * Hence no surrogates nor non-characters, nor non-Unicode. Thus, if the input 6172 * passes this dfa, it will be for a well-formed, non-problematic code point 6173 * that can be returned immediately. 6174 * 6175 * The "Implementation details" portion of 6176 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/ shows how 6177 * the first portion of the table maps each possible byte into a character 6178 * class. And that the classes for those bytes which are start bytes have been 6179 * carefully chosen so they serve as well to be used as a shift value to mask 6180 * off the leading 1 bits of the start byte. Unfortunately the addition of 6181 * being able to distinguish non-characters makes this not fully work. This is 6182 * because, now, the start bytes E1-EF have to be broken into 3 classes instead 6183 * of 2: 6184 * 1) ED because it could be a surrogate 6185 * 2) EF because it could be a non-character 6186 * 3) the rest, which can never evaluate to a problematic code point. 6187 * 6188 * Each of E1-EF has three leading 1 bits, then a 0. That means we could use a 6189 * shift (and hence class number) of either 3 or 4 to get a mask that works. 6190 * But that only allows two categories, and we need three. khw made the 6191 * decision to therefore treat the ED start byte as an error, so that the dfa 6192 * drops out immediately for that. In the dfa, classes 3 and 4 are used to 6193 * distinguish EF vs the rest. Then special code is used to deal with ED, 6194 * that's executed only when the dfa drops out. The code points started by ED 6195 * are half surrogates, and half hangul syllables. This means that 2048 of 6196 * the hangul syllables (about 18%) take longer than all other non-problematic 6197 * code points to handle. 6198 * 6199 * The changes to handle non-characters requires the addition of states and 6200 * classes to the dfa. (See the section on "Mapping bytes to character 6201 * classes" in the linked-to document for further explanation of the original 6202 * dfa.) 6203 * 6204 * The classes are 6205 * 00-7F 0 6206 * 80-8E 9 6207 * 8F 10 6208 * 90-9E 11 6209 * 9F 12 6210 * A0-AE 13 6211 * AF 14 6212 * B0-B6 15 6213 * B7 16 6214 * B8-BD 15 6215 * BE 17 6216 * BF 18 6217 * C0,C1 1 6218 * C2-DF 2 6219 * E0 7 6220 * E1-EC 3 6221 * ED 1 6222 * EE 3 6223 * EF 4 6224 * F0 8 6225 * F1-F3 6 (6 bits can be stripped) 6226 * F4 5 (only 5 can be stripped) 6227 * F5-FF 1 6228 */ 6229 6230 EXTCONST U8 PL_strict_utf8_dfa_tab[] = { 6231 /* The first part of the table maps bytes to character classes to reduce 6232 * the size of the transition table and create bitmasks. */ 6233 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*00-0F*/ 6234 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*10-1F*/ 6235 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*20-2F*/ 6236 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*30-3F*/ 6237 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*40-4F*/ 6238 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*50-5F*/ 6239 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*60-6F*/ 6240 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*70-7F*/ 6241 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10, /*80-8F*/ 6242 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,12, /*90-9F*/ 6243 13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,14, /*A0-AF*/ 6244 15,15,15,15,15,15,15,16,15,15,15,15,15,15,17,18, /*B0-BF*/ 6245 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /*C0-CF*/ 6246 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /*D0-DF*/ 6247 7, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 3, 4, /*E0-EF*/ 6248 8, 6, 6, 6, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /*F0-FF*/ 6249 6250 /* The second part is a transition table that maps a combination 6251 * of a state of the automaton and a character class to a new state, called a 6252 * node. The nodes are: 6253 * N0 The initial state, and final accepting one. 6254 * N1 Any one continuation byte (80-BF) left. This is transitioned to 6255 * immediately when the start byte indicates a two-byte sequence 6256 * N2 Any two continuation bytes left. 6257 * N3 Start byte is E0. Continuation bytes 80-9F are illegal (overlong); 6258 * the other continuations transition to state N1 6259 * N4 Start byte is EF. Continuation byte B7 transitions to N8; BF to N9; 6260 * the other continuations transitions to N1 6261 * N5 Start byte is F0. Continuation bytes 80-8F are illegal (overlong); 6262 * [9AB]F transition to N10; the other continuations to N2. 6263 * N6 Start byte is F[123]. Continuation bytes [89AB]F transition 6264 * to N10; the other continuations to N2. 6265 * N7 Start byte is F4. Continuation bytes 90-BF are illegal 6266 * (non-unicode); 8F transitions to N10; the other continuations to N2 6267 * N8 Initial sequence is EF B7. Continuation bytes 90-AF are illegal 6268 * (non-characters); the other continuations transition to N0. 6269 * N9 Initial sequence is EF BF. Continuation bytes BE and BF are illegal 6270 * (non-characters); the other continuations transition to N0. 6271 * N10 Initial sequence is one of: F0 [9-B]F; F[123] [8-B]F; or F4 8F. 6272 * Continuation byte BF transitions to N11; the other continuations to 6273 * N1 6274 * N11 Initial sequence is the two bytes given in N10 followed by BF. 6275 * Continuation bytes BE and BF are illegal (non-characters); the other 6276 * continuations transition to N0. 6277 * 1 Reject. All transitions not mentioned above (except the single 6278 * byte ones (as they are always legal) are to this state. 6279 */ 6280 6281 # undef N0 6282 # undef N1 6283 # undef N2 6284 # undef N3 6285 # undef N4 6286 # undef N5 6287 # undef N6 6288 # undef N7 6289 # undef N8 6290 # undef N9 6291 # undef NUM_CLASSES 6292 # define NUM_CLASSES 19 6293 # define N0 0 6294 # define N1 ((N0) + NUM_CLASSES) 6295 # define N2 ((N1) + NUM_CLASSES) 6296 # define N3 ((N2) + NUM_CLASSES) 6297 # define N4 ((N3) + NUM_CLASSES) 6298 # define N5 ((N4) + NUM_CLASSES) 6299 # define N6 ((N5) + NUM_CLASSES) 6300 # define N7 ((N6) + NUM_CLASSES) 6301 # define N8 ((N7) + NUM_CLASSES) 6302 # define N9 ((N8) + NUM_CLASSES) 6303 # define N10 ((N9) + NUM_CLASSES) 6304 # define N11 ((N10) + NUM_CLASSES) 6305 6306 /*Class: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 */ 6307 /*N0*/ 0, 1, N1, N2, N4, N7, N6, N3, N5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 6308 /*N1*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6309 /*N2*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, N1, N1, N1, N1, N1, N1, N1, N1, N1, 6310 6311 /*N3*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, N1, N1, N1, N1, N1, 6312 /*N4*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, N1, N1, N1, N1, N1, N1, N8, N1, N9, 6313 /*N5*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, N2,N10, N2,N10, N2, N2, N2,N10, 6314 /*N6*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N2,N10, N2,N10, N2,N10, N2, N2, N2,N10, 6315 /*N7*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N2,N10, 1, 1, 1, 1, 1, 1, 1, 1, 6316 /*N8*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 6317 /*N9*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 6318 /*N10*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, N1, N1, N1, N1, N1, N1, N1, N1,N11, 6319 /*N11*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 6320 }; 6321 6322 /* And below is yet another version of the above tables that accepts only UTF-8 6323 * as defined by Corregidum #9. Hence no surrogates nor non-Unicode, but 6324 * it allows non-characters. This is isomorphic to the original table 6325 * in https://bjoern.hoehrmann.de/utf-8/decoder/dfa/ 6326 * 6327 * The classes are 6328 * 00-7F 0 6329 * 80-8F 9 6330 * 90-9F 10 6331 * A0-BF 11 6332 * C0,C1 1 6333 * C2-DF 2 6334 * E0 7 6335 * E1-EC 3 6336 * ED 4 6337 * EE-EF 3 6338 * F0 8 6339 * F1-F3 6 (6 bits can be stripped) 6340 * F4 5 (only 5 can be stripped) 6341 * F5-FF 1 6342 */ 6343 6344 EXTCONST U8 PL_c9_utf8_dfa_tab[] = { 6345 /* The first part of the table maps bytes to character classes to reduce 6346 * the size of the transition table and create bitmasks. */ 6347 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*00-0F*/ 6348 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*10-1F*/ 6349 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*20-2F*/ 6350 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*30-3F*/ 6351 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*40-4F*/ 6352 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*50-5F*/ 6353 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*60-6F*/ 6354 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*70-7F*/ 6355 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, /*80-8F*/ 6356 10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10, /*90-9F*/ 6357 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, /*A0-AF*/ 6358 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, /*B0-BF*/ 6359 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /*C0-CF*/ 6360 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /*D0-DF*/ 6361 7, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 3, 3, /*E0-EF*/ 6362 8, 6, 6, 6, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /*F0-FF*/ 6363 6364 /* The second part is a transition table that maps a combination 6365 * of a state of the automaton and a character class to a new state, called a 6366 * node. The nodes are: 6367 * N0 The initial state, and final accepting one. 6368 * N1 Any one continuation byte (80-BF) left. This is transitioned to 6369 * immediately when the start byte indicates a two-byte sequence 6370 * N2 Any two continuation bytes left. 6371 * N3 Any three continuation bytes left. 6372 * N4 Start byte is E0. Continuation bytes 80-9F are illegal (overlong); 6373 * the other continuations transition to state N1 6374 * N5 Start byte is ED. Continuation bytes A0-BF all lead to surrogates, 6375 * so are illegal. The other continuations transition to state N1. 6376 * N6 Start byte is F0. Continuation bytes 80-8F are illegal (overlong); 6377 * the other continuations transition to N2 6378 * N7 Start byte is F4. Continuation bytes 90-BF are illegal 6379 * (non-unicode); the other continuations transition to N2 6380 * 1 Reject. All transitions not mentioned above (except the single 6381 * byte ones (as they are always legal) are to this state. 6382 */ 6383 6384 # undef N0 6385 # undef N1 6386 # undef N2 6387 # undef N3 6388 # undef N4 6389 # undef N5 6390 # undef N6 6391 # undef N7 6392 # undef NUM_CLASSES 6393 # define NUM_CLASSES 12 6394 # define N0 0 6395 # define N1 ((N0) + NUM_CLASSES) 6396 # define N2 ((N1) + NUM_CLASSES) 6397 # define N3 ((N2) + NUM_CLASSES) 6398 # define N4 ((N3) + NUM_CLASSES) 6399 # define N5 ((N4) + NUM_CLASSES) 6400 # define N6 ((N5) + NUM_CLASSES) 6401 # define N7 ((N6) + NUM_CLASSES) 6402 6403 /*Class: 0 1 2 3 4 5 6 7 8 9 10 11 */ 6404 /*N0*/ 0, 1, N1, N2, N5, N7, N3, N4, N6, 1, 1, 1, 6405 /*N1*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 6406 /*N2*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, N1, N1, 6407 /*N3*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N2, N2, N2, 6408 6409 /*N4*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, 6410 /*N5*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N1, N1, 1, 6411 /*N6*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, N2, N2, 6412 /*N7*/ 1, 1, 1, 1, 1, 1, 1, 1, 1, N2, 1, 1, 6413 }; 6414 6415 # endif /* defined(PERL_CORE) */ 6416 # else /* End of is DOINIT */ 6417 6418 EXTCONST U8 PL_extended_utf8_dfa_tab[]; 6419 EXTCONST U8 PL_strict_utf8_dfa_tab[]; 6420 EXTCONST U8 PL_c9_utf8_dfa_tab[]; 6421 6422 # endif 6423 #endif /* end of isn't EBCDIC */ 6424 6425 #include "overload.h" 6426 6427 END_EXTERN_C 6428 6429 struct am_table { 6430 U8 flags; 6431 U8 fallback; 6432 U16 spare; 6433 U32 was_ok_sub; 6434 CV* table[NofAMmeth]; 6435 }; 6436 struct am_table_short { 6437 U8 flags; 6438 U8 fallback; 6439 U16 spare; 6440 U32 was_ok_sub; 6441 }; 6442 typedef struct am_table AMT; 6443 typedef struct am_table_short AMTS; 6444 6445 #define AMGfallNEVER 1 6446 #define AMGfallNO 2 6447 #define AMGfallYES 3 6448 6449 #define AMTf_AMAGIC 1 6450 #define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) 6451 #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) 6452 #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) 6453 6454 #define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg)) 6455 6456 /* 6457 * some compilers like to redefine cos et alia as faster 6458 * (and less accurate?) versions called F_cos et cetera (Quidquid 6459 * latine dictum sit, altum viditur.) This trick collides with 6460 * the Perl overloading (amg). The following #defines fool both. 6461 */ 6462 6463 #ifdef _FASTMATH 6464 # ifdef atan2 6465 # define F_atan2_amg atan2_amg 6466 # endif 6467 # ifdef cos 6468 # define F_cos_amg cos_amg 6469 # endif 6470 # ifdef exp 6471 # define F_exp_amg exp_amg 6472 # endif 6473 # ifdef log 6474 # define F_log_amg log_amg 6475 # endif 6476 # ifdef pow 6477 # define F_pow_amg pow_amg 6478 # endif 6479 # ifdef sin 6480 # define F_sin_amg sin_amg 6481 # endif 6482 # ifdef sqrt 6483 # define F_sqrt_amg sqrt_amg 6484 # endif 6485 #endif /* _FASTMATH */ 6486 6487 #define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \ 6488 PERLDBf_NOOPT | PERLDBf_INTER | \ 6489 PERLDBf_SUBLINE| PERLDBf_SINGLE| \ 6490 PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \ 6491 PERLDBf_SAVESRC) 6492 /* No _NONAME, _GOTO */ 6493 #define PERLDBf_SUB 0x01 /* Debug sub enter/exit */ 6494 #define PERLDBf_LINE 0x02 /* Keep line # */ 6495 #define PERLDBf_NOOPT 0x04 /* Switch off optimizations */ 6496 #define PERLDBf_INTER 0x08 /* Preserve more data for 6497 later inspections */ 6498 #define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */ 6499 #define PERLDBf_SINGLE 0x20 /* Start with single-step on */ 6500 #define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */ 6501 #define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */ 6502 #define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */ 6503 #define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */ 6504 #define PERLDBf_SAVESRC 0x400 /* Save source lines into @{"_<$filename"} */ 6505 #define PERLDBf_SAVESRC_NOSUBS 0x800 /* Including evals that generate no subroutines */ 6506 #define PERLDBf_SAVESRC_INVALID 0x1000 /* Save source that did not compile */ 6507 6508 #define PERLDB_SUB (PL_perldb & PERLDBf_SUB) 6509 #define PERLDB_LINE (PL_perldb & PERLDBf_LINE) 6510 #define PERLDB_NOOPT (PL_perldb & PERLDBf_NOOPT) 6511 #define PERLDB_INTER (PL_perldb & PERLDBf_INTER) 6512 #define PERLDB_SUBLINE (PL_perldb & PERLDBf_SUBLINE) 6513 #define PERLDB_SINGLE (PL_perldb & PERLDBf_SINGLE) 6514 #define PERLDB_SUB_NN (PL_perldb & PERLDBf_NONAME) 6515 #define PERLDB_GOTO (PL_perldb & PERLDBf_GOTO) 6516 #define PERLDB_NAMEEVAL (PL_perldb & PERLDBf_NAMEEVAL) 6517 #define PERLDB_NAMEANON (PL_perldb & PERLDBf_NAMEANON) 6518 #define PERLDB_SAVESRC (PL_perldb & PERLDBf_SAVESRC) 6519 #define PERLDB_SAVESRC_NOSUBS (PL_perldb & PERLDBf_SAVESRC_NOSUBS) 6520 #define PERLDB_SAVESRC_INVALID (PL_perldb & PERLDBf_SAVESRC_INVALID) 6521 6522 #define PERLDB_LINE_OR_SAVESRC (PL_perldb & (PERLDBf_LINE | PERLDBf_SAVESRC)) 6523 6524 #ifdef USE_ITHREADS 6525 # define KEYWORD_PLUGIN_MUTEX_INIT MUTEX_INIT(&PL_keyword_plugin_mutex) 6526 # define KEYWORD_PLUGIN_MUTEX_LOCK MUTEX_LOCK(&PL_keyword_plugin_mutex) 6527 # define KEYWORD_PLUGIN_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_keyword_plugin_mutex) 6528 # define KEYWORD_PLUGIN_MUTEX_TERM MUTEX_DESTROY(&PL_keyword_plugin_mutex) 6529 # define USER_PROP_MUTEX_INIT MUTEX_INIT(&PL_user_prop_mutex) 6530 # define USER_PROP_MUTEX_LOCK MUTEX_LOCK(&PL_user_prop_mutex) 6531 # define USER_PROP_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_user_prop_mutex) 6532 # define USER_PROP_MUTEX_TERM MUTEX_DESTROY(&PL_user_prop_mutex) 6533 #else 6534 # define KEYWORD_PLUGIN_MUTEX_INIT NOOP 6535 # define KEYWORD_PLUGIN_MUTEX_LOCK NOOP 6536 # define KEYWORD_PLUGIN_MUTEX_UNLOCK NOOP 6537 # define KEYWORD_PLUGIN_MUTEX_TERM NOOP 6538 # define USER_PROP_MUTEX_INIT NOOP 6539 # define USER_PROP_MUTEX_LOCK NOOP 6540 # define USER_PROP_MUTEX_UNLOCK NOOP 6541 # define USER_PROP_MUTEX_TERM NOOP 6542 #endif 6543 6544 #ifdef USE_LOCALE /* These locale things are all subject to change */ 6545 6546 /* Returns TRUE if the plain locale pragma without a parameter is in effect. 6547 * */ 6548 # define IN_LOCALE_RUNTIME (PL_curcop \ 6549 && CopHINTS_get(PL_curcop) & HINT_LOCALE) 6550 6551 /* Returns TRUE if either form of the locale pragma is in effect */ 6552 # define IN_SOME_LOCALE_FORM_RUNTIME \ 6553 cBOOL(CopHINTS_get(PL_curcop) & (HINT_LOCALE|HINT_LOCALE_PARTIAL)) 6554 6555 # define IN_LOCALE_COMPILETIME cBOOL(PL_hints & HINT_LOCALE) 6556 # define IN_SOME_LOCALE_FORM_COMPILETIME \ 6557 cBOOL(PL_hints & (HINT_LOCALE|HINT_LOCALE_PARTIAL)) 6558 6559 /* 6560 =for apidoc_section $locale 6561 6562 =for apidoc Amn|bool|IN_LOCALE 6563 6564 Evaluates to TRUE if the plain locale pragma without a parameter (S<C<use 6565 locale>>) is in effect. 6566 6567 =for apidoc Amn|bool|IN_LOCALE_COMPILETIME 6568 6569 Evaluates to TRUE if, when compiling a perl program (including an C<eval>) if 6570 the plain locale pragma without a parameter (S<C<use locale>>) is in effect. 6571 6572 =for apidoc Amn|bool|IN_LOCALE_RUNTIME 6573 6574 Evaluates to TRUE if, when executing a perl program (including an C<eval>) if 6575 the plain locale pragma without a parameter (S<C<use locale>>) is in effect. 6576 6577 =cut 6578 */ 6579 6580 # define IN_LOCALE \ 6581 (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) 6582 # define IN_SOME_LOCALE_FORM \ 6583 (IN_PERL_COMPILETIME ? IN_SOME_LOCALE_FORM_COMPILETIME \ 6584 : IN_SOME_LOCALE_FORM_RUNTIME) 6585 6586 # define IN_LC_ALL_COMPILETIME IN_LOCALE_COMPILETIME 6587 # define IN_LC_ALL_RUNTIME IN_LOCALE_RUNTIME 6588 6589 # define IN_LC_PARTIAL_COMPILETIME cBOOL(PL_hints & HINT_LOCALE_PARTIAL) 6590 # define IN_LC_PARTIAL_RUNTIME \ 6591 (PL_curcop && CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL) 6592 6593 # define IN_LC_COMPILETIME(category) \ 6594 ( IN_LC_ALL_COMPILETIME \ 6595 || ( IN_LC_PARTIAL_COMPILETIME \ 6596 && Perl__is_in_locale_category(aTHX_ TRUE, (category)))) 6597 # define IN_LC_RUNTIME(category) \ 6598 (IN_LC_ALL_RUNTIME || (IN_LC_PARTIAL_RUNTIME \ 6599 && Perl__is_in_locale_category(aTHX_ FALSE, (category)))) 6600 # define IN_LC(category) \ 6601 (IN_LC_COMPILETIME(category) || IN_LC_RUNTIME(category)) 6602 6603 # if defined (PERL_CORE) || defined (PERL_IN_XSUB_RE) 6604 6605 /* This internal macro should be called from places that operate under 6606 * locale rules. If there is a problem with the current locale that 6607 * hasn't been raised yet, it will output a warning this time. Because 6608 * this will so rarely be true, there is no point to optimize for time; 6609 * instead it makes sense to minimize space used and do all the work in 6610 * the rarely called function */ 6611 # ifdef USE_LOCALE_CTYPE 6612 # define _CHECK_AND_WARN_PROBLEMATIC_LOCALE \ 6613 STMT_START { \ 6614 if (UNLIKELY(PL_warn_locale)) { \ 6615 Perl__warn_problematic_locale(); \ 6616 } \ 6617 } STMT_END 6618 # else 6619 # define _CHECK_AND_WARN_PROBLEMATIC_LOCALE 6620 # endif 6621 6622 6623 /* These two internal macros are called when a warning should be raised, 6624 * and will do so if enabled. The first takes a single code point 6625 * argument; the 2nd, is a pointer to the first byte of the UTF-8 encoded 6626 * string, and an end position which it won't try to read past */ 6627 # define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(cp) \ 6628 STMT_START { \ 6629 if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \ 6630 Perl_warner(aTHX_ packWARN(WARN_LOCALE), \ 6631 "Wide character (U+%" UVXf ") in %s",\ 6632 (UV) cp, OP_DESC(PL_op)); \ 6633 } \ 6634 } STMT_END 6635 6636 # define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \ 6637 STMT_START { /* Check if to warn before doing the conversion work */\ 6638 if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \ 6639 UV cp = utf8_to_uvchr_buf((U8 *) (s), (U8 *) (send), NULL); \ 6640 Perl_warner(aTHX_ packWARN(WARN_LOCALE), \ 6641 "Wide character (U+%" UVXf ") in %s", \ 6642 (cp == 0) \ 6643 ? UNICODE_REPLACEMENT \ 6644 : (UV) cp, \ 6645 OP_DESC(PL_op)); \ 6646 } \ 6647 } STMT_END 6648 6649 # endif /* PERL_CORE or PERL_IN_XSUB_RE */ 6650 #else /* No locale usage */ 6651 # define IN_LOCALE_RUNTIME 0 6652 # define IN_SOME_LOCALE_FORM_RUNTIME 0 6653 # define IN_LOCALE_COMPILETIME 0 6654 # define IN_SOME_LOCALE_FORM_COMPILETIME 0 6655 # define IN_LOCALE 0 6656 # define IN_SOME_LOCALE_FORM 0 6657 # define IN_LC_ALL_COMPILETIME 0 6658 # define IN_LC_ALL_RUNTIME 0 6659 # define IN_LC_PARTIAL_COMPILETIME 0 6660 # define IN_LC_PARTIAL_RUNTIME 0 6661 # define IN_LC_COMPILETIME(category) 0 6662 # define IN_LC_RUNTIME(category) 0 6663 # define IN_LC(category) 0 6664 # define _CHECK_AND_WARN_PROBLEMATIC_LOCALE 6665 # define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) 6666 # define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(c) 6667 #endif 6668 6669 6670 /* Locale/thread synchronization macros. */ 6671 #if ! ( defined(USE_LOCALE) \ 6672 && defined(USE_ITHREADS) \ 6673 && ( ! defined(USE_THREAD_SAFE_LOCALE) \ 6674 || ( defined(HAS_LOCALECONV) \ 6675 && ( ! defined(HAS_LOCALECONV_L) \ 6676 || defined(TS_W32_BROKEN_LOCALECONV))) \ 6677 || ( defined(HAS_NL_LANGINFO) \ 6678 && ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L)) \ 6679 || (defined(HAS_MBLEN) && ! defined(HAS_MBRLEN)) \ 6680 || (defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC)) \ 6681 || (defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB)))) 6682 6683 /* The whole expression just above was complemented, so here we have no need 6684 * for thread synchronization, most likely it would be that this isn't a 6685 * threaded build. */ 6686 # define LOCALE_INIT 6687 # define LOCALE_TERM 6688 # define LC_NUMERIC_LOCK(cond) NOOP 6689 # define LC_NUMERIC_UNLOCK NOOP 6690 # define LOCALECONV_LOCK NOOP 6691 # define LOCALECONV_UNLOCK NOOP 6692 # define LOCALE_READ_LOCK NOOP 6693 # define LOCALE_READ_UNLOCK NOOP 6694 # define MBLEN_LOCK NOOP 6695 # define MBLEN_UNLOCK NOOP 6696 # define MBTOWC_LOCK NOOP 6697 # define MBTOWC_UNLOCK NOOP 6698 # define NL_LANGINFO_LOCK NOOP 6699 # define NL_LANGINFO_UNLOCK NOOP 6700 # define SETLOCALE_LOCK NOOP 6701 # define SETLOCALE_UNLOCK NOOP 6702 # define WCTOMB_LOCK NOOP 6703 # define WCTOMB_UNLOCK NOOP 6704 #else 6705 6706 /* Here, we will need critical sections in locale handling, because one or 6707 * more of the above conditions are true. This could be because the 6708 * platform doesn't have thread-safe locales, or that at least one of the 6709 * locale-dependent functions in the core isn't thread-safe. The latter 6710 * case is generally because they return a pointer to a static buffer, which 6711 * may be per-process instead of per-thread. There are supposedly 6712 * re-entrant, safe versions for all of them Perl currently uses (which the 6713 * #if above checks for), but most platforms don't have all the needed ones 6714 * available, and the Posix standard doesn't require nl_langinfo_l() to be 6715 * fully thread-safe, so a Configure probe was written. localeconv_l() is 6716 * uncommon, and judging by bug reports on the web, some earlier library 6717 * localeconv_l versions were broken, so perhaps a probe is in order for 6718 * that, but it would be a pain to write. 6719 * 6720 * On non-thread-safe systems, some of the above functions are vulnerable to 6721 * races should another thread get control and change the locale in the 6722 * middle of their execution. 6723 * 6724 * We currently use a single mutex for all these cases. This solves both 6725 * the problem of another thread changing the locale, and the buffer being 6726 * overwritten (the code copies the results to a safe place before releasing 6727 * the mutex). Ideally, for locale thread-safe platforms where the only 6728 * issue is another thread clobbering the function's static buffer, there 6729 * would be a separate mutex for each such buffer. Otherwise, things get 6730 * locked that don't need to. But, it is not expected that any of these 6731 * will be called frequently, and the locked interval should be short, and 6732 * modern platforms will have reentrant versions (which don't lock) for 6733 * almost all of them, so khw thinks a single mutex should suffice. */ 6734 # define LOCALE_LOCK_ \ 6735 STMT_START { \ 6736 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 6737 "%s: %d: locking locale\n", __FILE__, __LINE__)); \ 6738 MUTEX_LOCK(&PL_locale_mutex); \ 6739 } STMT_END 6740 # define LOCALE_UNLOCK_ \ 6741 STMT_START { \ 6742 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 6743 "%s: %d: unlocking locale\n", __FILE__, __LINE__)); \ 6744 MUTEX_UNLOCK(&PL_locale_mutex); \ 6745 } STMT_END 6746 6747 /* We do define a different macro for each case; then if we want to have 6748 * separate mutexes for some of them, the only changes needed are here. 6749 * Define just the necessary macros. The compiler should then croak if the 6750 * #ifdef's in the code are incorrect */ 6751 # if defined(HAS_LOCALECONV) && ( ! defined(HAS_POSIX_2008_LOCALE) \ 6752 || ! defined(HAS_LOCALECONV_L) \ 6753 || defined(TS_W32_BROKEN_LOCALECONV)) 6754 # define LOCALECONV_LOCK LOCALE_LOCK_ 6755 # define LOCALECONV_UNLOCK LOCALE_UNLOCK_ 6756 # endif 6757 # if defined(HAS_NL_LANGINFO) && ( ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \ 6758 || ! defined(HAS_POSIX_2008_LOCALE)) 6759 # define NL_LANGINFO_LOCK LOCALE_LOCK_ 6760 # define NL_LANGINFO_UNLOCK LOCALE_UNLOCK_ 6761 # endif 6762 # if defined(HAS_MBLEN) && ! defined(HAS_MBRLEN) 6763 # define MBLEN_LOCK LOCALE_LOCK_ 6764 # define MBLEN_UNLOCK LOCALE_UNLOCK_ 6765 # endif 6766 # if defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC) 6767 # define MBTOWC_LOCK LOCALE_LOCK_ 6768 # define MBTOWC_UNLOCK LOCALE_UNLOCK_ 6769 # endif 6770 # if defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB) 6771 # define WCTOMB_LOCK LOCALE_LOCK_ 6772 # define WCTOMB_UNLOCK LOCALE_UNLOCK_ 6773 # endif 6774 # if defined(USE_THREAD_SAFE_LOCALE) 6775 /* On locale thread-safe systems, we don't need these workarounds */ 6776 # define LOCALE_TERM_LC_NUMERIC_ NOOP 6777 # define LOCALE_INIT_LC_NUMERIC_ NOOP 6778 # define LC_NUMERIC_LOCK(cond) NOOP 6779 # define LC_NUMERIC_UNLOCK NOOP 6780 # define LOCALE_INIT_LC_NUMERIC_ NOOP 6781 # define LOCALE_TERM_LC_NUMERIC_ NOOP 6782 6783 /* There may be instance core where we this is invoked yet should do 6784 * nothing. Rather than have #ifdef's around them, define it here */ 6785 # define SETLOCALE_LOCK NOOP 6786 # define SETLOCALE_UNLOCK NOOP 6787 # else 6788 # define SETLOCALE_LOCK LOCALE_LOCK_ 6789 # define SETLOCALE_UNLOCK LOCALE_UNLOCK_ 6790 6791 /* On platforms without per-thread locales, when another thread can switch 6792 * our locale, we need another mutex to create critical sections where we 6793 * want the LC_NUMERIC locale to be locked into either the C (standard) 6794 * locale, or the underlying locale, so that other threads interrupting 6795 * this one don't change it to the wrong state before we've had a chance to 6796 * complete our operation. It can stay locked over an entire printf 6797 * operation, for example. And so is made distinct from the LOCALE_LOCK 6798 * mutex. 6799 * 6800 * This simulates kind of a general semaphore. The current thread will 6801 * lock the mutex if the per-thread variable is zero, and then increments 6802 * that variable. Each corresponding UNLOCK decrements the variable until 6803 * it is 0, at which point it actually unlocks the mutex. Since the 6804 * variable is per-thread, there is no race with other threads. 6805 * 6806 * The single argument is a condition to test for, and if true, to panic, 6807 * as this would be an attempt to complement the LC_NUMERIC state, and 6808 * we're not supposed to because it's locked. 6809 * 6810 * Clang improperly gives warnings for this, if not silenced: 6811 * https://clang.llvm.org/docs/ThreadSafetyAnalysis.html#conditional-locks 6812 * 6813 * If LC_NUMERIC_LOCK is combined with one of the LOCKs above, calls to 6814 * that and its corresponding unlock should be contained entirely within 6815 * the locked portion of LC_NUMERIC. Those mutexes should be used only in 6816 * very short sections of code, while LC_NUMERIC_LOCK may span more 6817 * operations. By always following this convention, deadlock should be 6818 * impossible. But if necessary, the two mutexes could be combined. */ 6819 # define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \ 6820 CLANG_DIAG_IGNORE(-Wthread-safety) \ 6821 STMT_START { \ 6822 if (PL_lc_numeric_mutex_depth <= 0) { \ 6823 MUTEX_LOCK(&PL_lc_numeric_mutex); \ 6824 PL_lc_numeric_mutex_depth = 1; \ 6825 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 6826 "%s: %d: locking lc_numeric; depth=1\n", \ 6827 __FILE__, __LINE__)); \ 6828 } \ 6829 else { \ 6830 PL_lc_numeric_mutex_depth++; \ 6831 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 6832 "%s: %d: avoided lc_numeric_lock; new depth=%d\n", \ 6833 __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \ 6834 if (cond_to_panic_if_already_locked) { \ 6835 Perl_croak_nocontext("panic: %s: %d: Trying to change" \ 6836 " LC_NUMERIC incompatibly", \ 6837 __FILE__, __LINE__); \ 6838 } \ 6839 } \ 6840 } STMT_END 6841 6842 # define LC_NUMERIC_UNLOCK \ 6843 STMT_START { \ 6844 if (PL_lc_numeric_mutex_depth <= 1) { \ 6845 MUTEX_UNLOCK(&PL_lc_numeric_mutex); \ 6846 PL_lc_numeric_mutex_depth = 0; \ 6847 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 6848 "%s: %d: unlocking lc_numeric; depth=0\n", \ 6849 __FILE__, __LINE__)); \ 6850 } \ 6851 else { \ 6852 PL_lc_numeric_mutex_depth--; \ 6853 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 6854 "%s: %d: avoided lc_numeric_unlock; new depth=%d\n",\ 6855 __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \ 6856 } \ 6857 } STMT_END \ 6858 CLANG_DIAG_RESTORE 6859 6860 # define LOCALE_INIT_LC_NUMERIC_ MUTEX_INIT(&PL_lc_numeric_mutex) 6861 # define LOCALE_TERM_LC_NUMERIC_ MUTEX_DESTROY(&PL_lc_numeric_mutex) 6862 # endif 6863 6864 # ifdef USE_POSIX_2008_LOCALE 6865 /* We have a locale object holding the 'C' locale for Posix 2008 */ 6866 # define LOCALE_TERM_POSIX_2008_ \ 6867 STMT_START { \ 6868 if (PL_C_locale_obj) { \ 6869 /* Make sure we aren't using the locale \ 6870 * space we are about to free */ \ 6871 uselocale(LC_GLOBAL_LOCALE); \ 6872 freelocale(PL_C_locale_obj); \ 6873 PL_C_locale_obj = (locale_t) NULL; \ 6874 } \ 6875 } STMT_END 6876 # else 6877 # define LOCALE_TERM_POSIX_2008_ NOOP 6878 # endif 6879 6880 # define LOCALE_INIT STMT_START { \ 6881 MUTEX_INIT(&PL_locale_mutex); \ 6882 LOCALE_INIT_LC_NUMERIC_; \ 6883 } STMT_END 6884 6885 # define LOCALE_TERM STMT_START { \ 6886 MUTEX_DESTROY(&PL_locale_mutex); \ 6887 LOCALE_TERM_LC_NUMERIC_; \ 6888 LOCALE_TERM_POSIX_2008_; \ 6889 } STMT_END 6890 #endif 6891 6892 #ifdef USE_LOCALE_NUMERIC 6893 6894 /* These macros are for toggling between the underlying locale (UNDERLYING or 6895 * LOCAL) and the C locale (STANDARD). (Actually we don't have to use the C 6896 * locale if the underlying locale is indistinguishable from it in the numeric 6897 * operations used by Perl, namely the decimal point, and even the thousands 6898 * separator.) 6899 6900 =for apidoc_section $locale 6901 6902 =for apidoc Amn|void|DECLARATION_FOR_LC_NUMERIC_MANIPULATION 6903 6904 This macro should be used as a statement. It declares a private variable 6905 (whose name begins with an underscore) that is needed by the other macros in 6906 this section. Failing to include this correctly should lead to a syntax error. 6907 For compatibility with C89 C compilers it should be placed in a block before 6908 any executable statements. 6909 6910 =for apidoc Am|void|STORE_LC_NUMERIC_FORCE_TO_UNDERLYING 6911 6912 This is used by XS code that is C<LC_NUMERIC> locale-aware to force the 6913 locale for category C<LC_NUMERIC> to be what perl thinks is the current 6914 underlying locale. (The perl interpreter could be wrong about what the 6915 underlying locale actually is if some C or XS code has called the C library 6916 function L<setlocale(3)> behind its back; calling L</sync_locale> before calling 6917 this macro will update perl's records.) 6918 6919 A call to L</DECLARATION_FOR_LC_NUMERIC_MANIPULATION> must have been made to 6920 declare at compile time a private variable used by this macro. This macro 6921 should be called as a single statement, not an expression, but with an empty 6922 argument list, like this: 6923 6924 { 6925 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 6926 ... 6927 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); 6928 ... 6929 RESTORE_LC_NUMERIC(); 6930 ... 6931 } 6932 6933 The private variable is used to save the current locale state, so 6934 that the requisite matching call to L</RESTORE_LC_NUMERIC> can restore it. 6935 6936 On threaded perls not operating with thread-safe functionality, this macro uses 6937 a mutex to force a critical section. Therefore the matching RESTORE should be 6938 close by, and guaranteed to be called. 6939 6940 =for apidoc Am|void|STORE_LC_NUMERIC_SET_TO_NEEDED 6941 6942 This is used to help wrap XS or C code that is C<LC_NUMERIC> locale-aware. 6943 This locale category is generally kept set to a locale where the decimal radix 6944 character is a dot, and the separator between groups of digits is empty. This 6945 is because most XS code that reads floating point numbers is expecting them to 6946 have this syntax. 6947 6948 This macro makes sure the current C<LC_NUMERIC> state is set properly, to be 6949 aware of locale if the call to the XS or C code from the Perl program is 6950 from within the scope of a S<C<use locale>>; or to ignore locale if the call is 6951 instead from outside such scope. 6952 6953 This macro is the start of wrapping the C or XS code; the wrap ending is done 6954 by calling the L</RESTORE_LC_NUMERIC> macro after the operation. Otherwise 6955 the state can be changed that will adversely affect other XS code. 6956 6957 A call to L</DECLARATION_FOR_LC_NUMERIC_MANIPULATION> must have been made to 6958 declare at compile time a private variable used by this macro. This macro 6959 should be called as a single statement, not an expression, but with an empty 6960 argument list, like this: 6961 6962 { 6963 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 6964 ... 6965 STORE_LC_NUMERIC_SET_TO_NEEDED(); 6966 ... 6967 RESTORE_LC_NUMERIC(); 6968 ... 6969 } 6970 6971 On threaded perls not operating with thread-safe functionality, this macro uses 6972 a mutex to force a critical section. Therefore the matching RESTORE should be 6973 close by, and guaranteed to be called; see L</WITH_LC_NUMERIC_SET_TO_NEEDED> 6974 for a more contained way to ensure that. 6975 6976 =for apidoc Am|void|STORE_LC_NUMERIC_SET_TO_NEEDED_IN|bool in_lc_numeric 6977 6978 Same as L</STORE_LC_NUMERIC_SET_TO_NEEDED> with in_lc_numeric provided 6979 as the precalculated value of C<IN_LC(LC_NUMERIC)>. It is the caller's 6980 responsibility to ensure that the status of C<PL_compiling> and C<PL_hints> 6981 cannot have changed since the precalculation. 6982 6983 =for apidoc Am|void|RESTORE_LC_NUMERIC 6984 6985 This is used in conjunction with one of the macros 6986 L</STORE_LC_NUMERIC_SET_TO_NEEDED> 6987 and L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING> to properly restore the 6988 C<LC_NUMERIC> state. 6989 6990 A call to L</DECLARATION_FOR_LC_NUMERIC_MANIPULATION> must have been made to 6991 declare at compile time a private variable used by this macro and the two 6992 C<STORE> ones. This macro should be called as a single statement, not an 6993 expression, but with an empty argument list, like this: 6994 6995 { 6996 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 6997 ... 6998 RESTORE_LC_NUMERIC(); 6999 ... 7000 } 7001 7002 =for apidoc Am|void|WITH_LC_NUMERIC_SET_TO_NEEDED|block 7003 7004 This macro invokes the supplied statement or block within the context 7005 of a L</STORE_LC_NUMERIC_SET_TO_NEEDED> .. L</RESTORE_LC_NUMERIC> pair 7006 if required, so eg: 7007 7008 WITH_LC_NUMERIC_SET_TO_NEEDED( 7009 SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis) 7010 ); 7011 7012 is equivalent to: 7013 7014 { 7015 #ifdef USE_LOCALE_NUMERIC 7016 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 7017 STORE_LC_NUMERIC_SET_TO_NEEDED(); 7018 #endif 7019 SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis); 7020 #ifdef USE_LOCALE_NUMERIC 7021 RESTORE_LC_NUMERIC(); 7022 #endif 7023 } 7024 7025 =for apidoc Am|void|WITH_LC_NUMERIC_SET_TO_NEEDED_IN|bool in_lc_numeric|block 7026 7027 Same as L</WITH_LC_NUMERIC_SET_TO_NEEDED> with in_lc_numeric provided 7028 as the precalculated value of C<IN_LC(LC_NUMERIC)>. It is the caller's 7029 responsibility to ensure that the status of C<PL_compiling> and C<PL_hints> 7030 cannot have changed since the precalculation. 7031 7032 =cut 7033 7034 */ 7035 7036 /* If the underlying numeric locale has a non-dot decimal point or has a 7037 * non-empty floating point thousands separator, the current locale is instead 7038 * generally kept in the C locale instead of that underlying locale. The 7039 * current status is known by looking at two words. One is non-zero if the 7040 * current numeric locale is the standard C/POSIX one or is indistinguishable 7041 * from C. The other is non-zero if the current locale is the underlying 7042 * locale. Both can be non-zero if, as often happens, the underlying locale is 7043 * C or indistinguishable from it. 7044 * 7045 * khw believes the reason for the variables instead of the bits in a single 7046 * word is to avoid having to have masking instructions. */ 7047 7048 # define _NOT_IN_NUMERIC_STANDARD (! PL_numeric_standard) 7049 7050 /* We can lock the category to stay in the C locale, making requests to the 7051 * contrary be noops, in the dynamic scope by setting PL_numeric_standard to 2. 7052 * */ 7053 # define _NOT_IN_NUMERIC_UNDERLYING \ 7054 (! PL_numeric_underlying && PL_numeric_standard < 2) 7055 7056 # define DECLARATION_FOR_LC_NUMERIC_MANIPULATION \ 7057 void (*_restore_LC_NUMERIC_function)(pTHX) = NULL 7058 7059 # define STORE_LC_NUMERIC_SET_TO_NEEDED_IN(in) \ 7060 STMT_START { \ 7061 bool _in_lc_numeric = (in); \ 7062 LC_NUMERIC_LOCK( \ 7063 ( ( _in_lc_numeric && _NOT_IN_NUMERIC_UNDERLYING) \ 7064 || (! _in_lc_numeric && _NOT_IN_NUMERIC_STANDARD))); \ 7065 if (_in_lc_numeric) { \ 7066 if (_NOT_IN_NUMERIC_UNDERLYING) { \ 7067 Perl_set_numeric_underlying(aTHX); \ 7068 _restore_LC_NUMERIC_function \ 7069 = &Perl_set_numeric_standard; \ 7070 } \ 7071 } \ 7072 else { \ 7073 if (_NOT_IN_NUMERIC_STANDARD) { \ 7074 Perl_set_numeric_standard(aTHX); \ 7075 _restore_LC_NUMERIC_function \ 7076 = &Perl_set_numeric_underlying; \ 7077 } \ 7078 } \ 7079 } STMT_END 7080 7081 # define STORE_LC_NUMERIC_SET_TO_NEEDED() \ 7082 STORE_LC_NUMERIC_SET_TO_NEEDED_IN(IN_LC(LC_NUMERIC)) 7083 7084 # define RESTORE_LC_NUMERIC() \ 7085 STMT_START { \ 7086 if (_restore_LC_NUMERIC_function) { \ 7087 _restore_LC_NUMERIC_function(aTHX); \ 7088 } \ 7089 LC_NUMERIC_UNLOCK; \ 7090 } STMT_END 7091 7092 /* The next two macros set unconditionally. These should be rarely used, and 7093 * only after being sure that this is what is needed */ 7094 # define SET_NUMERIC_STANDARD() \ 7095 STMT_START { \ 7096 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 7097 "%s: %d: lc_numeric standard=%d\n", \ 7098 __FILE__, __LINE__, PL_numeric_standard)); \ 7099 Perl_set_numeric_standard(aTHX); \ 7100 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 7101 "%s: %d: lc_numeric standard=%d\n", \ 7102 __FILE__, __LINE__, PL_numeric_standard)); \ 7103 } STMT_END 7104 7105 # define SET_NUMERIC_UNDERLYING() \ 7106 STMT_START { \ 7107 if (_NOT_IN_NUMERIC_UNDERLYING) { \ 7108 Perl_set_numeric_underlying(aTHX); \ 7109 } \ 7110 } STMT_END 7111 7112 /* The rest of these LC_NUMERIC macros toggle to one or the other state, with 7113 * the RESTORE_foo ones called to switch back, but only if need be */ 7114 # define STORE_LC_NUMERIC_SET_STANDARD() \ 7115 STMT_START { \ 7116 LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_STANDARD); \ 7117 if (_NOT_IN_NUMERIC_STANDARD) { \ 7118 _restore_LC_NUMERIC_function = &Perl_set_numeric_underlying;\ 7119 Perl_set_numeric_standard(aTHX); \ 7120 } \ 7121 } STMT_END 7122 7123 /* Rarely, we want to change to the underlying locale even outside of 'use 7124 * locale'. This is principally in the POSIX:: functions */ 7125 # define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \ 7126 STMT_START { \ 7127 LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_UNDERLYING); \ 7128 if (_NOT_IN_NUMERIC_UNDERLYING) { \ 7129 Perl_set_numeric_underlying(aTHX); \ 7130 _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ 7131 } \ 7132 } STMT_END 7133 7134 /* Lock/unlock to the C locale until unlock is called. This needs to be 7135 * recursively callable. [perl #128207] */ 7136 # define LOCK_LC_NUMERIC_STANDARD() \ 7137 STMT_START { \ 7138 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 7139 "%s: %d: lc_numeric_standard now locked to depth %d\n", \ 7140 __FILE__, __LINE__, PL_numeric_standard)); \ 7141 __ASSERT_(PL_numeric_standard) \ 7142 PL_numeric_standard++; \ 7143 } STMT_END 7144 7145 # define UNLOCK_LC_NUMERIC_STANDARD() \ 7146 STMT_START { \ 7147 if (PL_numeric_standard > 1) { \ 7148 PL_numeric_standard--; \ 7149 } \ 7150 else { \ 7151 assert(0); \ 7152 } \ 7153 DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ 7154 "%s: %d: ", __FILE__, __LINE__); \ 7155 if (PL_numeric_standard <= 1) \ 7156 PerlIO_printf(Perl_debug_log, \ 7157 "lc_numeric_standard now unlocked\n");\ 7158 else PerlIO_printf(Perl_debug_log, \ 7159 "lc_numeric_standard lock decremented to depth %d\n", \ 7160 PL_numeric_standard););\ 7161 } STMT_END 7162 7163 # define WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, block) \ 7164 STMT_START { \ 7165 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; \ 7166 STORE_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric); \ 7167 block; \ 7168 RESTORE_LC_NUMERIC(); \ 7169 } STMT_END; 7170 7171 # define WITH_LC_NUMERIC_SET_TO_NEEDED(block) \ 7172 WITH_LC_NUMERIC_SET_TO_NEEDED_IN(IN_LC(LC_NUMERIC), block) 7173 7174 #else /* !USE_LOCALE_NUMERIC */ 7175 7176 # define SET_NUMERIC_STANDARD() 7177 # define SET_NUMERIC_UNDERLYING() 7178 # define IS_NUMERIC_RADIX(a, b) (0) 7179 # define DECLARATION_FOR_LC_NUMERIC_MANIPULATION dNOOP 7180 # define STORE_LC_NUMERIC_SET_STANDARD() 7181 # define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() 7182 # define STORE_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric) 7183 # define STORE_LC_NUMERIC_SET_TO_NEEDED() 7184 # define RESTORE_LC_NUMERIC() 7185 # define LOCK_LC_NUMERIC_STANDARD() 7186 # define UNLOCK_LC_NUMERIC_STANDARD() 7187 # define WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, block) \ 7188 STMT_START { block; } STMT_END 7189 # define WITH_LC_NUMERIC_SET_TO_NEEDED(block) \ 7190 STMT_START { block; } STMT_END 7191 7192 #endif /* !USE_LOCALE_NUMERIC */ 7193 7194 #ifdef USE_ITHREADS 7195 # define ENV_LOCK PERL_WRITE_LOCK(&PL_env_mutex) 7196 # define ENV_UNLOCK PERL_WRITE_UNLOCK(&PL_env_mutex) 7197 # define ENV_READ_LOCK PERL_READ_LOCK(&PL_env_mutex) 7198 # define ENV_READ_UNLOCK PERL_READ_UNLOCK(&PL_env_mutex) 7199 # define ENV_INIT PERL_RW_MUTEX_INIT(&PL_env_mutex) 7200 # define ENV_TERM PERL_RW_MUTEX_DESTROY(&PL_env_mutex) 7201 7202 /* On platforms where the static buffer contained in getenv() is per-thread 7203 * rather than process-wide, another thread executing a getenv() at the same 7204 * time won't destroy ours before we have copied the result safely away and 7205 * unlocked the mutex. On such platforms (which is most), we can have many 7206 * readers of the environment at the same time. */ 7207 # ifdef GETENV_PRESERVES_OTHER_THREAD 7208 # define GETENV_LOCK ENV_READ_LOCK 7209 # define GETENV_UNLOCK ENV_READ_UNLOCK 7210 # else 7211 /* If, on the other hand, another thread could zap our getenv() return, we 7212 * need to keep them from executing until we are done */ 7213 # define GETENV_LOCK ENV_LOCK 7214 # define GETENV_UNLOCK ENV_UNLOCK 7215 # endif 7216 #else 7217 # define ENV_LOCK NOOP 7218 # define ENV_UNLOCK NOOP 7219 # define ENV_READ_LOCK NOOP 7220 # define ENV_READ_UNLOCK NOOP 7221 # define ENV_INIT NOOP 7222 # define ENV_TERM NOOP 7223 # define GETENV_LOCK NOOP 7224 # define GETENV_UNLOCK NOOP 7225 #endif 7226 7227 #ifndef PERL_NO_INLINE_FUNCTIONS 7228 /* Static inline funcs that depend on includes and declarations above. 7229 Some of these reference functions in the perl object files, and some 7230 compilers aren't smart enough to eliminate unused static inline 7231 functions, so including this file in source code can cause link errors 7232 even if the source code uses none of the functions. Hence including these 7233 can be suppressed by setting PERL_NO_INLINE_FUNCTIONS. Doing this will 7234 (obviously) result in unworkable XS code, but allows simple probing code 7235 to continue to work, because it permits tests to include the perl headers 7236 for definitions without creating a link dependency on the perl library 7237 (which may not exist yet). 7238 */ 7239 7240 START_EXTERN_C 7241 7242 # include "inline.h" 7243 # include "sv_inline.h" 7244 7245 END_EXTERN_C 7246 7247 #endif 7248 7249 /* Some critical sections need to lock both the locale and the environment. 7250 * XXX khw intends to change this to lock both mutexes, but that brings up 7251 * issues of potential deadlock, so should be done at the beginning of a 7252 * development cycle. So for now, it just locks the environment. Note that 7253 * many modern platforms are locale-thread-safe anyway, so locking the locale 7254 * mutex is a no-op anyway */ 7255 #define ENV_LOCALE_LOCK ENV_LOCK 7256 #define ENV_LOCALE_UNLOCK ENV_UNLOCK 7257 7258 /* And some critical sections care only that no one else is writing either the 7259 * locale nor the environment. XXX Again this is for the future. This can be 7260 * simulated with using COND_WAIT in thread.h */ 7261 #define ENV_LOCALE_READ_LOCK ENV_LOCALE_LOCK 7262 #define ENV_LOCALE_READ_UNLOCK ENV_LOCALE_UNLOCK 7263 7264 #define Atof my_atof 7265 7266 /* 7267 7268 =for apidoc_section $numeric 7269 7270 =for apidoc AmTR|NV|Strtod|NN const char * const s|NULLOK char ** e 7271 7272 This is a synonym for L</my_strtod>. 7273 7274 =for apidoc AmTR|NV|Strtol|NN const char * const s|NULLOK char ** e|int base 7275 7276 Platform and configuration independent C<strtol>. This expands to the 7277 appropriate C<strotol>-like function based on the platform and F<Configure> 7278 options>. For example it could expand to C<strtoll> or C<strtoq> instead of 7279 C<strtol>. 7280 7281 =for apidoc AmTR|NV|Strtoul|NN const char * const s|NULLOK char ** e|int base 7282 7283 Platform and configuration independent C<strtoul>. This expands to the 7284 appropriate C<strotoul>-like function based on the platform and F<Configure> 7285 options>. For example it could expand to C<strtoull> or C<strtouq> instead of 7286 C<strtoul>. 7287 7288 =cut 7289 7290 */ 7291 7292 #define Strtod my_strtod 7293 7294 #if defined(HAS_STRTOD) \ 7295 || defined(USE_QUADMATH) \ 7296 || (defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE) \ 7297 && defined(USE_LONG_DOUBLE)) 7298 # define Perl_strtod Strtod 7299 #endif 7300 7301 #if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \ 7302 (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) 7303 # ifdef __hpux 7304 # define strtoll __strtoll /* secret handshake */ 7305 # endif 7306 # if defined(WIN64) && defined(_MSC_VER) 7307 # define strtoll _strtoi64 /* secret handshake */ 7308 # endif 7309 # if !defined(Strtol) && defined(HAS_STRTOLL) 7310 # define Strtol strtoll 7311 # endif 7312 # if !defined(Strtol) && defined(HAS_STRTOQ) 7313 # define Strtol strtoq 7314 # endif 7315 /* is there atoq() anywhere? */ 7316 #endif 7317 #if !defined(Strtol) && defined(HAS_STRTOL) 7318 # define Strtol strtol 7319 #endif 7320 #ifndef Atol 7321 /* It would be more fashionable to use Strtol() to define atol() 7322 * (as is done for Atoul(), see below) but for backward compatibility 7323 * we just assume atol(). */ 7324 # if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && defined(HAS_ATOLL) && \ 7325 (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) 7326 # ifdef WIN64 7327 # define atoll _atoi64 /* secret handshake */ 7328 # endif 7329 # define Atol atoll 7330 # else 7331 # define Atol atol 7332 # endif 7333 #endif 7334 7335 #if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && \ 7336 (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) 7337 # ifdef __hpux 7338 # define strtoull __strtoull /* secret handshake */ 7339 # endif 7340 # if defined(WIN64) && defined(_MSC_VER) 7341 # define strtoull _strtoui64 /* secret handshake */ 7342 # endif 7343 # if !defined(Strtoul) && defined(HAS_STRTOULL) 7344 # define Strtoul strtoull 7345 # endif 7346 # if !defined(Strtoul) && defined(HAS_STRTOUQ) 7347 # define Strtoul strtouq 7348 # endif 7349 /* is there atouq() anywhere? */ 7350 #endif 7351 #if !defined(Strtoul) && defined(HAS_STRTOUL) 7352 # define Strtoul strtoul 7353 #endif 7354 #if !defined(Strtoul) && defined(HAS_STRTOL) /* Last resort. */ 7355 # define Strtoul(s, e, b) strchr((s), '-') ? ULONG_MAX : (unsigned long)strtol((s), (e), (b)) 7356 #endif 7357 #ifndef Atoul 7358 # define Atoul(s) Strtoul(s, NULL, 10) 7359 #endif 7360 7361 #define grok_bin(s,lp,fp,rp) \ 7362 grok_bin_oct_hex(s, lp, fp, rp, 1, _CC_BINDIGIT, 'b') 7363 #define grok_oct(s,lp,fp,rp) \ 7364 (*(fp) |= PERL_SCAN_DISALLOW_PREFIX, \ 7365 grok_bin_oct_hex(s, lp, fp, rp, 3, _CC_OCTDIGIT, '\0')) 7366 #define grok_hex(s,lp,fp,rp) \ 7367 grok_bin_oct_hex(s, lp, fp, rp, 4, _CC_XDIGIT, 'x') 7368 7369 #ifndef PERL_SCRIPT_MODE 7370 #define PERL_SCRIPT_MODE "r" 7371 #endif 7372 7373 /* not used. Kept as a NOOP for backcompat */ 7374 #define PERL_STACK_OVERFLOW_CHECK() NOOP 7375 7376 /* 7377 * Some nonpreemptive operating systems find it convenient to 7378 * check for asynchronous conditions after each op execution. 7379 * Keep this check simple, or it may slow down execution 7380 * massively. 7381 */ 7382 7383 #ifndef PERL_MICRO 7384 # ifndef PERL_ASYNC_CHECK 7385 # define PERL_ASYNC_CHECK() if (UNLIKELY(PL_sig_pending)) PL_signalhook(aTHX) 7386 # endif 7387 #endif 7388 7389 #ifndef PERL_ASYNC_CHECK 7390 # define PERL_ASYNC_CHECK() NOOP 7391 #endif 7392 7393 /* 7394 * On some operating systems, a memory allocation may succeed, 7395 * but put the process too close to the system's comfort limit. 7396 * In this case, PERL_ALLOC_CHECK frees the pointer and sets 7397 * it to NULL. 7398 */ 7399 #ifndef PERL_ALLOC_CHECK 7400 #define PERL_ALLOC_CHECK(p) NOOP 7401 #endif 7402 7403 #ifdef HAS_SEM 7404 # include <sys/ipc.h> 7405 # include <sys/sem.h> 7406 # ifndef HAS_UNION_SEMUN /* Provide the union semun. */ 7407 union semun { 7408 int val; 7409 struct semid_ds *buf; 7410 unsigned short *array; 7411 }; 7412 # endif 7413 # ifdef USE_SEMCTL_SEMUN 7414 # ifdef IRIX32_SEMUN_BROKEN_BY_GCC 7415 union gccbug_semun { 7416 int val; 7417 struct semid_ds *buf; 7418 unsigned short *array; 7419 char __dummy[5]; 7420 }; 7421 # define semun gccbug_semun 7422 # endif 7423 # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun) 7424 # elif defined(USE_SEMCTL_SEMID_DS) 7425 # ifdef EXTRA_F_IN_SEMUN_BUF 7426 # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buff) 7427 # else 7428 # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf) 7429 # endif 7430 # endif 7431 #endif 7432 7433 /* 7434 * Boilerplate macros for initializing and accessing interpreter-local 7435 * data from C. All statics in extensions should be reworked to use 7436 * this, if you want to make the extension thread-safe. See 7437 * ext/XS/APItest/APItest.xs for an example of the use of these macros, 7438 * and perlxs.pod for more. 7439 * 7440 * Code that uses these macros is responsible for the following: 7441 * 1. #define MY_CXT_KEY to a unique string, e.g. 7442 * "DynaLoader::_guts" XS_VERSION 7443 * XXX in the current implementation, this string is ignored. 7444 * 2. Declare a typedef named my_cxt_t that is a structure that contains 7445 * all the data that needs to be interpreter-local. 7446 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. 7447 * 4. Use the MY_CXT_INIT macro such that it is called exactly once 7448 * (typically put in the BOOT: section). 7449 * 5. Use the members of the my_cxt_t structure everywhere as 7450 * MY_CXT.member. 7451 * 6. Use the dMY_CXT macro (a declaration) in all the functions that 7452 * access MY_CXT. 7453 */ 7454 7455 #if defined(MULTIPLICITY) 7456 7457 /* START_MY_CXT must appear in all extensions that define a my_cxt_t structure, 7458 * right after the definition (i.e. at file scope). The non-threads 7459 * case below uses it to declare the data as static. */ 7460 # define START_MY_CXT static int my_cxt_index = -1; 7461 # define MY_CXT_INDEX my_cxt_index 7462 # define MY_CXT_INIT_ARG &my_cxt_index 7463 7464 /* Creates and zeroes the per-interpreter data. 7465 * (We allocate my_cxtp in a Perl SV so that it will be released when 7466 * the interpreter goes away.) */ 7467 # define MY_CXT_INIT \ 7468 my_cxt_t *my_cxtp = \ 7469 (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \ 7470 PERL_UNUSED_VAR(my_cxtp) 7471 # define MY_CXT_INIT_INTERP(my_perl) \ 7472 my_cxt_t *my_cxtp = \ 7473 (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \ 7474 PERL_UNUSED_VAR(my_cxtp) 7475 7476 /* This declaration should be used within all functions that use the 7477 * interpreter-local data. */ 7478 # define dMY_CXT \ 7479 my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX] 7480 # define dMY_CXT_INTERP(my_perl) \ 7481 my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX] 7482 7483 /* Clones the per-interpreter data. */ 7484 # define MY_CXT_CLONE \ 7485 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ 7486 void * old_my_cxtp = PL_my_cxt_list[MY_CXT_INDEX]; \ 7487 PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp; \ 7488 Copy(old_my_cxtp, my_cxtp, 1, my_cxt_t); 7489 7490 7491 7492 /* This macro must be used to access members of the my_cxt_t structure. 7493 * e.g. MY_CXT.some_data */ 7494 # define MY_CXT (*my_cxtp) 7495 7496 /* Judicious use of these macros can reduce the number of times dMY_CXT 7497 * is used. Use is similar to pTHX, aTHX etc. */ 7498 # define pMY_CXT my_cxt_t *my_cxtp 7499 # define pMY_CXT_ pMY_CXT, 7500 # define _pMY_CXT ,pMY_CXT 7501 # define aMY_CXT my_cxtp 7502 # define aMY_CXT_ aMY_CXT, 7503 # define _aMY_CXT ,aMY_CXT 7504 7505 #else /* MULTIPLICITY */ 7506 # define START_MY_CXT static my_cxt_t my_cxt; 7507 # define dMY_CXT dNOOP 7508 # define dMY_CXT_INTERP(my_perl) dNOOP 7509 # define MY_CXT_INIT NOOP 7510 # define MY_CXT_CLONE NOOP 7511 # define MY_CXT my_cxt 7512 7513 # define pMY_CXT void 7514 # define pMY_CXT_ 7515 # define _pMY_CXT 7516 # define aMY_CXT 7517 # define aMY_CXT_ 7518 # define _aMY_CXT 7519 7520 #endif /* !defined(MULTIPLICITY) */ 7521 7522 #ifdef I_FCNTL 7523 # include <fcntl.h> 7524 #endif 7525 7526 #ifdef __Lynx__ 7527 # include <fcntl.h> 7528 #endif 7529 7530 #ifdef __amigaos4__ 7531 # undef FD_CLOEXEC /* a lie in AmigaOS */ 7532 #endif 7533 7534 #ifdef I_SYS_FILE 7535 # include <sys/file.h> 7536 #endif 7537 7538 #if defined(HAS_FLOCK) && !defined(HAS_FLOCK_PROTO) 7539 EXTERN_C int flock(int fd, int op); 7540 #endif 7541 7542 #ifndef O_RDONLY 7543 /* Assume UNIX defaults */ 7544 # define O_RDONLY 0000 7545 # define O_WRONLY 0001 7546 # define O_RDWR 0002 7547 # define O_CREAT 0100 7548 #endif 7549 7550 #ifndef O_BINARY 7551 # define O_BINARY 0 7552 #endif 7553 7554 #ifndef O_TEXT 7555 # define O_TEXT 0 7556 #endif 7557 7558 #if O_TEXT != O_BINARY 7559 /* If you have different O_TEXT and O_BINARY and you are a CRLF shop, 7560 * that is, you are somehow DOSish. */ 7561 # if defined(__HAIKU__) || defined(__VOS__) || defined(__CYGWIN__) 7562 /* Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect; 7563 * Haiku is always UNIXoid (LF), not DOSish (CRLF). */ 7564 /* VOS has O_TEXT != O_BINARY, and they have effect, 7565 * but VOS always uses LF, never CRLF. */ 7566 /* If you have O_TEXT different from your O_BINARY but you still are 7567 * not a CRLF shop. */ 7568 # undef PERLIO_USING_CRLF 7569 # else 7570 /* If you really are DOSish. */ 7571 # define PERLIO_USING_CRLF 1 7572 # endif 7573 #endif 7574 7575 #ifdef I_LIBUTIL 7576 # include <libutil.h> /* setproctitle() in some FreeBSDs */ 7577 #endif 7578 7579 #ifndef EXEC_ARGV_CAST 7580 #define EXEC_ARGV_CAST(x) (char **)x 7581 #endif 7582 7583 #define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not 7584 int). value returned in pointed- 7585 to UV */ 7586 #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */ 7587 #define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation or infnan */ 7588 #define IS_NUMBER_NEG 0x08 /* leading minus sign */ 7589 #define IS_NUMBER_INFINITY 0x10 /* this is big */ 7590 #define IS_NUMBER_NAN 0x20 /* this is not */ 7591 #define IS_NUMBER_TRAILING 0x40 /* number has trailing trash */ 7592 7593 /* 7594 =for apidoc_section $numeric 7595 7596 =for apidoc AmdR|bool|GROK_NUMERIC_RADIX|NN const char **sp|NN const char *send 7597 7598 A synonym for L</grok_numeric_radix> 7599 7600 =cut 7601 */ 7602 #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) 7603 7604 /* Number scan flags. All are used for input, the ones used for output are so 7605 * marked */ 7606 #define PERL_SCAN_ALLOW_UNDERSCORES 0x01 /* grok_??? accept _ in numbers */ 7607 #define PERL_SCAN_DISALLOW_PREFIX 0x02 /* grok_??? reject 0x in hex etc */ 7608 7609 /* grok_??? input: ignored; output: found overflow */ 7610 #define PERL_SCAN_GREATER_THAN_UV_MAX 0x04 7611 7612 /* grok_??? don't warn about illegal digits. To preserve total backcompat, 7613 * this isn't set on output if one is found. Instead, see 7614 * PERL_SCAN_NOTIFY_ILLDIGIT. */ 7615 #define PERL_SCAN_SILENT_ILLDIGIT 0x08 7616 7617 #define PERL_SCAN_TRAILING 0x10 /* grok_number_flags() allow trailing 7618 and set IS_NUMBER_TRAILING */ 7619 7620 /* These are considered experimental, so not exposed publicly */ 7621 #if defined(PERL_CORE) || defined(PERL_EXT) 7622 /* grok_??? don't warn about very large numbers which are <= UV_MAX; 7623 * output: found such a number */ 7624 # define PERL_SCAN_SILENT_NON_PORTABLE 0x20 7625 7626 /* If this is set on input, and no illegal digit is found, it will be cleared 7627 * on output; otherwise unchanged */ 7628 # define PERL_SCAN_NOTIFY_ILLDIGIT 0x40 7629 7630 /* Don't warn on overflow; output flag still set */ 7631 # define PERL_SCAN_SILENT_OVERFLOW 0x80 7632 7633 /* Forbid a leading underscore, which the other one doesn't */ 7634 # define PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES (0x100|PERL_SCAN_ALLOW_UNDERSCORES) 7635 #endif 7636 7637 7638 /* to let user control profiling */ 7639 #ifdef PERL_GPROF_CONTROL 7640 extern void moncontrol(int); 7641 #define PERL_GPROF_MONCONTROL(x) moncontrol(x) 7642 #else 7643 #define PERL_GPROF_MONCONTROL(x) 7644 #endif 7645 7646 /* ISO 6429 NEL - C1 control NExt Line */ 7647 /* See https://www.unicode.org/reports/tr13/ */ 7648 #define NEXT_LINE_CHAR NEXT_LINE_NATIVE 7649 7650 #ifndef PIPESOCK_MODE 7651 # define PIPESOCK_MODE 7652 #endif 7653 7654 #ifndef SOCKET_OPEN_MODE 7655 # define SOCKET_OPEN_MODE PIPESOCK_MODE 7656 #endif 7657 7658 #ifndef PIPE_OPEN_MODE 7659 # define PIPE_OPEN_MODE PIPESOCK_MODE 7660 #endif 7661 7662 #define PERL_MAGIC_UTF8_CACHESIZE 2 7663 7664 #ifdef PERL_CORE 7665 7666 #define PERL_UNICODE_STDIN_FLAG 0x0001 7667 #define PERL_UNICODE_STDOUT_FLAG 0x0002 7668 #define PERL_UNICODE_STDERR_FLAG 0x0004 7669 #define PERL_UNICODE_IN_FLAG 0x0008 7670 #define PERL_UNICODE_OUT_FLAG 0x0010 7671 #define PERL_UNICODE_ARGV_FLAG 0x0020 7672 #define PERL_UNICODE_LOCALE_FLAG 0x0040 7673 #define PERL_UNICODE_WIDESYSCALLS_FLAG 0x0080 /* for Sarathy */ 7674 #define PERL_UNICODE_UTF8CACHEASSERT_FLAG 0x0100 7675 7676 #define PERL_UNICODE_STD_FLAG \ 7677 (PERL_UNICODE_STDIN_FLAG | \ 7678 PERL_UNICODE_STDOUT_FLAG | \ 7679 PERL_UNICODE_STDERR_FLAG) 7680 7681 #define PERL_UNICODE_INOUT_FLAG \ 7682 (PERL_UNICODE_IN_FLAG | \ 7683 PERL_UNICODE_OUT_FLAG) 7684 7685 #define PERL_UNICODE_DEFAULT_FLAGS \ 7686 (PERL_UNICODE_STD_FLAG | \ 7687 PERL_UNICODE_INOUT_FLAG | \ 7688 PERL_UNICODE_LOCALE_FLAG) 7689 7690 #define PERL_UNICODE_ALL_FLAGS 0x01ff 7691 7692 #define PERL_UNICODE_STDIN 'I' 7693 #define PERL_UNICODE_STDOUT 'O' 7694 #define PERL_UNICODE_STDERR 'E' 7695 #define PERL_UNICODE_STD 'S' 7696 #define PERL_UNICODE_IN 'i' 7697 #define PERL_UNICODE_OUT 'o' 7698 #define PERL_UNICODE_INOUT 'D' 7699 #define PERL_UNICODE_ARGV 'A' 7700 #define PERL_UNICODE_LOCALE 'L' 7701 #define PERL_UNICODE_WIDESYSCALLS 'W' 7702 #define PERL_UNICODE_UTF8CACHEASSERT 'a' 7703 7704 #endif 7705 7706 /* 7707 =for apidoc_section $signals 7708 =for apidoc Amn|U32|PERL_SIGNALS_UNSAFE_FLAG 7709 If this bit in C<PL_signals> is set, the system is uing the pre-Perl 5.8 7710 unsafe signals. See L<perlrun/PERL_SIGNALS> and L<perlipc/Deferred Signals 7711 (Safe Signals)>. 7712 7713 =cut 7714 */ 7715 #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 7716 7717 /* 7718 =for apidoc_section $numeric 7719 7720 =for apidoc Am|int|PERL_ABS|int x 7721 7722 Typeless C<abs> or C<fabs>, I<etc>. (The usage below indicates it is for 7723 integers, but it works for any type.) Use instead of these, since the C 7724 library ones force their argument to be what it is expecting, potentially 7725 leading to disaster. But also beware that this evaluates its argument twice, 7726 so no C<x++>. 7727 7728 =cut 7729 */ 7730 7731 #define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) 7732 7733 #if defined(__DECC) && defined(__osf__) 7734 #pragma message disable (mainparm) /* Perl uses the envp in main(). */ 7735 #endif 7736 7737 #define do_open(g, n, l, a, rm, rp, sf) \ 7738 do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0) 7739 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION 7740 # define do_exec(cmd) do_exec3(cmd,0,0) 7741 #endif 7742 #ifdef OS2 7743 # define do_aexec Perl_do_aexec 7744 #else 7745 # define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0) 7746 #endif 7747 7748 7749 /* 7750 =for apidoc_section $utility 7751 7752 =for apidoc Am|bool|IS_SAFE_SYSCALL|NN const char *pv|STRLEN len|NN const char *what|NN const char *op_name 7753 7754 Same as L</is_safe_syscall>. 7755 7756 =cut 7757 7758 Allows one ending \0 7759 */ 7760 #define IS_SAFE_SYSCALL(p, len, what, op_name) (Perl_is_safe_syscall(aTHX_ (p), (len), (what), (op_name))) 7761 7762 #define IS_SAFE_PATHNAME(p, len, op_name) IS_SAFE_SYSCALL((p), (len), "pathname", (op_name)) 7763 7764 #if defined(OEMVS) || defined(__amigaos4__) 7765 #define NO_ENV_ARRAY_IN_MAIN 7766 #endif 7767 7768 /* These are used by Perl_pv_escape() and Perl_pv_pretty() 7769 * are here so that they are available throughout the core 7770 * NOTE that even though some are for _escape and some for _pretty 7771 * there must not be any clashes as the flags from _pretty are 7772 * passed straight through to _escape. 7773 */ 7774 7775 #define PERL_PV_ESCAPE_QUOTE 0x000001 7776 #define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE 7777 7778 #define PERL_PV_PRETTY_ELLIPSES 0x000002 7779 #define PERL_PV_PRETTY_LTGT 0x000004 7780 #define PERL_PV_PRETTY_EXACTSIZE 0x000008 7781 7782 #define PERL_PV_ESCAPE_UNI 0x000100 7783 #define PERL_PV_ESCAPE_UNI_DETECT 0x000200 7784 #define PERL_PV_ESCAPE_NONASCII 0x000400 7785 #define PERL_PV_ESCAPE_FIRSTCHAR 0x000800 7786 7787 #define PERL_PV_ESCAPE_ALL 0x001000 7788 #define PERL_PV_ESCAPE_NOBACKSLASH 0x002000 7789 #define PERL_PV_ESCAPE_NOCLEAR 0x004000 7790 #define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR 7791 #define PERL_PV_ESCAPE_RE 0x008000 7792 7793 /* Escape PV with hex, except leave NULs as octal: */ 7794 #define PERL_PV_ESCAPE_DWIM 0x010000 7795 7796 /* Escape PV with all hex, including NUL. */ 7797 #define PERL_PV_ESCAPE_DWIM_ALL_HEX 0x020000 7798 7799 7800 /* used by pv_display in dump.c*/ 7801 #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE 7802 #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII 7803 7804 #if DOUBLEKIND == DOUBLE_IS_VAX_F_FLOAT || \ 7805 DOUBLEKIND == DOUBLE_IS_VAX_D_FLOAT || \ 7806 DOUBLEKIND == DOUBLE_IS_VAX_G_FLOAT 7807 # define DOUBLE_IS_VAX_FLOAT 7808 #else 7809 # define DOUBLE_IS_IEEE_FORMAT 7810 #endif 7811 7812 #if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN || \ 7813 DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN || \ 7814 DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 7815 # define DOUBLE_LITTLE_ENDIAN 7816 #endif 7817 7818 #if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN || \ 7819 DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN || \ 7820 DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 7821 # define DOUBLE_BIG_ENDIAN 7822 #endif 7823 7824 #if DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE || \ 7825 DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE 7826 # define DOUBLE_MIX_ENDIAN 7827 #endif 7828 7829 /* The VAX fp formats are neither consistently little-endian nor 7830 * big-endian, and neither are they really IEEE-mixed endian like 7831 * the mixed-endian ARM IEEE formats (with swapped bytes). 7832 * Ultimately, the VAX format came from the PDP-11. 7833 * 7834 * The ordering of the parts in VAX floats is quite vexing. 7835 * In the below the fraction_n are the mantissa bits. 7836 * 7837 * The fraction_1 is the most significant (numbering as by DEC/Digital), 7838 * while the rightmost bit in each fraction is the least significant: 7839 * in other words, big-endian bit order within the fractions. 7840 * 7841 * The fraction segments themselves would be big-endianly, except that 7842 * within 32 bit segments the less significant half comes first, the more 7843 * significant after, except that in the format H (used for long doubles) 7844 * the first fraction segment is alone, because the exponent is wider. 7845 * This means for example that both the most and the least significant 7846 * bits can be in the middle of the floats, not at either end. 7847 * 7848 * References: 7849 * http://nssdc.gsfc.nasa.gov/nssdc/formats/VAXFloatingPoint.htm 7850 * http://www.quadibloc.com/comp/cp0201.htm 7851 * http://h71000.www7.hp.com/doc/82final/6443/6443pro_028.html 7852 * (somebody at HP should be fired for the URLs) 7853 * 7854 * F fraction_2:16 sign:1 exp:8 fraction_1:7 7855 * (exponent bias 128, hidden first one-bit) 7856 * 7857 * D fraction_2:16 sign:1 exp:8 fraction_1:7 7858 * fraction_4:16 fraction_3:16 7859 * (exponent bias 128, hidden first one-bit) 7860 * 7861 * G fraction_2:16 sign:1 exp:11 fraction_1:4 7862 * fraction_4:16 fraction_3:16 7863 * (exponent bias 1024, hidden first one-bit) 7864 * 7865 * H fraction_1:16 sign:1 exp:15 7866 * fraction_3:16 fraction_2:16 7867 * fraction_5:16 fraction_4:16 7868 * fraction_7:16 fraction_6:16 7869 * (exponent bias 16384, hidden first one-bit) 7870 * (available only on VAX, and only on Fortran?) 7871 * 7872 * The formats S, T and X are available on the Alpha (and Itanium, 7873 * also known as I64/IA64) and are equivalent with the IEEE-754 formats 7874 * binary32, binary64, and binary128 (commonly: float, double, long double). 7875 * 7876 * S sign:1 exp:8 mantissa:23 7877 * (exponent bias 127, hidden first one-bit) 7878 * 7879 * T sign:1 exp:11 mantissa:52 7880 * (exponent bias 1022, hidden first one-bit) 7881 * 7882 * X sign:1 exp:15 mantissa:112 7883 * (exponent bias 16382, hidden first one-bit) 7884 * 7885 */ 7886 7887 #ifdef DOUBLE_IS_VAX_FLOAT 7888 # define DOUBLE_VAX_ENDIAN 7889 #endif 7890 7891 #ifdef DOUBLE_IS_IEEE_FORMAT 7892 /* All the basic IEEE formats have the implicit bit, 7893 * except for the x86 80-bit extended formats, which will undef this. 7894 * Also note that the IEEE 754 subnormals (formerly known as denormals) 7895 * do not have the implicit bit of one. */ 7896 # define NV_IMPLICIT_BIT 7897 #endif 7898 7899 #if defined(LONG_DOUBLEKIND) && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE 7900 7901 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \ 7902 LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ 7903 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE 7904 # define LONGDOUBLE_LITTLE_ENDIAN 7905 # endif 7906 7907 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \ 7908 LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \ 7909 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE 7910 # define LONGDOUBLE_BIG_ENDIAN 7911 # endif 7912 7913 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE || \ 7914 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE 7915 # define LONGDOUBLE_MIX_ENDIAN 7916 # endif 7917 7918 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ 7919 LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 7920 # define LONGDOUBLE_X86_80_BIT 7921 # ifdef USE_LONG_DOUBLE 7922 # undef NV_IMPLICIT_BIT 7923 # define NV_X86_80_BIT 7924 # endif 7925 # endif 7926 7927 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE || \ 7928 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE || \ 7929 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE || \ 7930 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE 7931 # define LONGDOUBLE_DOUBLEDOUBLE 7932 # endif 7933 7934 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_VAX_H_FLOAT 7935 # define LONGDOUBLE_VAX_ENDIAN 7936 # endif 7937 7938 #endif /* LONG_DOUBLEKIND */ 7939 7940 #ifdef USE_QUADMATH /* assume quadmath endianness == native double endianness */ 7941 # if defined(DOUBLE_LITTLE_ENDIAN) 7942 # define NV_LITTLE_ENDIAN 7943 # elif defined(DOUBLE_BIG_ENDIAN) 7944 # define NV_BIG_ENDIAN 7945 # elif defined(DOUBLE_MIX_ENDIAN) /* stretch */ 7946 # define NV_MIX_ENDIAN 7947 # endif 7948 #elif NVSIZE == DOUBLESIZE 7949 # ifdef DOUBLE_LITTLE_ENDIAN 7950 # define NV_LITTLE_ENDIAN 7951 # endif 7952 # ifdef DOUBLE_BIG_ENDIAN 7953 # define NV_BIG_ENDIAN 7954 # endif 7955 # ifdef DOUBLE_MIX_ENDIAN 7956 # define NV_MIX_ENDIAN 7957 # endif 7958 # ifdef DOUBLE_VAX_ENDIAN 7959 # define NV_VAX_ENDIAN 7960 # endif 7961 #elif NVSIZE == LONG_DOUBLESIZE 7962 # ifdef LONGDOUBLE_LITTLE_ENDIAN 7963 # define NV_LITTLE_ENDIAN 7964 # endif 7965 # ifdef LONGDOUBLE_BIG_ENDIAN 7966 # define NV_BIG_ENDIAN 7967 # endif 7968 # ifdef LONGDOUBLE_MIX_ENDIAN 7969 # define NV_MIX_ENDIAN 7970 # endif 7971 # ifdef LONGDOUBLE_VAX_ENDIAN 7972 # define NV_VAX_ENDIAN 7973 # endif 7974 #endif 7975 7976 /* We have somehow managed not to define the denormal/subnormal 7977 * detection. 7978 * 7979 * This may happen if the compiler doesn't expose the C99 math like 7980 * the fpclassify() without some special switches. Perl tries to 7981 * stay C89, so for example -std=c99 is not an option. 7982 * 7983 * The Perl_isinf() and Perl_isnan() should have been defined even if 7984 * the C99 isinf() and isnan() are unavailable, and the NV_MIN becomes 7985 * from the C89 DBL_MIN or moral equivalent. */ 7986 #if !defined(Perl_fp_class_denorm) && defined(Perl_isinf) && defined(Perl_isnan) && defined(NV_MIN) 7987 # define Perl_fp_class_denorm(x) ((x) != 0.0 && !Perl_isinf(x) && !Perl_isnan(x) && PERL_ABS(x) < NV_MIN) 7988 #endif 7989 7990 /* This is not a great fallback: subnormals tests will fail, 7991 * but at least Perl will link and 99.999% of tests will work. */ 7992 #if !defined(Perl_fp_class_denorm) 7993 # define Perl_fp_class_denorm(x) FALSE 7994 #endif 7995 7996 #ifdef DOUBLE_IS_IEEE_FORMAT 7997 # define DOUBLE_HAS_INF 7998 # define DOUBLE_HAS_NAN 7999 #endif 8000 8001 #ifdef DOUBLE_HAS_NAN 8002 8003 START_EXTERN_C 8004 8005 #ifdef DOINIT 8006 8007 /* PL_inf and PL_nan initialization. 8008 * 8009 * For inf and nan initialization the ultimate fallback is dividing 8010 * one or zero by zero: however, some compilers will warn or even fail 8011 * on divide-by-zero, but hopefully something earlier will work. 8012 * 8013 * If you are thinking of using HUGE_VAL for infinity, or using 8014 * <math.h> functions to generate NV_INF (e.g. exp(1e9), log(-1.0)), 8015 * stop. Neither will work portably: HUGE_VAL can be just DBL_MAX, 8016 * and the math functions might be just generating DBL_MAX, or even zero. 8017 * 8018 * Also, do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF). 8019 * Though logically correct, some compilers (like Visual C 2003) 8020 * falsely misoptimize that to zero (x-x is always zero, right?) 8021 * 8022 * Finally, note that not all floating point formats define Inf (or NaN). 8023 * For the infinity a large number may be used instead. Operations that 8024 * under the IEEE floating point would return Inf or NaN may return 8025 * either large numbers (positive or negative), or they may cause 8026 * a floating point exception or some other fault. 8027 */ 8028 8029 /* The quadmath literals are anon structs which -Wc++-compat doesn't like. */ 8030 # ifndef USE_CPLUSPLUS 8031 GCC_DIAG_IGNORE_DECL(-Wc++-compat); 8032 # endif 8033 8034 # ifdef USE_QUADMATH 8035 /* Cannot use HUGE_VALQ for PL_inf because not a compile-time 8036 * constant. */ 8037 INFNAN_NV_U8_DECL PL_inf = { 1.0Q/0.0Q }; 8038 # elif NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLINFBYTES) 8039 INFNAN_U8_NV_DECL PL_inf = { { LONGDBLINFBYTES } }; 8040 # elif NVSIZE == DOUBLESIZE && defined(DOUBLEINFBYTES) 8041 INFNAN_U8_NV_DECL PL_inf = { { DOUBLEINFBYTES } }; 8042 # else 8043 # if NVSIZE == LONG_DOUBLESIZE && defined(USE_LONG_DOUBLE) 8044 # if defined(LDBL_INFINITY) 8045 INFNAN_NV_U8_DECL PL_inf = { LDBL_INFINITY }; 8046 # elif defined(LDBL_INF) 8047 INFNAN_NV_U8_DECL PL_inf = { LDBL_INF }; 8048 # elif defined(INFINITY) 8049 INFNAN_NV_U8_DECL PL_inf = { (NV)INFINITY }; 8050 # elif defined(INF) 8051 INFNAN_NV_U8_DECL PL_inf = { (NV)INF }; 8052 # else 8053 INFNAN_NV_U8_DECL PL_inf = { 1.0L/0.0L }; /* keep last */ 8054 # endif 8055 # else 8056 # if defined(DBL_INFINITY) 8057 INFNAN_NV_U8_DECL PL_inf = { DBL_INFINITY }; 8058 # elif defined(DBL_INF) 8059 INFNAN_NV_U8_DECL PL_inf = { DBL_INF }; 8060 # elif defined(INFINITY) /* C99 */ 8061 INFNAN_NV_U8_DECL PL_inf = { (NV)INFINITY }; 8062 # elif defined(INF) 8063 INFNAN_NV_U8_DECL PL_inf = { (NV)INF }; 8064 # else 8065 INFNAN_NV_U8_DECL PL_inf = { 1.0/0.0 }; /* keep last */ 8066 # endif 8067 # endif 8068 # endif 8069 8070 # ifdef USE_QUADMATH 8071 /* Cannot use nanq("0") for PL_nan because not a compile-time 8072 * constant. */ 8073 INFNAN_NV_U8_DECL PL_nan = { 0.0Q/0.0Q }; 8074 # elif NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLNANBYTES) 8075 INFNAN_U8_NV_DECL PL_nan = { { LONGDBLNANBYTES } }; 8076 # elif NVSIZE == DOUBLESIZE && defined(DOUBLENANBYTES) 8077 INFNAN_U8_NV_DECL PL_nan = { { DOUBLENANBYTES } }; 8078 # else 8079 # if NVSIZE == LONG_DOUBLESIZE && defined(USE_LONG_DOUBLE) 8080 # if defined(LDBL_NAN) 8081 INFNAN_NV_U8_DECL PL_nan = { LDBL_NAN }; 8082 # elif defined(LDBL_QNAN) 8083 INFNAN_NV_U8_DECL PL_nan = { LDBL_QNAN }; 8084 # elif defined(NAN) 8085 INFNAN_NV_U8_DECL PL_nan = { (NV)NAN }; 8086 # else 8087 INFNAN_NV_U8_DECL PL_nan = { 0.0L/0.0L }; /* keep last */ 8088 # endif 8089 # else 8090 # if defined(DBL_NAN) 8091 INFNAN_NV_U8_DECL PL_nan = { DBL_NAN }; 8092 # elif defined(DBL_QNAN) 8093 INFNAN_NV_U8_DECL PL_nan = { DBL_QNAN }; 8094 # elif defined(NAN) /* C99 */ 8095 INFNAN_NV_U8_DECL PL_nan = { (NV)NAN }; 8096 # else 8097 INFNAN_NV_U8_DECL PL_nan = { 0.0/0.0 }; /* keep last */ 8098 # endif 8099 # endif 8100 # endif 8101 8102 # ifndef USE_CPLUSPLUS 8103 GCC_DIAG_RESTORE_DECL; 8104 # endif 8105 8106 #else 8107 8108 /* The declarations here need to match the initializations done above, 8109 since a mismatch across compilation units causes undefined 8110 behavior. It also prevents warnings from LTO builds. 8111 */ 8112 # if !defined(USE_QUADMATH) && \ 8113 (NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLINFBYTES) || \ 8114 NVSIZE == DOUBLESIZE && defined(DOUBLEINFBYTES)) 8115 INFNAN_U8_NV_DECL PL_inf; 8116 # else 8117 INFNAN_NV_U8_DECL PL_inf; 8118 # endif 8119 8120 # if !defined(USE_QUADMATH) && \ 8121 (NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLNANBYTES) || \ 8122 NVSIZE == DOUBLESIZE && defined(DOUBLENANBYTES)) 8123 INFNAN_U8_NV_DECL PL_nan; 8124 # else 8125 INFNAN_NV_U8_DECL PL_nan; 8126 # endif 8127 8128 #endif 8129 8130 END_EXTERN_C 8131 8132 /* If you have not defined NV_INF/NV_NAN (like for example win32/win32.h), 8133 * we will define NV_INF/NV_NAN as the nv part of the global const 8134 * PL_inf/PL_nan. Note, however, that the preexisting NV_INF/NV_NAN 8135 * might not be a compile-time constant, in which case it cannot be 8136 * used to initialize PL_inf/PL_nan above. */ 8137 #ifndef NV_INF 8138 # define NV_INF PL_inf.nv 8139 #endif 8140 #ifndef NV_NAN 8141 # define NV_NAN PL_nan.nv 8142 #endif 8143 8144 /* NaNs (not-a-numbers) can carry payload bits, in addition to 8145 * "nan-ness". Part of the payload is the quiet/signaling bit. 8146 * To back up a bit (harhar): 8147 * 8148 * For IEEE 754 64-bit formats [1]: 8149 * 8150 * s 000 (mantissa all-zero) zero 8151 * s 000 (mantissa non-zero) subnormals (denormals) 8152 * s 001 ... 7fe normals 8153 * s 7ff q nan 8154 * 8155 * For IEEE 754 128-bit formats: 8156 * 8157 * s 0000 (mantissa all-zero) zero 8158 * s 0000 (mantissa non-zero) subnormals (denormals) 8159 * s 0001 ... 7ffe normals 8160 * s 7fff q nan 8161 * 8162 * [1] this looks like big-endian, but applies equally to little-endian. 8163 * 8164 * s = Sign bit. Yes, zeros and nans can have negative sign, 8165 * the interpretation is application-specific. 8166 * 8167 * q = Quietness bit, the interpretation is platform-specific. 8168 * Most platforms have the most significant bit being one 8169 * meaning quiet, but some (older mips, hppa) have the msb 8170 * being one meaning signaling. Note that the above means 8171 * that on most platforms there cannot be signaling nan with 8172 * zero payload because that is identical with infinity; 8173 * while conversely on older mips/hppa there cannot be a quiet nan 8174 * because that is identical with infinity. 8175 * 8176 * Moreover, whether there is any behavioral difference 8177 * between quiet and signaling NaNs, depends on the platform. 8178 * 8179 * x86 80-bit extended precision is different, the mantissa bits: 8180 * 8181 * 63 62 61 30387+ pre-387 visual c 8182 * -------- ---- -------- -------- 8183 * 0 0 0 invalid infinity 8184 * 0 0 1 invalid snan 8185 * 0 1 0 invalid snan 8186 * 0 1 1 invalid snan 8187 * 1 0 0 infinity snan 1.#INF 8188 * 1 0 1 snan 1.#SNAN 8189 * 1 1 0 qnan -1.#IND (x86 chooses this to negative) 8190 * 1 1 1 qnan 1.#QNAN 8191 * 8192 * This means that in this format there are 61 bits available 8193 * for the nan payload. 8194 * 8195 * Note that the 32-bit x86 ABI cannot do signaling nans: the x87 8196 * simply cannot preserve the bit. You can either use the 80-bit 8197 * extended precision (long double, -Duselongdouble), or use x86-64. 8198 * 8199 * In all platforms, the payload bytes (and bits, some of them are 8200 * often in a partial byte) themselves can be either all zero (x86), 8201 * all one (sparc or mips), or a mixture: in IEEE 754 128-bit double 8202 * or in a double-double, the first half of the payload can follow the 8203 * native double, while in the second half the payload can be all 8204 * zeros. (Therefore the mask for payload bits is not necessarily 8205 * identical to bit complement of the NaN.) Another way of putting 8206 * this: the payload for the default NaN might not be zero. 8207 * 8208 * For the x86 80-bit long doubles, the trailing bytes (the 80 bits 8209 * being 'packaged' in either 12 or 16 bytes) can be whatever random 8210 * garbage. 8211 * 8212 * Furthermore, the semantics of the sign bit on NaNs are platform-specific. 8213 * On normal floats, the sign bit being on means negative. But this may, 8214 * or may not, be reverted on NaNs: in other words, the default NaN might 8215 * have the sign bit on, and therefore look like negative if you look 8216 * at it at the bit level. 8217 * 8218 * NaN payloads are not propagated even on copies, or in arithmetics. 8219 * They *might* be, according to some rules, on your particular 8220 * cpu/os/compiler/libraries, but no guarantees. 8221 * 8222 * To summarize, on most platforms, and for 64-bit doubles 8223 * (using big-endian ordering here): 8224 * 8225 * [7FF8000000000000..7FFFFFFFFFFFFFFF] quiet 8226 * [FFF8000000000000..FFFFFFFFFFFFFFFF] quiet 8227 * [7FF0000000000001..7FF7FFFFFFFFFFFF] signaling 8228 * [FFF0000000000001..FFF7FFFFFFFFFFFF] signaling 8229 * 8230 * The C99 nan() is supposed to generate *quiet* NaNs. 8231 * 8232 * Note the asymmetry: 8233 * The 7FF0000000000000 is positive infinity, 8234 * the FFF0000000000000 is negative infinity. 8235 */ 8236 8237 /* NVMANTBITS is the number of _real_ mantissa bits in an NV. 8238 * For the standard IEEE 754 fp this number is usually one less that 8239 * *DBL_MANT_DIG because of the implicit (aka hidden) bit, which isn't 8240 * real. For the 80-bit extended precision formats (x86*), the number 8241 * of mantissa bits... depends. For normal floats, it's 64. But for 8242 * the inf/nan, it's different (zero for inf, 61 for nan). 8243 * NVMANTBITS works for normal floats. */ 8244 8245 /* We do not want to include the quiet/signaling bit. */ 8246 #define NV_NAN_BITS (NVMANTBITS - 1) 8247 8248 #if defined(USE_LONG_DOUBLE) && NVSIZE > DOUBLESIZE 8249 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 8250 # define NV_NAN_QS_BYTE_OFFSET 13 8251 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 8252 # define NV_NAN_QS_BYTE_OFFSET 2 8253 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 8254 # define NV_NAN_QS_BYTE_OFFSET 7 8255 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 8256 # define NV_NAN_QS_BYTE_OFFSET 2 8257 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE 8258 # define NV_NAN_QS_BYTE_OFFSET 13 8259 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE 8260 # define NV_NAN_QS_BYTE_OFFSET 1 8261 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE 8262 # define NV_NAN_QS_BYTE_OFFSET 9 8263 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE 8264 # define NV_NAN_QS_BYTE_OFFSET 6 8265 # else 8266 # error "Unexpected long double format" 8267 # endif 8268 #else 8269 # ifdef USE_QUADMATH 8270 # ifdef NV_LITTLE_ENDIAN 8271 # define NV_NAN_QS_BYTE_OFFSET 13 8272 # elif defined(NV_BIG_ENDIAN) 8273 # define NV_NAN_QS_BYTE_OFFSET 2 8274 # else 8275 # error "Unexpected quadmath format" 8276 # endif 8277 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN 8278 # define NV_NAN_QS_BYTE_OFFSET 2 8279 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN 8280 # define NV_NAN_QS_BYTE_OFFSET 1 8281 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN 8282 # define NV_NAN_QS_BYTE_OFFSET 6 8283 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN 8284 # define NV_NAN_QS_BYTE_OFFSET 1 8285 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 8286 # define NV_NAN_QS_BYTE_OFFSET 13 8287 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 8288 # define NV_NAN_QS_BYTE_OFFSET 2 8289 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE 8290 # define NV_NAN_QS_BYTE_OFFSET 2 /* bytes 4 5 6 7 0 1 2 3 (MSB 7) */ 8291 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE 8292 # define NV_NAN_QS_BYTE_OFFSET 5 /* bytes 3 2 1 0 7 6 5 4 (MSB 7) */ 8293 # else 8294 /* For example the VAX formats should never 8295 * get here because they do not have NaN. */ 8296 # error "Unexpected double format" 8297 # endif 8298 #endif 8299 /* NV_NAN_QS_BYTE is the byte to test for the quiet/signaling */ 8300 #define NV_NAN_QS_BYTE(nvp) (((U8*)(nvp))[NV_NAN_QS_BYTE_OFFSET]) 8301 /* NV_NAN_QS_BIT is the bit to test in the NV_NAN_QS_BYTE_OFFSET 8302 * for the quiet/signaling */ 8303 #if defined(USE_LONG_DOUBLE) && \ 8304 (LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ 8305 LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN) 8306 # define NV_NAN_QS_BIT_SHIFT 6 /* 0x40 */ 8307 #elif defined(USE_LONG_DOUBLE) && \ 8308 (LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE || \ 8309 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE || \ 8310 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE || \ 8311 LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE) 8312 # define NV_NAN_QS_BIT_SHIFT 3 /* 0x08, but not via NV_NAN_BITS */ 8313 #else 8314 # define NV_NAN_QS_BIT_SHIFT ((NV_NAN_BITS) % 8) /* usually 3, or 0x08 */ 8315 #endif 8316 #define NV_NAN_QS_BIT (1 << (NV_NAN_QS_BIT_SHIFT)) 8317 /* NV_NAN_QS_BIT_OFFSET is the bit offset from the beginning of a NV 8318 * (bytes ordered big-endianly) for the quiet/signaling bit 8319 * for the quiet/signaling */ 8320 #define NV_NAN_QS_BIT_OFFSET \ 8321 (8 * (NV_NAN_QS_BYTE_OFFSET) + (NV_NAN_QS_BIT_SHIFT)) 8322 /* NV_NAN_QS_QUIET (always defined) is true if the NV_NAN_QS_QS_BIT being 8323 * on indicates quiet NaN. NV_NAN_QS_SIGNALING (also always defined) 8324 * is true if the NV_NAN_QS_BIT being on indicates signaling NaN. */ 8325 #define NV_NAN_QS_QUIET \ 8326 ((NV_NAN_QS_BYTE(PL_nan.u8) & NV_NAN_QS_BIT) == NV_NAN_QS_BIT) 8327 #define NV_NAN_QS_SIGNALING (!(NV_NAN_QS_QUIET)) 8328 #define NV_NAN_QS_TEST(nvp) (NV_NAN_QS_BYTE(nvp) & NV_NAN_QS_BIT) 8329 /* NV_NAN_IS_QUIET() returns true if the NV behind nvp is a NaN, 8330 * whether it is a quiet NaN, NV_NAN_IS_SIGNALING() if a signaling NaN. 8331 * Note however that these do not check whether the nvp is a NaN. */ 8332 #define NV_NAN_IS_QUIET(nvp) \ 8333 (NV_NAN_QS_TEST(nvp) == (NV_NAN_QS_QUIET ? NV_NAN_QS_BIT : 0)) 8334 #define NV_NAN_IS_SIGNALING(nvp) \ 8335 (NV_NAN_QS_TEST(nvp) == (NV_NAN_QS_QUIET ? 0 : NV_NAN_QS_BIT)) 8336 #define NV_NAN_SET_QUIET(nvp) \ 8337 (NV_NAN_QS_QUIET ? \ 8338 (NV_NAN_QS_BYTE(nvp) |= NV_NAN_QS_BIT) : \ 8339 (NV_NAN_QS_BYTE(nvp) &= ~NV_NAN_QS_BIT)) 8340 #define NV_NAN_SET_SIGNALING(nvp) \ 8341 (NV_NAN_QS_QUIET ? \ 8342 (NV_NAN_QS_BYTE(nvp) &= ~NV_NAN_QS_BIT) : \ 8343 (NV_NAN_QS_BYTE(nvp) |= NV_NAN_QS_BIT)) 8344 #define NV_NAN_QS_XOR(nvp) (NV_NAN_QS_BYTE(nvp) ^= NV_NAN_QS_BIT) 8345 8346 /* NV_NAN_PAYLOAD_MASK: masking the nan payload bits. 8347 * 8348 * NV_NAN_PAYLOAD_PERM: permuting the nan payload bytes. 8349 * 0xFF means "don't go here".*/ 8350 8351 /* Shorthands to avoid typoses. */ 8352 #define NV_NAN_PAYLOAD_MASK_SKIP_EIGHT \ 8353 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0 8354 #define NV_NAN_PAYLOAD_PERM_SKIP_EIGHT \ 8355 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff 8356 #define NV_NAN_PAYLOAD_PERM_0_TO_7 \ 8357 0x0, 0x1, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7 8358 #define NV_NAN_PAYLOAD_PERM_7_TO_0 \ 8359 0x7, 0x6, 0x5, 0x4, 0x3, 0x2, 0x1, 0x0 8360 #define NV_NAN_PAYLOAD_MASK_IEEE_754_128_LE \ 8361 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, \ 8362 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f, 0x00, 0x00 8363 #define NV_NAN_PAYLOAD_PERM_IEEE_754_128_LE \ 8364 NV_NAN_PAYLOAD_PERM_0_TO_7, \ 8365 0x8, 0x9, 0xa, 0xb, 0xc, 0xd, 0xFF, 0xFF 8366 #define NV_NAN_PAYLOAD_MASK_IEEE_754_128_BE \ 8367 0x00, 0x00, 0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, \ 8368 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff 8369 #define NV_NAN_PAYLOAD_PERM_IEEE_754_128_BE \ 8370 0xFF, 0xFF, 0xd, 0xc, 0xb, 0xa, 0x9, 0x8, \ 8371 NV_NAN_PAYLOAD_PERM_7_TO_0 8372 #define NV_NAN_PAYLOAD_MASK_IEEE_754_64_LE \ 8373 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x07, 0x00 8374 #define NV_NAN_PAYLOAD_PERM_IEEE_754_64_LE \ 8375 0x0, 0x1, 0x2, 0x3, 0x4, 0x5, 0x6, 0xFF 8376 #define NV_NAN_PAYLOAD_MASK_IEEE_754_64_BE \ 8377 0x00, 0x07, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff 8378 #define NV_NAN_PAYLOAD_PERM_IEEE_754_64_BE \ 8379 0xFF, 0x6, 0x5, 0x4, 0x3, 0x2, 0x1, 0x0 8380 8381 #if defined(USE_LONG_DOUBLE) && NVSIZE > DOUBLESIZE 8382 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 8383 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_128_LE 8384 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_128_LE 8385 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 8386 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_128_BE 8387 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_128_BE 8388 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 8389 # if LONG_DOUBLESIZE == 10 8390 # define NV_NAN_PAYLOAD_MASK \ 8391 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x1f, \ 8392 0x00, 0x00 8393 # define NV_NAN_PAYLOAD_PERM \ 8394 NV_NAN_PAYLOAD_PERM_0_TO_7, 0xFF, 0xFF 8395 # elif LONG_DOUBLESIZE == 12 8396 # define NV_NAN_PAYLOAD_MASK \ 8397 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x1f, \ 8398 0x00, 0x00, 0x00, 0x00 8399 # define NV_NAN_PAYLOAD_PERM \ 8400 NV_NAN_PAYLOAD_PERM_0_TO_7, 0xFF, 0xFF, 0xFF, 0xFF 8401 # elif LONG_DOUBLESIZE == 16 8402 # define NV_NAN_PAYLOAD_MASK \ 8403 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x1f, \ 8404 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 8405 # define NV_NAN_PAYLOAD_PERM \ 8406 NV_NAN_PAYLOAD_PERM_0_TO_7, \ 8407 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF 8408 # else 8409 # error "Unexpected x86 80-bit little-endian long double format" 8410 # endif 8411 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 8412 # if LONG_DOUBLESIZE == 10 8413 # define NV_NAN_PAYLOAD_MASK \ 8414 0x00, 0x00, 0x1f, 0xff, 0xff, 0xff, 0xff, 0xff, \ 8415 0xff, 0xff 8416 # define NV_NAN_PAYLOAD_PERM \ 8417 NV_NAN_PAYLOAD_PERM_7_TO_0, 0xFF, 0xFF 8418 # elif LONG_DOUBLESIZE == 12 8419 # define NV_NAN_PAYLOAD_MASK \ 8420 0x00, 0x00, 0x1f, 0xff, 0xff, 0xff, 0xff, 0xff, \ 8421 0xff, 0xff, 0x00, 0x00 8422 # define NV_NAN_PAYLOAD_PERM \ 8423 NV_NAN_PAYLOAD_PERM_7_TO_0, 0xFF, 0xFF, 0xFF, 0xFF 8424 # elif LONG_DOUBLESIZE == 16 8425 # define NV_NAN_PAYLOAD_MASK \ 8426 0x00, 0x00, 0x1f, 0xff, 0xff, 0xff, 0xff, 0xff, \ 8427 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 8428 # define NV_NAN_PAYLOAD_PERM \ 8429 NV_NAN_PAYLOAD_PERM_7_TO_0, \ 8430 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF 8431 # else 8432 # error "Unexpected x86 80-bit big-endian long double format" 8433 # endif 8434 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_LE 8435 /* For double-double we assume only the first double (in LE or BE terms) 8436 * is used for NaN. */ 8437 # define NV_NAN_PAYLOAD_MASK \ 8438 NV_NAN_PAYLOAD_MASK_SKIP_EIGHT, NV_NAN_PAYLOAD_MASK_IEEE_754_64_LE 8439 # define NV_NAN_PAYLOAD_PERM \ 8440 NV_NAN_PAYLOAD_PERM_SKIP_EIGHT, NV_NAN_PAYLOAD_PERM_IEEE_754_64_LE 8441 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE 8442 # define NV_NAN_PAYLOAD_MASK \ 8443 NV_NAN_PAYLOAD_MASK_IEEE_754_64_BE 8444 # define NV_NAN_PAYLOAD_PERM \ 8445 NV_NAN_PAYLOAD_PERM_IEEE_754_64_BE 8446 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LE_BE 8447 # define NV_NAN_PAYLOAD_MASK \ 8448 NV_NAN_PAYLOAD_MASK_IEEE_754_64_LE 8449 # define NV_NAN_PAYLOAD_PERM \ 8450 NV_NAN_PAYLOAD_PERM_IEEE_754_64_LE 8451 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_LE 8452 # define NV_NAN_PAYLOAD_MASK \ 8453 NV_NAN_PAYLOAD_MASK_SKIP_EIGHT, NV_NAN_PAYLOAD_MASK_IEEE_754_64_BE 8454 # define NV_NAN_PAYLOAD_PERM \ 8455 NV_NAN_PAYLOAD_PERM_SKIP_EIGHT, NV_NAN_PAYLOAD_PERM_IEEE_754_64_BE 8456 # else 8457 # error "Unexpected long double format" 8458 # endif 8459 #else 8460 # ifdef USE_QUADMATH /* quadmath is not long double */ 8461 # ifdef NV_LITTLE_ENDIAN 8462 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_128_LE 8463 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_128_LE 8464 # elif defined(NV_BIG_ENDIAN) 8465 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_128_BE 8466 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_128_BE 8467 # else 8468 # error "Unexpected quadmath format" 8469 # endif 8470 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN 8471 # define NV_NAN_PAYLOAD_MASK 0xff, 0xff, 0x07, 0x00 8472 # define NV_NAN_PAYLOAD_PERM 0x0, 0x1, 0x2, 0xFF 8473 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN 8474 # define NV_NAN_PAYLOAD_MASK 0x00, 0x07, 0xff, 0xff 8475 # define NV_NAN_PAYLOAD_PERM 0xFF, 0x2, 0x1, 0x0 8476 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN 8477 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_64_LE 8478 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_64_LE 8479 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN 8480 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_64_BE 8481 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_64_BE 8482 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 8483 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_128_LE 8484 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_128_LE 8485 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 8486 # define NV_NAN_PAYLOAD_MASK NV_NAN_PAYLOAD_MASK_IEEE_754_128_BE 8487 # define NV_NAN_PAYLOAD_PERM NV_NAN_PAYLOAD_PERM_IEEE_754_128_BE 8488 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE 8489 # define NV_NAN_PAYLOAD_MASK 0xff, 0xff, 0x07, 0x00, 0xff, 0xff, 0xff, 0xff 8490 # define NV_NAN_PAYLOAD_PERM 0x4, 0x5, 0x6, 0xFF, 0x0, 0x1, 0x2, 0x3 8491 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE 8492 # define NV_NAN_PAYLOAD_MASK 0xff, 0xff, 0xff, 0xff, 0x00, 0x07, 0xff, 0xff 8493 # define NV_NAN_PAYLOAD_PERM 0x3, 0x2, 0x1, 0x0, 0xFF, 0x6, 0x5, 0x4 8494 # else 8495 # error "Unexpected double format" 8496 # endif 8497 #endif 8498 8499 #endif /* DOUBLE_HAS_NAN */ 8500 8501 8502 /* 8503 8504 (KEEP THIS LAST IN perl.h!) 8505 8506 Mention 8507 8508 NV_PRESERVES_UV 8509 8510 HAS_MKSTEMP 8511 HAS_MKSTEMPS 8512 HAS_MKDTEMP 8513 8514 HAS_GETCWD 8515 8516 HAS_MMAP 8517 HAS_MPROTECT 8518 HAS_MSYNC 8519 HAS_MADVISE 8520 HAS_MUNMAP 8521 I_SYSMMAN 8522 Mmap_t 8523 8524 NVef 8525 NVff 8526 NVgf 8527 8528 HAS_UALARM 8529 HAS_USLEEP 8530 8531 HAS_SETITIMER 8532 HAS_GETITIMER 8533 8534 HAS_SENDMSG 8535 HAS_RECVMSG 8536 HAS_READV 8537 HAS_WRITEV 8538 I_SYSUIO 8539 HAS_STRUCT_MSGHDR 8540 HAS_STRUCT_CMSGHDR 8541 8542 HAS_NL_LANGINFO 8543 8544 HAS_DIRFD 8545 8546 so that Configure picks them up. 8547 8548 (KEEP THIS LAST IN perl.h!) 8549 8550 */ 8551 8552 #endif /* Include guard */ 8553 8554 /* 8555 * ex: set ts=8 sts=4 sw=4 et: 8556 */ 8557