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