git.gag.com Git - debian/pforth/blob - csrc/pf_text.c

   1 /* @(#) pf_text.c 98/01/26 1.3 */\r
   2 /***************************************************************\r
   3 ** Text Strings for Error Messages\r
   4 ** Various Text tools.\r
   5 **\r
   6 ** For PForth based on 'C'\r
   7 **\r
   8 ** Author: Phil Burk\r
   9 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
  10 **\r
  11 ** The pForth software code is dedicated to the public domain,\r
  12 ** and any third party may reproduce, distribute and modify\r
  13 ** the pForth software code or any derivative works thereof\r
  14 ** without any compensation or license.  The pForth software\r
  15 ** code is provided on an "as is" basis without any warranty\r
  16 ** of any kind, including, without limitation, the implied\r
  17 ** warranties of merchantability and fitness for a particular\r
  18 ** purpose and their equivalents under the laws of any jurisdiction.\r
  19 **\r
  20 ****************************************************************\r
  21 ** 19970702 PLB Fixed ConvertNumberToText for unsigned numbers.\r
  22 ** 19980522 PLB Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.\r
  23 ***************************************************************/\r
  24 \r
  25 #include "pf_all.h"\r
  26 \r
  27 #define PF_ENGLISH\r
  28 \r
  29 /*\r
  30 ** Define array of error messages.\r
  31 ** These are defined in one place to make it easier to translate them.\r
  32 */\r
  33 #ifdef PF_ENGLISH\r
  34 /***************************************************************/\r
  35 void pfReportError( const char *FunctionName, Err ErrCode )\r
  36 {\r
  37         const char *s;\r
  38         \r
  39         MSG("Error in ");\r
  40         MSG(FunctionName);\r
  41         MSG(" - ");\r
  42         \r
  43         switch(ErrCode & 0xFF)\r
  44         {\r
  45         case PF_ERR_NO_MEM & 0xFF:\r
  46                 s = "insufficient memory"; break;\r
  47         case PF_ERR_TOO_BIG & 0xFF:\r
  48                 s = "data chunk too large"; break;\r
  49         case PF_ERR_NUM_PARAMS & 0xFF:\r
  50                 s = "incorrect number of parameters"; break;\r
  51         case PF_ERR_OPEN_FILE & 0xFF:\r
  52                 s = "could not open file"; break;\r
  53         case PF_ERR_WRONG_FILE & 0xFF:\r
  54                 s = "wrong type of file format"; break;\r
  55         case PF_ERR_BAD_FILE & 0xFF:\r
  56                 s = "badly formatted file"; break;\r
  57         case PF_ERR_READ_FILE & 0xFF:\r
  58                 s = "file read failed"; break;\r
  59         case PF_ERR_WRITE_FILE & 0xFF:\r
  60                 s = "file write failed"; break;\r
  61         case PF_ERR_CORRUPT_DIC & 0xFF:\r
  62                 s = "corrupted dictionary"; break;\r
  63         case PF_ERR_NOT_SUPPORTED & 0xFF:\r
  64                 s = "not supported in this version"; break;\r
  65         case PF_ERR_VERSION_FUTURE & 0xFF:\r
  66                 s = "version from future"; break;\r
  67         case PF_ERR_VERSION_PAST & 0xFF:\r
  68                 s = "version is obsolete. Rebuild new one."; break;\r
  69         case PF_ERR_COLON_STACK & 0xFF:\r
  70                 s = "stack depth changed between : and ; . Probably unbalanced conditional"; break;\r
  71         case PF_ERR_HEADER_ROOM & 0xFF:\r
  72                 s = "no room left in header space"; break;\r
  73         case PF_ERR_CODE_ROOM & 0xFF:\r
  74                 s = "no room left in code space"; break;\r
  75         case PF_ERR_NO_SHELL & 0xFF:\r
  76                 s = "attempt to use names in forth compiled with PF_NO_SHELL"; break;\r
  77         case PF_ERR_NO_NAMES & 0xFF:\r
  78                 s = "dictionary has no names";  break;\r
  79         case PF_ERR_OUT_OF_RANGE & 0xFF:\r
  80                 s = "parameter out of range";  break;\r
  81         case PF_ERR_ENDIAN_CONFLICT & 0xFF:\r
  82                 s = "endian-ness of dictionary does not match code";  break;\r
  83         case PF_ERR_FLOAT_CONFLICT & 0xFF:\r
  84                 s = "float support mismatch between .dic file and code";  break;\r
  85         case PF_ERR_CELL_SIZE_CONFLICT & 0xFF:\r
  86                 s = "cell size mismatch between .dic file and code";  break;\r
  87         default:\r
  88                 s = "unrecognized error code!"; break;\r
  89         }\r
  90         MSG(s);\r
  91         EMIT_CR;\r
  92 }\r
  93 \r
  94 void pfReportThrow( ThrowCode code )\r
  95 {\r
  96         const char *s = NULL;\r
  97         switch(code)\r
  98         {\r
  99         case THROW_ABORT:\r
 100         case THROW_ABORT_QUOTE:\r
 101                 s = "ABORT"; break;\r
 102         case THROW_STACK_OVERFLOW:\r
 103                 s = "Stack overflow!"; break;\r
 104         case THROW_STACK_UNDERFLOW:\r
 105                 s = "Stack underflow!"; break;\r
 106         case THROW_EXECUTING:\r
 107                 s = "Executing a compile-only word!"; break;\r
 108         case THROW_FLOAT_STACK_UNDERFLOW:\r
 109                 s = "Float Stack underflow!"; break;\r
 110         case THROW_UNDEFINED_WORD:\r
 111                 s = "Undefined word!"; break;\r
 112         case THROW_PAIRS:\r
 113                 s = "Conditional control structure mismatch!"; break;\r
 114         case THROW_BYE:\r
 115         case THROW_QUIT:\r
 116                 break;\r
 117         case THROW_SEMICOLON:\r
 118                 s = "Stack depth changed between : and ; . Probably unbalanced conditional!"; break;\r
 119         case THROW_DEFERRED:\r
 120                 s = "Not a DEFERred word!"; break;\r
 121         default:\r
 122                 s = "Unrecognized throw code!"; break;\r
 123         }\r
 124         \r
 125         if( s )\r
 126         {\r
 127                 MSG_NUM_D("THROW code = ", code );\r
 128                 MSG(s);\r
 129                 EMIT_CR;\r
 130         }\r
 131 }\r
 132 #endif\r
 133 \r
 134 /**************************************************************\r
 135 ** Copy a Forth String to a 'C' string.\r
 136 */\r
 137 \r
 138 char *ForthStringToC( char *dst, const char *FString, cell_t dstSize )\r
 139 {\r
 140         cell_t Len;\r
 141 \r
 142         Len = (cell_t) *FString;\r
 143         /* Make sure the text + NUL can fit. */\r
 144         if( Len >= dstSize )\r
 145         {\r
 146                 Len = dstSize - 1;\r
 147         }\r
 148         pfCopyMemory( dst, FString+1, Len );\r
 149         dst[Len] = '\0';\r
 150 \r
 151         return dst;\r
 152 }\r
 153 \r
 154 /**************************************************************\r
 155 ** Copy a NUL terminated string to a Forth counted string.\r
 156 */\r
 157 char *CStringToForth( char *dst, const char *CString, cell_t dstSize )\r
 158 {\r
 159         cell_t i;\r
 160 \r
 161         /* Make sure the SIZE+text can fit. */\r
 162         for( i=1; i<dstSize; i++ )\r
 163         {\r
 164                 if( *CString == 0 )\r
 165                 {\r
 166                         break;\r
 167                 }\r
 168                 dst[i] = *CString++;\r
 169         }\r
 170         *dst = (char ) i-1;\r
 171         return dst;\r
 172 }\r
 173 \r
 174 /**************************************************************\r
 175 ** Compare two test strings, case sensitive.\r
 176 ** Return TRUE if they match.\r
 177 */\r
 178 cell_t ffCompareText( const char *s1, const char *s2, cell_t len )\r
 179 {\r
 180         cell_t i, Result;\r
 181         \r
 182         Result = TRUE;\r
 183         for( i=0; i<len; i++ )\r
 184         {\r
 185 DBUGX(("ffCompareText: *s1 = 0x%x, *s2 = 0x%x\n", *s1, *s2 ));\r
 186                 if( *s1++ != *s2++ )\r
 187                 {\r
 188                         Result = FALSE;\r
 189                         break;\r
 190                 }\r
 191         }\r
 192 DBUGX(("ffCompareText: return 0x%x\n", Result ));\r
 193         return Result;\r
 194 }\r
 195 \r
 196 /**************************************************************\r
 197 ** Compare two test strings, case INsensitive.\r
 198 ** Return TRUE if they match.\r
 199 */\r
 200 cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len )\r
 201 {\r
 202         cell_t i, Result;\r
 203         char  c1,c2;\r
 204         \r
 205         Result = TRUE;\r
 206         for( i=0; i<len; i++ )\r
 207         {\r
 208                 c1 = pfCharToLower(*s1++);\r
 209                 c2 = pfCharToLower(*s2++);\r
 210 DBUGX(("ffCompareText: c1 = 0x%x, c2 = 0x%x\n", c1, c2 ));\r
 211                 if( c1 != c2 )\r
 212                 {\r
 213                         Result = FALSE;\r
 214                         break;\r
 215                 }\r
 216         }\r
 217 DBUGX(("ffCompareText: return 0x%x\n", Result ));\r
 218         return Result;\r
 219 }\r
 220 \r
 221 /**************************************************************\r
 222 ** Compare two strings, case sensitive.\r
 223 ** Return zero if they match, -1 if s1<s2, +1 is s1>s2;\r
 224 */\r
 225 cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 )\r
 226 {\r
 227         cell_t i, result, n, diff;\r
 228         \r
 229         result = 0;\r
 230         n = MIN(len1,len2);\r
 231         for( i=0; i<n; i++ )\r
 232         {\r
 233                 if( (diff = (*s2++ - *s1++)) != 0 )\r
 234                 {\r
 235                         result = (diff > 0) ? -1 : 1 ;\r
 236                         break;\r
 237                 }\r
 238         }\r
 239         if( result == 0 )  /* Match up to MIN(len1,len2) */\r
 240         {\r
 241                 if( len1 < len2 )\r
 242                 {\r
 243                         result = -1;\r
 244                 }\r
 245                 else if ( len1 > len2 )\r
 246                 {\r
 247                         result = 1;\r
 248                 }\r
 249         }\r
 250         return result;\r
 251 }\r
 252 \r
 253 /***************************************************************\r
 254 ** Convert number to text.\r
 255 */\r
 256 #define CNTT_PAD_SIZE ((sizeof(cell_t)*8)+2)  /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */\r
 257 static char cnttPad[CNTT_PAD_SIZE];\r
 258 \r
 259 char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars )\r
 260 {\r
 261         cell_t IfNegative = 0;\r
 262         char *p,c;\r
 263         ucell_t NewNum, Rem, uNum;\r
 264         cell_t i = 0;\r
 265         \r
 266         uNum = Num;\r
 267         if( IfSigned )\r
 268         {\r
 269 /* Convert to positive and keep sign. */\r
 270                 if( Num < 0 )\r
 271                 {\r
 272                         IfNegative = TRUE;\r
 273                         uNum = -Num;\r
 274                 }\r
 275         }\r
 276         \r
 277 /* Point past end of Pad */\r
 278         p = cnttPad + CNTT_PAD_SIZE;\r
 279         *(--p) = (char) 0; /* NUL terminate */\r
 280         \r
 281         while( (i++<MinChars) || (uNum != 0) )\r
 282         {\r
 283                 NewNum = uNum / Base;\r
 284                 Rem = uNum - (NewNum * Base);\r
 285                 c = (char) (( Rem < 10 ) ? (Rem + '0') : (Rem - 10 + 'A'));\r
 286                 *(--p) = c;\r
 287                 uNum = NewNum;\r
 288         }\r
 289         \r
 290         if( IfSigned )\r
 291         {\r
 292                 if( IfNegative ) *(--p) = '-';\r
 293         }\r
 294         return p;\r
 295 }\r
 296 \r
 297 /***************************************************************\r
 298 ** Diagnostic routine that prints memory in table format.\r
 299 */\r
 300 void DumpMemory( void *addr, cell_t cnt)\r
 301 {\r
 302         cell_t ln, cn, nlines;\r
 303         unsigned char *ptr, *cptr, c;\r
 304 \r
 305         nlines = (cnt + 15) / 16;\r
 306 \r
 307         ptr = (unsigned char *) addr;\r
 308 \r
 309         EMIT_CR;\r
 310         \r
 311         for (ln=0; ln<nlines; ln++)\r
 312         {\r
 313                 MSG( ConvertNumberToText( (cell_t) ptr, 16, FALSE, 8 ) );\r
 314                 MSG(": ");\r
 315                 cptr = ptr;\r
 316                 for (cn=0; cn<16; cn++)\r
 317                 {\r
 318                         MSG( ConvertNumberToText( (cell_t) *cptr++, 16, FALSE, 2 ) );\r
 319                         EMIT(' ');\r
 320                 }\r
 321                 EMIT(' ');\r
 322                 for (cn=0; cn<16; cn++)\r
 323                 {\r
 324                         c = *ptr++;\r
 325                         if ((c < ' ') || (c > '}')) c = '.';\r
 326                         EMIT(c);\r
 327                 }\r
 328                 EMIT_CR;\r
 329         }\r
 330 }\r
 331 \r
 332 \r
 333 /* Print name, mask off any dictionary bits. */\r
 334 void TypeName( const char *Name )\r
 335 {\r
 336         const char *FirstChar;\r
 337         cell_t Len;\r
 338         \r
 339         FirstChar = Name+1;\r
 340         Len = *Name & 0x1F;\r
 341         \r
 342         ioType( FirstChar, Len );\r
 343 }\r
 344 \r
 345 \r
 346 \r
 347 #ifdef PF_UNIT_TEST\r
 348 /* Unit test for string conversion routines. */\r
 349 #define ASSERT_PAD_IS( index, value, msg ) \\r
 350         if( pad[index] != ((char)(value)) ) \\r
 351         { \\r
 352                 ERR(( "ERROR text test failed: " msg "\n")); \\r
 353                 numErrors += 1; \\r
 354         } \\r
 355 \r
 356 cell_t pfUnitTestText( void )\r
 357 {\r
 358         cell_t numErrors = 0;\r
 359         char pad[16];\r
 360         char fpad[8];\r
 361 \r
 362         /* test CStringToForth */\r
 363         pfSetMemory(pad,0xA5,sizeof(pad));\r
 364         CStringToForth( pad, "frog", 6 );\r
 365         ASSERT_PAD_IS( 0, 4, "CS len 6" );\r
 366         ASSERT_PAD_IS( 4, 'g', "CS end 6" );\r
 367         ASSERT_PAD_IS( 5, 0xA5, "CS past 6" );\r
 368         \r
 369         pfSetMemory(pad,0xA5,sizeof(pad));\r
 370         CStringToForth( pad, "frog", 5 );\r
 371         ASSERT_PAD_IS( 0, 4, "CS len 5" );\r
 372         ASSERT_PAD_IS( 4, 'g', "CS end 5" );\r
 373         ASSERT_PAD_IS( 5, 0xA5, "CS past 5" );\r
 374         \r
 375         pfSetMemory(pad,0xA5,sizeof(pad));\r
 376         CStringxxxxxToForth( pad, "frog", 4 );\r
 377         ASSERT_PAD_IS( 0, 3, "CS len 4" );\r
 378         ASSERT_PAD_IS( 3, 'o', "CS end 4" );\r
 379         ASSERT_PAD_IS( 4, 0xA5, "CS past 4" );\r
 380         \r
 381         /* Make a Forth string for testing ForthStringToC. */\r
 382         CStringToForth( fpad, "frog", sizeof(fpad) );\r
 383         \r
 384         pfSetMemory(pad,0xA5,sizeof(pad));\r
 385         ForthStringToC( pad, fpad, 6 );\r
 386         ASSERT_PAD_IS( 0, 'f', "FS len 6" );\r
 387         ASSERT_PAD_IS( 3, 'g', "FS end 6" );\r
 388         ASSERT_PAD_IS( 4, 0, "FS nul 6" );\r
 389         ASSERT_PAD_IS( 5, 0xA5, "FS past 6" );\r
 390         \r
 391         pfSetMemory(pad,0xA5,sizeof(pad));\r
 392         ForthStringToC( pad, fpad, 5 );\r
 393         ASSERT_PAD_IS( 0, 'f', "FS len 5" );\r
 394         ASSERT_PAD_IS( 3, 'g', "FS end 5" );\r
 395         ASSERT_PAD_IS( 4, 0, "FS nul 5" );\r
 396         ASSERT_PAD_IS( 5, 0xA5, "FS past 5" );\r
 397         \r
 398         pfSetMemory(pad,0xA5,sizeof(pad));\r
 399         ForthStringToC( pad, fpad, 4 );\r
 400         ASSERT_PAD_IS( 0, 'f', "FS len 4" );\r
 401         ASSERT_PAD_IS( 2, 'o', "FS end 4" );\r
 402         ASSERT_PAD_IS( 3, 0, "FS nul 4" );\r
 403         ASSERT_PAD_IS( 4, 0xA5, "FS past 4" );\r
 404         \r
 405         return numErrors;\r
 406 }\r
 407 #endif\r