1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1997-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * System: Eclipse 25 * 26 * $Id: tkexdr.c,v 1.4 2010/04/11 02:36:01 jschimpf Exp $ 27 * 28 * Code for exdr communications with ECLiPSe in a tcl program 29 */ 30 31#include <stdio.h> 32#include <stdlib.h> 33#include <errno.h> 34#include <signal.h> 35#include <string.h> 36 37#include <tcl.h> 38 39#include "config.h" 40#include "tkcommon.h" 41 42/* define a pointer-sized integer type */ 43#if (SIZEOF_CHAR_P == SIZEOF_INT) 44typedef int word; /* pointer-sized */ 45typedef unsigned int uword; 46#elif (SIZEOF_CHAR_P == SIZEOF_LONG) 47typedef long word; /* pointer-sized */ 48typedef unsigned long uword; 49#elif (defined(HAVE_LONG_LONG) || defined(__GNUC__)) && (SIZEOF_CHAR_P == __SIZEOF_LONG_LONG__) 50typedef long long word; /* pointer-sized */ 51typedef unsigned long long uword; 52#elif defined(HAVE__INT64) && SIZEOF_CHAR_P == 8 53typedef __int64 word; /* pointer-sized */ 54typedef unsigned __int64 uword; 55#else 56PROBLEM: word size not supported! 57#endif 58 59/* suffix needed for 64 bit integer constants */ 60#if SIZEOF_LONG >= 8 61# define LSUF(X) (X##L) 62#elif (defined(HAVE_LONG_LONG) || defined(__GNUC__)) 63# define LSUF(X) (X##LL) 64#elif defined(HAVE_INT64) 65# define LSUF(X) (X##I64) 66#endif 67 68#ifdef __STDC__ 69int EcReadExdr(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); 70int EcTcl2Exdr(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); 71int EcExdr2Tcl(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); 72#endif 73 74 75 76/*--------------------------------------------------------------------------- 77 * Serialisation of ground terms for communication with other languages 78 * 79 * EXDR Version 2 80 * 81 * ExdrTerm ::= 'V' Version CompactFlag? Term 82 * CompactFlag ::= 'C' 83 * Term ::= (Integer|Double|String|List|Nil|Struct|Variable) 84 * Integer ::= ('B' <byte> | 'I' XDR_int | 'J' XDR_long) 85 * Double ::= 'D' XDR_double 86 * String ::= ('S' Length <byte>* | 'R' Index) 87 * List ::= '[' Term (List|Nil) 88 * Nil ::= ']' 89 * Struct ::= 'F' Arity String Term* 90 * Variable ::= '_' 91 * Length ::= XDR_nat 92 * Index ::= XDR_nat 93 * Arity ::= XDR_nat 94 * Version ::= <byte> 95 * XDR_int ::= <4 bytes, msb first> 96 * XDR_long ::= <8 bytes, msb first> 97 * XDR_double ::= <8 bytes, ieee double, exponent first> 98 * XDR_nat ::= <8 bits: 1 + seven bits unsigned value> 99 * | XDR_int // >= 0 100 *---------------------------------------------------------------------------*/ 101 102#define EXDR_VERSION 2 103#define EXDR_HEADER_LEN 2 104#define EXDR_COMPRESSED_HEADER_LEN 3 105 106static char exdr_header[EXDR_COMPRESSED_HEADER_LEN] = {'V',EXDR_VERSION,'C'}; 107 108/* read n bytes from 'channel' to 'bp' */ 109#define Tcl_Read_Check(n) \ 110 { if (Tcl_Read(channel, bp, n) < n) goto _error_; } 111 112#define Load_Byte(n) (n) = *bp++; 113#define Load_Word(n) { \ 114 (n) = *bp++; \ 115 (n) = (n) << 8 | (*bp++) & 0xff; \ 116 (n) = (n) << 8 | (*bp++) & 0xff; \ 117 (n) = (n) << 8 | (*bp++) & 0xff; \ 118} 119#define Load_DWord(n) { \ 120 (n) = *bp++; \ 121 (n) = (n) << 8 | (*bp++) & 0xff; \ 122 (n) = (n) << 8 | (*bp++) & 0xff; \ 123 (n) = (n) << 8 | (*bp++) & 0xff; \ 124 (n) = (n) << 8 | (*bp++) & 0xff; \ 125 (n) = (n) << 8 | (*bp++) & 0xff; \ 126 (n) = (n) << 8 | (*bp++) & 0xff; \ 127 (n) = (n) << 8 | (*bp++) & 0xff; \ 128} 129#define Load_Nat(GET,n) { \ 130 GET(1); \ 131 (n) = *bp++; \ 132 if ((n) & 0x80) { \ 133 (n) &= 0x7f; \ 134 } else { \ 135 GET(3); \ 136 (n) = (n) << 8 | (*bp++) & 0xff; \ 137 (n) = (n) << 8 | (*bp++) & 0xff; \ 138 (n) = (n) << 8 | (*bp++) & 0xff; \ 139 } \ 140} 141 142#define Store_Byte(byte) *dest++ = (byte) 143#define Store_Word(word) {\ 144 register unsigned long aux = (word); \ 145 *dest++ = (char) (aux >> 24); \ 146 *dest++ = (char) (aux >> 16); \ 147 *dest++ = (char) (aux >> 8); \ 148 *dest++ = (char) (aux); \ 149 } 150#define Store_DWord(myword) {\ 151 register Tcl_WideUInt aux = (myword); \ 152 *dest++ = (char) (aux >> 56); \ 153 *dest++ = (char) (aux >> 48); \ 154 *dest++ = (char) (aux >> 40); \ 155 *dest++ = (char) (aux >> 32); \ 156 *dest++ = (char) (aux >> 24); \ 157 *dest++ = (char) (aux >> 16); \ 158 *dest++ = (char) (aux >> 8); \ 159 *dest++ = (char) (aux); \ 160 } 161#define Store_Nat(word) { \ 162 register unsigned long aux = (word); \ 163 if (aux < 0x80) { \ 164 *dest++ = (char) (aux | 0x80); \ 165 } else { \ 166 *dest++ = (char) (aux >> 24); \ 167 *dest++ = (char) (aux >> 16); \ 168 *dest++ = (char) (aux >> 8); \ 169 *dest++ = (char) (aux); \ 170 } \ 171 } 172 173typedef union { 174 double as_dbl; 175#if (SIZEOF_CHAR_P == 8) 176 uword as_int; 177#elif (SIZEOF_CHAR_P == 4) 178 struct ieee_parts { 179#ifdef WORDS_BIGENDIAN 180 unsigned mant1; 181 unsigned mant0; 182#else 183 unsigned mant0; 184 unsigned mant1; 185#endif 186 } as_struct; 187#else 188 PROBLEM: no code for this SIZEOF_WORD 189#endif 190} ieee_double; 191 192 193static Tcl_Obj * 194_EcReadExdr(Tcl_Interp *interp, Tcl_Channel channel, int nextch, Tcl_HashTable *string_table, uword *string_index) 195{ 196 char buf[10]; 197 char *bp; 198 ieee_double d; 199 Tcl_Obj *obj, *elem; 200 int err; 201 long len, arity; 202#if SIZEOF_LONG < 8 203 /* 64 bit integers. Tcl_WideInt (Tcl >= 8.4) is at least 64 bits */ 204 Tcl_WideInt wlen; 205#endif 206 207 switch(nextch) 208 { 209 case 'B': 210 bp = buf; 211 Tcl_Read_Check(1); 212 Load_Byte(len); 213 return Tcl_NewLongObj(len); 214 215 case 'I': 216 bp = buf; 217 Tcl_Read_Check(4); 218 Load_Word(len); 219 return Tcl_NewLongObj(len); 220 221 case 'J': 222 bp = buf; 223 Tcl_Read_Check(8); 224#if SIZEOF_LONG < 8 225 Load_DWord(wlen); 226 return Tcl_NewWideIntObj(wlen); 227#else 228 Load_DWord(len); 229 return Tcl_NewLongObj(len); 230#endif 231 232 case 'D': 233 bp = buf; 234 Tcl_Read_Check(8); 235#if SIZEOF_CHAR_P == 8 236 Load_DWord(d.as_int); 237#else 238 Load_Word(d.as_struct.mant1); 239 Load_Word(d.as_struct.mant0); 240#endif 241 return Tcl_NewDoubleObj(d.as_dbl); 242 243 case '_': 244 return Tcl_NewStringObj("_", 1); 245 246 case 'S': 247 { 248 int new_entry; 249 Tcl_HashEntry *entry; 250 bp = buf; 251 Load_Nat(Tcl_Read_Check, len); 252 obj = Tcl_NewObj(); 253 bp = Tcl_SetByteArrayLength(obj, len); 254 Tcl_Read_Check(len); 255 if (string_table) 256 { 257 entry = Tcl_CreateHashEntry(string_table, (char *) (*string_index), &new_entry); 258 ++(*string_index); 259 Tcl_SetHashValue(entry, (ClientData) obj); 260 } 261 return obj; 262 } 263 264 case 'R': 265 { 266 uword this_index; 267 Tcl_HashEntry *entry; 268 if (!string_table) return NULL; 269 bp = buf; 270 Load_Nat(Tcl_Read_Check, this_index); 271 entry = Tcl_FindHashEntry(string_table, (char *) this_index); 272 if (!entry) return NULL; 273 return (Tcl_Obj *) Tcl_GetHashValue(entry); 274 } 275 276 case 'F': 277 bp = buf; 278 Load_Nat(Tcl_Read_Check, arity); 279 obj = Tcl_NewObj(); 280 for (; arity >= 0; --arity) 281 { 282 bp = buf; 283 Tcl_Read_Check(1); 284 elem = _EcReadExdr(interp, channel, *bp, string_table, string_index); 285 if (!elem) return NULL; 286 err = Tcl_ListObjAppendElement(interp, obj, elem); 287 if (err != TCL_OK) return NULL; 288 } 289 return obj; 290 291 case '[': 292 obj = Tcl_NewObj(); 293 for (;;) 294 { 295 bp = buf; 296 Tcl_Read_Check(1); 297 elem = _EcReadExdr(interp, channel, *bp, string_table, string_index); 298 if (!elem) return NULL; 299 err = Tcl_ListObjAppendElement(interp, obj, elem); 300 if (err != TCL_OK) return NULL; 301 bp = buf; 302 Tcl_Read_Check(1); 303 if (*buf == ']') 304 return obj; 305 if (*buf != '[') 306 return NULL; 307 } 308 309 case ']': /* a lone nil, not terminating a list */ 310 return Tcl_NewObj(); 311 312 default: 313 return NULL; 314 } 315_error_: 316 return NULL; 317} 318 319 320/* ec_read_exdr channel */ 321 322int 323EcReadExdr(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) 324{ 325 Tcl_Channel channel; 326 Tcl_Obj *resultObj; 327 uword string_index = 0; 328 Tcl_HashTable string_table; 329 char buf[10], *bp; 330 int nextch; 331 332 if (objc != 2) 333 { 334 Tcl_WrongNumArgs(interp, 1, objv, "channel"); 335 return TCL_ERROR; 336 } 337 channel = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); 338 if (!channel) 339 { 340 Tcl_SetResult(interp, "no such channel", TCL_STATIC); 341 return TCL_ERROR; 342 } 343 344 bp = buf; 345 Tcl_Read_Check(EXDR_COMPRESSED_HEADER_LEN); 346 if (buf[0] != 'V') 347 { 348 Tcl_SetResult(interp, "no exdr-term to read", TCL_STATIC); 349 return TCL_ERROR; 350 } 351 if ((unsigned) buf[1] > (unsigned) EXDR_VERSION) 352 { 353 Tcl_SetResult(interp, "incompatible exdr version", TCL_STATIC); 354 return TCL_ERROR; 355 } 356 nextch = buf[2]; 357 if (nextch == 'C') /* compact-flag */ 358 { 359 bp = buf; 360 Tcl_Read_Check(1); 361 Tcl_InitHashTable(&string_table, TCL_ONE_WORD_KEYS); 362 resultObj = _EcReadExdr(interp, channel, *bp, &string_table, &string_index); 363 Tcl_DeleteHashTable(&string_table); 364 } 365 else 366 { 367 resultObj = _EcReadExdr(interp, channel, nextch, NULL, NULL); 368 } 369 if (resultObj) 370 { 371 Tcl_SetObjResult(interp, resultObj); 372 return TCL_OK; 373 } 374_error_: 375 Tcl_SetResult(interp, "conversion error while reading exdr format", TCL_STATIC); 376 return TCL_ERROR; 377} 378 379 380#define Buf_Check(n) { if (bp+(n) > stop) return NULL; } 381 382static char * 383_EcExdr2Tcl(Tcl_Interp *interp, char *bp, char *stop, Tcl_HashTable *string_table, uword *string_index, Tcl_Obj **result) 384{ 385 ieee_double d; 386 Tcl_Obj *elem; 387 int err; 388 long len, arity; 389#if SIZEOF_LONG < 8 390 Tcl_WideInt wlen; 391#endif 392 393 Buf_Check(1); 394 switch(*bp++) 395 { 396 case 'B': 397 Buf_Check(1); 398 Load_Byte(len); 399 *result = Tcl_NewLongObj(len); 400 return bp; 401 402 case 'I': 403 Buf_Check(4); 404 Load_Word(len); 405 *result = Tcl_NewLongObj(len); 406 return bp; 407 408 case 'J': 409 Buf_Check(8); 410#if SIZEOF_LONG < 8 411 Load_DWord(wlen); 412 *result = Tcl_NewWideIntObj(wlen); 413#else 414 Load_DWord(len); 415 *result = Tcl_NewLongObj(len); 416#endif 417 return bp; 418 419 case 'D': 420 Buf_Check(8); 421#if SIZEOF_CHAR_P == 8 422 Load_DWord(d.as_int); 423#else 424 Load_Word(d.as_struct.mant1); 425 Load_Word(d.as_struct.mant0); 426#endif 427 *result = Tcl_NewDoubleObj(d.as_dbl); 428 return bp; 429 430 case '_': 431 *result = Tcl_NewStringObj("_", 1); 432 return bp; 433 434 case 'S': 435 { 436 int new_entry; 437 Tcl_HashEntry *entry; 438 Load_Nat(Buf_Check, len); 439 Buf_Check(len); 440 *result = Tcl_NewByteArrayObj(bp, len); 441 if (string_table) 442 { 443 entry = Tcl_CreateHashEntry(string_table, (char *) (*string_index), &new_entry); 444 ++(*string_index); 445 Tcl_SetHashValue(entry, (ClientData) *result); 446 } 447 return bp+len; 448 } 449 450 case 'R': 451 { 452 uword this_index; 453 Tcl_HashEntry *entry; 454 if (!string_table) return NULL; 455 Load_Nat(Buf_Check, this_index); 456 entry = Tcl_FindHashEntry(string_table, (char *) this_index); 457 if (!entry) return NULL; 458 *result = (Tcl_Obj *) Tcl_GetHashValue(entry); 459 return bp; 460 } 461 462 case 'F': 463 Load_Nat(Buf_Check, arity); 464 *result = Tcl_NewObj(); 465 for (; arity >= 0; --arity) 466 { 467 bp = _EcExdr2Tcl(interp, bp, stop, string_table, string_index, &elem); 468 if (!bp) return NULL; 469 err = Tcl_ListObjAppendElement(interp, *result, elem); 470 if (err != TCL_OK) return NULL; 471 } 472 return bp; 473 474 case '[': 475 *result = Tcl_NewObj(); 476 for (;;) 477 { 478 bp = _EcExdr2Tcl(interp, bp, stop, string_table, string_index, &elem); 479 if (!bp) return NULL; 480 err = Tcl_ListObjAppendElement(interp, *result, elem); 481 if (err != TCL_OK) return NULL; 482 Buf_Check(1); 483 switch (*bp++) { 484 case ']': return bp; 485 case '[': break; 486 default: return NULL; 487 } 488 } 489 490 case ']': /* a lone nil, not terminating a list */ 491 *result = Tcl_NewObj(); 492 return bp; 493 494 default: 495 return NULL; 496 } 497} 498 499 500/* ec_exdr2tcl exdr_string */ 501 502int 503EcExdr2Tcl(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) 504{ 505 Tcl_Obj *resultObj; 506 char *bp, *stop; 507 int len; 508 uword string_index = 0; 509 Tcl_HashTable string_table; 510 511 if (objc != 2) 512 { 513 Tcl_WrongNumArgs(interp, 1, objv, "exdr_string"); 514 return TCL_ERROR; 515 } 516 bp = Tcl_GetByteArrayFromObj(objv[1], &len); 517 stop = bp+len; 518 if (len < EXDR_COMPRESSED_HEADER_LEN) 519 { 520 Tcl_SetResult(interp, "ec_exdr2tcl: not exdr format (short)", TCL_STATIC); 521 return TCL_ERROR; 522 } 523 if (*bp++ != exdr_header[0]) 524 { 525 Tcl_SetResult(interp, "ec_exdr2tcl: not exdr format", TCL_STATIC); 526 return TCL_ERROR; 527 } 528 if ((unsigned) *bp++ > (unsigned) exdr_header[1]) 529 { 530 Tcl_SetResult(interp, "ec_exdr2tcl: incompatible exdr version", TCL_STATIC); 531 return TCL_ERROR; 532 } 533 if (*bp == exdr_header[2]) /* optional compact-flag */ 534 { 535 ++bp; 536 Tcl_InitHashTable(&string_table, TCL_ONE_WORD_KEYS); 537 bp = _EcExdr2Tcl(interp, bp, stop, &string_table, &string_index, &resultObj); 538 Tcl_DeleteHashTable(&string_table); 539 } 540 else 541 { 542 bp = _EcExdr2Tcl(interp, bp, stop, NULL, NULL, &resultObj); 543 } 544 if (!bp || bp != stop) 545 { 546 Tcl_SetResult(interp, "ec_exdr2tcl: conversion error", TCL_STATIC); 547 return TCL_ERROR; 548 } 549 Tcl_SetObjResult(interp, resultObj); 550 return TCL_OK; 551} 552 553 554/* 555 * ec_tcl2exdr data ?format? 556 * 557 * Convert Tcl-data to EXDR term (according to format) 558 */ 559 560void 561Tcl_AppendToByteArray(Tcl_Obj *objPtr, char *bytes, int length, int *pos) 562{ 563 int new_len, alloc; 564 char *bp; 565 new_len = *pos+length; 566 bp = Tcl_GetByteArrayFromObj(objPtr, &alloc); 567 if (new_len > alloc) 568 { 569 while (new_len > alloc) 570 alloc *= 2; 571 bp = Tcl_SetByteArrayLength(objPtr, alloc); 572 } 573 memcpy(bp+*pos, bytes, (size_t) length); 574 *pos = new_len; 575} 576 577static int 578_EcTcl2Exdr(Tcl_Interp *interp, 579 char **typespec, 580 Tcl_Obj *obj, /* the object to convert */ 581 Tcl_Obj *exdr_obj, /* the object to append exdr data to */ 582 Tcl_HashTable *string_table, 583 Tcl_HashTable *utf8_table, 584 uword *string_index, 585 int *pos) /* next position in the resulting byte array */ 586{ 587 int i, len, res, objc; 588 Tcl_WideInt n; 589 ieee_double d; 590 char *dest, *s, *subtype; 591 char buf[10]; 592 Tcl_Obj **objv; 593 594 switch (**typespec) { 595 case '_': 596 s = Tcl_GetStringFromObj(obj, &len); 597 if (s[0] != '_' || s[1] != 0) { 598 Tcl_SetResult(interp, "ec_tcl2exdr: _ expected", TCL_STATIC); 599 return TCL_ERROR; 600 } 601 Tcl_AppendToByteArray(exdr_obj, "_", 1, pos); 602 ++(*typespec); 603 break; 604 605 case 'S': /* send a byte (8-bit) string */ 606 { 607 int new_entry; 608 Tcl_HashEntry *entry; 609 char *hash_string; 610 dest = buf; 611 /* Unfortunately, Tcl hash tables cannot hash raw byte arrays, only 612 * null-terminated strings that don't contain nulls. We therefore 613 * get the string representation of the byte array and use that for 614 * hashing here. However, that has the consequence that the raw 'S' 615 * string and the corresponding 'U' string hash to the same value, 616 * even though their exdr-representation is different. That's why 617 * we need two separate hash tables string_table and utf8_table... */ 618 hash_string = Tcl_GetString(obj); 619 entry = Tcl_CreateHashEntry(string_table, hash_string, &new_entry); 620 if (new_entry) 621 { 622 Tcl_SetHashValue(entry, (ClientData) (*string_index)); 623 ++(*string_index); 624 s = Tcl_GetByteArrayFromObj(obj, &len); 625 Store_Byte('S'); 626 Store_Nat(len); 627 Tcl_AppendToByteArray(exdr_obj, buf, dest-buf, pos); 628 Tcl_AppendToByteArray(exdr_obj, s, len, pos); 629 } 630 else 631 { 632 Store_Byte('R'); 633 Store_Nat((uword) Tcl_GetHashValue(entry)); 634 Tcl_AppendToByteArray(exdr_obj, buf, dest-buf, pos); 635 } 636 ++(*typespec); 637 break; 638 } 639 640 case 'U': /* send a UTF-8 encoded string */ 641 { 642 int new_entry; 643 Tcl_HashEntry *entry; 644 dest = buf; 645 s = Tcl_GetStringFromObj(obj, &len); 646 entry = Tcl_CreateHashEntry(utf8_table, s, &new_entry); 647 if (new_entry) 648 { 649 Tcl_SetHashValue(entry, (ClientData) (*string_index)); 650 ++(*string_index); 651 Store_Byte('S'); 652 Store_Nat(len); 653 Tcl_AppendToByteArray(exdr_obj, buf, dest-buf, pos); 654 Tcl_AppendToByteArray(exdr_obj, s, len, pos); 655 } 656 else 657 { 658 Store_Byte('R'); 659 Store_Nat((uword) Tcl_GetHashValue(entry)); 660 Tcl_AppendToByteArray(exdr_obj, buf, dest-buf, pos); 661 } 662 ++(*typespec); 663 break; 664 } 665 666 case 'I': 667 res = Tcl_GetWideIntFromObj(interp, obj, &n); 668 if (res != TCL_OK) { 669 Tcl_SetResult(interp, "ec_tcl2exdr: integer expected", TCL_STATIC); 670 return TCL_ERROR; 671 } 672 dest = buf; 673 if ((Tcl_WideInt)(char) n == n) 674 { 675 Store_Byte('B'); 676 Store_Byte((char) n); 677 Tcl_AppendToByteArray(exdr_obj, buf, 2, pos); 678 } 679 else if (n < LSUF(-2147483648) || n > LSUF(2147483647)) 680 { 681 Store_Byte('J'); 682 Store_DWord(n); 683 Tcl_AppendToByteArray(exdr_obj, buf, 9, pos); 684 } 685 else 686 { 687 Store_Byte('I'); 688 Store_Word(n); 689 Tcl_AppendToByteArray(exdr_obj, buf, 5, pos); 690 } 691 ++(*typespec); 692 break; 693 694 case 'D': 695 res = Tcl_GetDoubleFromObj(interp, obj, &d.as_dbl); 696 if (res != TCL_OK) { 697 Tcl_SetResult(interp, "ec_tcl2exdr: double expected", TCL_STATIC); 698 return TCL_ERROR; 699 } 700 dest = buf; 701 Store_Byte('D'); 702#if SIZEOF_CHAR_P == 8 703 Store_DWord(d.as_int); 704#else 705 Store_Word(d.as_struct.mant1); 706 Store_Word(d.as_struct.mant0); 707#endif 708 Tcl_AppendToByteArray(exdr_obj, buf, 9, pos); 709 ++(*typespec); 710 break; 711 712 case '[': 713 ++(*typespec); 714 res = Tcl_ListObjGetElements(interp,obj,&objc,&objv); 715 if (res != TCL_OK) { 716 Tcl_SetResult(interp, "ec_tcl2exdr: list expected", TCL_STATIC); 717 return TCL_ERROR; 718 } 719 for (i=0; i<objc; ++i) 720 { 721 subtype = *typespec; 722 Tcl_AppendToByteArray(exdr_obj, "[", 1, pos); 723 res = _EcTcl2Exdr(interp, typespec, objv[i], exdr_obj, string_table, utf8_table, string_index, pos); 724 if (res != TCL_OK) return res; 725 if (**typespec == '*') 726 *typespec = (i+1 < objc) ? subtype : *typespec + 1; 727 } 728 if (**typespec != ']') 729 { 730 Tcl_SetResult(interp, "ec_tcl2exdr: list too short", TCL_STATIC); 731 return TCL_ERROR; 732 } 733 ++(*typespec); 734 Tcl_AppendToByteArray(exdr_obj, "]", 1, pos); 735 break; 736 737 case '(': 738 ++(*typespec); 739 res = Tcl_ListObjGetElements(interp,obj,&objc,&objv); 740 if (res != TCL_OK) { 741 Tcl_SetResult(interp, "ec_tcl2exdr: list expected", TCL_STATIC); 742 return TCL_ERROR; 743 } 744 if (objc < 1) /* need functor at least */ 745 { 746 Tcl_SetResult(interp, "ec_tcl2exdr: list too short", TCL_STATIC); 747 return TCL_ERROR; 748 } 749 dest = buf; 750 Store_Byte('F'); 751 Store_Nat(objc-1); 752 Tcl_AppendToByteArray(exdr_obj, buf, dest-buf, pos); 753 subtype = "S"; 754 res = _EcTcl2Exdr(interp, &subtype, objv[0], exdr_obj, string_table, utf8_table, string_index, pos); 755 if (res != TCL_OK) return res; 756 for (i=1; i<objc; ++i) 757 { 758 subtype = *typespec; 759 res = _EcTcl2Exdr(interp, typespec, objv[i], exdr_obj, string_table, utf8_table, string_index, pos); 760 if (res != TCL_OK) return res; 761 if (**typespec == '*') 762 *typespec = (i+1 < objc) ? subtype : *typespec + 1; 763 } 764 if (**typespec != ')') 765 { 766 Tcl_SetResult(interp, "ec_tcl2exdr: list too short", TCL_STATIC); 767 return TCL_ERROR; 768 } 769 ++(*typespec); 770 break; 771 772 default: 773 Tcl_SetResult(interp, "ec_tcl2exdr: malformed format string", TCL_STATIC); 774 return TCL_ERROR; 775 } 776 return TCL_OK; 777} 778 779int 780EcTcl2Exdr(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) 781{ 782 Tcl_Obj *obj; 783 Tcl_Obj *exdr_obj; 784 Tcl_HashTable string_table, utf8_table; 785 uword string_index = 0; 786 char *typespec; 787 int pos = 0; 788 int res; 789 790 if (objc < 2 || objc > 3) 791 { 792 Tcl_WrongNumArgs(interp, 1, objv, "data ?format?"); 793 return TCL_ERROR; 794 } 795 typespec = objc == 3 ? Tcl_GetStringFromObj(objv[2], NULL) : "S"; 796 obj = objv[1]; 797 798 exdr_obj = Tcl_NewObj(); 799 Tcl_SetByteArrayLength(exdr_obj, 1000); 800 Tcl_AppendToByteArray(exdr_obj, exdr_header, EXDR_COMPRESSED_HEADER_LEN, &pos); 801 Tcl_InitHashTable(&string_table, TCL_STRING_KEYS); 802 Tcl_InitHashTable(&utf8_table, TCL_STRING_KEYS); 803 res = _EcTcl2Exdr(interp, &typespec, obj, exdr_obj, &string_table, &utf8_table, &string_index, &pos); 804 Tcl_DeleteHashTable(&string_table); 805 Tcl_DeleteHashTable(&utf8_table); 806 if (res != TCL_OK) 807 return TCL_ERROR; 808 Tcl_SetByteArrayLength(exdr_obj, pos); 809 Tcl_SetObjResult(interp, exdr_obj); 810 return TCL_OK; 811} 812 813 814/*--------------------------------------------------------------------------- 815 * Create the Tcl commands 816 *---------------------------------------------------------------------------*/ 817 818int 819Tkexdr_Init(Tcl_Interp *interp) 820{ 821 Tcl_CreateObjCommand(interp, "ec_read_exdr", EcReadExdr, 822 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); 823 Tcl_CreateObjCommand(interp, "ec_tcl2exdr", EcTcl2Exdr, 824 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); 825 Tcl_CreateObjCommand(interp, "ec_exdr2tcl", EcExdr2Tcl, 826 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); 827 828 return TCL_OK; 829} 830 831 832 833