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

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