1 /* # skkinput (Simple Kana-Kanji Input)
2 *
3 * This file is part of skkinput.
4 * Copyright (C) 2002
5 * Takashi SAKAMOTO (PXG01715@nifty.ne.jp)
6 *
7 * This program is free software; you can redistribute it and/or modify
8 * it under the terms of the GNU General Public License as published by
9 * the Free Software Foundation; either version 2, or (at your option)
10 * any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with skkinput; see the file COPYING. If not, write to
19 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20 */
21 #include "local.h"
22 #include <stdio.h>
23 #include <assert.h>
24 #include <stdarg.h>
25 #include "lispmgrp.h"
26 #include "cstring.h"
27 #include "kanji.h"
28
29 #define TEMPBUFSIZE (1024)
30
31 static Boolean lispEntity_princStr (TLispManager*, TLispEntity*, TVarbuffer*) ;
32 static Boolean lispEntity_princStrInteger (TLispManager*, TLispEntity*, TVarbuffer*) ;
33 static Boolean lispEntity_princStrFloat (TLispManager*, TLispEntity*, TVarbuffer*) ;
34 static Boolean lispEntity_princStrSymbol (TLispManager*, TLispEntity*, TVarbuffer*) ;
35 static Boolean lispEntity_princStrString (TLispManager*, TLispEntity*, TVarbuffer*) ;
36 static Boolean lispEntity_princStrConscell (TLispManager*, TLispEntity*, TVarbuffer*) ;
37 static Boolean lispEntity_princStrVector (TLispManager*, TLispEntity*, TVarbuffer*) ;
38 static Boolean lispEntity_princStrMarker (TLispManager*, TLispEntity*, TVarbuffer*) ;
39 static Boolean lispEntity_princStrBuffer (TLispManager*, TLispEntity*, TVarbuffer*) ;
40 static Boolean lispEntity_princStrWindow (TLispManager*, TLispEntity*, TVarbuffer*) ;
41 static Boolean lispEntity_princStrFrame (TLispManager*, TLispEntity*, TVarbuffer*) ;
42 static Boolean lispEntity_princStrSubr (TLispManager*, TLispEntity*, TVarbuffer*) ;
43 static Boolean lispEntity_princStrIMClient (TLispManager*, TLispEntity*, TVarbuffer*) ;
44 static Boolean lispEntity_princStrMutex (TLispManager*, TLispEntity*, TVarbuffer*) ;
45 static Boolean lispEntity_princStrXEvent (TLispManager*, TLispEntity*, TVarbuffer*) ;
46 static Boolean lispEntity_princStrRest (TLispManager*, const char*, TLispEntity*, TVarbuffer*) ;
47 static Boolean lispEntity_print (TLispManager*, TLispEntity*) ;
48 static Boolean lispEntity_printInteger (TLispManager*, TLispEntity*) ;
49 static Boolean lispEntity_printFloat (TLispManager*, TLispEntity*) ;
50 static Boolean lispEntity_printSymbol (TLispManager*, TLispEntity*) ;
51 static Boolean lispEntity_printString (TLispManager*, TLispEntity*) ;
52 static Boolean lispEntity_printConscell(TLispManager*, TLispEntity*) ;
53 static Boolean lispEntity_printVector (TLispManager*r, TLispEntity*) ;
54 static Boolean lispEntity_printMarker (TLispManager*, TLispEntity*) ;
55 static Boolean lispEntity_printBuffer (TLispManager*, TLispEntity*) ;
56 static Boolean lispEntity_printWindow (TLispManager*, TLispEntity*) ;
57 static Boolean lispEntity_printFrame (TLispManager*, TLispEntity*) ;
58 static Boolean lispEntity_printSubr (TLispManager*, TLispEntity*) ;
59 static Boolean lispEntity_printIMClient(TLispManager*, TLispEntity*) ;
60 static Boolean lispEntity_printMutex (TLispManager*, TLispEntity*) ;
61 static Boolean lispEntity_printXEvent (TLispManager*, TLispEntity*) ;
62 static Boolean lispEntity_printEmpty (TLispManager*, TLispEntity*) ;
63 static Boolean lispEntity_printVoid (TLispManager*, TLispEntity*) ;
64 static Boolean lispEntity_formatString (TLispManager*, TLispEntity*, int, TVarbuffer*) ;
65 static Boolean lispEntity_formatChar (TLispManager*, TLispEntity*, TVarbuffer*) ;
66 static Boolean lispEntity_formatNumber (TLispManager*, TLispEntity*, const Char*, int, const Boolean, TVarbuffer*) ;
67 static Boolean lispEntity_formatNumberA (TLispManager*, TLispEntity*, const char*, int, const Boolean, TVarbuffer*) ;
68 static Boolean lispEntity_formatNumberCommon (TLispManager*, TLispEntity*, const char*, const Boolean, TVarbuffer*) ;
69 static Boolean lispEntity_copyConscell (TLispManager*, TLispEntity*, TLispEntity**) ;
70 static Boolean lispEntity_copyVector (TLispManager*, TLispEntity*, TLispEntity**) ;
71
72 /*
73 * LIST pEntList �� CAR �� pEntElt �� eq �Ǥ���С����� CDR ��
74 * �֤���
75 */
76 Boolean
lispEntity_Memq(register TLispManager * pLispMgr,register TLispEntity * pEntElt,register TLispEntity * pEntList,register TLispEntity ** ppEntRetval)77 lispEntity_Memq (
78 register TLispManager* pLispMgr,
79 register TLispEntity* pEntElt,
80 register TLispEntity* pEntList,
81 register TLispEntity** ppEntRetval)
82 {
83 TLispEntity* pEntCar ;
84 TLispEntity* pEntNextList ;
85
86 assert (pLispMgr != NULL) ;
87 assert (pEntElt != NULL) ;
88 assert (pEntList != NULL) ;
89
90 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntList))) {
91 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntList, &pEntCar)) ||
92 TFAILED (lispEntity_GetCdr (pLispMgr, pEntList, &pEntNextList)))
93 return False ;
94 if (TSUCCEEDED (lispEntity_Eq (pLispMgr, pEntElt, pEntCar)))
95 break ;
96 pEntList = pEntNextList ;
97 }
98 if (ppEntRetval != NULL)
99 *ppEntRetval = pEntList ;
100 return True ;
101 }
102
103 Boolean
lispEntity_Member(register TLispManager * pLispMgr,register TLispEntity * pEntElt,register TLispEntity * pEntList,register TLispEntity ** ppEntRetval)104 lispEntity_Member (
105 register TLispManager* pLispMgr,
106 register TLispEntity* pEntElt,
107 register TLispEntity* pEntList,
108 register TLispEntity** ppEntRetval)
109 {
110 TLispEntity* pEntCar ;
111 TLispEntity* pEntNextList ;
112
113 assert (pLispMgr != NULL) ;
114 assert (pEntElt != NULL) ;
115 assert (pEntList != NULL) ;
116
117 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntList))) {
118 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntList, &pEntCar)) ||
119 TFAILED (lispEntity_GetCdr (pLispMgr, pEntList, &pEntNextList)))
120 return False ;
121 if (TSUCCEEDED (lispEntity_Equal (pLispMgr, pEntElt, pEntCar)))
122 break ;
123 pEntList = pEntNextList ;
124 }
125 if (ppEntRetval != NULL)
126 *ppEntRetval = pEntList ;
127 return True ;
128 }
129
130 Boolean
lispEntity_Rassoc(register TLispManager * pLispMgr,register TLispEntity * pEntKey,register TLispEntity * pEntList,register TLispEntity ** ppEntRetval)131 lispEntity_Rassoc (
132 register TLispManager* pLispMgr,
133 register TLispEntity* pEntKey,
134 register TLispEntity* pEntList,
135 register TLispEntity** ppEntRetval)
136 {
137 TLispEntity* pEntCar ;
138 TLispEntity* pEntCadr ;
139 TLispEntity* pEntNextList ;
140 TLispEntity* pEntRetval ;
141
142 assert (pLispMgr != NULL) ;
143 assert (pEntKey != NULL) ;
144 assert (pEntList != NULL) ;
145
146 lispMgr_CreateNil (pLispMgr, &pEntRetval) ;
147 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntList))) {
148 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntList, &pEntCar)) ||
149 TFAILED (lispEntity_GetCdr (pLispMgr, pEntList, &pEntNextList)))
150 return False ;
151 if (TSUCCEEDED (lispEntity_GetCdr (pLispMgr, pEntCar, &pEntCadr)) &&
152 TSUCCEEDED (lispEntity_Equal (pLispMgr, pEntKey, pEntCadr))) {
153 pEntRetval = pEntCar ;
154 break ;
155 }
156 pEntList = pEntNextList ;
157 }
158 if (ppEntRetval != NULL)
159 *ppEntRetval = pEntRetval ;
160 return True ;
161 }
162
163 Boolean
lispEntity_Nconc(register TLispManager * pLispMgr,register TLispEntity * pEntList,register TLispEntity ** ppEntRetval)164 lispEntity_Nconc (
165 register TLispManager* pLispMgr,
166 register TLispEntity* pEntList,
167 register TLispEntity** ppEntRetval)
168 {
169 TLispEntity* pEntRetval ;
170 TLispEntity* pEntTail ;
171 TLispEntity* pEntCar ;
172 TLispEntity* pEntCdr ;
173
174 assert (pLispMgr != NULL) ;
175 assert (pEntList != NULL) ;
176 assert (ppEntRetval != NULL) ;
177
178 lispMgr_CreateNil (pLispMgr, &pEntRetval) ;
179 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntList))) {
180 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntList, &pEntCar)) ||
181 TFAILED (lispEntity_GetCdr (pLispMgr, pEntList, &pEntCdr)))
182 return False ;
183 pEntList = pEntCdr ;
184 if (TFAILED (lispEntity_Nullp (pLispMgr, pEntCar))) {
185 pEntRetval = pEntCar ;
186 lispEntity_GetLastElement (pLispMgr, pEntCar, &pEntTail) ;
187 break ;
188 }
189 }
190 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntList))) {
191 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntList, &pEntCar)) ||
192 TFAILED (lispEntity_Listp (pLispMgr, pEntCar)) ||
193 TFAILED (lispEntity_GetCdr (pLispMgr, pEntList, &pEntCdr)))
194 return False ;
195 if (TFAILED (lispEntity_Nullp (pLispMgr, pEntCar))) {
196 lispEntity_SetCdr (pLispMgr, pEntTail, pEntCar) ;
197 lispEntity_GetLastElement (pLispMgr, pEntCar, &pEntTail) ;
198 break ;
199 }
200 pEntList = pEntCdr ;
201 }
202 *ppEntRetval = pEntRetval ;
203 return True ;
204 }
205
206 Boolean
lispEntity_Equal(register TLispManager * pLispMgr,register TLispEntity * pEntLeft,register TLispEntity * pEntRight)207 lispEntity_Equal (
208 register TLispManager* pLispMgr,
209 register TLispEntity* pEntLeft,
210 register TLispEntity* pEntRight)
211 {
212 int iLeftType, iRightType ;
213
214 assert (pLispMgr != NULL) ;
215 assert (pEntLeft != NULL) ;
216 assert (pEntRight != NULL) ;
217
218 /* `eq' �ʤ����� `equal' ����Ω���롣*/
219 if (TSUCCEEDED (lispEntity_Eq (pLispMgr, pEntLeft, pEntRight)))
220 return True ;
221
222 if (TFAILED (lispEntity_GetType (pLispMgr, pEntLeft, &iLeftType)) ||
223 TFAILED (lispEntity_GetType (pLispMgr, pEntRight, &iRightType)) ||
224 iLeftType != iRightType)
225 return False ;
226
227 switch (iLeftType /* == iRightType */) {
228 case LISPENTITY_FLOAT:
229 {
230 float fLeftValue, fRightValue ;
231
232 lispEntity_GetFloatValue (pLispMgr, pEntLeft, &fLeftValue) ;
233 lispEntity_GetFloatValue (pLispMgr, pEntRight, &fRightValue) ;
234 return (fLeftValue == fRightValue)? True : False ;
235 }
236
237 case LISPENTITY_CONSCELL:
238 {
239 TLispEntity* pLeftCar ;
240 TLispEntity* pLeftCdr ;
241 TLispEntity* pRightCar ;
242 TLispEntity* pRightCdr ;
243
244 lispEntity_GetCar (pLispMgr, pEntLeft, &pLeftCar) ;
245 lispEntity_GetCar (pLispMgr, pEntRight, &pRightCar) ;
246 if (TFAILED (lispEntity_Equal (pLispMgr, pLeftCar, pRightCar)))
247 return False ;
248 lispEntity_GetCdr (pLispMgr, pEntLeft, &pLeftCdr) ;
249 lispEntity_GetCdr (pLispMgr, pEntRight, &pRightCdr) ;
250 if (TFAILED (lispEntity_Equal (pLispMgr, pLeftCdr, pRightCdr)))
251 return False ;
252 return True ;
253 }
254
255 case LISPENTITY_STRING:
256 {
257 const Char* pLeftString ;
258 int nLeftLength ;
259 const Char* pRightString ;
260 int nRightLength ;
261
262 lispEntity_GetStringValue (pLispMgr, pEntLeft, &pLeftString, &nLeftLength) ;
263 lispEntity_GetStringValue (pLispMgr, pEntRight, &pRightString, &nRightLength) ;
264 if (nLeftLength != nRightLength ||
265 Cstrncmp (pLeftString, pRightString, nLeftLength))
266 return False ;
267 return True ;
268 }
269
270 case LISPENTITY_VECTOR:
271 {
272 TLispEntity** ppLeftElement ;
273 int nLeftElement ;
274 TLispEntity** ppRightElement ;
275 int nRightElement ;
276
277 lispEntity_GetVectorValue (pLispMgr, pEntLeft, &ppLeftElement, &nLeftElement) ;
278 lispEntity_GetVectorValue (pLispMgr, pEntRight, &ppRightElement, &nRightElement) ;
279 if (nLeftElement != nRightElement)
280 return False ;
281
282 while (nLeftElement > 0) {
283 if (TFAILED (lispEntity_Equal (pLispMgr, *ppLeftElement, *ppRightElement)))
284 return False ;
285 ppLeftElement ++ ;
286 ppRightElement ++ ;
287 nLeftElement -- ;
288 }
289 return True ;
290 }
291
292 case LISPENTITY_SYMBOL:
293 case LISPENTITY_INTEGER:
294 default:
295 return False ;
296 }
297 }
298
299 Boolean
lispEntity_GetNumberValueOrMarkerPosition(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TLispNumber * pReturn)300 lispEntity_GetNumberValueOrMarkerPosition (
301 register TLispManager* pLispMgr,
302 register TLispEntity* pEntity,
303 register TLispNumber* pReturn)
304 {
305 long lValue ;
306 float fValue ;
307 TLispEntity* pEntBuffer ;
308 int iPos ;
309
310 assert (pLispMgr != NULL) ;
311
312 switch (pEntity->m_iType) {
313 case LISPENTITY_XEVENT:
314 case LISPENTITY_INTEGER:
315 if (TFAILED (lispEntity_GetIntegerValue (pLispMgr, pEntity, &lValue)))
316 return False ;
317 pReturn->m_fFloatp = False ;
318 pReturn->m_Value.m_lLong = lValue ;
319 break ;
320 case LISPENTITY_MARKER:
321 if (TFAILED (lispMarker_GetBufferPosition (pLispMgr, pEntity, &pEntBuffer, &iPos)) ||
322 pEntBuffer == NULL)
323 return False ;
324 pReturn->m_fFloatp = False ;
325 pReturn->m_Value.m_lLong = (long) iPos ;
326 break ;
327 case LISPENTITY_FLOAT:
328 (void) lispEntity_GetFloatValue (pLispMgr, pEntity, &fValue) ;
329 pReturn->m_fFloatp = True ;
330 pReturn->m_Value.m_fFloat = fValue ;
331 break ;
332 default:
333 return False ;
334 }
335 return True ;
336 }
337
338 Boolean
lispEntity_GetLength(register TLispManager * pLispMgr,register TLispEntity * pEntity,register int * pnLength)339 lispEntity_GetLength (
340 register TLispManager* pLispMgr,
341 register TLispEntity* pEntity,
342 register int* pnLength)
343 {
344 int nLength ;
345
346 assert (pLispMgr != NULL) ;
347 assert (pEntity != NULL) ;
348 assert (pnLength != NULL) ;
349
350 if (TFAILED (lispEntity_Sequencep (pLispMgr, pEntity)))
351 return False ;
352
353 switch (pEntity->m_iType) {
354 case LISPENTITY_STRING:
355 {
356 const Char* pString ;
357
358 (void) lispEntity_GetStringValue (pLispMgr, pEntity, &pString, &nLength) ;
359 break ;
360 }
361
362 case LISPENTITY_VECTOR:
363 {
364 TLispEntity** ppElement ;
365
366 (void) lispEntity_GetVectorValue (pLispMgr, pEntity, &ppElement, &nLength) ;
367 break ;
368 }
369
370 default:
371 {
372 TLispEntity* pNextEntity ;
373
374 nLength = 0 ;
375 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntity))) {
376 if (TFAILED (lispEntity_GetCdr (pLispMgr, pEntity, &pNextEntity))) {
377 #if defined (DEBUG)
378 fprintf (stderr, "Wrong type argument: listp, ") ;
379 lispEntity_Print (pLispMgr, pEntity) ;
380 fprintf (stderr, "\n") ;
381 #endif
382 return False ;
383 }
384 nLength ++ ;
385 pEntity = pNextEntity ;
386 }
387 }
388 }
389 *pnLength = nLength ;
390 return True ;
391 }
392
393 Boolean
lispEntity_GetInteractive(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TLispEntity ** ppReturn)394 lispEntity_GetInteractive (
395 register TLispManager* pLispMgr,
396 register TLispEntity* pEntity,
397 register TLispEntity** ppReturn)
398 {
399 TLispEntity* pInteractive ;
400 TLispEntity* pNextEntity ;
401
402 assert (pLispMgr != NULL) ;
403 assert (pEntity != NULL) ;
404 assert (ppReturn != NULL) ;
405
406 pInteractive = lispMgr_GetReservedEntity (pLispMgr, LISPMGR_INDEX_INTERACTIVE) ;
407 while (TFAILED (lispEntity_Nullp (pLispMgr, pEntity))) {
408 TLispEntity* pCar ;
409 TLispEntity* pCaar ;
410 if (TSUCCEEDED (lispEntity_GetCar (pLispMgr, pEntity, &pCar)) &&
411 TSUCCEEDED (lispEntity_GetCar (pLispMgr, pCar, &pCaar)) &&
412 pCaar == pInteractive) {
413 lispEntity_GetCadr (pLispMgr, pCar, ppReturn) ;
414 return True ;
415 }
416 if (TFAILED (lispEntity_GetCdr (pLispMgr, pEntity, &pNextEntity)))
417 return False ;
418 pEntity = pNextEntity ;
419 }
420 *ppReturn = NULL ;
421 return True ;
422 }
423
424 /*
425 * (format STRING &rest OBJECTS) �μ��ΤȤʤ�ؿ���
426 *
427 * (pFormat, nFormat) ��Ϳ����줿���˽��ä� pEntData �ˤ�ä�
428 * Ϳ����줿 entity �� list ��ɽ�����롣
429 * �����б����� entity ���ְ�äƤ���/�ʤ����ˤϥ��顼���֤���
430 */
431 Boolean
lispEntity_Format(register TLispManager * pLispMgr,register const Char * pFormat,register int nFormat,register TLispEntity * pEntData,register TLispEntity ** ppEntRetval)432 lispEntity_Format (
433 register TLispManager* pLispMgr,
434 register const Char* pFormat,
435 register int nFormat,
436 register TLispEntity* pEntData,
437 register TLispEntity** ppEntRetval)
438 {
439 TVarbuffer vbuf ;
440 TLispEntity* pEntArg ;
441 TLispEntity* pEntNextData ;
442 register int nUpper ;
443 register const Char* pSubFormat ;
444 register int nSubFormat ;
445
446 if (TFAILED (TVarbuffer_Initialize (&vbuf, sizeof (Char))))
447 return False ;
448
449 while (nFormat > 0) {
450 if (*pFormat != '%') {
451 if (TFAILED (TVarbuffer_Add (&vbuf, pFormat, 1)))
452 goto error ;
453 goto skip ;
454 }
455 pSubFormat = pFormat ;
456 pFormat ++ ;
457 nFormat -- ;
458 if (nFormat <= 0) {
459 #if defined (DEBUG) || 1
460 fprintf (stderr, "format error -> nFormat = 0\n") ;
461 #endif
462 goto error ;
463 }
464 nUpper = 0 ;
465 while (nFormat > 0 && '0' <= *pFormat && *pFormat <= '9') {
466 nUpper = nUpper * 10 + (nUpper - '0') ;
467 pFormat ++ ;
468 nFormat -- ;
469 }
470 if (nFormat > 0 && *pFormat == '.') {
471 pFormat ++ ;
472 nFormat -- ;
473 while (nFormat > 0 && '0' <= *pFormat && *pFormat <= '9') {
474 pFormat ++ ;
475 nFormat -- ;
476 }
477 }
478 if (nFormat <= 0) {
479 #if defined (DEBUG) || 1
480 fprintf (stderr, "format error -> nFormat = 0\n") ;
481 #endif
482 goto error ;
483 }
484 nSubFormat = pFormat - pSubFormat + 1 ;
485 switch (*pFormat) {
486 case 's':
487 case 'S':
488 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
489 TFAILED (lispEntity_formatString (pLispMgr, pEntArg, nUpper, &vbuf))) {
490 #if defined (DEBUG) || 1
491 fprintf (stderr, "format error -> %%s -> ") ;
492 lispEntity_Print (pLispMgr, pEntArg) ;
493 fprintf (stderr, "\n") ;
494 #endif
495 goto error ;
496 }
497 break ;
498
499 case 'c':
500 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
501 TFAILED (lispEntity_formatChar (pLispMgr, pEntArg, &vbuf))) {
502 #if defined (DEBUG) || 1
503 fprintf (stderr, "format error -> %%c -> ") ;
504 lispEntity_Print (pLispMgr, pEntArg) ;
505 fprintf (stderr, "\n") ;
506 #endif
507 goto error ;
508 }
509 break ;
510
511 case 'd':
512 case 'o':
513 case 'x':
514 case 'X':
515 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
516 TFAILED (lispEntity_formatNumber (pLispMgr, pEntArg, pSubFormat, nSubFormat, False, &vbuf))) {
517 #if defined (DEBUG) || 1
518 fprintf (stderr, "format error -> doxX -> ") ;
519 lispEntity_Print (pLispMgr, pEntArg) ;
520 fprintf (stderr, "\n") ;
521 #endif
522 goto error ;
523 }
524 break ;
525
526 case 'e':
527 case 'f':
528 case 'g':
529 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
530 TFAILED (lispEntity_formatNumber (pLispMgr, pEntArg, pSubFormat, nSubFormat, True, &vbuf))) {
531 #if defined (DEBUG) || 1
532 fprintf (stderr, "format error -> efg -> ") ;
533 lispEntity_Print (pLispMgr, pEntArg) ;
534 fprintf (stderr, "\n") ;
535 #endif
536 goto error ;
537 }
538 break ;
539
540 case '%':
541 if (TFAILED (TVarbuffer_Add (&vbuf, pFormat, 1)))
542 goto error ;
543 goto skip ;
544
545 default:
546 #if defined (DEBUG) || 1
547 fprintf (stderr, "format error -> default (%c), %c\n",
548 (int)*pSubFormat, (int)*pFormat) ;
549 #endif
550 goto error ;
551 }
552 if (TFAILED (lispEntity_GetCdr (pLispMgr, pEntData, &pEntNextData)))
553 goto error ;
554 pEntData = pEntNextData ;
555 skip:
556 pFormat ++ ;
557 nFormat -- ;
558 }
559
560 if (TFAILED (lispMgr_CreateString (pLispMgr, TVarbuffer_GetBuffer (&vbuf), TVarbuffer_GetUsage (&vbuf), ppEntRetval)))
561 goto error ;
562 return True ;
563
564 error:
565 TVarbuffer_Uninitialize (&vbuf) ;
566 return False ;
567 }
568
569 /*
570 * (format STRING &rest OBJECTS) �μ��ΤȤʤ�ؿ���
571 *
572 * (pFormat, nFormat) ��Ϳ����줿���˽��ä� pEntData �ˤ�ä�
573 * Ϳ����줿 entity �� list ��ɽ�����롣
574 * �����б����� entity ���ְ�äƤ���/�ʤ����ˤϥ��顼���֤���
575 */
576 Boolean
lispEntity_FormatA(register TLispManager * pLispMgr,register const char * pFormat,register int nFormat,register TLispEntity * pEntData,register TLispEntity ** ppEntRetval)577 lispEntity_FormatA (
578 register TLispManager* pLispMgr,
579 register const char* pFormat,
580 register int nFormat,
581 register TLispEntity* pEntData,
582 register TLispEntity** ppEntRetval)
583 {
584 TVarbuffer vbuf ;
585 TLispEntity* pEntArg ;
586 TLispEntity* pEntNextData ;
587 Char cc ;
588 register int nUpper ;
589 register const char* pSubFormat ;
590 register int nSubFormat ;
591 register Boolean fRetval = False ;
592
593 if (TFAILED (TVarbuffer_Initialize (&vbuf, sizeof (Char))))
594 return False ;
595
596 while (nFormat > 0) {
597 if (*pFormat != '%') {
598 cc = Char_MakeAscii (*pFormat) ;
599 if (TFAILED (TVarbuffer_Add (&vbuf, &cc, 1)))
600 goto error ;
601 goto skip ;
602 }
603 pSubFormat = pFormat ;
604 pFormat ++ ;
605 nFormat -- ;
606 if (nFormat <= 0)
607 goto error ;
608 nUpper = 0 ;
609 while (nFormat > 0 && '0' <= *pFormat && *pFormat <= '9') {
610 nUpper = nUpper * 10 + (nUpper - '0') ;
611 pFormat ++ ;
612 nFormat -- ;
613 }
614 if (nFormat > 0 && *pFormat == '.') {
615 pFormat ++ ;
616 nFormat -- ;
617 while (nFormat > 0 && '0' <= *pFormat && *pFormat <= '9') {
618 pFormat ++ ;
619 nFormat -- ;
620 }
621 }
622 if (nFormat <= 0)
623 goto error ;
624
625 nSubFormat = pFormat - pSubFormat + 1 ;
626 switch (*pFormat) {
627 case 's':
628 case 'S':
629 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
630 TFAILED (lispEntity_formatString (pLispMgr, pEntArg, nUpper, &vbuf)))
631 goto error ;
632 break ;
633
634 case 'c':
635 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
636 TFAILED (lispEntity_formatChar (pLispMgr, pEntArg, &vbuf)))
637 goto error ;
638 break ;
639
640 case 'd':
641 case 'o':
642 case 'x':
643 case 'X':
644 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
645 TFAILED (lispEntity_formatNumberA (pLispMgr, pEntArg, pSubFormat, nSubFormat, False, &vbuf)))
646 goto error ;
647 break ;
648
649 case 'e':
650 case 'f':
651 case 'g':
652 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntData, &pEntArg)) ||
653 TFAILED (lispEntity_formatNumberA (pLispMgr, pEntArg, pSubFormat, nSubFormat, True, &vbuf)))
654 goto error ;
655 break ;
656
657 case '%':
658 cc = Char_MakeAscii (*pFormat) ;
659 if (TFAILED (TVarbuffer_Add (&vbuf, &cc, 1)))
660 goto error ;
661 goto skip ;
662
663 default:
664 goto error ;
665 }
666 if (TFAILED (lispEntity_GetCdr (pLispMgr, pEntData, &pEntNextData)))
667 goto error ;
668 pEntData = pEntNextData ;
669 skip:
670 pFormat ++ ;
671 nFormat -- ;
672 }
673
674 if (TFAILED (lispMgr_CreateString (pLispMgr, TVarbuffer_GetBuffer (&vbuf), TVarbuffer_GetUsage (&vbuf), ppEntRetval)))
675 goto error ;
676 fRetval = True ;
677
678 error:
679 TVarbuffer_Uninitialize (&vbuf) ;
680 return fRetval ;
681 }
682
683 Boolean
lispEntity_PrincStr(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)684 lispEntity_PrincStr (
685 register TLispManager* pLispMgr,
686 register TLispEntity* pEntity,
687 register TVarbuffer* pvbuf)
688 {
689 static const Char chL = '(' ;
690 static const Char chR = ')' ;
691
692 assert (pLispMgr != NULL) ;
693 assert (pEntity != NULL) ;
694 assert (pvbuf != NULL) ;
695
696 if (TSUCCEEDED (lispEntity_Consp (pLispMgr, pEntity))) {
697 if (TFAILED (TVarbuffer_Add (pvbuf, &chL, 1)) ||
698 TFAILED (lispEntity_princStr (pLispMgr, pEntity, pvbuf)) ||
699 TFAILED (TVarbuffer_Add (pvbuf, &chR, 1)))
700 return False ;
701 return True ;
702 } else {
703 return lispEntity_princStr (pLispMgr, pEntity, pvbuf) ;
704 }
705 }
706
707 Boolean
lispEntity_princStr(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)708 lispEntity_princStr (
709 register TLispManager* pLispMgr,
710 register TLispEntity* pEntity,
711 register TVarbuffer* pvbuf)
712 {
713 static Boolean (*arPrincStrFuncTbl[])(TLispManager*, TLispEntity*, TVarbuffer*) = {
714 lispEntity_princStrInteger, lispEntity_princStrFloat,
715 lispEntity_princStrConscell, lispEntity_princStrVector,
716 lispEntity_princStrString, lispEntity_princStrSymbol,
717 lispEntity_princStrMarker, lispEntity_princStrBuffer,
718 lispEntity_princStrWindow, lispEntity_princStrFrame,
719 lispEntity_princStrSubr, lispEntity_princStrIMClient,
720 lispEntity_princStrMutex, lispEntity_princStrXEvent,
721 NULL, /* empty */ NULL, /* void */
722 NULL, /* bool-vector */ NULL, /* char-table */
723 } ;
724 int nType ;
725
726 assert (pLispMgr != NULL) ;
727 assert (pEntity != NULL) ;
728 assert (pvbuf != NULL) ;
729
730 lispEntity_GetType (pLispMgr, pEntity, &nType) ;
731 if (nType < 0 || nType >= MAX_LISPENTITY_TYPE)
732 return False ;
733 if (arPrincStrFuncTbl [nType] != NULL) {
734 return (arPrincStrFuncTbl [nType])(pLispMgr, pEntity, pvbuf) ;
735 } else {
736 static const Char sstrUnknown[] = { '(','u','n','k','n','o','w','n',')' } ;
737 return TVarbuffer_Add (pvbuf, sstrUnknown, NELEMENTS (sstrUnknown)) ;
738 }
739 }
740
741 /*
742 * ��δؿ��Ȼ��Ƥ��뤬��������ϥǥХå��ѤǤ��롣
743 */
744 Boolean
lispEntity_Print(register TLispManager * pLispMgr,register TLispEntity * pEntity)745 lispEntity_Print (
746 register TLispManager* pLispMgr,
747 register TLispEntity* pEntity)
748 {
749 assert (pLispMgr != NULL) ;
750
751 if (pEntity == NULL) {
752 fprintf (stderr, "NULL") ;
753 return True ;
754 }
755 if (TSUCCEEDED (lispEntity_Consp (pLispMgr, pEntity))) {
756 fprintf (stderr, "(") ;
757 lispEntity_print (pLispMgr, pEntity) ;
758 fprintf (stderr, ")") ;
759 return True ;
760 } else {
761 return lispEntity_print (pLispMgr, pEntity) ;
762 }
763 }
764
765 Boolean
lispEntity_print(register TLispManager * pLispMgr,register TLispEntity * pEntity)766 lispEntity_print (
767 register TLispManager* pLispMgr,
768 register TLispEntity* pEntity)
769 {
770 static Boolean (*arPrintFuncTbl[])(TLispManager*, TLispEntity*) = {
771 lispEntity_printInteger, lispEntity_printFloat,
772 lispEntity_printConscell, lispEntity_printVector,
773 lispEntity_printString, lispEntity_printSymbol,
774 lispEntity_printMarker, lispEntity_printBuffer,
775 lispEntity_printWindow, lispEntity_printFrame,
776 lispEntity_printSubr, lispEntity_printIMClient,
777 lispEntity_printMutex, lispEntity_printXEvent,
778 lispEntity_printEmpty, lispEntity_printVoid,
779 NULL, /* bool-vector */
780 NULL, /* char-table */
781 } ;
782 int nType ;
783
784 assert (pLispMgr != NULL) ;
785
786 if (pEntity == NULL) {
787 fprintf (stderr, "NULL") ;
788 return True ;
789 }
790 lispEntity_GetType (pLispMgr, pEntity, &nType) ;
791 if (nType < 0 || nType >= MAX_LISPENTITY_TYPE)
792 return False ;
793 if (arPrintFuncTbl [nType] != NULL) {
794 return (arPrintFuncTbl [nType])(pLispMgr, pEntity) ;
795 } else {
796 fprintf (stderr, "'unknown") ;
797 return True ;
798 }
799 }
800
801 /* private functions */
802 Boolean
lispEntity_princStrInteger(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)803 lispEntity_princStrInteger (
804 register TLispManager* pLispMgr,
805 register TLispEntity* pEntity,
806 register TVarbuffer* pvbuf)
807 {
808 char szBuf [64] ;
809 long lValue ;
810 register int nLength ;
811 register Char* pDest ;
812 register int nUsage ;
813
814 if (TFAILED (lispEntity_GetIntegerValue (pLispMgr, pEntity, &lValue)))
815 return False ;
816 snprintf (szBuf, sizeof (szBuf) - 1, "%ld", lValue) ;
817 szBuf [sizeof (szBuf) - 1] = '\0' ;
818 nLength = strlen (szBuf) ;
819 nUsage = TVarbuffer_GetUsage (pvbuf) ;
820 if (TFAILED (TVarbuffer_Require (pvbuf, nLength)))
821 return False ;
822 pDest = (Char *)TVarbuffer_GetBuffer (pvbuf) + nUsage ;
823 strtocstr (pDest, szBuf, nLength) ;
824 return True ;
825 }
826
827 Boolean
lispEntity_princStrFloat(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)828 lispEntity_princStrFloat (
829 register TLispManager* pLispMgr,
830 register TLispEntity* pEntity,
831 register TVarbuffer* pvbuf)
832 {
833 char szBuf [64] ;
834 float fValue ;
835 register int nLength ;
836 register Char* pDest ;
837 register int nUsage ;
838
839 if (TFAILED (lispEntity_GetFloatValue (pLispMgr, pEntity, &fValue)))
840 return False ;
841 snprintf (szBuf, sizeof (szBuf) - 1, "%f", fValue) ;
842 szBuf [sizeof (szBuf) - 1] = '\0' ;
843 nLength = strlen (szBuf) ;
844 nUsage = TVarbuffer_GetUsage (pvbuf) ;
845 if (TFAILED (TVarbuffer_Require (pvbuf, nLength)))
846 return False ;
847 pDest = (Char *)TVarbuffer_GetBuffer (pvbuf) + nUsage ;
848 strtocstr (pDest, szBuf, nLength) ;
849 return True ;
850 }
851
852 Boolean
lispEntity_princStrSymbol(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)853 lispEntity_princStrSymbol (
854 register TLispManager* pLispMgr,
855 register TLispEntity* pEntity,
856 register TVarbuffer* pvbuf)
857 {
858 const Char* pName ;
859 int nName ;
860
861 if (TFAILED (lispEntity_GetSymbolName (pLispMgr, pEntity, &pName, &nName)) |\
862 TFAILED (TVarbuffer_Add (pvbuf, pName, nName)))
863 return False ;
864 return True ;
865 }
866
867 Boolean
lispEntity_princStrString(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)868 lispEntity_princStrString (
869 register TLispManager* pLispMgr,
870 register TLispEntity* pEntity,
871 register TVarbuffer* pvbuf)
872 {
873 static const Char chDoubleQuote = '\"' ;
874 const Char* pString ;
875 int nLength ;
876
877 (void) lispEntity_GetStringValue (pLispMgr, pEntity, &pString, &nLength) ;
878 if (TFAILED (TVarbuffer_Add (pvbuf, &chDoubleQuote, 1)) ||
879 TFAILED (TVarbuffer_Add (pvbuf, pString, nLength)) ||
880 TFAILED (TVarbuffer_Add (pvbuf, &chDoubleQuote, 1)))
881 return False ;
882 return True ;
883 }
884
885 Boolean
lispEntity_princStrConscell(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)886 lispEntity_princStrConscell (
887 register TLispManager* pLispMgr,
888 register TLispEntity* pEntity,
889 register TVarbuffer* pvbuf)
890 {
891 static const Char chParenthesisL = '(' ;
892 static const Char chParenthesisR = ')' ;
893 static const Char chSpace = ' ' ;
894 TLispEntity* pEntCar ;
895 TLispEntity* pEntCdr ;
896
897 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntity, &pEntCar)) ||
898 TFAILED (lispEntity_GetCdr (pLispMgr, pEntity, &pEntCdr)))
899 return False ;
900 if (TSUCCEEDED (lispEntity_Consp (pLispMgr, pEntCar))) {
901 if (TFAILED (TVarbuffer_Add (pvbuf, &chParenthesisL, 1)) ||
902 TFAILED (lispEntity_princStr (pLispMgr, pEntCar, pvbuf)) ||
903 TFAILED (TVarbuffer_Add (pvbuf, &chParenthesisR, 1)))
904 return False ;
905 } else {
906 if (TFAILED (lispEntity_princStr (pLispMgr, pEntCar, pvbuf)))
907 return False ;
908 }
909 if (TFAILED (lispEntity_Listp (pLispMgr, pEntCdr))) {
910 static const Char rchSDS [] = { ' ', '.', ' ', } ;
911 if (TFAILED (TVarbuffer_Add (pvbuf, rchSDS, NELEMENTS (rchSDS))) ||
912 TFAILED (lispEntity_princStr (pLispMgr, pEntCdr, pvbuf)))
913 return False ;
914 } else {
915 if (TFAILED (lispEntity_Nullp (pLispMgr, pEntCdr)) &&
916 (TFAILED (TVarbuffer_Add (pvbuf, &chSpace, 1)) ||
917 TFAILED (lispEntity_princStr (pLispMgr, pEntCdr, pvbuf))))
918 return False ;
919 }
920 return True ;
921 }
922
923 Boolean
lispEntity_princStrVector(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)924 lispEntity_princStrVector (
925 register TLispManager* pLispMgr,
926 register TLispEntity* pEntity,
927 register TVarbuffer* pvbuf)
928 {
929 static const Char chBracketL = '[' ;
930 static const Char chSpace = ' ' ;
931 static const Char chBracketR = ']' ;
932 TLispEntity** ppElement ;
933 int nElement ;
934
935 lispEntity_GetVectorValue (pLispMgr, pEntity, &ppElement, &nElement) ;
936 if (TFAILED (TVarbuffer_Add (pvbuf, &chBracketL, 1)))
937 return False ;
938 if (nElement > 0) {
939 do {
940 if (TFAILED (lispEntity_PrincStr (pLispMgr, *ppElement ++, pvbuf)) ||
941 (nElement > 1 && TFAILED (TVarbuffer_Add (pvbuf, &chSpace, 1))))
942 return False ;
943 nElement -- ;
944 } while (nElement > 0) ;
945 }
946 return TVarbuffer_Add (pvbuf, &chBracketR, 1) ;
947 }
948
949 Boolean
lispEntity_princStrMarker(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)950 lispEntity_princStrMarker (
951 register TLispManager* pLispMgr,
952 register TLispEntity* pEntity,
953 register TVarbuffer* pvbuf)
954 {
955 TLispEntity* pEntBuffer ;
956 int nPos ;
957 char szBuf [64] ;
958 register int nLength ;
959 register Char* pDest ;
960
961 lispMarker_GetBufferPosition (pLispMgr, pEntity, &pEntBuffer, &nPos) ;
962 if (pEntBuffer != NULL) {
963 snprintf (szBuf, sizeof (szBuf) - 1, "#<marker at %d in %lx>", nPos, (unsigned long)pEntBuffer) ;
964 } else {
965 snprintf (szBuf, sizeof (szBuf) - 1, "#<marker in no buffer>") ;
966 }
967 szBuf [sizeof (szBuf) - 1] = '\0' ;
968 nLength = strlen (szBuf) ;
969 if (TFAILED (TVarbuffer_Require (pvbuf, nLength)))
970 return False ;
971 pDest = (Char *)TVarbuffer_GetBuffer (pvbuf) + TVarbuffer_GetUsage (pvbuf) ;
972 strtocstr (pDest, szBuf, nLength) ;
973 return True ;
974 }
975
976 Boolean
lispEntity_princStrBuffer(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)977 lispEntity_princStrBuffer (
978 register TLispManager* pLispMgr,
979 register TLispEntity* pEntity,
980 register TVarbuffer* pvbuf)
981 {
982 return lispEntity_princStrRest (pLispMgr, "#<buffer %lx>", pEntity, pvbuf) ;
983 }
984
985 Boolean
lispEntity_princStrWindow(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)986 lispEntity_princStrWindow (
987 register TLispManager* pLispMgr,
988 register TLispEntity* pEntity,
989 register TVarbuffer* pvbuf)
990 {
991 return lispEntity_princStrRest (pLispMgr, "#<window %lx>", pEntity, pvbuf) ;
992 }
993
994 Boolean
lispEntity_princStrFrame(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)995 lispEntity_princStrFrame (
996 register TLispManager* pLispMgr,
997 register TLispEntity* pEntity,
998 register TVarbuffer* pvbuf)
999 {
1000 return lispEntity_princStrRest (pLispMgr, "#<frame %lx>", pEntity, pvbuf) ;
1001 }
1002
1003 Boolean
lispEntity_princStrSubr(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)1004 lispEntity_princStrSubr (
1005 register TLispManager* pLispMgr,
1006 register TLispEntity* pEntity,
1007 register TVarbuffer* pvbuf)
1008 {
1009 static const Char rchSTR1 [] = { '#','<','s','u','b','r',' ', } ;
1010 static const Char rchSTR2 [] = { '>', } ;
1011 const Char* strSubrName ;
1012
1013 if (TFAILED (lispSubr_GetName (pLispMgr, pEntity, &strSubrName)))
1014 return False ;
1015 if (TFAILED (TVarbuffer_Add (pvbuf, rchSTR1, NELEMENTS (rchSTR1))) ||
1016 TFAILED (TVarbuffer_Add (pvbuf, strSubrName, Cstrlen (strSubrName))) ||
1017 TFAILED (TVarbuffer_Add (pvbuf, rchSTR2, NELEMENTS (rchSTR2))))
1018 return False ;
1019 return True ;
1020 }
1021
1022 Boolean
lispEntity_princStrIMClient(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)1023 lispEntity_princStrIMClient (
1024 register TLispManager* pLispMgr,
1025 register TLispEntity* pEntity,
1026 register TVarbuffer* pvbuf)
1027 {
1028 return lispEntity_princStrRest (pLispMgr, "#<im-client %lx>", pEntity, pvbuf) ;
1029 }
1030
1031 Boolean
lispEntity_princStrMutex(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)1032 lispEntity_princStrMutex (
1033 register TLispManager* pLispMgr,
1034 register TLispEntity* pEntity,
1035 register TVarbuffer* pvbuf)
1036 {
1037 return lispEntity_princStrRest (pLispMgr, "#<mutex %lx>", pEntity, pvbuf) ;
1038 }
1039
1040 Boolean
lispEntity_princStrXEvent(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)1041 lispEntity_princStrXEvent (
1042 register TLispManager* pLispMgr,
1043 register TLispEntity* pEntity,
1044 register TVarbuffer* pvbuf)
1045 {
1046 return lispEntity_princStrRest (pLispMgr, "#<xevent %lx>", pEntity, pvbuf) ;
1047 }
1048
1049 Boolean
lispEntity_princStrRest(register TLispManager * pLispMgr,register const char * pFormat,register TLispEntity * pEntity,register TVarbuffer * pvbuf)1050 lispEntity_princStrRest (
1051 register TLispManager* pLispMgr,
1052 register const char* pFormat,
1053 register TLispEntity* pEntity,
1054 register TVarbuffer* pvbuf)
1055 {
1056 char szBuf [64] ;
1057 int nLength ;
1058 Char* pDest ;
1059 snprintf (szBuf, sizeof (szBuf) - 1, pFormat, (unsigned long) pEntity) ;
1060 szBuf [sizeof (szBuf) - 1] = '\0' ;
1061 nLength = strlen (szBuf) ;
1062 if (TFAILED (TVarbuffer_Require (pvbuf, nLength)))
1063 return False ;
1064 pDest = (Char *)TVarbuffer_GetBuffer (pvbuf) + TVarbuffer_GetUsage (pvbuf) ;
1065 strtocstr (pDest, szBuf, nLength) ;
1066 return True ;
1067 }
1068
1069 Boolean
lispEntity_printInteger(register TLispManager * pLispMgr,register TLispEntity * pEntity)1070 lispEntity_printInteger (
1071 register TLispManager* pLispMgr,
1072 register TLispEntity* pEntity)
1073 {
1074 long lValue ;
1075 (void) lispEntity_GetIntegerValue (pLispMgr, pEntity, &lValue) ;
1076 fprintf (stderr, "%ld", lValue) ;
1077 return True ;
1078 }
1079
1080 Boolean
lispEntity_printFloat(register TLispManager * pLispMgr,register TLispEntity * pEntity)1081 lispEntity_printFloat (
1082 register TLispManager* pLispMgr,
1083 register TLispEntity* pEntity)
1084 {
1085 float fValue ;
1086 (void) lispEntity_GetFloatValue (pLispMgr, pEntity, &fValue) ;
1087 fprintf (stderr, "%f", fValue) ;
1088 return True ;
1089 }
1090
1091 Boolean
lispEntity_printSymbol(register TLispManager * pLispMgr,register TLispEntity * pEntity)1092 lispEntity_printSymbol (
1093 register TLispManager* pLispMgr,
1094 register TLispEntity* pEntity)
1095 {
1096 const Char* pName ;
1097 int nName ;
1098 int nLength ;
1099 char achBuf [TEMPBUFSIZE] ;
1100
1101 (void) lispEntity_GetSymbolName (pLispMgr, pEntity, &pName, &nName) ;
1102 nLength = NELEMENTS (achBuf) - 1 ;
1103 if (nName < nLength)
1104 nLength = nName ;
1105
1106 cstrtostr (achBuf, pName, nLength) ;
1107 achBuf [nLength] = '\0' ;
1108 fprintf (stderr, "%s", achBuf) ;
1109 return True ;
1110 }
1111
1112 Boolean
lispEntity_printString(register TLispManager * pLispMgr,register TLispEntity * pEntity)1113 lispEntity_printString (
1114 register TLispManager* pLispMgr,
1115 register TLispEntity* pEntity)
1116 {
1117 const Char* pString ;
1118 int nLength ;
1119 char achBuf [TEMPBUFSIZE] ;
1120
1121 (void) lispEntity_GetStringValue (pLispMgr, pEntity, &pString, &nLength) ;
1122 if (nLength <= 0) {
1123 fprintf (stderr, "\"\"") ;
1124 return True ;
1125 }
1126 if (nLength > (sizeof (achBuf) - 1))
1127 nLength = sizeof (achBuf) - 1 ;
1128 #if 1
1129 {
1130 KANJISTATEMACHINE ksm ;
1131 int n ;
1132 InitializeKanjiFiniteStateMachine (&ksm, KCODING_SYSTEM_ISO2022JP2) ;
1133 fprintf (stderr, "\"") ;
1134 while (nLength > 0) {
1135 n = RtransferKanjiFiniteStateMachine (&ksm, *pString ++, achBuf) ;
1136 achBuf [n] = '\0' ;
1137 fprintf (stderr, "%s", achBuf) ;
1138 nLength -- ;
1139 }
1140 n = RtransferKanjiFiniteStateMachine (&ksm, '\"', achBuf) ;
1141 achBuf [n] = '\0' ;
1142 fprintf (stderr, "%s", achBuf) ;
1143 fflush (stderr) ;
1144 }
1145 #else
1146 cstrtostr (achBuf, pString, nLength) ;
1147 achBuf [nLength] = '\0' ;
1148 fprintf (stderr, "\"%s\"", achBuf) ;
1149 #endif
1150 return True ;
1151 }
1152
1153 Boolean
lispEntity_printConscell(register TLispManager * pLispMgr,register TLispEntity * pEntity)1154 lispEntity_printConscell (
1155 register TLispManager* pLispMgr,
1156 register TLispEntity* pEntity)
1157 {
1158 TLispEntity* pEntCar ;
1159 TLispEntity* pEntCdr ;
1160
1161 lispEntity_GetCar (pLispMgr, pEntity, &pEntCar) ;
1162 lispEntity_GetCdr (pLispMgr, pEntity, &pEntCdr) ;
1163
1164 if (TSUCCEEDED (lispEntity_Consp (pLispMgr, pEntCar))) {
1165 fprintf (stderr, "(") ;
1166 lispEntity_print (pLispMgr, pEntCar) ;
1167 fprintf (stderr, ")") ;
1168 } else {
1169 lispEntity_print (pLispMgr, pEntCar) ;
1170 }
1171 if (TFAILED (lispEntity_Listp (pLispMgr, pEntCdr))) {
1172 fprintf (stderr, " . ") ;
1173 lispEntity_print (pLispMgr, pEntCdr) ;
1174 } else {
1175 if (TFAILED (lispEntity_Nullp (pLispMgr, pEntCdr))) {
1176 fprintf (stderr, " ") ;
1177 lispEntity_print (pLispMgr, pEntCdr) ;
1178 }
1179 }
1180 return True ;
1181 }
1182
1183 Boolean
lispEntity_printVector(register TLispManager * pLispMgr,register TLispEntity * pEntity)1184 lispEntity_printVector (
1185 register TLispManager* pLispMgr,
1186 register TLispEntity* pEntity)
1187 {
1188 TLispEntity** ppElement ;
1189 int nElement ;
1190
1191 lispEntity_GetVectorValue (pLispMgr, pEntity, &ppElement, &nElement) ;
1192 fprintf (stderr, "[") ;
1193 if (nElement > 0) {
1194 do {
1195 lispEntity_Print (pLispMgr, *ppElement ++) ;
1196 if (nElement > 1)
1197 fprintf (stderr, " ") ;
1198 nElement -- ;
1199 } while (nElement > 0) ;
1200 }
1201 fprintf (stderr, "]") ;
1202 return True ;
1203 }
1204
1205 Boolean
lispEntity_printMarker(register TLispManager * pLispMgr,register TLispEntity * pEntity)1206 lispEntity_printMarker (
1207 register TLispManager* pLispMgr,
1208 register TLispEntity* pEntity)
1209 {
1210 TLispEntity* pEntBuffer ;
1211 int nPos ;
1212 lispMarker_GetBufferPosition (pLispMgr, pEntity, &pEntBuffer, &nPos) ;
1213 if (pEntBuffer != NULL) {
1214 fprintf (stderr, "#<marker at %d in %lx>",
1215 nPos,
1216 (unsigned long)pEntBuffer) ;
1217 } else {
1218 fprintf (stderr, "#<marker in no buffer>") ;
1219 }
1220 return True ;
1221 }
1222
1223 Boolean
lispEntity_printBuffer(register TLispManager * pLispMgr,register TLispEntity * pEntity)1224 lispEntity_printBuffer (
1225 register TLispManager* pLispMgr,
1226 register TLispEntity* pEntity)
1227 {
1228 fprintf (stderr, "#<buffer %lx>", (unsigned long)pEntity) ;
1229 return True ;
1230 }
1231
1232 Boolean
lispEntity_printWindow(register TLispManager * pLispMgr,register TLispEntity * pEntity)1233 lispEntity_printWindow (
1234 register TLispManager* pLispMgr,
1235 register TLispEntity* pEntity)
1236 {
1237 fprintf (stderr, "#<window %lx>", (unsigned long)pEntity) ;
1238 return True ;
1239 }
1240
1241 Boolean
lispEntity_printFrame(register TLispManager * pLispMgr,register TLispEntity * pEntity)1242 lispEntity_printFrame (
1243 register TLispManager* pLispMgr,
1244 register TLispEntity* pEntity)
1245 {
1246 fprintf (stderr, "#<frame %lx>", (unsigned long)pEntity) ;
1247 return True ;
1248 }
1249
1250 Boolean
lispEntity_printSubr(register TLispManager * pLispMgr,register TLispEntity * pEntity)1251 lispEntity_printSubr (
1252 register TLispManager* pLispMgr,
1253 register TLispEntity* pEntity)
1254 {
1255 const Char* pName ;
1256 int nName ;
1257 char achBuf [TEMPBUFSIZE] ;
1258
1259 fprintf (stderr, "#<subr ") ;
1260 lispSubr_GetName (pLispMgr, pEntity, &pName) ;
1261 nName = Cstrlen (pName) ;
1262 if (nName >= NELEMENTS (achBuf))
1263 nName = NELEMENTS (achBuf) - 1 ;
1264 cstrtostr (achBuf, pName, nName) ;
1265 achBuf [nName] = '\0' ;
1266 fprintf (stderr, "%s>", achBuf) ;
1267 return True ;
1268 }
1269
1270 Boolean
lispEntity_printIMClient(register TLispManager * pLispMgr,register TLispEntity * pEntity)1271 lispEntity_printIMClient (
1272 register TLispManager* pLispMgr,
1273 register TLispEntity* pEntity)
1274 {
1275 fprintf (stderr, "#<im-client %lx>", (unsigned long)pEntity) ;
1276 return True ;
1277 }
1278
1279 Boolean
lispEntity_printMutex(register TLispManager * pLispMgr,register TLispEntity * pEntity)1280 lispEntity_printMutex (
1281 register TLispManager* pLispMgr,
1282 register TLispEntity* pEntity)
1283 {
1284 const Char* pString ;
1285 int nLength ;
1286 char achBuf [TEMPBUFSIZE] ;
1287 unsigned int uLockCount ;
1288 const void* pOwner ;
1289
1290 fprintf (stderr, "#<mutex ") ;
1291 (void) lispEntity_GetMutexInfo (pLispMgr, pEntity, &pString, &nLength, &uLockCount, &pOwner) ;
1292 if (nLength <= 0) {
1293 fprintf (stderr, "\"\", ") ;
1294 } else {
1295 cstrtostr (achBuf, pString, nLength) ;
1296 achBuf [nLength] = '\0' ;
1297 fprintf (stderr, "\"%s\", ", achBuf) ;
1298 }
1299 fprintf (stderr, "lock(%u), owner(0x%lx)>", uLockCount, (unsigned long)pOwner) ;
1300 return True ;
1301 }
1302
1303 Boolean
lispEntity_printXEvent(register TLispManager * pLispMgr,register TLispEntity * pEntity)1304 lispEntity_printXEvent (
1305 register TLispManager* pLispMgr,
1306 register TLispEntity* pEntity)
1307 {
1308 XEvent* pEv ;
1309
1310 if (TFAILED (lispEntity_GetXEvent (pLispMgr, pEntity, &pEv)))
1311 return False ;
1312
1313 switch (pEv->type) {
1314 case KeyPress:
1315 fprintf (stderr, "#<xkeyevent: type(%d), window(%lx), keycode(%d)>",
1316 pEv->type, pEv->xkey.window, pEv->xkey.keycode) ;
1317 break ;
1318 default:
1319 fprintf (stderr, "#<xevent: type(%d), window(%lx)>",
1320 pEv->type, pEv->xany.window) ;
1321 break ;
1322 }
1323 return True ;
1324 }
1325
1326 Boolean
lispEntity_printEmpty(register TLispManager * pLispMgr,register TLispEntity * pEntity)1327 lispEntity_printEmpty (
1328 register TLispManager* pLispMgr,
1329 register TLispEntity* pEntity)
1330 {
1331 fprintf (stderr, "#<empty>") ;
1332 return True ;
1333 }
1334
1335 Boolean
lispEntity_printVoid(register TLispManager * pLispMgr,register TLispEntity * pEntity)1336 lispEntity_printVoid (
1337 register TLispManager* pLispMgr,
1338 register TLispEntity* pEntity)
1339 {
1340 fprintf (stderr, "#<void>") ;
1341 return True ;
1342 }
1343
1344 Boolean
lispEntity_formatString(register TLispManager * pLispMgr,register TLispEntity * pEntity,register int nCount,register TVarbuffer * pvbuf)1345 lispEntity_formatString (
1346 register TLispManager* pLispMgr,
1347 register TLispEntity* pEntity,
1348 register int nCount,
1349 register TVarbuffer* pvbuf)
1350 {
1351 TVarbuffer vbuf ;
1352 register Boolean fRetval = False ;
1353 register const Char* pString ;
1354 register int nUsage, nOffset ;
1355
1356 if (TFAILED (TVarbuffer_Initialize (&vbuf, sizeof (Char))))
1357 return False ;
1358 if (TFAILED (lispEntity_PrincStr (pLispMgr, pEntity, &vbuf)))
1359 goto error ;
1360
1361 /* string ���ä����ˤϡ������ double quote ���Ĥ��Τ�
1362 * ������������Τ���� -2 ���롣*/
1363 nUsage = TVarbuffer_GetUsage (&vbuf) ;
1364 nOffset = 0 ;
1365 if (TSUCCEEDED (lispEntity_Stringp (pLispMgr, pEntity))) {
1366 assert (nUsage >= 2) ;
1367 nUsage -= 2 ;
1368 nOffset ++ ;
1369 }
1370 if (0 < nCount && 0 <= nUsage && nUsage < nCount) {
1371 register int nSpace = nUsage - nCount ;
1372 static const Char cc = ' ' ;
1373 while (nSpace > 0) {
1374 if (TFAILED (TVarbuffer_Add (pvbuf, &cc, 1)))
1375 goto error ;
1376 nSpace -- ;
1377 }
1378 }
1379 if (nUsage > 0) {
1380 pString = (const Char *)TVarbuffer_GetBuffer (&vbuf) + nOffset ;
1381 fRetval = TVarbuffer_Add (pvbuf, pString, nUsage) ;
1382 } else {
1383 fRetval = True ;
1384 }
1385 error:
1386 TVarbuffer_Uninitialize (&vbuf) ;
1387 return fRetval ;
1388 }
1389
1390 Boolean
lispEntity_formatChar(register TLispManager * pLispMgr,register TLispEntity * pEntity,register TVarbuffer * pvbuf)1391 lispEntity_formatChar (
1392 register TLispManager* pLispMgr,
1393 register TLispEntity* pEntity,
1394 register TVarbuffer* pvbuf)
1395 {
1396 Char cc ;
1397
1398 if (TFAILED (lispEntity_GetIntegerValue (pLispMgr, pEntity, &cc)))
1399 return False ;
1400 return TVarbuffer_Add (pvbuf, &cc, 1) ;
1401 }
1402
1403 Boolean
lispEntity_formatNumber(register TLispManager * pLispMgr,register TLispEntity * pEntity,register const Char * pFormat,register int nFormat,register const Boolean fFloat,register TVarbuffer * pvbuf)1404 lispEntity_formatNumber (
1405 register TLispManager* pLispMgr,
1406 register TLispEntity* pEntity,
1407 register const Char* pFormat,
1408 register int nFormat,
1409 register const Boolean fFloat,
1410 register TVarbuffer* pvbuf)
1411 {
1412 char achFormat [64] ;
1413
1414 assert (pLispMgr != NULL) ;
1415 assert (pEntity != NULL) ;
1416 assert (pvbuf != NULL) ;
1417
1418 if (nFormat >= NELEMENTS (achFormat))
1419 return False ;
1420 cstrtostr (achFormat, pFormat, nFormat) ;
1421 achFormat [nFormat] = '\0' ;
1422 return lispEntity_formatNumberCommon (pLispMgr, pEntity, achFormat, fFloat, pvbuf) ;
1423 }
1424
1425 Boolean
lispEntity_formatNumberA(register TLispManager * pLispMgr,register TLispEntity * pEntity,register const char * pFormat,register int nFormat,register const Boolean fFloat,register TVarbuffer * pvbuf)1426 lispEntity_formatNumberA (
1427 register TLispManager* pLispMgr,
1428 register TLispEntity* pEntity,
1429 register const char* pFormat,
1430 register int nFormat,
1431 register const Boolean fFloat,
1432 register TVarbuffer* pvbuf)
1433 {
1434 char achFormat [64] ;
1435
1436 assert (pLispMgr != NULL) ;
1437 assert (pEntity != NULL) ;
1438 assert (pvbuf != NULL) ;
1439
1440 if (nFormat >= NELEMENTS (achFormat))
1441 return False ;
1442 memcpy (achFormat, pFormat, nFormat) ;
1443 achFormat [nFormat] = '\0' ;
1444 return lispEntity_formatNumberCommon (pLispMgr, pEntity, achFormat, fFloat, pvbuf) ;
1445 }
1446
1447 Boolean
lispEntity_formatNumberCommon(register TLispManager * pLispMgr,register TLispEntity * pEntity,register const char * pFormat,register const Boolean fFloat,register TVarbuffer * pvbuf)1448 lispEntity_formatNumberCommon (
1449 register TLispManager* pLispMgr,
1450 register TLispEntity* pEntity,
1451 register const char* pFormat,
1452 register const Boolean fFloat,
1453 register TVarbuffer* pvbuf)
1454 {
1455 char achBuffer [64] ;
1456 Char aChBuffer [64] ;
1457 register char* ptr ;
1458 register Char* pPtr ;
1459 TLispNumber num ;
1460
1461 assert (pLispMgr != NULL) ;
1462 assert (pEntity != NULL) ;
1463 assert (pFormat != NULL) ;
1464 assert (pvbuf != NULL) ;
1465
1466 if (TFAILED (lispEntity_GetNumberValue (pLispMgr, pEntity, &num)))
1467 return False ;
1468
1469 if (fFloat) {
1470 register double dValue ;
1471 if (TSUCCEEDED (num.m_fFloatp)) {
1472 dValue = num.m_Value.m_fFloat ;
1473 } else {
1474 dValue = (float)num.m_Value.m_lLong ;
1475 }
1476 snprintf (achBuffer, NELEMENTS (achBuffer) - 1, pFormat, dValue) ;
1477 } else {
1478 register long lValue ;
1479 if (TSUCCEEDED (num.m_fFloatp)) {
1480 lValue = (long)num.m_Value.m_fFloat ;
1481 } else {
1482 lValue = num.m_Value.m_lLong ;
1483 }
1484 snprintf (achBuffer, NELEMENTS (achBuffer) - 1, pFormat, lValue) ;
1485 }
1486 achBuffer [NELEMENTS (achBuffer) - 1] = '\0' ;
1487 ptr = achBuffer ;
1488 pPtr = aChBuffer ;
1489 while (*ptr != '\0')
1490 *pPtr ++ = Char_MakeAscii (*ptr ++) ;
1491 return TVarbuffer_Add (pvbuf, aChBuffer, pPtr - aChBuffer) ;
1492 }
1493
1494 Boolean
lispEntity_Copy(register TLispManager * pLispMgr,register TLispEntity * pEntSrc,register TLispEntity ** ppEntDest)1495 lispEntity_Copy (
1496 register TLispManager* pLispMgr,
1497 register TLispEntity* pEntSrc,
1498 register TLispEntity** ppEntDest)
1499 {
1500 int nType ;
1501
1502 lispEntity_GetType (pLispMgr, pEntSrc, &nType) ;
1503 if (nType == LISPENTITY_CONSCELL) {
1504 return lispEntity_copyConscell (pLispMgr, pEntSrc, ppEntDest) ;
1505 } else if (nType == LISPENTITY_VECTOR) {
1506 return lispEntity_copyVector (pLispMgr, pEntSrc, ppEntDest) ;
1507 } else {
1508 *ppEntDest = pEntSrc ;
1509 return True ;
1510 }
1511 }
1512
1513 Boolean
lispEntity_copyConscell(register TLispManager * pLispMgr,register TLispEntity * pEntSrc,register TLispEntity ** ppEntDest)1514 lispEntity_copyConscell (
1515 register TLispManager* pLispMgr,
1516 register TLispEntity* pEntSrc,
1517 register TLispEntity** ppEntDest)
1518 {
1519 TLispEntity* pEntSrcCar ;
1520 TLispEntity* pEntSrcCdr ;
1521 TLispEntity* pEntDestCar ;
1522 TLispEntity* pEntDestCdr ;
1523
1524 if (TFAILED (lispEntity_GetCar (pLispMgr, pEntSrc, &pEntSrcCar)) ||
1525 TFAILED (lispEntity_GetCdr (pLispMgr, pEntSrc, &pEntSrcCdr)))
1526 return False ;
1527 if (TFAILED (lispEntity_Copy (pLispMgr, pEntSrcCar, &pEntDestCar)))
1528 return False ;
1529 lispEntity_AddRef (pLispMgr, pEntDestCar) ;
1530 if (TFAILED (lispEntity_Copy (pLispMgr, pEntSrcCdr, &pEntDestCdr))) {
1531 lispEntity_Release (pLispMgr, pEntDestCar) ;
1532 return False;
1533 }
1534 lispEntity_AddRef (pLispMgr, pEntDestCdr) ;
1535 if (TFAILED (lispMgr_CreateConscell (pLispMgr, pEntDestCar, pEntDestCdr, ppEntDest))) {
1536 lispEntity_Release (pLispMgr, pEntDestCar) ;
1537 lispEntity_Release (pLispMgr, pEntDestCdr) ;
1538 return False ;
1539 }
1540 lispEntity_Release (pLispMgr, pEntDestCar) ;
1541 lispEntity_Release (pLispMgr, pEntDestCdr) ;
1542 return True ;
1543 }
1544
1545 Boolean
lispEntity_copyVector(register TLispManager * pLispMgr,register TLispEntity * pEntSrc,register TLispEntity ** ppEntDest)1546 lispEntity_copyVector (
1547 register TLispManager* pLispMgr,
1548 register TLispEntity* pEntSrc,
1549 register TLispEntity** ppEntDest)
1550 {
1551 TVarbuffer vbufEntDest ;
1552 TLispEntity** ppEntSrcElm ;
1553 TLispEntity* pEntDestElm ;
1554 int nEntSrcElm ;
1555 register TLispEntity** ppEntDests ;
1556 register int nEntDests ;
1557 register int i ;
1558 register Boolean fRetval = False ;
1559
1560 if (TFAILED (TVarbuffer_Initialize (&vbufEntDest, sizeof (TLispEntity*))))
1561 return False ;
1562
1563 lispEntity_GetVectorValue (pLispMgr, pEntSrc, &ppEntSrcElm, &nEntSrcElm) ;
1564 for (i = 0 ; i < nEntSrcElm ; i ++) {
1565 if (TFAILED (lispEntity_Copy (pLispMgr, *ppEntSrcElm ++, &pEntDestElm)))
1566 break ;
1567 if (TFAILED (TVarbuffer_Add (&vbufEntDest, &pEntDestElm, 1)))
1568 return False ;
1569 lispEntity_AddRef (pLispMgr, pEntDestElm) ;
1570 }
1571
1572 ppEntDests = TVarbuffer_GetBuffer (&vbufEntDest) ;
1573 nEntDests = TVarbuffer_GetUsage (&vbufEntDest) ;
1574 if (i == nEntSrcElm)
1575 fRetval = lispMgr_CreateVector (pLispMgr, ppEntDests, nEntDests, ppEntDest) ;
1576 for (i = 0 ; i < nEntDests ; i ++) {
1577 lispEntity_Release (pLispMgr, *ppEntDests) ;
1578 ppEntDests ++ ;
1579 }
1580 TVarbuffer_Uninitialize (&vbufEntDest) ;
1581 return fRetval ;
1582 }
1583
1584
1585