/tags/V_33_70/pfe-33/pfe/core-sub.c

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