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) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * VERSION $Id: bip_serialize.c,v 1.1 2013/09/28 00:25:39 jschimpf Exp $ 25 */ 26 27/* 28 * IDENTIFICATION: bip_serialize.c (was part of property.c) 29 * 30 * DESCRIPTION: Built-ins and functions for term serialization 31 * - dbformat (term_to_bytes, bytes_to_term) 32 * - EXDR (read_exdr, write_exdr) 33 * 34 * CONTENTS: 35 * 36 * AUTHOR: joachim 37 * 38 */ 39 40 41#include "config.h" 42#include "sepia.h" 43#include "types.h" 44#include "embed.h" 45#include "error.h" 46#include "mem.h" 47#include "dict.h" 48#include "ec_io.h" 49#include "module.h" 50#include "emu_export.h" 51 52extern pword *transf_meta_out(value val, type tag, pword *top, dident mod, pword *presult), 53 *transf_meta_in(pword *pw, dident mod, int *err); 54 55extern pword *p_meta_arity_; 56 57static int _fill_procedures(pword *prev_ld, dident mod, type tmod); 58 59 60/*--------------------------------------------------------------------------- 61 * 62 * Prolog term <==> Database format conversion routines 63 * 64 * pword * term_to_dbformat(pword *term) 65 * 66 * pword * dbformat_to_term(char *buffer) 67 * 68 * These routines are used to convert Prolog terms into the external database 69 * format and vice versa. 70 * The main differences of the external format compared to standard term 71 * representation are: 72 * 73 * - no absolute addresses, but relative offsets 74 * - no dictionary references, but explicit strings 75 * - no alignment, more compact byte representation 76 * - a breadth-first, prefix representation 77 * - machine-independent (byte order, word size) 78 * 79 * Format description: 80 * 81 * <external_term> :: <termsize> <simple_term>+ 82 * 83 * <simple_term> :: 84 * TNIL 85 * TINT <int> 86 * TSTRG <length> <name> 87 * TDICT <arity> <length> <name> 88 * TLIST <offset> 89 * TCOMP <offset> 90 * TVAR_TAG <offset> 91 * TNAME <offset> <length> <name> 92 * TMETA <offset> <length> <name> 93 * TUNIV <offset> <length> <name> 94 * TSUSP <offset> 95 * TDE <flags> 96 * 97 * <flags> :: <word> 98 * <float> :: <word> 99 * <termsize> :: <word> 100 * <int> :: <compact> 101 * <arity> :: <compact> 102 * <length> :: <compact> 103 * <offset> :: <compact> 104 * <tag> :: <byte> 105 * 106 * <word> :: <byte> <byte> <byte> <byte> (MSB first) 107 * <compact> :: <1byte>* <0byte> 108 * <1byte> :: <byte> (byte >= 0x80) 109 * <0byte> :: <byte> (byte < 0x80) 110 * <name> :: <byte>* 111 * 112 * An <offset> field holds a relative address (in words). When the term is 113 * restored, the start address of the restored term is added to the relative 114 * address to obtain the absolute one. Note that this is not an offset into 115 * the external representation! 116 * 117 * During conversion to external format, in the original term the MARK bit is 118 * used to mark variables that have already been encountered. Their value 119 * field is temporarily overwritten with the proper <offset>. These destructive 120 * modifications are trailed and are undone at the end of the conversion. 121 *----------------------------------------------------------------------------*/ 122 123#define QUEUE_MASK_META 0x80000000 124#define QUEUE_MASK (QUEUE_MASK_META) 125#define EnQueue_(pw, arity, mark) { \ 126 if (queue_head) { \ 127 queue_tail[1].val.ptr = (pword *) hg_alloc_size(2*sizeof(pword));\ 128 queue_tail = queue_tail[1].val.ptr; \ 129 } else \ 130 queue_tail = queue_head = (pword *) hg_alloc_size(2*sizeof(pword));\ 131 queue_tail[0].val.ptr = (pw); \ 132 queue_tail[0].tag.kernel = (arity|(mark)); \ 133 queue_tail[1].val.ptr = (pword *) 0; \ 134} 135 136#define DeQueue_(pw, arity, mark) { \ 137 register pword *elem = queue_head; \ 138 (pw) = elem[0].val.ptr; \ 139 (arity) = elem[0].tag.kernel; \ 140 (mark) = (arity) & QUEUE_MASK; \ 141 (arity) = (arity) & ~QUEUE_MASK; \ 142 queue_head = elem[1].val.ptr; \ 143 hg_free_size((generic_ptr)elem, 2*sizeof(pword)); \ 144} 145 146#define EmptyQueue() (!queue_head) 147 148 149#define Reserve_Space(nbytes) \ 150 if ((dest + nbytes) > (char *) TG) { \ 151 TG += (dest + nbytes + 32 - (char*)TG) / sizeof(pword); \ 152 Check_Gc; \ 153 } 154 155#define Store_Byte(byte) *dest++ = (char) (byte) 156#define Store_Int32(word) {\ 157 register unsigned long aux = (word); \ 158 *dest++ = (char) (aux >> 24); \ 159 *dest++ = (char) (aux >> 16); \ 160 *dest++ = (char) (aux >> 8); \ 161 *dest++ = (char) (aux); \ 162 } 163#ifdef OLD_FORMAT 164#define Store_Int(word) \ 165 if ((unsigned long)(word) < 0xff) *dest++ = (char) (word); \ 166 else { \ 167 *dest++ = (char) 0xff; \ 168 Store_Int32(word); \ 169 } 170#else 171#define Store_Int(w) { \ 172 word aux = (word) (w); \ 173 if (-64 <= aux && aux <= 63) { \ 174 *dest++ = aux & 0x7f; \ 175 } else { \ 176 uword rev = 0; \ 177 int k = 0; \ 178 do { \ 179 rev = (rev << 7) | (aux & 0x7f); \ 180 aux >>= 7; \ 181 ++k; \ 182 } while (!(-64 <= aux && aux <= 63)); \ 183 *dest++ = 0x80 | (aux & 0x7f); \ 184 while (--k) { \ 185 *dest++ = (rev & 0x7f) | 0x80; \ 186 rev >>= 7; \ 187 } \ 188 *dest++ = rev; \ 189 } \ 190} 191#endif 192 193#ifdef OLD_FORMAT 194#define Store_String(length, string) { \ 195 register char *source = (string); \ 196 register long ctr = (length); \ 197 while (ctr-- >= 0) *dest++ = *source++; \ 198} 199#else 200#define Store_String(length, string) { \ 201 register char *source = (string); \ 202 register word ctr = (length); \ 203 while (ctr-- > 0) *dest++ = *source++; \ 204} 205#endif 206#define Align() while ((word) dest % sizeof(pword)) *dest++ = (char) 0; 207 208#define LoadByte *buf++ 209#define Load_Byte(n) (n) = LoadByte 210#define Load_Int32(n) { \ 211 (n) = LoadByte; \ 212 (n) = ((n) << 8) | ((LoadByte) & 0xff); \ 213 (n) = ((n) << 8) | ((LoadByte) & 0xff); \ 214 (n) = ((n) << 8) | ((LoadByte) & 0xff); \ 215} 216#define BITS_PER_WORD (8*SIZEOF_CHAR_P) 217#ifdef OLD_FORMAT 218#define Load_Int(n) \ 219 { if (((n) = (unsigned char)(LoadByte)) == 0xff) Load_Int32(n); } 220#else 221#define Load_Int(n) { /* n must be of type (signed) word */ \ 222 word i = LoadByte; \ 223 int shift = BITS_PER_WORD-7; \ 224 n = i & 0x7f; \ 225 while (i & 0x80) { \ 226 i = LoadByte; \ 227 n = ((n) << 7) | (i & 0x7f); \ 228 shift -= 7; \ 229 } \ 230 if (shift > 0) \ 231 n = (n << shift) >> shift; /* sign extend */ \ 232} 233#endif 234 235/* Write an EXDR Nat */ 236#define Store_Nat(n) \ 237 if ((n) == (word)(char)(n)) { \ 238 *dest++ = (char)((n) | 0x80); \ 239 } else { \ 240 Store_Int32((n)); \ 241 } 242 243/* Combined macro for Get and Load of a Nat 244 * The macro is combined since it must be responsible 245 * for the loading of either a single byte or a 4 byte 246 * integer/ 247 */ 248#define GetLoad_Nat(n) \ 249 Get_Next(1); \ 250 (n) = LoadByte; \ 251 if (n & 0x80) { \ 252 n = n & 0x7f; \ 253 } else { \ 254 Get_Next(3); \ 255 (n) = ((n) << 8) | ((LoadByte) & 0xff); \ 256 (n) = ((n) << 8) | ((LoadByte) & 0xff); \ 257 (n) = ((n) << 8) | ((LoadByte) & 0xff); \ 258 } 259 260#define WordOffset(pw, offset) ((pword*)((uword*)(pw) + (offset))) 261#define Words(pwords) ((sizeof(pword)/sizeof(uword))*(pwords)) 262 263 264/* dest is assumeed to equal buf on entry 265 * res is set as the result of operations performed by the macro 266 * perr is set for non-fatal errors - a valid EXDR term is written 267 */ 268#define Write_String_Or_Ref(nst, strhm, sval) \ 269 { \ 270 pword id; \ 271 if (strhm) { \ 272 Make_Integer(&id, strhm->nentries); \ 273 res = store_get_else_set(strhm, sval, tstrg, &id); \ 274 if (res < PSUCCEED) { \ 275 *perr = res; \ 276 res = PFAIL; /* Write the 'S'tring form instead */ \ 277 } \ 278 } else { \ 279 res = PFAIL; \ 280 } \ 281 if (res == PSUCCEED) { \ 282 Store_Byte('R'); \ 283 Store_Nat(id.val.nint); \ 284 res = ec_outf(nst, buf, dest - buf); \ 285 } else { \ 286 Store_Byte('S'); \ 287 Store_Nat(StringLength(sval)); \ 288 if ((res = ec_outf(nst, buf, dest - buf)) == PSUCCEED) { \ 289 res = ec_outf(nst, StringStart(sval), StringLength(sval)); \ 290 } \ 291 } \ 292 } 293 294/* 295 * pword * term_to_dbformat(term) 296 * 297 * Convert a general term into external format. This is created on the global 298 * stack in form of a Sepia string. The return value is a pointer to this 299 * string. For the reverse conversion, only the string contents is needed, 300 * not its header! The sharing of variables and suspensions is preserved. 301 */ 302 303pword * 304term_to_dbformat(pword *parg, dident mod) 305{ 306 pword **save_tt = TT; 307 register word arity = 1, len; 308 register word curr_offset = 0, top_offset = 2; /* in 'word's */ 309 register pword *queue_tail = (pword *) 0; 310 pword *queue_head = (pword *) 0; 311 register pword *pw; 312 register char *dest, *stop; 313 pword *header; 314 temp_area meta_attr; 315 int flag = 0; 316 317 Temp_Create(meta_attr, 4 * ATTR_IO_TERM_SIZE * sizeof(pword)); 318 header = TG; 319 dest = (char *) (header + 1) + 4; /* space for the TBUFFER pword and for 320 * the external format header */ 321 322 for(;;) /* handle <arity> consecutive pwords, starting at <parg> */ 323 { 324 do /* handle the pword pointed to by parg */ 325 { 326 pw = parg; 327 328 /* I need here a slightly modified version of Dereference_(pw) 329 * that stops also at MARKed words. Not very nice, I know. 330 */ 331 while (IsRef(pw->tag) && !(pw->tag.kernel & MARK) && !IsSelfRef(pw)) 332 pw = pw->val.ptr; 333 334 Reserve_Space(6); 335 336 if (pw->tag.kernel & MARK) 337 { 338 if (SameTypeC(pw->tag,TDE)) /* a suspension */ 339 { 340 Store_Byte(Tag(pw->tag.kernel)); 341 Store_Int32((pw[SUSP_FLAGS].tag.kernel & ~MARK)); 342 if (SuspDead(pw)) { 343 curr_offset += Words(SUSP_HEADER_SIZE-1); 344 parg += SUSP_HEADER_SIZE-1; 345 arity -= SUSP_HEADER_SIZE-1; 346 } else { 347 Store_Byte(SuspPrio(pw) + (SuspRunPrio(pw) << 4)); 348 curr_offset += Words(SUSP_GOAL-1); 349 parg += SUSP_GOAL-1; 350 arity -= SUSP_GOAL-1; 351 } 352 } 353 else if (pw->val.nint == curr_offset) /* a nonstd variable */ 354 { 355 Store_Byte(Tag(pw->tag.kernel)); 356 Store_Int(pw->val.nint); 357 if (!IsNamed(pw->tag.kernel)) 358 { 359 Store_Byte(0); 360 } 361 else /* store its name */ 362 { 363 dident vdid = TagDid(pw->tag.kernel); 364 len = DidLength(vdid); 365 Store_Int(len); 366 Reserve_Space(len); 367 Store_String(len, DidName(vdid)); 368 } 369 } 370 else /* just a reference to an already encountered variable */ 371 { 372 Store_Byte(Tag(TVAR_TAG)); 373 Store_Int(pw->val.nint); 374 } 375 } 376 else switch (TagType(pw->tag)) 377 { 378 case TINT: 379#if SIZEOF_CHAR_P > 4 380 if (pw->val.nint < WSUF(-2147483648) || WSUF(2147483648) <= pw->val.nint) 381 { 382 /* store as a bignum (to be readable on 32bit machines) */ 383 len = tag_desc[pw->tag.kernel].string_size(pw->val, pw->tag, 1); 384 Store_Byte(TBIG); 385 Store_Int(len); 386 Reserve_Space(len+1); 387 stop = dest+len; 388 dest += tag_desc[pw->tag.kernel].to_string(pw->val, pw->tag, 389 dest, 1); 390 while (dest <= stop) /* pad and terminate */ 391 *dest++ = 0; 392 break; 393 } 394#endif 395 Store_Byte(TINT); 396#ifdef OLD_FORMAT 397 Store_Int32(pw->val.nint); 398#else 399 Store_Int(pw->val.nint); 400#endif 401 break; 402 403 case TNIL: 404 Store_Byte(Tag(pw->tag.kernel)); 405 break; 406 407 case TDICT: 408 len = DidLength(pw->val.did); 409 Store_Byte(TDICT); 410 Store_Int(DidArity(pw->val.did)); 411 Store_Int(len); 412 Reserve_Space(len); 413 Store_String(len, DidName(pw->val.did)); 414 break; 415 416 case TDBL: 417 { 418 ieee_double d; 419 d.as_dbl = Dbl(pw->val); 420 Store_Byte(TDBL); 421 Store_Byte(sizeof(double)-1); /* backward compat */ 422 Reserve_Space(sizeof(double)); 423 Store_Int32(d.as_struct.mant1); 424 Store_Int32(d.as_struct.mant0); 425 break; 426 } 427 428 case TIVL: 429 { 430 ieee_double dlwb, dupb; 431 dlwb.as_dbl = IvlLwb(pw->val.ptr); 432 dupb.as_dbl = IvlUpb(pw->val.ptr); 433 Store_Byte(TIVL); 434 Reserve_Space(2*sizeof(double)); 435 Store_Int32(dlwb.as_struct.mant1); 436 Store_Int32(dlwb.as_struct.mant0); 437 Store_Int32(dupb.as_struct.mant1); 438 Store_Int32(dupb.as_struct.mant0); 439 break; 440 } 441 442 case TSTRG: 443 len = StringLength(pw->val); 444 Store_Byte(TSTRG); 445 Store_Int(len); 446 Reserve_Space(len); 447 Store_String(len, StringStart(pw->val)); 448 break; 449 450 case TVAR_TAG: /* standard variable */ 451 Store_Byte(Tag(TVAR_TAG)); 452 Store_Int(curr_offset); 453 Trail_(pw); 454 pw->val.nint = curr_offset; 455 pw->tag.kernel |= MARK; 456 break; 457 458 case TNAME: 459 case TUNIV: 460 Store_Byte(Tag(TVAR_TAG)); 461 Store_Int(top_offset); 462 Trail_Tag(pw); 463 pw->val.nint = top_offset; 464 pw->tag.kernel |= MARK; 465 top_offset += 2; 466 EnQueue_(pw, 1, 0); 467 break; 468 469 case TMETA: 470 Store_Byte(Tag(TVAR_TAG)); 471 Store_Int(top_offset); 472 Trail_Tag(pw); 473 pw->val.nint = top_offset; 474 pw->tag.kernel |= MARK; 475 top_offset += 4; 476 EnQueue_(pw, 2, QUEUE_MASK_META); 477 break; 478 479 case TSUSP: 480 Store_Byte(Tag(TSUSP)); 481 pw = pw->val.ptr; 482 if (pw->tag.kernel & MARK) /* not the first encounter */ 483 { 484 Store_Int(pw->val.nint); 485 } 486 else 487 { 488 Store_Int(top_offset); 489 Trail_Pword(pw); 490 pw->tag.kernel |= MARK; 491 pw->val.nint = top_offset; 492 if (SuspDead(pw)) 493 { 494 top_offset += Words(SUSP_HEADER_SIZE); /* for TDE */ 495 EnQueue_(pw, SUSP_HEADER_SIZE, 0); 496 } 497 else 498 { 499 top_offset += Words(SUSP_SIZE); /* for TDE */ 500 EnQueue_(pw, SUSP_SIZE, 0); 501 } 502 } 503 break; 504 505 case TLIST: 506 Store_Byte(Tag(TLIST)); 507 Store_Int(top_offset); 508 top_offset += 4; 509 EnQueue_(pw->val.ptr, 2, 0); 510 break; 511 512 case TCOMP: 513 Store_Byte(Tag(TCOMP)); 514 Store_Int(top_offset); 515 if (flag) { 516 pword pw_out; 517 (void) transf_meta_out(pw->val, pw->tag, 518 (pword *) TempAlloc(meta_attr, ATTR_IO_TERM_SIZE * sizeof(pword)), 519 D_UNKNOWN, &pw_out); 520 pw = pw_out.val.ptr; 521 len = 1 + DidArity(pw->val.did); 522 EnQueue_(pw, len, 0); 523 } else { 524 len = 1 + DidArity(pw->val.ptr->val.did); 525 EnQueue_(pw->val.ptr, len, 0); 526 } 527 top_offset += 2*len; 528 break; 529 530 default: 531 if (TagType(pw->tag) >= 0 && TagType(pw->tag) <= NTYPES) 532 { 533 len = tag_desc[TagType(pw->tag)].string_size(pw->val, pw->tag, 1); 534 Store_Byte(Tag(pw->tag.kernel)); 535 Store_Int(len); 536 Reserve_Space(len+1); 537 stop = dest+len; 538 dest += tag_desc[TagType(pw->tag)].to_string(pw->val, pw->tag, 539 dest, 1); 540 while (dest <= stop) /* pad and terminate */ 541 *dest++ = 0; 542 } 543 else 544 { 545 p_fprintf(current_err_, 546 "bad type in term_to_dbformat: 0x%x\n", 547 pw->tag.kernel); 548 } 549 break; 550 } 551 curr_offset += Words(1); 552 ++parg; 553 } while (--arity); 554 if (EmptyQueue()) 555 break; 556 DeQueue_(parg, arity, flag); 557 } 558 /* # bytes of external representation */ 559 Store_Byte(0); /* add a terminating 0 */ 560 Set_Buffer_Size(header, dest - (char*) header - sizeof(pword)); 561 header->tag.kernel = TBUFFER; 562 Align(); /* align the global stack pointer */ 563 TG = (pword *) dest; 564 dest = (char *) (header + 1); /* fill in the external format header */ 565 Store_Int32(top_offset); /* (size of term after restoring) */ 566 Untrail_Variables(save_tt); 567 Temp_Destroy(meta_attr); 568 return header; 569} 570 571/* 572 * pword *dbformat_to_term(buf) 573 * 574 * Decode a term in database format (in the buffer pointed to by buf), 575 * construct it on the global stack and return its address. 576 * Return NULL if there is no space to construct the term. 577 */ 578 579pword * 580dbformat_to_term(register char *buf, dident mod, type tmod) 581{ 582 register pword *pw; 583 pword *p; 584 pword *base, *top; 585 pword *prev_ld = LD; 586 pword *r; 587 pword meta; 588 word n, t; 589 int res; 590 591 meta.tag.kernel = TNIL; 592 Load_Int32(n); 593 base = pw = TG; 594 TG = WordOffset(TG, n); 595 if (GlobalStackOverflow) 596 return (pword *)0; 597 top = TG; 598 599 while (pw < top) 600 { 601 Load_Byte(t); 602 switch (TagTypeC(t)) 603 { 604 case TINT: /* value */ 605#ifdef OLD_FORMAT 606 Load_Int32(n); 607#else 608 Load_Int(n); 609#endif 610 pw->val.nint = n; 611 pw++->tag.kernel = t; 612 break; 613 614 case TNIL: /* */ 615 pw++->tag.kernel = t; 616 break; 617 618 case TVAR_TAG: /* offset */ 619 Load_Int(n); 620 pw->val.ptr = WordOffset(base, n); 621 pw++->tag.kernel = TREF; 622 break; 623 624 case TUNIV: /* offset, length, "string\0" */ 625 case TNAME: 626 case TMETA: 627 Load_Int(n); 628 pw->val.ptr = WordOffset(base, n); 629 Load_Int(n); 630 if (n) 631 { 632 pw++->tag.kernel = DidTag(t, enter_dict_n(buf, n, 0)); 633#ifdef OLD_FORMAT 634 buf += n + 1; 635#else 636 buf += n; 637#endif 638 } 639 else 640 pw++->tag.kernel = RefTag(t); /* no name */ 641 if (TagTypeC(t) == TMETA) { 642 p = TG; 643 TG += 2; 644 Check_Gc 645 p[0].val.ptr = pw; 646 p[0].tag.kernel = TREF; 647 p[1] = meta; 648 meta.val.ptr = p; 649 meta.tag.kernel = TLIST; 650 } 651 break; 652 653 case TSUSP: 654 case TCOMP: 655 case TLIST: 656 Load_Int(n); 657 pw->val.ptr = WordOffset(base, n); 658 pw++->tag.kernel = t; 659 break; 660 661 case TDICT: /* arity, length, "string\0" */ 662 Load_Int(n); 663 Load_Int(t); 664 pw->val.did = enter_dict_n(buf, t, (int) n); 665 pw++->tag.kernel = TDICT; 666#ifdef OLD_FORMAT 667 buf += t + 1; 668#else 669 buf += t; 670#endif 671 break; 672 673 case TDBL: /* length, double */ 674 { 675 ieee_double d; 676 Load_Byte(n); /* backward compatibility */ 677 Load_Int32(d.as_struct.mant1); 678 Load_Int32(d.as_struct.mant0); 679 Make_Double(pw, d.as_dbl); 680 pw++; 681 } 682 break; 683 684 case TIVL: /* double, double */ 685 { 686 ieee_double dlwb, dupb; 687 Load_Int32(dlwb.as_struct.mant1); 688 Load_Int32(dlwb.as_struct.mant0); 689 Load_Int32(dupb.as_struct.mant1); 690 Load_Int32(dupb.as_struct.mant0); 691 Push_Interval(pw->val.ptr, dlwb.as_dbl, dupb.as_dbl); 692 pw++->tag.kernel = TIVL; 693 } 694 break; 695 696 case TSTRG: /* length, "string" */ 697 { 698 register char *string; 699 Load_Int(n); 700 Make_Stack_String(n, pw->val, string); 701 pw++->tag.kernel = TSTRG; 702#ifdef OLD_FORMAT 703 while (n-- >= 0) *string++ = *buf++; 704#else 705 while (n-- > 0) *string++ = *buf++; 706 *string = 0; 707#endif 708 } 709 break; 710 711 case TDE: 712 pw[SUSP_LD].val.ptr = LD; 713 Update_LD(pw) 714 Load_Int32(n); 715 pw[SUSP_FLAGS].tag.kernel = n; 716 pw[SUSP_PRI].val.ptr = (pword *) 0; /* missing */ 717 pw[SUSP_INVOC].tag.kernel = 0; 718 if (!SuspDead(pw)) { 719 Load_Byte(n); 720 Init_Susp_State(pw, n & 0xF, (n>>4) & 0xF); 721 pw += SUSP_GOAL; 722 } else { 723 pw += SUSP_HEADER_SIZE; 724 } 725 break; 726 727 default: 728 if (t >= 0 && t <= NTYPES) 729 { 730 Load_Int(n); 731 pw->tag.kernel = t; /* from_string() may change tag! */ 732 if (tag_desc[t].from_string(buf, pw, 10) != PSUCCEED) 733 { 734 /* this can happen e.g. if we try to read a bignum 735 * in an Eclipse that doesn't support them */ 736 Make_Nil(pw); 737 p_fprintf(current_err_, 738 "dbformat_to_term: cannot represent constant of type %s\n", 739 DidName(tag_desc[t].tag_name)); 740 } 741 ++pw; 742 buf += n+1; 743 } 744 else 745 { 746 Make_Nil(pw); 747 p_fprintf(current_err_, 748 "bad type in dbformat_to_term: 0x%x\n", t); 749 pw++; buf++; 750 } 751 break; 752 } 753 } 754 p = &meta; 755 while (IsList(p->tag)) { 756 p = p->val.ptr; 757 pw = (p++)->val.ptr; 758 r = transf_meta_in(pw, mod, &res); 759 if (!r) { 760 p_fprintf(current_err_, 761 "unknown attribute in dbformat_to_term: "); 762 (void) ec_pwrite(0, 2, current_err_, pw->val, pw->tag, 1200, 0, 763 mod, tdict); 764 (void) ec_newline(current_err_); 765 return (pword *) 0; 766 } 767 pw->val.ptr = r; 768 } 769 res = _fill_procedures(prev_ld, mod, tmod); 770 return (res == PSUCCEED) ? base : 0; 771} 772 773/* 774 * Fill in pri's in the newly read suspensions 775 */ 776static int 777_fill_procedures(pword *prev_ld, dident mod, type tmod) 778{ 779 pword *p, *env; 780 dident pd; 781 dident module_ref; 782 pri *proc; 783 784 for(env=LD; env > prev_ld; env = SuspPrevious(env)) 785 { 786 if (!(SuspDead(env))) 787 { 788 proc = SuspProc(env); 789 if (!proc) { 790 p = env + SUSP_GOAL; 791 Dereference_(p); 792 pd = p->val.ptr->val.did; 793 p = env + SUSP_MODULE; 794 Dereference_(p); 795 module_ref = p->val.did; 796 /* Create the module if it did not exist */ 797 if (!IsModule(module_ref)) 798 (void) ec_create_module(module_ref); 799 proc = visible_procedure(pd, module_ref, 800 (module_ref == mod) ? tmod : tdict, PRI_CREATE|PRI_REFER); 801 if (!proc) { 802 int err; 803 Get_Bip_Error(err); 804 p_fprintf(current_err_, 805 "locked module in dbformat_to_term: %s\n", 806 DidName(module_ref)); 807 return err; 808 } 809 env[SUSP_PRI].val.wptr = (uword *) proc; 810 } 811 } 812 } 813 return PSUCCEED; 814} 815 816static int 817p_term_to_bytes(value v, type t, value vs, type ts, value vm, type tm) 818{ 819 pword pw, *result; 820 Check_Output_String(ts); 821 Check_Atom(tm); 822 pw.val.all = v.all; 823 pw.tag.all = t.all; 824 result = term_to_dbformat(&pw, vm.did); 825 Return_Unify_String(vs, ts, result); 826} 827 828static int 829p_bytes_to_term(value vs, type ts, value v, type t, value vmod, type tmod) 830{ 831 pword *result; 832 833 Check_Atom(tmod); 834 Check_String(ts); 835 result = dbformat_to_term(StringStart(vs), vmod.did, tmod); 836 if (!result) 837 { 838 value va; 839 va.did = d_.abort; 840 Bip_Throw(va, tdict); 841 } 842 Return_Unify_Pw(v, t, result->val, result->tag); 843} 844 845 846 847/*--------------------------------------------------------------------------- 848 * Serialisation of ground terms for communication with other languages 849 * 850 * ExdrTerm ::= 'V' Version 'C'? Term 851 * Term ::= (Integer|Double|String|List|Nil|Struct|Variable) 852 * Integer ::= ('B' <byte> | 'I' XDR_int | 'J' XDR_long) 853 * Double ::= 'D' XDR_double 854 * String ::= ('S' Length <byte>* | 'R' Index) 855 * List ::= '[' Term (List|Nil) 856 * Nil ::= ']' 857 * Struct ::= 'F' Arity String Term* 858 * Variable ::= '_' 859 * Length ::= XDR_nat 860 * Index ::= XDR_nat 861 * Arity ::= XDR_nat 862 * Version ::= <byte> 863 * XDR_int ::= <4 bytes, msb first> 864 * XDR_long ::= <8 bytes, msb first> 865 * XDR_double ::= <8 bytes, ieee double, exponent first> 866 * XDR_nat ::= <8 bits: 1 + seven bits unsigned value> 867 * | XDR_int // >= 0 868 * 869 * NOTE: Eclipse integers are wordsized (TINT) or bignums (TBIG). 870 * Values between 2^31..2^63-1 and -2^63+1..-2^31 can be TINT or TBIG, 871 * depending on machine's wordsize. 872 * On the other hand, EXDR 'I' format is always 32 bits and 'J' 64 bits. 873 * As an additional complication, TINT and EXDR I,J are two's complement 874 * representations, but TBIGs are sign/magnitude. 875 * The code must therefore deal with 876 * TINT <--> I 877 * TINT <--> J 878 * TBIG (one limb) <--> J 879 * TBIG (two limbs) <--> J 880 *---------------------------------------------------------------------------*/ 881 882/* 883 * write_exdr/2 fails if the term cannot be represented in EXDR format. 884 * The execute_rpc/1 predicate in kernel.pl relies on that. 885 * Note also that we are careful to always write a complete EXDR term, 886 * even when we fail. This is to avoid the recipient of the term crashing. 887 */ 888 889#define EXDR_VERSION 2 890 891#define Negate_32_32(_lo, _hi) \ 892 _lo = -(_lo); \ 893 _hi = _lo ? ~(_hi) : -(_hi); 894 895 896static int 897_write_exdr(stream_id nst, pword *pw, t_heap_htable *strhm, int *perr) 898{ 899 int arity, res; 900 pword *arg; 901 value val; 902 char buf[10]; 903 char *dest; 904 ieee_double d; 905 906 for(;;) 907 { 908 Dereference_(pw); 909 if (IsRef(pw->tag)) 910 { 911 return ec_outfc(nst, '_'); 912 } 913 switch (TagType(pw->tag)) 914 { 915 case TDICT: /* like atom/0 structure */ 916 dest = buf; 917 Store_Byte('F'); 918 Store_Nat(0); 919 val.ptr = DidString(pw->val.did); 920 Write_String_Or_Ref(nst, strhm, val); 921 return res; 922 923 case TCOMP: 924 dest = buf; 925 arity = DidArity(pw->val.ptr->val.did); 926 arg = pw->val.ptr; 927 Store_Byte('F'); 928 Store_Nat(arity); 929 val.ptr = DidString(arg->val.did); 930 Write_String_Or_Ref(nst, strhm, val); 931 if (res != PSUCCEED) return res; 932 ++arg; 933 break; 934 935 case TLIST: 936 for (;;) 937 { 938 if ((res = ec_outfc(nst, '[')) != PSUCCEED) return res; 939 pw = pw->val.ptr; /* write car */ 940 if ((res = _write_exdr(nst, pw, strhm, perr)) != PSUCCEED) return res; 941 ++pw; 942 Dereference_(pw); /* check cdr */ 943 if (IsNil(pw->tag)) /* proper end */ 944 { 945 return ec_outfc(nst, ']'); 946 } 947 else if (!IsList(pw->tag)) /* improper list, truncate */ 948 { 949 *perr = PFAIL; 950 return ec_outfc(nst, ']'); 951 } 952 } 953 954 case TNIL: 955 return ec_outfc(nst, ']'); 956 957 case TINT: 958 dest = buf; 959 if (pw->val.nint == (word)(char)pw->val.nint) /* use 'B' format */ 960 { 961 Store_Byte('B'); 962 Store_Byte(pw->val.nint); 963 return ec_outf(nst, buf, 2); 964 } 965#if (SIZEOF_WORD > 4) 966 if ((int32) pw->val.nint != pw->val.nint) /* need 'J' format */ 967 { 968 int32 lo, hi; 969 Store_Byte('J'); 970 lo = (int32) pw->val.nint; 971 hi = (int32) (pw->val.nint >> 32); 972 Store_Int32(hi); 973 Store_Int32(lo); 974 return ec_outf(nst, buf, 9); 975 } 976#endif 977 Store_Byte('I'); 978 Store_Int32(pw->val.nint); 979 return ec_outf(nst, buf, 5); 980 981#if SIZEOF_WORD <= 4 982 case TBIG: 983 { 984 int32 *limbs = (int32*) BufferStart(pw->val.ptr); 985 int32 lo, hi; 986 if (BufferSize(pw->val.ptr) > 8) 987 { 988 *perr = PFAIL; 989 return ec_outfc(nst, '_'); 990 } 991 lo = limbs[0]; 992 hi = BufferSize(pw->val.ptr) > 4 ? limbs[1] : 0; 993 if (BigNegative(pw->val.ptr)) 994 { 995 Negate_32_32(lo, hi); 996 if (hi >= 0) 997 { 998 *perr = PFAIL; 999 return ec_outfc(nst, '_'); 1000 } 1001 } 1002 else 1003 { 1004 if (hi < 0) 1005 { 1006 *perr = PFAIL; 1007 return ec_outfc(nst, '_'); 1008 } 1009 } 1010 dest = buf; 1011 Store_Byte('J'); 1012 Store_Int32(hi); 1013 Store_Int32(lo); 1014 return ec_outf(nst, buf, 9); 1015 } 1016#endif 1017 1018 case TSTRG: 1019 dest = buf; 1020 Write_String_Or_Ref(nst, strhm, pw->val); 1021 return res; 1022 1023 case TDBL: 1024 dest = buf; 1025 d.as_dbl = Dbl(pw->val); 1026 Store_Byte('D'); 1027 Store_Int32(d.as_struct.mant1); 1028 Store_Int32(d.as_struct.mant0); 1029 return ec_outf(nst, buf, 9); 1030 1031 default: 1032 *perr = PFAIL; 1033 return ec_outfc(nst, '_'); 1034 } 1035 for (; arity > 1; arity--,arg++) 1036 { 1037 if ((res = _write_exdr(nst, arg, strhm, perr)) != PSUCCEED) 1038 return res; 1039 } 1040 pw = arg; /* tail recursion optimised */ 1041 } 1042} 1043 1044 1045int p_write_exdr(value vs, type ts, value v, type t) 1046{ 1047 int res, err; 1048 pword vt; 1049 char buf[2]; 1050 char *dest = buf; 1051 t_heap_htable *strhm = NULL; 1052 1053 stream_id nst = get_stream_id(vs, ts, SWRITE, &res); 1054 if (nst == NO_STREAM) 1055 return res; 1056 if (!IsWriteStream(nst)) 1057 return STREAM_MODE; 1058 Store_Byte('V'); 1059 Store_Byte(EXDR_VERSION); 1060 if ((res = ec_outf(nst, buf, 2)) != PSUCCEED) 1061 return res; 1062 if (StreamMode(nst) & SCOMPRESS) 1063 { 1064 if ((res = ec_outfc(nst, 'C')) != PSUCCEED) 1065 return res; 1066 strhm = htable_new(HTABLE_INTERNAL); 1067 } 1068 vt.val.all = v.all; 1069 vt.tag.all = t.all; 1070 err = PSUCCEED; 1071 res = _write_exdr(nst, &vt, strhm, &err); 1072 if (strhm) 1073 htable_free(strhm); 1074 if (res != PSUCCEED) 1075 return res; /* fatal error, exdr incomplete */ 1076 if (err != PSUCCEED) 1077 return err; /* non-fatal, exdr sane but wrong */ 1078 Succeed_; 1079} 1080 1081 1082#define Get_Next(n) { \ 1083 buf = (char *) StreamPtr(nst); \ 1084 if (StreamBuf(nst) + StreamCnt(nst) >= (unsigned char*) (buf + n)) \ 1085 StreamPtr(nst) = (unsigned char*) (buf + n); \ 1086 else { \ 1087 word _l; \ 1088 buf = ec_getstring(nst, n, &_l); \ 1089 if (_l < n) buf = 0; \ 1090 } \ 1091} 1092 1093static int 1094_read_exdr(stream_id nst, t_heap_htable *strhm, pword *pw) 1095{ 1096 word arity, len; 1097 char *buf; 1098 ieee_double d; 1099 pword *arg, key, valpw; 1100 int res; 1101 dident functor; 1102 1103 for (;;) 1104 { 1105 Get_Next(1); 1106 switch(*buf) 1107 { 1108 case '_': 1109 Make_Var(pw); 1110 return PSUCCEED; 1111 1112 case 'B': 1113 Get_Next(1); 1114 Load_Byte(len); 1115 Make_Integer(pw, len); 1116 return PSUCCEED; 1117 1118 case 'I': 1119 Get_Next(4); 1120 Load_Int32(len); 1121 Make_Integer(pw, len); 1122 return PSUCCEED; 1123 1124 case 'J': 1125 { 1126 int32 hi, lo; 1127 Get_Next(8); 1128 Load_Int32(hi); 1129 Load_Int32(lo); 1130#if (SIZEOF_WORD >= 8) 1131 Make_Integer(pw, ((word) hi << 32) + (uint32) lo); 1132#else 1133 arg = TG; 1134 Push_Buffer(8); 1135 if (hi < 0) /* convert to sign/magnitude */ 1136 { 1137 Negate_32_32(lo, hi); 1138 arg->tag.kernel |= BIGSIGN; 1139 } 1140 ((int32 *) BufferStart(arg))[0] = lo; 1141 if (hi) /* need two limbs */ 1142 { 1143 ((int32 *) BufferStart(arg))[1] = hi; 1144 } 1145 else /* need only one limb */ 1146 { 1147 Trim_Buffer(arg, 4); 1148 } 1149 pw->tag.kernel = TBIG; 1150 pw->val.ptr = arg; 1151#endif 1152 return PSUCCEED; 1153 } 1154 1155 case 'D': 1156 Get_Next(8); 1157 Load_Int32(d.as_struct.mant1); 1158 Load_Int32(d.as_struct.mant0); 1159 Make_Float(pw, d.as_dbl); 1160 return PSUCCEED; 1161 1162 case ']': 1163 Make_Nil(pw); 1164 return PSUCCEED; 1165 1166 case 'R': 1167 if (!strhm) return BAD_FORMAT_STRING; 1168 GetLoad_Nat(len); 1169 Make_Integer(&key, len); 1170 res = store_get(strhm, key.val, key.tag, pw); 1171 if (res != PSUCCEED) return res; 1172 /* What is retrieved from the store may be a string, 1173 * or a dictionary entry! 1174 */ 1175 if (!IsString(pw->tag)) { 1176 pw->val.ptr = DidString(pw->val.did); 1177 pw->tag.kernel = TSTRG; 1178 } 1179 return PSUCCEED; 1180 1181 case 'S': 1182 GetLoad_Nat(len); 1183 Get_Next(len); 1184 pw->tag.kernel = TSTRG; 1185 pw->val.ptr = TG; 1186 Push_Buffer(len+1); 1187 Copy_Bytes(StringStart(pw->val), buf, len); 1188 StringStart(pw->val)[len] = 0; 1189 if (strhm) { 1190 Make_Integer(&key, strhm->nentries); 1191 return store_set(strhm, key.val, key.tag, pw); 1192 } 1193 return PSUCCEED; 1194 1195 case 'F': 1196 GetLoad_Nat(arity); 1197 Get_Next(1); 1198 if (arity < 0 ) return BAD_FORMAT_STRING; 1199 Load_Byte(len); 1200 if ( len == 'S') { 1201 GetLoad_Nat(len); 1202 Get_Next(len); 1203 functor = enter_dict_n(buf, len, arity); 1204 if (strhm) { 1205 Make_Integer(&key, strhm->nentries); 1206 Make_Atom(&valpw, functor); 1207 res = store_set(strhm, key.val, key.tag, &valpw); 1208 if (res != PSUCCEED) return res; 1209 } 1210 } else if (len == 'R') { 1211 if (!strhm) return BAD_FORMAT_STRING; 1212 GetLoad_Nat(len); 1213 Make_Integer(&key, len); 1214 res = store_get(strhm, key.val, key.tag, &valpw); 1215 if (res != PSUCCEED) return res; 1216 /* What is retrieved from the store may be a string, 1217 * or a dictionary entry with correct/incorrect arity. 1218 */ 1219 if (IsString(valpw.tag)) { 1220 functor = enter_dict_n(StringStart(valpw.val), 1221 StringLength(valpw.val), arity); 1222 } else if (DidArity(valpw.val.did) == arity) { 1223 functor = valpw.val.did; 1224 } else { 1225 functor = add_dict(valpw.val.did, arity); 1226 } 1227 } else return BAD_FORMAT_STRING; 1228 if (arity == 0) { 1229 if (functor == d_.nil) { 1230 Make_Nil(pw); 1231 } else { 1232 Make_Atom(pw, functor); 1233 } 1234 return PSUCCEED; 1235 } 1236 arg = TG; 1237 if (functor == d_.list) { 1238 Make_List(pw, arg); 1239 Push_List_Frame(); 1240 } else { 1241 Make_Struct(pw, arg); 1242 Push_Struct_Frame(functor); 1243 ++arg; 1244 } 1245 break; 1246 1247 case '[': 1248 arity = 2; 1249 arg = TG; 1250 Make_List(pw, arg); 1251 Push_List_Frame(); 1252 break; 1253 1254 default: 1255 return BAD_FORMAT_STRING; 1256 } 1257 for (; arity > 1; arity--,arg++) 1258 { 1259 if ((res = _read_exdr(nst, strhm, arg)) != PSUCCEED) 1260 return res; 1261 } 1262 pw = arg; /* tail recursion optimised */ 1263 } 1264} 1265 1266 1267int p_read_exdr(value vs, type ts, value v, type t) 1268{ 1269 char *buf; 1270 pword vt; 1271 int res; 1272 t_heap_htable *strhm = NULL; 1273 1274 stream_id nst = get_stream_id(vs, ts, SREAD, &res); 1275 if (nst == NO_STREAM) 1276 return res; 1277 if (nst == null_) 1278 return PEOF; 1279 if (!(IsReadStream(nst))) 1280 return STREAM_MODE; 1281 Get_Next(3); 1282 if (!buf) 1283 return PEOF; 1284 if (*buf++ != 'V') 1285 return NOT_DUMP_FILE; 1286 if (*buf++ > EXDR_VERSION) 1287 return BAD_DUMP_VERSION; 1288 if (*buf == 'C') /* is it compressed exdr format? */ 1289 { 1290 strhm = htable_new(HTABLE_INTERNAL); 1291 } 1292 else 1293 { 1294 res = ec_ungetch(nst); 1295 if (res != PSUCCEED) return res; 1296 } 1297 res = _read_exdr(nst, strhm, &vt); 1298 if (strhm) 1299 htable_free(strhm); 1300 if (res != PSUCCEED) { 1301 return res; 1302 } 1303 if (!(IsRef(vt.tag) && vt.val.ptr == &vt)) 1304 { 1305 Return_Unify_Pw(v, t, vt.val, vt.tag); 1306 } 1307 Succeed_ 1308} 1309 1310 1311/* 1312 * Routines to convert from to simple types and xdr format 1313 * used by VB interface since it VB has no bit manipulation stuff 1314 */ 1315void Winapi 1316ec_double_xdr(double *d, char *dest) 1317{ 1318 ieee_double id; 1319 1320 id.as_dbl = *d; 1321 Store_Int32(id.as_struct.mant1); 1322 Store_Int32(id.as_struct.mant0); 1323} 1324 1325void Winapi 1326ec_xdr_double(char *buf, double *d) 1327{ 1328 ieee_double id; 1329 1330 Load_Int32(id.as_struct.mant1); 1331 Load_Int32(id.as_struct.mant0); 1332 *d = id.as_dbl; 1333} 1334void Winapi 1335ec_int32_xdr(int32 *l, char *dest) 1336{ 1337 Store_Int32(*l); 1338} 1339 1340void Winapi 1341ec_xdr_int32(char *buf, int32 *l) 1342{ 1343 Load_Int32(*l); 1344} 1345 1346 1347/*--------------------------------------------------------------------------- 1348 * Init 1349 *---------------------------------------------------------------------------*/ 1350 1351void 1352bip_serialize_init(int flags) 1353{ 1354 if (!(flags & INIT_SHARED)) 1355 return; 1356 (void) built_in(in_dict("write_exdr", 2), 1357 p_write_exdr, B_SAFE); 1358 (void) built_in(in_dict("read_exdr", 2), 1359 p_read_exdr, B_UNSAFE|U_FRESH); 1360 (void) exported_built_in(in_dict("term_to_bytes_", 3), 1361 p_term_to_bytes, B_UNSAFE|U_SIMPLE); 1362 (void) exported_built_in(in_dict("bytes_to_term_", 3), 1363 p_bytes_to_term, B_UNSAFE|U_FRESH); 1364} 1365