/tags/V_34_11/libpfe/src/main/c/core-sub.c

# · C · 1821 lines · 1435 code · 128 blank · 258 comment · 244 complexity · f31b52c9b0ef30d2ba365b2dea617768 MD5 · raw file

  1. /**
  2. * -- Subroutines for the Core Forth-System
  3. *
  4. * Copyright (C) Tektronix, Inc. 1998 - 2001.
  5. * Copyright (C) 2005 - 2008 Guido U. Draheim <guidod@gmx.de>
  6. *
  7. * @see GNU LGPL
  8. * @author Guido U. Draheim (modified by $Author: guidod $)
  9. * @version $Revision: 533 $
  10. * (modified $Date: 2009-10-24 14:53:14 +0200 (Sat, 24 Oct 2009) $)
  11. *
  12. * @description
  13. * Subroutines for the Forth Core System - especially the
  14. * general input/output routines like ACCEPT/QUERY/WORD/PARSE
  15. * and converters like UD.DR and >NUMBER
  16. */
  17. /*@{*/
  18. #if defined(__version_control__) && defined(__GNUC__)
  19. static char* id __attribute__((unused)) =
  20. "@(#) $Id: core-sub.c 533 2009-10-24 12:53:14Z guidod $";
  21. #endif
  22. #define _P4_SOURCE 1
  23. #include <pfe/pfe-base.h>
  24. #include <pfe/def-limits.h>
  25. #include <stdio.h>
  26. #include <stdlib.h>
  27. #include <stdarg.h>
  28. #include <math.h>
  29. #include <limits.h>
  30. #include <errno.h>
  31. #include <pfe/os-string.h>
  32. #include <pfe/os-ctype.h>
  33. #ifdef PFE_HAVE_UNISTD_H
  34. #include <unistd.h> /* access() if available */
  35. #endif
  36. #if defined PFE_HAVE_PWD_H
  37. #include <pwd.h> /* to resolve ~user/path */
  38. #endif
  39. #include <pfe/double-sub.h>
  40. #include <pfe/block-sub.h>
  41. #include <pfe/file-sub.h>
  42. #include <pfe/term-sub.h>
  43. #include <pfe/lined.h>
  44. #include <pfe/_missing.h>
  45. #include <pfe/logging.h>
  46. extern void FXCode(p4_bye);
  47. /***********************************************************************/
  48. /* removed this one from general def-types */
  49. #define SPAN p4_SPAN
  50. /**
  51. * return cell-aligned address
  52. */
  53. P4_GCC_CONST p4cell
  54. p4_aligned (p4cell n)
  55. {
  56. while (!P4_ALIGNED (n))
  57. n++;
  58. return n;
  59. }
  60. /* *********************************************************************
  61. * strings
  62. */
  63. /** _strpush_ ( zstr* -- S: str* str# )
  64. * push a C-string onto the SP runtime-stack, as if => S" string" was used
  65. : _strpush_ s! _strlen_ s! ;
  66. */
  67. void
  68. p4_strpush (const char *s)
  69. {
  70. if (s) {
  71. *--SP = (p4cell)s; *--SP = p4_strlen (s);
  72. } else {
  73. *--SP = 0; *--SP = 0;
  74. }
  75. }
  76. /** _pocket_ ( -- str* )
  77. * return the next pocket for interactive string input.
  78. : _pocket_ _pockets@_ _pocket@_ th _pocket@_ 1+ _pockets#_ mod to _pocket@_ ;
  79. */
  80. P4_GCC_MALLOC void*
  81. p4_pocket (void)
  82. {
  83. register void *p = PFE.pocket->buffer;
  84. if (++ PFE.pocket >= PFE.pockets_top) PFE.pocket = PFE.pockets_ptr;
  85. return p;
  86. }
  87. /** _-trailing_ ( str* str# -- str#' )
  88. * chop off trailing spaces for the stringbuffer. returns the new length,
  89. * so for an internal counted string, use
  90. <x> dup count _-trailing_ c!
  91. : _-trailing_ begin dup while
  92. 2dup + c@ bl <> if nip exit then
  93. 1- repeat nip ;
  94. */
  95. P4_GCC_WARN_UNUSED_RESULT int
  96. p4_dash_trailing (p4_char_t *s, int n)
  97. {
  98. while (n > 0 && p4_isspace (s[n - 1]))
  99. {
  100. n--;
  101. }
  102. return n;
  103. }
  104. /** _lower_ ( str* str# -- )
  105. * _tolower_ applied to a stringbuffer
  106. : _lower_ 0 do dup c@ _tolower_ over c! 1+ loop drop ;
  107. */
  108. void
  109. p4_lower (p4_char_t *p, int n)
  110. {
  111. while (--n >= 0)
  112. {
  113. *p = (p4_char_t) tolower ((char) *p);
  114. p++;
  115. }
  116. }
  117. /** _upper_ ( str* str# -- )
  118. * _toupper_ applied to a stringbuffer
  119. : _upper_ 0 do dup c@ _toupper_ over c! 1+ loop drop ;
  120. */
  121. void
  122. p4_upper (p4_char_t *p, int n)
  123. {
  124. while (--n >= 0)
  125. {
  126. *p = (p4_char_t) toupper ((char) *p);
  127. p++;
  128. }
  129. }
  130. /** _zplaced_ ( str* str# dst* max# -- dst* ) [alias] _store_c_string_
  131. * copy stringbuffer into a field as a zero-terminated string.
  132. : _zsplaced_ rot 2dup > if drop 1- else nip then _zplace_ ;
  133. */
  134. char*
  135. p4_store_c_string (const p4_char_t *src, int n, char *dst, int max)
  136. {
  137. /* RENAME: p4_zplaced */
  138. if (n >= max)
  139. n = max - 1;
  140. p4_memcpy (dst, src, n);
  141. dst[n] = '\0';
  142. return dst;
  143. }
  144. /** _pocket_zplaced ( str* str# -- pocket* ) [alias] _pocket_c_string_
  145. * store a string-span as a zero-terminated string into another pocket-pad
  146. : _pocket_zplaced _pocket_ _/pocket_ _zplaced_ ;
  147. */
  148. P4_GCC_MALLOC char*
  149. p4_pocket_c_string (const p4_char_t* src, int n)
  150. {
  151. /* RENAME: p4_pocket_zplace */ /* REQUIRE: p4_pocket_place */
  152. return p4_store_c_string (src, n, p4_pocket (), P4_POCKET_SIZE);
  153. }
  154. /** _zplaced_filename_ ( str* str# dst* max# -- dst* ) [alias] _store_filename_
  155. * copy stringbuffer into a field as a zero-terminated filename-string,
  156. * a shell-homedir like "~username" will be expanded, and the
  157. * platform-specific dir-delimiter is converted in on the fly ('/' vs. '\\')
  158. */
  159. char*
  160. p4_store_filename (const p4_char_t* str, int n, char* dst, int max)
  161. {
  162. /* RENAME: p4_zplace_filename */
  163. int s = 0;
  164. int d;
  165. char* p;
  166. char* src = (char*) str;
  167. if (!src || !n) { *dst = '\0'; return dst; }
  168. # if PFE_DIR_DELIMITER == '\\'
  169. # define PFE_ANTI_DELIMITER '/'
  170. # else
  171. # define PFE_ANTI_DELIMITER '\\'
  172. # endif
  173. # define PFE_HOMEDIR_CHAR '~'
  174. *dst = '\0';
  175. if (n && max > n && *src == PFE_HOMEDIR_CHAR)
  176. {
  177. s = d = 1;
  178. while (s < n && d < max && src[s] && src[s] != PFE_DIR_DELIMITER)
  179. { dst[d++] = src[s++]; }
  180. dst[d] = '\0';
  181. if (s == 1)
  182. {
  183. p = getenv("HOME");
  184. if (p && max > p4_strlen(p)) { p4_strcpy (dst, p); }
  185. /* else *dst = '\0'; */
  186. }else{
  187. # if PFE_HAVE_PWD_H
  188. struct passwd *passwd = getpwnam (dst+1);
  189. if (passwd && max > p4_strlen (passwd->pw_dir))
  190. p4_strcpy (dst, passwd->pw_dir);
  191. else
  192. # endif
  193. *dst = PFE_DIR_DELIMITER; /* /user/restofpath */
  194. }
  195. }
  196. d = p4_strlen (dst);
  197. while (d < max && s < n && src[s])
  198. {
  199. if (src[s] != PFE_ANTI_DELIMITER)
  200. dst[d++] = src[s];
  201. else
  202. dst[d++] = PFE_DIR_DELIMITER;
  203. s++;
  204. }
  205. dst[d] = '\0';
  206. return dst;
  207. }
  208. /** _pocket_fileame_ ( str* str# -- dst* )
  209. * a new pocket with the given filename as asciiz
  210. : _pocket_filename_ _pocket_ /pocket _zplaced_filename_
  211. */
  212. P4_GCC_MALLOC char*
  213. p4_pocket_filename (const p4_char_t* src, int n)
  214. {
  215. /* RENAME: p4_pocket_zplace_filename */
  216. return p4_store_filename (src, n, p4_pocket (), P4_POCKET_SIZE);
  217. }
  218. /* **********************************************************************
  219. * expanding file names with paths and extensions
  220. */
  221. /* <try-extensions> ( zstr* zext* -- ?ok )
  222. * Append all extensions from ext to nm (which is assumed to be like a POCKET)
  223. * Check if file exists, if so return true, else false.
  224. * The nm-string is expected to be writeable up to max. pocket_size.
  225. */
  226. static int
  227. try_extensions (char* nm, const char *ext)
  228. {
  229. if (_P4_access (nm, F_OK) == 0)
  230. return 1;
  231. int vv = p4_strlen (nm);
  232. if (!ext || vv > P4_POCKET_SIZE-4)
  233. return 0;
  234. while (*ext)
  235. {
  236. int v = vv;
  237. while (*ext && *ext == PFE_PATH_DELIMITER)
  238. { ext++; }
  239. do { nm[v++] = *ext++; }
  240. while (*ext && *ext != PFE_PATH_DELIMITER && v < P4_POCKET_SIZE-1);
  241. nm[v] = '\0';
  242. if (_P4_access (nm, F_OK) == 0)
  243. return 1;
  244. }
  245. nm[vv] = '\0';
  246. return 0;
  247. }
  248. #if 0
  249. /*
  250. * if the src-path starts with "~" then expand the homedir
  251. * and append the rest of the path after the pathdelimiter.
  252. * In any case, the src-string is copied to the dst-string,
  253. * and the dst-string ist returned for further usage.
  254. */
  255. static char*
  256. strcpy_homedir (char* dst, const char* src)
  257. {
  258. if (*src != PFE_HOMEDIR_CHAR) { p4_strcpy (dst, src); return dst; }
  259. const char* s = src+1; char* d = dst+1;
  260. while (*s && *s != PFE_DIR_DELIMITER) { *d++ = *s++; }
  261. *d = '\0';
  262. if (s == src+1)
  263. {
  264. d = getenv("HOME");
  265. if (d) { p4_strcpy (dst, d); } else *dst = '\0';
  266. }else{
  267. # if PFE_HAVE_PWD_H
  268. struct passwd *passwd = getpwnam (dst+1);
  269. if (passwd)
  270. p4_strcpy (dst, passwd->pw_dir);
  271. else
  272. # endif
  273. *dst = PFE_DIR_DELIMITER; /* /user/restofpath */
  274. }
  275. p4_strcat (dst, s);
  276. return dst;
  277. }
  278. #endif
  279. /** _pocket-expanded-filename_ ( str* str# zpaths* zexts* -- dst* )
  280. * str*,str# file name input
  281. * paths search path for files (a delimited series of dirname prefixes )
  282. * ext default file extensions (a delimited series of ext suffixes )
  283. * -> result in a pocket with the expanded filename, basically operate
  284. * as foreach dirname prefix run => <store-filename> to expand shellparticles
  285. * and if then => <try-extensions> returns true then return that one. If no
  286. * file was found to exist that way then just <store-filename> and return.
  287. */
  288. char*
  289. p4_pocket_expanded_filename (const p4_char_t *nm, int ln,
  290. const char *paths, const char *exts)
  291. {
  292. if (*nm == PFE_DIR_DELIMITER || *nm == PFE_HOMEDIR_CHAR)
  293. {
  294. char* path = p4_pocket ();
  295. p4_store_filename (nm, ln, path, P4_POCKET_SIZE);
  296. try_extensions (path, exts);
  297. return path;
  298. }else{
  299. char* path = p4_pocket ();
  300. p4_store_filename (nm, ln, path, P4_POCKET_SIZE);
  301. if (try_extensions (path, exts))
  302. return path;
  303. char* pock = p4_pocket ();
  304. while (*paths)
  305. {
  306. char *p = pock;
  307. while (*paths && *paths == PFE_PATH_DELIMITER)
  308. { paths++; }
  309. if (!*paths) break;
  310. do { *p++ = *paths++; }
  311. while (*paths && *paths != PFE_PATH_DELIMITER);
  312. if (p[-1] != PFE_DIR_DELIMITER) *p++ = PFE_DIR_DELIMITER;
  313. int fill = ln + (p - pock);
  314. if (fill > P4_POCKET_SIZE) continue;
  315. p4_strncpy (p, (char*) nm, ln);
  316. p4_store_filename ((p4_char_t*) pock, fill, path, P4_POCKET_SIZE);
  317. if (try_extensions (path, exts))
  318. return path;
  319. }
  320. p4_store_filename (nm, ln, path, P4_POCKET_SIZE);
  321. return path;
  322. }
  323. }
  324. /* **********************************************************************
  325. * string comparision and pattern matching
  326. */
  327. /** _search_ ( str* str# key* key# -- 0 | key-in-str* )
  328. * search for substring p2/u2 in string p1/u1, returns null if not found
  329. * or a pointer into str*,str# that has lenght of key#
  330. */
  331. char *
  332. p4_search (const char *p1, int u1, const char *p2, int u2)
  333. {
  334. if (u2 == 0)
  335. return (char *) p1;
  336. if (u2 > u1)
  337. return NULL;
  338. u1 -= u2;
  339. for (;;)
  340. {
  341. char *p = (char *) memchr (p1, *p2, u1 + 1);
  342. if (p == NULL)
  343. return NULL;
  344. if (p4_memcmp (p, p2, u2) == 0)
  345. return (char *) p;
  346. u1 -= p - p1;
  347. if (u1 == 0)
  348. return NULL;
  349. p1 = p + 1;
  350. u1--;
  351. }
  352. }
  353. /* match with a processed pattern, i.e. one without `\' escapes */
  354. static int
  355. do_match (const short *pattern, const p4char *str, int len, int uppermax)
  356. {
  357. int c;
  358. const p4char* end = str+len;
  359. for (; str < end; /*str++*/)
  360. {
  361. --uppermax;
  362. switch (c = *pattern++)
  363. {
  364. case '\0':
  365. break;
  366. case -'*':
  367. while (*str && end-str && !do_match (pattern, str, end-str, uppermax))
  368. { --uppermax; str++; }
  369. continue;
  370. case -'?':
  371. if (*str++)
  372. continue;
  373. return 0;
  374. default:
  375. if (uppermax < 0)
  376. {
  377. if (*str++ == c)
  378. continue;
  379. }else{
  380. if (*str == c || *str == toupper(c))
  381. { str++; continue; }
  382. }
  383. return 0;
  384. }
  385. }
  386. return str == end || *str == '\0';
  387. }
  388. /** _match_ ( zpattern* zstring* ignorecase? -- yes? )
  389. * Match string against pattern.
  390. * Pattern knows wildcards `*' and `?' and `\' to escape a wildcard.
  391. */
  392. int
  393. p4_match (const p4char *pattern, const p4char *str, int len, int ic)
  394. {
  395. /* RENAME: p4_wild_match - move near p4_wild_words - possibly export */
  396. short preprocessed[POCKET_SIZE], *p = preprocessed;
  397. /* preprocess pattern, remove `\' */
  398. for (;;)
  399. {
  400. int c = *(unsigned char *) pattern;
  401. pattern++;
  402. switch (c)
  403. {
  404. default:
  405. *p++ = c;
  406. continue;
  407. case '\0':
  408. *p = 0;
  409. break;
  410. case '?':
  411. *p++ = -'?';
  412. continue;
  413. case '*':
  414. *p++ = -'*';
  415. continue;
  416. case '\\':
  417. if (*pattern)
  418. *p++ = *pattern++;
  419. else
  420. *p++ = c;
  421. continue;
  422. }
  423. break;
  424. }
  425. /* match with preprocessed pattern */
  426. # define UPPERMAX 32
  427. return do_match (preprocessed, str, len, (ic ? UPPERMAX : 0));
  428. }
  429. /* _________________________________________________________________________
  430. * unsigned and floored divide and number i/o conversion
  431. */
  432. /** _U/_
  433. * unsigned divide procedure, single prec
  434. */
  435. P4_GCC_CONST udiv_t
  436. p4_udiv (p4ucell num, p4ucell denom)
  437. {
  438. udiv_t res;
  439. res.quot = num / denom;
  440. res.rem = num % denom;
  441. return res;
  442. }
  443. /** _/_
  444. * floored divide procedure, single prec
  445. */
  446. P4_GCC_CONST fdiv_t
  447. p4_fdiv (p4cell num, p4cell denom)
  448. {
  449. fdiv_t res;
  450. res.quot = num / denom;
  451. res.rem = num % denom;
  452. if (res.rem && (num ^ denom) < 0)
  453. {
  454. res.quot--;
  455. res.rem += denom;
  456. }
  457. return res;
  458. }
  459. /** _ud/_
  460. * Divides *ud by denom, leaves result in *ud, returns remainder.
  461. * For number output conversion: dividing by BASE.
  462. */
  463. p4ucell
  464. p4_u_d_div (p4udcell *ud, p4ucell denom)
  465. {
  466. p4udcell nom = *ud;
  467. udiv_t h;
  468. h = p4_udiv (P4xD0 (nom), denom);
  469. P4xD0 (*ud) = h.quot;
  470. P4xD0 (nom) = h.rem;
  471. h = p4_udiv (nom.hi, denom);
  472. P4xD1 (*ud) = h.quot;
  473. P4xD1 (nom) = h.rem;
  474. h = p4_udiv (P4xCELL (P4xD1 (nom), P4xD2 (nom)), denom);
  475. P4xD2 (*ud) = h.quot;
  476. P4xD2 (nom) = h.rem;
  477. h = p4_udiv (nom.lo, denom);
  478. P4xD3 (*ud) = h.quot;
  479. return h.rem;
  480. }
  481. /** _ud*_
  482. * Computes *ud * w + c, where w is actually only half of a cell in size.
  483. * Leaves result in *ud.
  484. * For number input conversion: multiply by BASE and add digit.
  485. */
  486. void
  487. p4_u_d_mul (p4udcell *ud, p4ucell w, p4ucell c)
  488. {
  489. c += P4xD3 (*ud) * w, P4xD3 (*ud) = P4xW1 (c), c >>= (sizeof(p4cell)*4);
  490. c += P4xD2 (*ud) * w, P4xD2 (*ud) = P4xW1 (c), c >>= (sizeof(p4cell)*4);
  491. c += P4xD1 (*ud) * w, P4xD1 (*ud) = P4xW1 (c), c >>= (sizeof(p4cell)*4);
  492. P4xD0 (*ud) = P4xD0 (*ud) * w + c;
  493. }
  494. /** _dig>num_ ( c n* base -- ?ok )
  495. * Get value of digit c into *n, return flag: valid digit.
  496. */
  497. int
  498. p4_dig2num (p4_char_t c, p4ucell *n, p4ucell base)
  499. {
  500. if (c < '0')
  501. return P4_FALSE;
  502. if (c <= '9')
  503. c -= '0';
  504. else
  505. {
  506. if (UPPER_CASE)
  507. c = toupper (c);
  508. if (c < 'A')
  509. return P4_FALSE;
  510. if (c <= 'Z')
  511. c -= 'A' - ('9' - '0' + 1);
  512. else
  513. {
  514. if (UPPER_CASE || c < 'a')
  515. return P4_FALSE;
  516. c -= 'a' - ('9' - '0' + 1) - ('Z' - 'A' + 1);
  517. }
  518. }
  519. if (c >= base)
  520. return P4_FALSE;
  521. *n = c;
  522. return P4_TRUE;
  523. }
  524. /** _num2dig_ ( val -- c )
  525. * make digit
  526. */
  527. P4_GCC_CONST char
  528. p4_num2dig (p4ucell n)
  529. {
  530. if (n < 10)
  531. return n + '0';
  532. if (n < 10 + 'Z' - 'A' + 1)
  533. return n - 10 + 'A';
  534. else
  535. return n - (10 + 'Z' - 'A' + 1) + 'a';
  536. }
  537. /** _hold_ ( c -- )
  538. * insert into pictured numeric output string
  539. */
  540. void
  541. p4_hold (char c)
  542. {
  543. if (p4_HLD <= HERE)
  544. p4_throw (P4_ON_PICNUM_OVER);
  545. *--p4_HLD = c;
  546. }
  547. /** _>number_
  548. * try to convert into numer, see => >NUMBER
  549. */
  550. const p4_char_t *
  551. p4_to_number (const p4_char_t *p, p4ucell *n, p4udcell *d, p4ucell base)
  552. {
  553. #ifdef DEBUG /* good place to check some assertions (for debugging) */
  554. {
  555. auto p4udcell udbl;
  556. auto p4ucell_hi_lo hilo;
  557. p4_memset(&udbl, 0, sizeof(udbl));
  558. p4_memset(&hilo, 0, sizeof(hilo));
  559. if (sizeof(hilo) != sizeof(p4cell))
  560. { p4_outs(" {double-halfcell is not the size of cell} "); }
  561. if (sizeof(hilo.lo) != sizeof(p4cell)/2)
  562. { p4_outs(" {halfcell is not half the size of cell} "); }
  563. if (sizeof(hilo) != sizeof(udbl)/2)
  564. { p4_outs(" {double-halfcell is not half the size of double} "); }
  565. hilo.lo = 1;
  566. if ( (*(p4cell*)&hilo) != ((p4cell)1) )
  567. { p4_outs(" {double-halfcell is in incorrect (byteorder?)} "); }
  568. P4xD3(udbl) = 1;
  569. if ( udbl.lo != 1 )
  570. { p4_outs(" {double-lo-accessor is in incorrect (byteorder?)} "); }
  571. P4xD1(udbl) = 1;
  572. if ( udbl.hi != 1 )
  573. { p4_outs(" {double-hi-accessor is in incorrect (byteorder?)} "); }
  574. }
  575. #endif
  576. for (; *n > 0; p++, --*n)
  577. {
  578. p4ucell c;
  579. if (!p4_dig2num (*p, &c, base))
  580. break;
  581. p4_u_d_mul (d, base, c);
  582. if (p4_DPL >= 0)
  583. p4_DPL++;
  584. }
  585. return p;
  586. }
  587. /*
  588. * Options controlling input and output:
  589. */
  590. #ifndef USE_DOLLARHEX /* USER-CONFIG: */
  591. #define USE_DOLLARHEX 1 /* allow $XXX and %BBB input for hex and bin */
  592. #endif
  593. #ifndef PREFIX_HEX /* USER-CONFIG: */
  594. #define PREFIX_HEX '$' /* 0 or prefix for input of hex numbers */
  595. #endif
  596. #ifndef PREFIX_BINARY /* USER-CONFIG: */
  597. #define PREFIX_BINARY '%' /* 0 or prefix for input of binary numbers */
  598. #endif
  599. #ifndef PREFIX_DECIMAL /* USER-CONFIG: */
  600. #define PREFIX_DECIMAL '#' /* 0 or prefix for input of decimal numbers */
  601. #define PREFIX_DECIMAL_OLD '&'
  602. #endif
  603. #ifndef PREFIX_0x /* USER-CONFIG: */
  604. #define PREFIX_0x 1 /* 0x10 =16, 0X100 = 256 */
  605. #endif
  606. #ifndef PREFIX_0o /* USER-CONFIG: */
  607. #define PREFIX_0o 1 /* 0o10 = 8, 0O100 = 64 */
  608. #endif
  609. #ifndef PREFIX_0b /* USER-CONFIG: */
  610. #define PREFIX_0b 1 /* 0b10 = 2, 0B100 = 4 */
  611. #endif
  612. /** _?number_ ( str* str# dcell* -- ?ok )
  613. * try to convert into number, see => ?NUMBER
  614. */
  615. int
  616. p4_number_question (const p4_char_t *p, p4ucell n, p4dcell *d)
  617. {
  618. p4ucell base = 0;
  619. int sign = 0;
  620. # ifdef PREFIX_DECIMAL_OLD
  621. p4_bool_t old_decimal_prefix = P4_FALSE;
  622. # endif
  623. if (*p == '-') { p++; n--; sign = 1; }
  624. #if USE_DOLLARHEX
  625. if (p4_FLOAT_INPUT && n > 1)
  626. {
  627. switch (*p)
  628. {
  629. case PREFIX_HEX:
  630. base = 16; p++; n--;
  631. break;
  632. case PREFIX_BINARY:
  633. base = 2; p++; n--;
  634. break;
  635. case PREFIX_DECIMAL:
  636. base = 10; p++; n--;
  637. break;
  638. # ifdef PREFIX_DECIMAL_OLD
  639. case PREFIX_DECIMAL_OLD:
  640. old_decimal_prefix = P4_TRUE;
  641. base = 10; p++; n--;
  642. break;
  643. # endif
  644. }
  645. }
  646. if (*p == '-') { if (sign) { return 0; } else { p++; n--; sign = 1; } }
  647. #endif
  648. #if PREFIX_0x || PREFIX_0o || PREFIX_0b
  649. if( ! base && n > 2 && *p == '0' )
  650. {
  651. switch(*(p+1))
  652. {
  653. # if (PREFIX_0x)
  654. case 'x':
  655. case 'X':
  656. if (BASE <= 10+'X'-'A') { base = 16; p+=2; n-=2; }
  657. break;
  658. # endif
  659. # if (PREFIX_0o)
  660. case 'o':
  661. case 'O':
  662. if (BASE <= 10+'O'-'A') { base = 8; p+=2; n-=2; }
  663. break;
  664. # endif
  665. # if (PREFIX_0b)
  666. case 'b':
  667. case 'B':
  668. if (BASE <= 10+'B'-'A') { base = 2; p+=2; n-=2; }
  669. break;
  670. # endif
  671. }
  672. }
  673. #endif
  674. if (base == 0)
  675. base = BASE;
  676. d->lo = d->hi = 0;
  677. p4_DPL = -1;
  678. p = p4_to_number (p, &n, (p4udcell *) d, base);
  679. if (n == 0)
  680. goto happy;
  681. if (*p != '.')
  682. return 0;
  683. p4_DPL = 0;
  684. p++;
  685. n--;
  686. p = p4_to_number (p, &n, (p4udcell *) d, base);
  687. if (n != 0)
  688. return 0;
  689. happy:
  690. if (sign)
  691. p4_d_negate (d);
  692. # ifdef PREFIX_DECIMAL_OLD
  693. { /* TODO: remove PREFIX_DECIMAL_OLD in pfe-34 */
  694. static int shown = 0;
  695. if (old_decimal_prefix && ! shown && REDEFINED_MSG) {
  696. p4_outf ("\n> oops, a usage of the old decimal prefix '%c' was detected,", PREFIX_DECIMAL_OLD);
  697. p4_outf ("\n> need to change it to the forth200x new decimal prefix '%c'", PREFIX_DECIMAL);
  698. FX (p4_cr_show_input);
  699. shown ++;
  700. }
  701. }
  702. # endif
  703. return P4_TRUE;
  704. }
  705. /** _ud.r_ ( d,d str* str# base -- str* )
  706. * This is for internal use only (SEE and debugger),
  707. * The real => UD.R etc. words uses => HOLD and the memory area below => PAD
  708. */
  709. char *
  710. p4_str_ud_dot_r (p4udcell ud, char *p, int w, int base)
  711. {
  712. *--p = '\0';
  713. do {
  714. *--p = p4_num2dig (p4_u_d_div (&ud, base));
  715. w--;
  716. } while (ud.lo || ud.hi);
  717. while (w > 0) { *--p = ' '; w--; }
  718. return p;
  719. }
  720. /** _d.r_ ( d,d str* str# base -- str* )
  721. * This is for internal use only (SEE and debugger),
  722. * The real => UD.R etc. words use => HOLD and the memory area below => PAD
  723. */
  724. char *
  725. p4_str_d_dot_r (p4dcell d, char *p, int w, int base)
  726. {
  727. int sign = 0;
  728. if (d.hi < 0)
  729. p4_d_negate (&d), sign = 1;
  730. *--p = '\0';
  731. do {
  732. *--p = p4_num2dig (p4_u_d_div ((p4udcell *) &d, base));
  733. w--;
  734. } while (d.lo || d.hi);
  735. if (sign) { *--p = '-'; w--; }
  736. while (w > 0) { *--p = ' '; w--; }
  737. return p;
  738. }
  739. /** _._ ( i str* str# base -- str* )
  740. * This is for internal use only (SEE and debugger),
  741. * The real => . etc. words use => HOLD and the memory area below => PAD
  742. */
  743. char *
  744. p4_str_dot (p4cell n, char *p, int base)
  745. {
  746. p4dcell d;
  747. char *bl;
  748. *--p = '\0';
  749. bl = p - 1;
  750. d.lo = n;
  751. d.hi = n < 0 ? -1 : 0;
  752. p = p4_str_d_dot_r (d, p, 0, base);
  753. *bl = ' ';
  754. return p;
  755. }
  756. /* ********************************************************************** */
  757. /* console i/o */
  758. /* ********************************************************************** */
  759. /** _outc_ ( char -- ) [alias] _outc
  760. * emit single character,
  761. * (output adjusting the => OUT variable, see => _putc_ to do without)
  762. : _emit_ _putc_ _?xy_ drop out ! ;
  763. */
  764. void
  765. p4_outc (char c)
  766. {
  767. int x, y;
  768. p4_putc (c);
  769. p4_wherexy (&x, &y);
  770. p4_OUT = x;
  771. }
  772. /** _ztype_ ( zstr* -- ) [alias] _outs
  773. * type a string
  774. * (output adjusting the => OUT variable, see => _puts_ to do without)
  775. : _ztype_ _puts_ _?xy_ drop out ! ;
  776. */
  777. void
  778. p4_outs (const char *s)
  779. {
  780. int x = 0, y = 0;
  781. p4_puts (s);
  782. p4_wherexy (&x, &y);
  783. p4_OUT = x;
  784. }
  785. /** _outf_ ( ... zstr* -- n# )
  786. * type a string with formatting
  787. * (output adjusting the => OUT variable, see => _puts_ and => _outs_ )
  788. : _outf_ 0x200 lbuffer: buf[] buf[] _vsprintf_ buf[] _outs_ ;
  789. */
  790. P4_GCC_PRINTF int
  791. p4_outf (const char *s,...)
  792. {
  793. char buf[P4_PIPE_BUF];
  794. va_list p;
  795. int r;
  796. va_start (p, s);
  797. r = vsprintf (buf, s, p);
  798. p4_outs (buf);
  799. va_end (p);
  800. return r;
  801. }
  802. /** _type_ ( str* str# -- )
  803. * type counted string to terminal
  804. * (output adjusting the => OUT variable, see => _puts_ and => _outs_ )
  805. : _type_ 0 do c@++ _putc_ loop drop _flush_ _?xy drop out ! ;
  806. */
  807. void
  808. p4_type (const p4_char_t *str, p4cell len)
  809. {
  810. int x, y; const char* s = (const char*) str;
  811. while (--len >= 0)
  812. p4_putc_noflush (*s++);
  813. p4_wherexy (&x, &y);
  814. p4_OUT = x;
  815. p4_put_flush ();
  816. }
  817. /** _typeline_ ( str* str# -- )
  818. * type counted string to terminal, if it does not fit in full on
  819. * the current line, emit a => CR before
  820. * (output adjusting the OUT variable, see => _type_ and => _outs_ )
  821. : _typeline_ out @ over + cols @ > if cr then _type_ ;
  822. */
  823. void
  824. p4_type_on_line (const p4_char_t *str, p4cell len)
  825. {
  826. /* RENAME: ... might need p4_Q_cr variant... make macro from this? */
  827. if (p4_OUT + len >= p4_COLS)
  828. FX (p4_cr);
  829. p4_type (str, len);
  830. }
  831. /** _emits_ ( n# ch -- )
  832. * type a string of chars by repeating a single character which
  833. * is usually a space, see => SPACES
  834. * (output adjusting the OUT variable, see => _type_ and => _outs_ )
  835. : _emits_ swap 0 do dup _putc_ loop drop _flush_ _?xy_ drop out ! ;
  836. */
  837. void
  838. p4_emits (int n, const char c)
  839. {
  840. int x, y;
  841. while (--n >= 0)
  842. p4_putc_noflush (c);
  843. fflush (stdout);
  844. p4_wherexy (&x, &y);
  845. p4_OUT = x;
  846. }
  847. /** _tab_ ( n# -- )
  848. * type a string of space up to the next tabulator column
  849. * (output adjusting the OUT variable, see => _emits and => _typeonline )
  850. : _tab_ dup out @ - swap mod bl _emits_ ;
  851. */
  852. void
  853. p4_tab (int n)
  854. {
  855. p4_emits (n - p4_OUT % n, ' ');
  856. }
  857. /** _expect_noecho_ ( str* str# -- span# )
  858. * EXPECT counted string from terminal, without echo, so no real editing
  859. * it will however convert backspace and tabulators, break on newline/escape
  860. */
  861. static int
  862. p4_expect_noecho (char *p, p4cell n)
  863. {
  864. int i;
  865. char c;
  866. int out = 0;
  867. for (i = 0; i < n;)
  868. {
  869. switch (c = p4_getkey ())
  870. {
  871. default:
  872. p[i++] = c; out++;
  873. continue;
  874. case '\t':
  875. while (i < n)
  876. {
  877. p[i++] = ' '; out++;
  878. if (out % 8 == 0)
  879. break;
  880. }
  881. continue;
  882. case '\33':
  883. case '\r':
  884. case '\n':
  885. goto fin;
  886. case 127:
  887. case '\b':
  888. if (i <= 0)
  889. continue;
  890. i--; out--;
  891. continue;
  892. }
  893. }
  894. fin:
  895. p[i] = 0;
  896. SPAN = i;
  897. return i;
  898. }
  899. int p4_expect_line(char* p, p4cell n)
  900. {
  901. char *q = fgets (p, n, stdin);
  902. if (q == NULL) FX (p4_bye); /* ?? */
  903. q = strchr (p, '\n');
  904. if (q) *q = '\0';
  905. return p4_strlen (p);
  906. }
  907. /** _expect_ ( str* str# -- span# )
  908. * EXPECT counted string from terminal, with echo, so one can use
  909. * simple editing facility with backspace, but nothing more.
  910. * it's very traditional, you want to use a lined-like function instead!
  911. */
  912. int
  913. p4_expect (char *p, p4cell n)
  914. {
  915. int i;
  916. char c;
  917. if (P4_opt.isnotatty) {
  918. if (P4_opt.isnotatty == P4_TTY_NOECHO)
  919. return p4_expect_noecho (p, n);
  920. else {
  921. return p4_expect_line (p, n);
  922. }
  923. }
  924. for (i = 0; i < n;)
  925. {
  926. switch (c = p4_getkey ())
  927. {
  928. default:
  929. p[i++] = c;
  930. p4_outc (c);
  931. continue;
  932. case 27:
  933. for (; i > 0; i--)
  934. FX (p4_backspace);
  935. continue;
  936. case '\t':
  937. while (i < n)
  938. {
  939. p[i++] = ' ';
  940. FX (p4_space);
  941. if (p4_OUT % 8 == 0)
  942. break;
  943. }
  944. continue;
  945. case '\r':
  946. case '\n':
  947. FX (p4_space);
  948. goto fin;
  949. case 127:
  950. case '\b':
  951. if (i <= 0)
  952. {
  953. p4_dot_bell ();
  954. continue;
  955. }
  956. i--;
  957. FX (p4_backspace);
  958. continue;
  959. }
  960. }
  961. fin:
  962. p[i] = 0;
  963. SPAN = i;
  964. return i;
  965. }
  966. int p4_accept_line (char *tib, int tiblen)
  967. {
  968. char inputbuf[P4_MAX_INPUT];
  969. register char *buf;
  970. int len;
  971. buf = fgets (inputbuf, sizeof(inputbuf), stdin);
  972. if (buf == NULL) FX (p4_bye);
  973. buf = strchr (buf, '\n');
  974. len = (buf) ? (buf-inputbuf) : p4_strlen(inputbuf);
  975. if (len > tiblen) len = tiblen;
  976. memcpy (tib, inputbuf, len);
  977. return len;
  978. }
  979. int p4_accept_noecho (char *tib, int tiblen)
  980. {
  981. char inputbuf[P4_MAX_INPUT];
  982. int len = p4_expect_noecho (inputbuf, sizeof(inputbuf));
  983. if (len > tiblen) len = tiblen;
  984. memcpy (tib, inputbuf, len);
  985. return len;
  986. }
  987. /** _accept_ ( str* str# -- span# )
  988. * better input facility using lined if possible, otherwise
  989. * call _expect_noecho when running in a pipe or just _expect_ if no
  990. * real terminal attached.
  991. */
  992. int
  993. p4_accept (p4_char_t *tib, int n)
  994. {
  995. char* p = (char*) tib;
  996. if (P4_opt.isnotatty) {
  997. if (P4_opt.isnotatty == P4_TTY_NOECHO)
  998. return p4_accept_noecho (p, n);
  999. else
  1000. return p4_accept_line (p, n);
  1001. }
  1002. PFE.accept_lined.string = p;
  1003. PFE.accept_lined.max_length = n;
  1004. p4_lined (&PFE.accept_lined, NULL);
  1005. FX (p4_space);
  1006. return PFE.accept_lined.length;
  1007. }
  1008. /* **********************************************************************
  1009. * source input
  1010. */
  1011. /** QUERY ( -- )
  1012. * source input: read from terminal using => _accept_ with the
  1013. * returned string to show up in => TIB of => /TIB size.
  1014. */
  1015. void FXCode (p4_query)
  1016. {
  1017. SOURCE_ID = 0;
  1018. BLK = 0;
  1019. TO_IN = 0;
  1020. TIB = PFE.tib;
  1021. NUMBER_TIB = p4_accept (PFE.tib, TIB_SIZE);
  1022. /* if (PFE.query_hook) // please use lined.h:lined->intercept now
  1023. * NUMBER_TIB = (*PFE.query_hook)(NUMBER_TIB);
  1024. */
  1025. SPAN = NUMBER_TIB;
  1026. }
  1027. /**
  1028. * source input: read from text-file
  1029. */
  1030. p4_bool_t
  1031. p4_next_line (void)
  1032. {
  1033. p4cell ior;
  1034. p4ucell len;
  1035. len = sizeof SOURCE_FILE->buffer;
  1036. if (!p4_read_line (SOURCE_FILE->buffer, &len, SOURCE_FILE, &ior))
  1037. {
  1038. SOURCE_FILE->len = len;
  1039. return P4_FALSE;
  1040. }
  1041. TIB = SOURCE_FILE->buffer;
  1042. NUMBER_TIB = SOURCE_FILE->len = len;
  1043. BLK = 0;
  1044. TO_IN = 0;
  1045. return P4_TRUE;
  1046. }
  1047. /** _source_ ( str*& str#& -- )
  1048. * see => SOURCE - dispatch input source
  1049. */
  1050. void
  1051. p4_source (const p4_char_t **p, int *n)
  1052. {
  1053. switch (SOURCE_ID)
  1054. {
  1055. case -1: /* string from EVALUATE */
  1056. *p = TIB;
  1057. *n = NUMBER_TIB;
  1058. break;
  1059. case 0: /* string from QUERY or BLOCK */
  1060. if (BLK)
  1061. {
  1062. *p = p4_blockfile_block (BLOCK_FILE, BLK);
  1063. *n = BPBUF;
  1064. }else{
  1065. *p = TIB;
  1066. *n = NUMBER_TIB;
  1067. }
  1068. break;
  1069. default: /* source line from text file */
  1070. *p = SOURCE_FILE->buffer;
  1071. *n = SOURCE_FILE->len;
  1072. }
  1073. }
  1074. /** _size_saved_input_ ( -- iframe-size )
  1075. */
  1076. p4ucell
  1077. p4_size_saved_input (void)
  1078. {
  1079. return sizeof (Iframe);
  1080. }
  1081. /*NOTE: the (void* p) is often the RP being aligned to 32bit on most
  1082. * platforms but an Iframe contains an .input.off possibly being 64bit
  1083. * wide when off_t=64bit. This creates an alignment problem. We fix it
  1084. * here with a CP operation. A better variant would be align the input
  1085. * pointer magically in p4_save_input, until someone calls p4_link_s..
  1086. */
  1087. /* I hate compiler bugs, especially this one for solaris gcc 2.95 : */
  1088. /* #define CP(X,I,Y) p4_memcpy ((char*)&(X), (char*)&(Y), (int)sizeof(X)) */
  1089. #define CP(X,I,Y) { register int i = sizeof((X)); \
  1090. p4_memcpy ((char*)&(X), (char*)&(Y), i); }
  1091. /** _link_saved_input_ ( iframe* -- )
  1092. * see => SAVE-INPUT
  1093. */
  1094. void
  1095. p4_link_saved_input (void *p)
  1096. {
  1097. Iframe *iframe = (Iframe *) p;
  1098. iframe->magic = P4_INPUT_MAGIC;
  1099. CP(iframe->input, =, PFE.input);
  1100. CP(iframe->prev, =, PFE.saved_input);
  1101. CP(PFE.saved_input, =, iframe);
  1102. }
  1103. /** _save_input_ ( iframe-stack* -- iframe-stack*' )
  1104. * see => SAVE-INPUT
  1105. */
  1106. void *
  1107. p4_save_input (void *p)
  1108. {
  1109. Iframe *iframe = (Iframe *) p;
  1110. --iframe;
  1111. p4_link_saved_input (iframe);
  1112. return ((void*) iframe);
  1113. }
  1114. /** _unlink_saved_input_ ( iframe* -- )
  1115. * see => RESTORE-INPUT
  1116. */
  1117. void
  1118. p4_unlink_saved_input (void *p)
  1119. {
  1120. Iframe *iframe = (Iframe *) p;
  1121. if (iframe->magic != P4_INPUT_MAGIC)
  1122. p4_throw (P4_ON_ARG_TYPE);
  1123. CP(PFE.input, = ,iframe->input);
  1124. CP(PFE.saved_input, =, iframe->prev);
  1125. }
  1126. /** _restore_input_ ( iframe-stack* -- iframe-stack*' )
  1127. * see => RESTORE-INPUT
  1128. */
  1129. void *
  1130. p4_restore_input (void *p)
  1131. {
  1132. Iframe *iframe = (Iframe *) p;
  1133. p4_unlink_saved_input (p);
  1134. ++iframe;
  1135. return ((void *) iframe);
  1136. }
  1137. /** _refill_ ( -- flag )
  1138. * see => REFILL
  1139. */
  1140. p4_bool_t
  1141. p4_refill (void)
  1142. {
  1143. switch (SOURCE_ID)
  1144. {
  1145. case -1:
  1146. return 0;
  1147. case 0:
  1148. if (BLK)
  1149. {
  1150. BLK++;
  1151. TO_IN = 0;
  1152. }else{
  1153. FX (p4_query);
  1154. }
  1155. return P4_TRUE;
  1156. default:
  1157. return p4_next_line ();
  1158. }
  1159. }
  1160. /** _skip_delimiter_ ( del -- )
  1161. * => SKIP-DELIMITER
  1162. */
  1163. void
  1164. p4_skip_delimiter (char del)
  1165. {
  1166. const char *q;
  1167. int i, n;
  1168. p4_source ((const p4_char_t**) &q, &n);
  1169. if (del == ' ')
  1170. {
  1171. for (i = TO_IN;
  1172. i < n && p4_isascii (q[i]) && p4_isspace (q[i]);
  1173. i++)
  1174. {
  1175. ;
  1176. }
  1177. }else{
  1178. for (i = TO_IN; i < n && q[i] == del; i++)
  1179. {
  1180. ;
  1181. }
  1182. }
  1183. TO_IN = i;
  1184. }
  1185. /** _word:parse_ ( delim -- <end?> )
  1186. */
  1187. p4_cell_t
  1188. p4_word_parse (char del)
  1189. {
  1190. const char *q;
  1191. int i, n;
  1192. p4_source ((const p4_char_t**) &q, &n);
  1193. PFE.word.ptr = (p4_char_t*) q + TO_IN;
  1194. i = TO_IN;
  1195. if (i >= n)
  1196. goto empty;
  1197. if (del != ' ') /* no BL */
  1198. {
  1199. while (1)
  1200. {
  1201. if (q[i] == del)
  1202. goto delimfound;
  1203. i++;
  1204. if (i == n)
  1205. goto empty;
  1206. }
  1207. }else if (! p4_QUOTED_PARSE) /* BL and no QUOTED-PARSE */
  1208. {
  1209. while (1)
  1210. {
  1211. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1212. goto delimfound;
  1213. i++;
  1214. if (i == n)
  1215. goto empty;
  1216. }
  1217. #if 0
  1218. }else if (q[i] == '"') { /* scan "..." strings - including quotes */
  1219. i++;
  1220. while (1)
  1221. {
  1222. if (q[i++] == '"')
  1223. goto keepnextchar;
  1224. if (i == n)
  1225. goto empty;
  1226. }
  1227. #endif
  1228. }else{ /* BL && QUOTED -> before whitespace and after doublequote */
  1229. while (1)
  1230. {
  1231. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1232. goto delimfound;
  1233. if (q[i++] == '"')
  1234. goto keepnextchar;
  1235. if (i == n)
  1236. goto empty;
  1237. }
  1238. }
  1239. /* two exit sequences */
  1240. delimfound:
  1241. /* put the ">IN" pointer just after the delimiter that was found */
  1242. PFE.word.len = i - TO_IN;
  1243. TO_IN = i + 1;
  1244. return 1;
  1245. keepnextchar:
  1246. /* put the ">IN" pointer just after the delimiter that was found */
  1247. PFE.word.len = i - TO_IN;
  1248. TO_IN = i;
  1249. return 1;
  1250. empty:
  1251. /* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1252. PFE.word.len = i - TO_IN;
  1253. TO_IN = i; /* = n */
  1254. return 0;
  1255. }
  1256. /** _parse_ ( delim -- ptr len )
  1257. : _parse_ _word:parse_ _word*_ s! _word#_ s! ;
  1258. */
  1259. p4_cell_t
  1260. p4_parse (char del, const p4_char_t **p, p4ucell *l)
  1261. {
  1262. register p4_cell_t x = p4_word_parse(del);
  1263. *p = PFE.word.ptr;
  1264. *l = PFE.word.len;
  1265. return x;
  1266. }
  1267. /** _word>here_ ( -- here* )
  1268. * complement => _word:parse_ to arrive at the normal => WORD implementation
  1269. * will also ensure the string is zero-terminated - this makes a lot of
  1270. * operations easier since most forth function can receive a string-span
  1271. * directly but some need a string-copy and that is usually because it has
  1272. * to be passed down into a C-defined function with zerotermined string. Just
  1273. * use HERE+1 (which is also the returnvalue of this function!) to have
  1274. * the start of the zero-terminated string. Note that this function may throw
  1275. * with P4_ON_PARSE_OVER if the string is too long (it has set *HERE=0 to
  1276. * ensure again that => THROW will report PFE.word. as the offending string)
  1277. */
  1278. char*
  1279. p4_word_to_here (void)
  1280. {
  1281. if (PFE.word.len > 255) /* (1<<CHAR_BITS)-1 */
  1282. { *HERE = 0; p4_throw (P4_ON_PARSE_OVER); }
  1283. *HERE = PFE.word.len;
  1284. p4_memcpy (HERE+1, PFE.word.ptr, PFE.word.len);
  1285. (HERE+1)[PFE.word.len] = 0; /* zero-terminated */
  1286. return (char*) (HERE+1); /* HERE+1 -> start of z-string */
  1287. }
  1288. /** _word_ ( del -- here* )
  1289. : _word_ dup _skip_delimiter_ _word:parse_ _word>here_ ;
  1290. */
  1291. p4_char_t *
  1292. p4_word (char del)
  1293. {
  1294. p4_skip_delimiter (del);
  1295. p4_word_parse (del);
  1296. p4_word_to_here ();
  1297. return HERE;
  1298. }
  1299. /**
  1300. * PARSE-WORD a.k.a. BL PARSEWORD
  1301. *
  1302. * return and args mean the same as for => _parse_ but it really
  1303. * scans like => _word_. It most cases you can replace => _word_ with
  1304. * a sequence of _parseword_ and _word>here_ (.);
  1305. * The point is, that _parseword_ *doesn't* copy the next word onto
  1306. * here, it just returns the pointers. In some cases, esp. where
  1307. * a failure could be p4_thrown , it must be copied to HERE later.
  1308. * You can use _word2here_ for that. See _interpret_ for an example.
  1309. */
  1310. p4_cell_t
  1311. p4_word_parseword (char del)
  1312. {
  1313. /* quick path for wordset-loader: */
  1314. if (SOURCE_ID == -1 && PFE.word.len == -1) goto tib_static_string;
  1315. p4_skip_delimiter (del);
  1316. return p4_word_parse (del);
  1317. tib_static_string:
  1318. PFE.word.len = p4_strlen ((char*) PFE.word.ptr);
  1319. /* if (! FENCE) return; // libpfe.so is firing up */
  1320. /* assume: PFE.word.ptr points to the static_string we like to have */
  1321. TIB = PFE.word.ptr; NUMBER_TIB = PFE.word.len; TO_IN = 0;
  1322. return PFE.word.len;
  1323. }
  1324. #if 0
  1325. p4_cell_t
  1326. p4_parseword (char del, p4_char_t** p, p4ucell* l)
  1327. {
  1328. p4_skip_delimiter (del);
  1329. p4_cell_t x = p4_word_parse (del);
  1330. *p = PFE.word.ptr;
  1331. *l = PFE.word.len;
  1332. return x;
  1333. }
  1334. #endif
  1335. /*@}*/
  1336. /* _________________________________________________________________________ */
  1337. /* _________________________________________________________________________ */
  1338. #if 0
  1339. /*
  1340. * here are a few implemenations to show you how we came to the above
  1341. * parsing code.
  1342. */
  1343. /**
  1344. * PARSE
  1345. */
  1346. int
  1347. # if 0 /* standard implementation */
  1348. p4_parse (char del, p4_char_t **p, p4ucell *l) /*1*/
  1349. {
  1350. char *q;
  1351. int i, n;
  1352. p4_source ((p4_char_t**) &q, &n);
  1353. *p = (p4_char_t*) q + TO_IN;
  1354. i = TO_IN;
  1355. if (del == ' ')
  1356. {
  1357. while (i < n && !(p4_isascii (q[i]) && p4_isspace (q[i])))
  1358. {
  1359. i++;
  1360. }
  1361. }else{
  1362. while (i < n && q[i] != del)
  1363. {
  1364. i++;
  1365. }
  1366. }
  1367. *l = i - TO_IN;
  1368. if (i == n)
  1369. {/* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1370. TO_IN = i;
  1371. return 0;
  1372. }else
  1373. {/* put the ">IN" pointer just after the delimiter that was found */
  1374. TO_IN = i + 1;
  1375. return 1;
  1376. }
  1377. }
  1378. # elif 0 /* split the while loop condition */
  1379. p4_parse (char del, p4_char_t **p, p4ucell *l) /*2*/
  1380. {
  1381. char *q;
  1382. int i, n;
  1383. p4_source ((p4_char_t**) &q, &n);
  1384. *p = (p4_char_t*) q + TO_IN;
  1385. i = TO_IN;
  1386. if (del == ' ')
  1387. {
  1388. while (1)
  1389. {
  1390. if (i >= n)
  1391. break;
  1392. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1393. break;
  1394. i++;
  1395. }
  1396. }else{
  1397. while (1)
  1398. {
  1399. if (i >= n)
  1400. break;
  1401. if (q[i] == del)
  1402. break;
  1403. i++;
  1404. }
  1405. }
  1406. *l = i - TO_IN;
  1407. if (i == n)
  1408. {/* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1409. TO_IN = i;
  1410. return 0;
  1411. }else
  1412. {/* put the ">IN" pointer just after the delimiter that was found */
  1413. TO_IN = i + 1;
  1414. return 1;
  1415. }
  1416. }
  1417. # elif 0 /* move the length setting inside the last if-check */
  1418. p4_parse (char del, char **p, p4ucell *l) /*3*/
  1419. {
  1420. char *q;
  1421. int i, n;
  1422. p4_source ((p4_char_t**) &q, &n);
  1423. *p = q + TO_IN;
  1424. i = TO_IN;
  1425. if (del == ' ')
  1426. {
  1427. while (1)
  1428. {
  1429. if (i >= n)
  1430. break;
  1431. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1432. break;
  1433. i++;
  1434. }
  1435. }else{
  1436. while (1)
  1437. {
  1438. if (i >= n)
  1439. break;
  1440. if (q[i] == del)
  1441. break;
  1442. i++;
  1443. }
  1444. }
  1445. if (i == n)
  1446. {/* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1447. *l = i - TO_IN;
  1448. TO_IN = i;
  1449. return 0;
  1450. }else
  1451. {/* put the ">IN" pointer just after the delimiter that was found */
  1452. *l = i - TO_IN;
  1453. TO_IN = i + 1;
  1454. return 1;
  1455. }
  1456. }
  1457. # elif 0 /* move an if(usedup)-check up front, and reverse order in whiles */
  1458. p4_parse (char del, char **p, p4ucell *l) /*4*/
  1459. {
  1460. char *q;
  1461. int i, n;
  1462. p4_source ((p4_char_t**) &q, &n);
  1463. *p = q + TO_IN;
  1464. i = TO_IN;
  1465. if (i >= n)
  1466. goto empty;
  1467. if (del == ' ')
  1468. {
  1469. while (1)
  1470. {
  1471. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1472. break;
  1473. i++;
  1474. if (i == n)
  1475. break;
  1476. }
  1477. }else{
  1478. while (1)
  1479. {
  1480. if (q[i] == del)
  1481. break;
  1482. i++;
  1483. if (i == n)
  1484. break;
  1485. }
  1486. }
  1487. empty:
  1488. if (i == n)
  1489. {/* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1490. *l = i - TO_IN;
  1491. TO_IN = i;
  1492. return 0;
  1493. }else
  1494. {/* put the ">IN" pointer just after the delimiter that was found */
  1495. *l = i - TO_IN;
  1496. TO_IN = i + 1;
  1497. return 1;
  1498. }
  1499. }
  1500. # elif 0 /* bind [if (i==n)] occurences */
  1501. p4_parse (char del, char **p, p4ucell *l) /*5*/
  1502. {
  1503. char *q;
  1504. int i, n;
  1505. p4_source ((p4_char_t**) &q, &n);
  1506. *p = q + TO_IN;
  1507. i = TO_IN;
  1508. if (i >= n)
  1509. goto empty;
  1510. if (del == ' ')
  1511. {
  1512. while (1)
  1513. {
  1514. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1515. break;
  1516. i++;
  1517. if (i == n)
  1518. goto empty;
  1519. }
  1520. }else{
  1521. while (1)
  1522. {
  1523. if (q[i] == del)
  1524. break;
  1525. i++;
  1526. if (i == n)
  1527. goto empty;
  1528. }
  1529. }
  1530. /* put the ">IN" pointer just after the delimiter that was found */
  1531. *l = i - TO_IN;
  1532. TO_IN = i + 1;
  1533. return 1;
  1534. empty:
  1535. /* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1536. *l = i - TO_IN;
  1537. TO_IN = i;
  1538. return 0;
  1539. }
  1540. # elif 0 /* make delimfound exit */
  1541. p4_parse (char del, char **p, p4ucell *l) /*6*/
  1542. {
  1543. char *q;
  1544. int i, n;
  1545. p4_source ((p4_char_t**) &q, &n);
  1546. *p = q + TO_IN;
  1547. i = TO_IN;
  1548. if (i >= n)
  1549. goto empty;
  1550. if (del == ' ')
  1551. {
  1552. while (1)
  1553. {
  1554. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1555. goto delimfound;
  1556. i++;
  1557. if (i == n)
  1558. goto empty;
  1559. }
  1560. }else{
  1561. while (1)
  1562. {
  1563. if (q[i] == del)
  1564. goto delimfound;
  1565. i++;
  1566. if (i == n)
  1567. goto empty;
  1568. }
  1569. }
  1570. /* two exit sequences */
  1571. delimfound:
  1572. /* put the ">IN" pointer just after the delimiter that was found */
  1573. *l = i - TO_IN;
  1574. TO_IN = i + 1;
  1575. return 1;
  1576. empty:
  1577. /* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1578. *l = i - TO_IN;
  1579. TO_IN = i;
  1580. return 0;
  1581. }
  1582. # elif 0 /* use global variables instead of p and l */
  1583. p4_parse (char del, char **p, p4ucell *l) /*7*/
  1584. {
  1585. register int x = _p4_parse(del);
  1586. *p = PFE.word.ptr;
  1587. *l = PFE.word.len;
  1588. return x;
  1589. }
  1590. int
  1591. p4_word_parse (char del)
  1592. {
  1593. char *q;
  1594. int i, n;
  1595. p4_source ((p4_char_t**) &q, &n);
  1596. PFE.word.ptr = q + TO_IN;
  1597. i = TO_IN;
  1598. if (i >= n)
  1599. goto empty;
  1600. if (del == ' ')
  1601. {
  1602. while (1)
  1603. {
  1604. if (p4_isascii (q[i]) && p4_isspace (q[i]))
  1605. goto delimfound;
  1606. i++;
  1607. if (i == n)
  1608. goto empty;
  1609. }
  1610. }else{
  1611. while (1)
  1612. {
  1613. if (q[i] == del)
  1614. goto delimfound;
  1615. i++;
  1616. if (i == n)
  1617. goto empty;
  1618. }
  1619. }
  1620. /* two exit sequences */
  1621. delimfound:
  1622. /* put the ">IN" pointer just after the delimiter that was found */
  1623. PFE.word.len = i - TO_IN;
  1624. TO_IN = i + 1;
  1625. return 1;
  1626. empty:
  1627. /* no delimiter but end of parse area -> set ">IN" to n -> empty state */
  1628. PFE.word.len = i - TO_IN;
  1629. TO_IN = i; /* = n */
  1630. return 0;
  1631. }
  1632. #else
  1633. /*
  1634. and finally, make p4_word depend also on p4_word_parse, and use the
  1635. global word.ptr/len to copy it to HERE afterwards. On the upside, we
  1636. can make the visual at p4_throw a bit better, since we can now show
  1637. the complete offending word-span, not just the point where ">in" had
  1638. stopped. And we avoid multiple code areas doing more or less the same
  1639. thing.
  1640. */
  1641. # endif
  1642. /*show parsecode */
  1643. #endif