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_strings.c,v 1.5 2014/07/11 02:29:20 jschimpf Exp $ 25 */ 26 27/* 28 * IDENTIFICATION: bip_strings.c 29 * 30 * DESCRIPTION: SEPIA Built-in Predicates: Strings 31 * 32 * CONTENTS: 33 * 34 * AUTHOR VERSION DATE REASON 35 * P.Dufresne 0.0 File Created. 36 * E.Falvey 0.1 890221 Added ICL standards. 37 * J.Schimpf 02/90 New string format 38 */ 39 40#include "config.h" 41#include "sepia.h" 42#include "types.h" 43#include "embed.h" 44#include "mem.h" 45#include "dict.h" 46#include "emu_export.h" 47#include "error.h" 48 49#ifdef HAVE_STRING_H 50#include <string.h> 51#endif 52#ifdef HAVE_CTYPE_H 53#include <ctype.h> 54#endif 55 56pword *empty_string; 57 58static dident d_sha_; 59 60static int _concat_string(value v1, type t1, value vsep, pword **conc); 61 62static int p_string_list(value vs, type ts, value vl, type tl), 63 p_utf8_list(value vs, type ts, value vl, type tl), 64 p_concat_atoms(value v1, type t1, value v2, type t2, value vconc, type tconc), 65 p_concat_atom(value v1, type t1, value vconc, type tconc), 66 p_concat_string(value v1, type t1, value vconc, type tconc), 67 p_concat_strings(value v1, type t1, value v2, type t2, value vconc, type tconc), 68 p_first_substring(value vstr, type tstr, value vpos, type tpos, value vlen, type tlen, value vsub, type tsub), 69 p_hash_secure(value v1, type t1, value vhash, type thash, value vmethod, type tmethod), 70 p_join_string(value v1, type t1, value vsep, type tsep, value vconc, type tconc), 71 p_string_length(value sval, type stag, value nval, type ntag), 72 p_atom_length(value aval, type atag, value nval, type ntag), 73 p_split_string(value vstr, type tstr, value vsep, type tsep, value vpad, type tpad, value v, type t), 74 p_get_string_code(value vs, type ts, value vi, type ti, value vc, type tc), 75 p_string_code(value vs, type ts, value vi, type ti, value vc, type tc, value vfi, type tfi), 76 p_string_lower(value vs, type ts, value v, type t), 77 p_string_upper(value vs, type ts, value v, type t), 78 p_substring(value val1, type tag1, value val2, type tag2, value valp, type tagp), 79 p_string_print_length(value v1, type t1, value vs, type ts, value ve, type te, value vl, type tl), 80 p_text_to_string(value v, type t, value vs, type ts), 81 p_char_int(value chval, type chtag, value ival, type itag); 82 83 84 85/* 86 * FUNCTION NAME: bip_strings_init() 87 * 88 * PARAMETERS: NONE. 89 * 90 * DESCRIPTION: links the 'C' functions in this file with SEPIA 91 * built-in predicates. 92 */ 93void 94bip_strings_init(int flags) 95{ 96 if (flags & INIT_PRIVATE) 97 { 98 empty_string = enter_string_n("", 0, DICT_PERMANENT); 99 d_sha_ = in_dict("sha", 0); 100 } 101 102 if (flags & INIT_SHARED) 103 { 104 built_in(in_dict("string_list", 2), p_string_list, B_UNSAFE|U_GROUND|PROC_DEMON) 105 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 106 built_in(in_dict("utf8_list", 2), p_utf8_list, B_UNSAFE|U_GROUND|PROC_DEMON) 107 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 108 (void) built_in(in_dict("hash_secure", 3), p_hash_secure, B_UNSAFE|U_SIMPLE); 109 (void) built_in(in_dict("string_length", 2), p_string_length,B_UNSAFE|U_SIMPLE); 110 (void) built_in(in_dict("get_string_code", 3), p_get_string_code, B_UNSAFE|U_SIMPLE); 111 (void) b_built_in(in_dict("string_code", 4), p_string_code, d_.kernel_sepia); 112 (void) built_in(in_dict("substring", 3), p_substring, B_UNSAFE|U_SIMPLE); 113 (void) built_in(in_dict("atom_length", 2), p_atom_length, B_UNSAFE|U_SIMPLE); 114 (void) built_in(in_dict("string_upper", 2), p_string_upper, B_UNSAFE|U_SIMPLE); 115 (void) built_in(in_dict("string_lower", 2), p_string_lower, B_UNSAFE|U_SIMPLE); 116 (void) built_in(in_dict("concat_atoms", 3), p_concat_atoms, B_UNSAFE|U_SIMPLE|PROC_DEMON); 117 (void) built_in(in_dict("concat_atom", 2), p_concat_atom, B_UNSAFE|U_SIMPLE|PROC_DEMON); 118 (void) built_in(in_dict("concat_strings", 3), p_concat_strings,B_UNSAFE|U_SIMPLE|PROC_DEMON); 119 (void) built_in(in_dict("concat_string", 2), p_concat_string,B_UNSAFE|U_SIMPLE|PROC_DEMON); 120 (void) built_in(in_dict("atomics_to_string", 2),p_concat_string,B_UNSAFE|U_SIMPLE|PROC_DEMON); 121 (void) built_in(in_dict("join_string", 3), p_join_string, B_UNSAFE|U_SIMPLE|PROC_DEMON); 122 (void) built_in(in_dict("atomics_to_string", 3),p_join_string, B_UNSAFE|U_SIMPLE|PROC_DEMON); 123 (void) built_in(in_dict("text_to_string", 2), p_text_to_string, B_UNSAFE|U_SIMPLE|PROC_DEMON); 124 built_in(in_dict("split_string", 4), p_split_string, B_UNSAFE|U_GROUND) 125 -> mode = BoundArg(4, GROUND); 126 built_in(in_dict("char_int", 2), p_char_int, B_UNSAFE|U_SIMPLE) 127 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 128 (void) exported_built_in(in_dict("first_substring", 4), 129 p_first_substring, B_UNSAFE|U_SIMPLE); 130 exported_built_in(in_dict("string_print_length", 4), 131 p_string_print_length, B_UNSAFE|U_SIMPLE) -> mode = BoundArg(3, CONSTANT); 132 } 133} 134 135 136 137/* 138 * FUNCTION NAME: p_string_list(vs, ts, vl, tl) - logical 139 * 140 * PARAMETERS: vs, ts - a string or a variable. 141 * vl, tl - a list or a variable. 142 * 143 * DESCRIPTION: Used to convert a string to a list whose elements are 144 * the ascii codes for the characters of the string. 145 * Also used to convert a list (whose elements are ascii 146 * codes - i.e. integers in the range 0 to 255) to a 147 * string. 148 * If both arguments are instantiated, we chose the 149 * string->list direction. This is necessary since the 150 * argument list may be partly instantiated. 151 * In this case the list is currently no type checked! 152 */ 153 154static int 155p_string_list(value vs, type ts, value vl, type tl) 156{ 157 register pword *pw, *list; 158 register char *s; 159 register int len; 160 pword *old_tg = Gbl_Tg; 161 162 if (IsRef(ts)) /* no string given */ 163 { 164 if (IsRef(tl)) /* we need at least one */ 165 { 166 Bip_Error(PDELAY_1_2); 167 } 168 else if (IsList(tl)) /* make a string from a list */ 169 { 170 list = vl.ptr; /* space for the string header */ 171 Push_Buffer(1); /* make minimum buffer */ 172 s = (char *) BufferStart(old_tg); /* start of the new string */ 173 for(;;) /* loop through the list */ 174 { 175 pw = list++; 176 Dereference_(pw); /* get the list element */ 177 if (IsRef(pw->tag)) /* check it */ 178 { 179 Gbl_Tg = old_tg; 180 Push_var_delay(vs.ptr, ts.all); 181 Push_var_delay(pw, pw->tag.all); 182 Bip_Error(PDELAY); 183 } 184 else if (!IsInteger(pw->tag)) 185 { 186 Gbl_Tg = old_tg; 187 Bip_Error(TYPE_ERROR); 188 } 189 else if (pw->val.nint < 0 || pw->val.nint > 255) 190 { 191 Gbl_Tg = old_tg; 192 Bip_Error(RANGE_ERROR); 193 } 194 *s++ = pw->val.nint; 195 if (s == (char *) Gbl_Tg) /* we need another pword */ 196 { 197 Gbl_Tg += 1; 198 Check_Gc; 199 } 200 Dereference_(list); /* get the list tail */ 201 if (IsRef(list->tag)) 202 { 203 Gbl_Tg = old_tg; 204 Push_var_delay(vs.ptr, ts.all); 205 Push_var_delay(list, list->tag.all); 206 Bip_Error(PDELAY); 207 } 208 else if (IsList(list->tag)) 209 list = list->val.ptr; 210 else if (IsNil(list->tag)) 211 break; /* end of the list */ 212 else 213 { 214 Gbl_Tg = old_tg; 215 Bip_Error(TYPE_ERROR); 216 } 217 } 218 *s = '\0'; /* terminate the string */ 219 Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1); 220 Kill_DE; 221 Return_Unify_String(vs, ts, old_tg); 222 } 223 else if (IsNil(tl)) 224 { 225 Kill_DE; 226 Return_Unify_String(vs, ts, empty_string); 227 } 228 else 229 { 230 Bip_Error(TYPE_ERROR); 231 } 232 } 233 else if (IsString(ts)) 234 { 235 Kill_DE; 236 Check_Output_List(tl); 237 s = StringStart(vs); /* get a pointer to the string */ 238 len = StringLength(vs); 239 if (len == 0) 240 { 241 Return_Unify_Nil(vl, tl); 242 } 243 /* Additional a-priori overflow check because adding to TG may 244 * may wrap around the address space and break Check_Gc below 245 */ 246 Check_Available_Pwords(2*len); 247 pw = Gbl_Tg; /* reserve space for the list */ 248 Gbl_Tg += 2*len; 249 Check_Gc; 250 pw->val.nint = *s++ & 0xFFL; /* construct the list */ 251 pw++->tag.kernel = TINT; 252 while (--len > 0) 253 { 254 pw->val.ptr = pw + 1; 255 pw++->tag.kernel = TLIST; 256 pw->val.nint = *s++ & 0xFFL; 257 pw++->tag.kernel = TINT; 258 } 259 pw->tag.kernel = TNIL; 260 Return_Unify_List(vl, tl, old_tg); 261 } 262 else 263 { 264 Bip_Error(TYPE_ERROR); 265 } 266} 267 268 269/* 270 * text_to_string(+Text, -String) 271 * Convert atom, string, codes or chars to string. 272 * Delay if not sufficiently instantiated. 273 */ 274 275static int 276p_text_to_string(value v, type t, value vs, type ts) 277{ 278 pword *pw, *list; 279 char *s; 280 int len; 281 pword *old_tg = Gbl_Tg; 282 283 if (IsRef(t)) 284 { 285 Bip_Error(PDELAY_1); 286 } 287 288 if (IsString(t)) 289 { 290 Kill_DE; 291 Return_Unify_Pw(v, t, vs, ts); 292 } 293 294 if (IsAtom(t)) /* not including [] ! */ 295 { 296 Kill_DE; 297 Return_Unify_String(vs, ts, DidString(v.did)); 298 } 299 300 if (IsNil(t)) 301 { 302 Kill_DE; 303 Return_Unify_String(vs, ts, empty_string); 304 } 305 306 if (IsList(t)) /* make a string from a list */ 307 { 308 int element_type = 0; 309 list = v.ptr; /* space for the string header */ 310 Push_Buffer(1); /* make minimum buffer */ 311 s = (char *) BufferStart(old_tg); /* start of the new string */ 312 for(;;) /* loop through the list */ 313 { 314 int c; 315 pw = list++; 316 Dereference_(pw); /* get the list element */ 317 if (IsRef(pw->tag)) /* check it */ 318 { 319 Gbl_Tg = old_tg; 320 Push_var_delay(vs.ptr, ts.all); 321 Push_var_delay(pw, pw->tag.all); 322 Bip_Error(PDELAY); 323 } 324 else if (IsInteger(pw->tag)) /* char code */ 325 { 326 element_type |= 1; 327 c = pw->val.nint; 328 if (c < 0 || 255 < c) 329 { 330 Gbl_Tg = old_tg; 331 Bip_Error(RANGE_ERROR); 332 } 333 } 334 else if (IsAtom(pw->tag)) /* char atom */ 335 { 336 element_type |= 2; 337 if (DidLength(pw->val.did) != 1) 338 { 339 Gbl_Tg = old_tg; 340 Bip_Error(RANGE_ERROR); 341 } 342 c = DidName(pw->val.did)[0]; 343 } 344 else 345 { 346 Gbl_Tg = old_tg; 347 Bip_Error(TYPE_ERROR); 348 } 349 *s++ = c; 350 if (s == (char *) Gbl_Tg) /* we need another pword */ 351 { 352 Gbl_Tg += 1; 353 Check_Gc; 354 } 355 Dereference_(list); /* get the list tail */ 356 if (IsRef(list->tag)) 357 { 358 Gbl_Tg = old_tg; 359 Push_var_delay(vs.ptr, ts.all); 360 Push_var_delay(list, list->tag.all); 361 Bip_Error(PDELAY); 362 } 363 else if (IsList(list->tag)) 364 list = list->val.ptr; 365 else if (IsNil(list->tag)) 366 break; /* end of the list */ 367 else 368 { 369 Gbl_Tg = old_tg; 370 Bip_Error(TYPE_ERROR); 371 } 372 } 373 if (element_type != 1 && element_type != 2) /* mixed type list? */ 374 { 375 Gbl_Tg = old_tg; 376 Bip_Error(TYPE_ERROR); 377 } 378 *s = '\0'; /* terminate the string */ 379 Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1); 380 Kill_DE; 381 Return_Unify_String(vs, ts, old_tg); 382 } 383 384 Bip_Error(TYPE_ERROR); 385} 386 387 388 389/* 390 * FUNCTION NAME: p_substring(val1, tag1, val2, tag2, valp, tagp) 391 * 392 * PARAMETERS: val1 - string1->val 393 * tag1 - string1->tag, where string1 is the string 394 * containing string2. 395 * string1 must be a string. 396 * 397 * val2 - string2->val 398 * tag2 - string2->tag, where string2 is a substring 399 * of string1. 400 * string2 must be a string. 401 * 402 * valp - posn->val 403 * tagp - posn->tag, where posn is the position 404 * in string1 where string2 first occurs. 405 * posn must be an integer or a variable. 406 * 407 * DESCRIPTION: Used to test that string2 is a substring of string1 408 * beginning at position posn. In this case, string1 409 * and string2 are strings and posn is an integer. 410 * Also used to find the position in string1 that its 411 * substring string2 begins. In this case, string1 and 412 * string2 are strings and posn is a variable. 413 */ 414 415static int 416p_substring(value val1, type tag1, value val2, type tag2, value valp, type tagp) 417{ 418 char *p1, *p2; 419 word length1, length2; 420 word i, j; 421 422 /* string1 and string2 must be strings; posn an integer/variable. */ 423 424 Check_Output_Integer(tagp); 425 Check_Output_String(tag1); 426 Check_String(tag2); 427 Error_If_Ref(tag1); 428 429 length1 = StringLength(val1); 430 length2 = StringLength(val2); 431 432 if (!IsRef(tagp)) 433 { 434 if (valp.nint <= 0 || valp.nint > length1 + 1) 435 { 436 Bip_Error(RANGE_ERROR); 437 } 438 if (valp.nint > length1 - length2 + 1) 439 { 440 Fail_; /* string 2 is too long to match */ 441 } 442 443 p1 = StringStart(val1) + valp.nint - 1; 444 p2 = StringStart(val2); 445 for(j = 0; j < length2; ++j) 446 { 447 if (p1[j] != p2[j]) 448 { 449 Fail_; 450 } 451 } 452 Succeed_; 453 } 454 else 455 { 456 p1 = StringStart(val1); 457 p2 = StringStart(val2); 458 for (i = 1; i <= length1 - length2 + 1; i++) 459 { 460 /* 461 * search through p (i.e. string1) 'length2' characters 462 * at a time for val2.str (i.e. string2), till the end 463 * of string1. 464 */ 465 for(j = 0; j < length2; ++j) 466 { 467 if (p1[j] != p2[j]) 468 break; 469 } 470 if (j == length2) 471 { 472 Return_Unify_Integer(valp, tagp, i); 473 } 474 p1++; 475 } 476 /* if not found, fail. */ 477 Fail_; 478 } 479} 480 481 482 483/* 484 * FUNCTION NAME: p_string_length(sval, stag, nval, ntag) - logical 485 * 486 * PARAMETERS: sval - string1->val 487 * stag - string1->tag, where string1 is the string passed. 488 * string1 must be a string. 489 * 490 * nval - length1->val 491 * ntag - length1->tag 492 * length1 must be an integer/variable. 493 * 494 * DESCRIPTION: Used to measure the length of a string. In this case, 495 * string1 is a string and length1 is a variable. 496 * Also used to test whether length1 matches string1's 497 * length. In this case, string1 is a string and length1 498 * is an integer. 499 */ 500 501static int 502p_string_length(value sval, type stag, value nval, type ntag) 503{ 504 Check_Output_Integer(ntag); 505 if (IsRef(stag)) 506 { Bip_Error(PDELAY_1); } 507 else if (!IsString(stag)) 508 { Bip_Error(TYPE_ERROR); } 509 510 Return_Unify_Integer(nval, ntag, StringLength(sval)); 511} 512 513 514 515/* 516 * FUNCTION NAME: p_atom_length(aval, atag, nval, ntag) - logical 517 * 518 * PARAMETERS: value aval - atom1->val 519 * type atag - atom1->tag where atom1 is the atom passed. 520 * atom1 must be an atom. 521 * 522 * value nval - length1->val 523 * type ntag - length1->tag where length1 is the length of 524 * the atom passed. 525 * length1 must be an integer or a variable. 526 * 527 * DESCRIPTION: Used to find the length of the atom passed to it as a 528 * parameter. In this case, the atom is passed to the 529 * function as 'aval' and 'atag', and as the length of 530 * the atom is uninstantiated, 'nval' and 'ntag' refer to 531 * a variable. 532 * Also used to match the integer 'nval.int' to the length 533 * of the atom. In this case, the atom is passed as 534 * before, and the 'nval' and 'ntag' are also passed 535 * instantiated. The success or failure of the matching 536 * is returned. 537 */ 538 539static int 540p_atom_length(value aval, type atag, value nval, type ntag) 541{ 542 Check_Output_Integer(ntag); 543 if (IsRef(atag)) 544 { Bip_Error(PDELAY_1); } 545 Check_Output_Atom_Or_Nil(aval, atag); 546 Return_Unify_Integer(nval, ntag, DidLength(aval.did)); 547} 548 549 550 551/* 552 * FUNCTION NAME: p_char_int(chval, chtag, ival, itag) - logical 553 * 554 * PARAMETERS: chval, chtag - a single character string or a variable 555 * ival,itag - an integer (0..255) or a variable 556 * 557 * DESCRIPTION: Used to find the ascii code for a character passed. 558 * The character is represented by a single-element 559 * string. Character codes are in the range 0..255. 560 * This is a BSI predicate of questionable usefulness. 561 */ 562 563static 564p_char_int(value chval, type chtag, value ival, type itag) 565{ 566 567 /* Case of: converting an integer to a character. */ 568 569 if (IsRef(chtag)) 570 { 571 value v; 572 register char *s; 573 574 if (IsRef(itag)) 575 { Bip_Error(PDELAY_1_2); } 576 else if (!IsInteger(itag)) 577 { Bip_Error(TYPE_ERROR); } 578 if ((ival.nint < 0) || (ival.nint > 255)) 579 { 580 Bip_Error(RANGE_ERROR) 581 } 582 Make_Stack_String(1, v, s); 583 *s++ = ival.nint; 584 *s = '\0'; 585 Return_Unify_String(chval, chtag, v.ptr); 586 } 587 else if (IsString(chtag) && StringLength(chval) == 1) 588 { 589 /* 590 * Case of: converting a character to an integer / testing 591 * whether character and integer match. 592 */ 593 594 Check_Output_Integer(itag); 595 Return_Unify_Integer(ival, itag, (*(StringStart(chval)) & 0xFFL)); 596 } 597 598 Bip_Error(TYPE_ERROR) 599} 600 601 602 603/* 604 * FUNCTION NAME: p_concat_atoms(v1, t1, v2, t2, vconc, tconc) - logical 605 * 606 * PARAMETERS: v1 - atom1->val 607 * t1 - atom1->tag, where atom1 is the leftmost part 608 * of the resultant atom atomconc. 609 * atom1 must be an atom. 610 * v2 - atom2->val 611 * t2 - atom2->tag, where atom2 is the rightmost part 612 * of the resultant atom atomconc. 613 * atom2 must be an atom. 614 * vconc - atomconc->val 615 * tconc - atomconc->tag, where atomconc is the concaten- 616 * ation of atom1 and atom2. 617 * atomconc must be an atom or a variable. 618 * 619 * DESCRIPTION: Used to concatenate atom1 with atom2 to form the atom 620 * atomconc. In this case, atom1 and atom2 are atoms and 621 * atomconc is a variable. 622 * Also used to test if atomconc is the concatenation of 623 * atom1 and atom2. In this case, all args are atoms. 624 */ 625 626static int 627p_concat_atoms(value v1, type t1, value v2, type t2, value vconc, type tconc) 628{ 629 dident cdid; 630 register char *s, *t; 631 value v; 632 register word l1, l2; 633 pword *old_tg = Gbl_Tg; 634 635 Check_Output_Atom_Or_Nil(vconc, tconc); 636 Check_Output_Atom_Or_Nil(v1, t1); 637 Check_Output_Atom_Or_Nil(v2, t2); 638 if (IsRef(t1)) 639 { Bip_Error(PDELAY_1); } 640 if (IsRef(t2)) 641 { Bip_Error(PDELAY_2); } 642 Kill_DE; 643 644 l1 = DidLength(v1.did); 645 l2 = DidLength(v2.did); 646 Make_Stack_String(l1+l2, v, s) 647 t = DidName(v1.did); /* copy the strings */ 648 while (l1--) 649 *s++ = *t++; 650 t = DidName(v2.did); 651 while (l2--) 652 *s++ = *t++; 653 *s = '\0'; 654 655 cdid = enter_dict_n(StringStart(v), StringLength(v), 0); 656 Gbl_Tg = old_tg; 657 Return_Unify_Atom(vconc, tconc, cdid); 658} 659 660 661/* 662 * FUNCTION NAME: p_concat_string(v1, t1, vconc, tconc) 663 * 664 * PARAMETERS: - a list of constants 665 * - a string or variable 666 * 667 * DESCRIPTION: Used to concatenate constants in the given list 668 * to yield a string. 669 */ 670 671static int 672p_concat_string(value v1, type t1, value vconc, type tconc) 673{ 674 value v, vsep; 675 int status; 676 677 Check_Output_List(t1); 678 Check_Output_String(tconc); 679 if (IsRef(t1)) 680 { Bip_Error(PDELAY_1); } 681 vsep.ptr = empty_string; 682 if ((status = _concat_string(v1, t1, vsep, &v.ptr)) != PSUCCEED) 683 { 684 return status; 685 } 686 Kill_DE; 687 Return_Unify_String(vconc, tconc, v.ptr); 688 689} 690 691static int 692p_join_string(value v1, type t1, value vsep, type tsep, value vconc, type tconc) 693{ 694 value v; 695 int status; 696 697 if (IsRef(t1)) 698 { Bip_Error(PDELAY_1); } 699 if (IsRef(tsep)) 700 { Bip_Error(PDELAY_2); } 701 Check_Output_String(tconc); 702 Check_List(t1); 703 if (IsString(tsep)) ; 704 else if (IsAtom(tsep)) vsep.ptr = DidString(vsep.did); 705 else if (IsNil(tsep)) vsep.ptr = DidString(d_.nil); 706 else { Bip_Error(TYPE_ERROR); } 707 if ((status = _concat_string(v1, t1, vsep, &v.ptr)) != PSUCCEED) 708 { 709 return status; 710 } 711 Kill_DE; 712 Return_Unify_String(vconc, tconc, v.ptr); 713 714} 715 716 717/* 718 * FUNCTION NAME: p_concat_atom(v1, t1, vconc, tconc) 719 * 720 * PARAMETERS: - a list of constants 721 * - an atom or variable 722 * 723 * DESCRIPTION: Used to concatenate constants in the given list 724 * to yield an atom. 725 */ 726 727static int 728p_concat_atom(value v1, type t1, value vconc, type tconc) 729{ 730 pword *old_tg = Gbl_Tg; 731 value v, vsep; 732 dident cdid; 733 int status; 734 735 Check_Output_List(t1); 736 Check_Output_Atom_Or_Nil(vconc, tconc); 737 if (IsRef(t1)) 738 { Bip_Error(PDELAY_1); } 739 vsep.ptr = empty_string; 740 if ((status = _concat_string(v1, t1, vsep, &v.ptr)) != PSUCCEED) 741 { 742 return status; 743 } 744 Kill_DE; 745 cdid = enter_dict_n(StringStart(v), StringLength(v), 0); 746 Gbl_Tg = old_tg; /* the string can be discarded now */ 747 Return_Unify_Atom(vconc, tconc, cdid); 748} 749 750 751/* 752 * auxiliary function for concat_atom/2 and concat_string/2 753 * CAUTION: it may push something on SV and return PDELAY 754 */ 755 756static int 757_concat_string(value v1, type t1, value vsep, pword **conc) 758{ 759 pword *p; 760 pword *cst; 761 char *pa; 762 char *pc; 763 word length = 0; 764 value v; 765 int parts = 0; 766 word cst_tag; 767 768 if (IsNil(t1)) 769 { 770 *conc = empty_string; 771 Succeed_; 772 } 773 774 /* First check all arguments and obtain a conservative 775 * estimate for the length of the concatenated atom. 776 */ 777 p = v1.ptr; 778 for (;;) 779 { 780 ++parts; 781 cst = p++; 782 Dereference_(cst); 783 cst_tag = TagType(cst->tag); 784 if (IsRef(cst->tag)) 785 { 786 Push_var_delay(cst, cst->tag.all); 787 Bip_Error(PDELAY); 788 } 789 switch(cst_tag) 790 { 791 case TDICT: 792 length += DidLength(cst->val.did); 793 break; 794 case TSTRG: 795 length += StringLength(cst->val); 796 break; 797 case TNIL: 798 length += 2; 799 break; 800 case THANDLE: 801 if (ExternalData(cst->val.ptr)) 802 length += ExternalClass(cst->val.ptr)->string_size(ExternalData(cst->val.ptr), 0); 803 break; 804 default: /* handles all the numeric types */ 805 if (IsNumber(cst->tag)) 806 length += tag_desc[cst_tag].string_size(cst->val, cst->tag, 0); 807 else 808 { Bip_Error(TYPE_ERROR); } 809 break; 810 } 811 812 Dereference_(p); 813 if (IsRef(p->tag)) 814 { 815 Push_var_delay(p, p->tag.all); 816 Bip_Error(PDELAY); 817 } 818 else if (IsNil(p->tag)) 819 break; 820 else if (IsList(p->tag)) 821 p = p->val.ptr; 822 else 823 { 824 Bip_Error(TYPE_ERROR); 825 } 826 } 827 length += (parts-1) * StringLength(vsep); 828 Make_Stack_String(length, v, pa); /* may be too long */ 829 /* 830 * Then copy the strings to the buffer. 831 */ 832 p = v1.ptr; 833 for (;;) 834 { 835 cst = p++; 836 Dereference_(cst); 837 cst_tag = TagType(cst->tag); 838 switch(cst_tag) 839 { 840 case TDICT: 841 pc = DidName(cst->val.did); 842 length = DidLength(cst->val.did); 843 while (length--) *pa++ = *pc++; 844 break; 845 case TSTRG: 846 pc = StringStart(cst->val); 847 length = StringLength(cst->val); 848 while (length--) *pa++ = *pc++; 849 break; 850 case TNIL: 851 *pa++ = '['; *pa++ = ']'; 852 break; 853 case THANDLE: 854 if (ExternalData(cst->val.ptr)) 855 pa += ExternalClass(cst->val.ptr)->to_string(ExternalData(cst->val.ptr), pa, 0); 856 break; 857 default: /* handles all the numeric types */ 858 pa += tag_desc[cst_tag].to_string(cst->val, cst->tag, pa, 0); 859 break; 860 } 861 862 Dereference_(p); 863 if (IsNil(p->tag)) 864 break; 865 866 length = StringLength(vsep); /* add separator */ 867 pc = StringStart(vsep); 868 while (length--) 869 *pa++ = *pc++; 870 871 p = p->val.ptr; 872 } 873 *pa++ = 0; /* NUL terminator */ 874 875 Trim_Buffer(v.ptr, (pa-StringStart(v))); 876 *conc = v.ptr; 877 Succeed_; 878} 879 880 881/* 882 * split_string(+String, +SepChars, +PadChars, -List) 883 * 884 * Break up a string at the given separator characters. 885 * Padding characters are removed around separators. 886 * The remaining substrings are returned in List. 887 * Characters occuring both in SepChars and PadChars are multi-separators, 888 * ie. a sequence of them is treated as a single separator. If they 889 * occur at the beginning or end of the input string, they are treated 890 * like padding. 891 */ 892 893#define S_START 0 /* in initial padding */ 894#define S_PRE 1 /* in padding after separator (pre-data) */ 895#define S_FIRST 2 /* just after first data char */ 896#define S_DATA 3 /* in data field */ 897#define S_POST 4 /* padding within or after data */ 898#define S_SEP 5 /* just after separator */ 899#define S_MSEP 6 /* in multi-separator */ 900#define S_STOP 7 /* end of string */ 901#define S_SIZE 7 902#define P 0x10 /* output action */ 903 904#define C_DATA 0 /* input character classes */ 905#define C_PAD 1 906#define C_SEP 2 907#define C_MSEP (C_PAD|C_SEP) 908#define C_STOP 4 909#define C_SIZE 5 910 911static int transitions[S_SIZE][C_SIZE] = 912{ 913/* C_DATA C_PAD C_SEP C_MSEP C_STOP */ 914 915/* S_START */ S_FIRST, S_START, P|S_SEP, S_START, P|S_STOP, 916/* S_PRE */ S_FIRST, S_PRE, P|S_SEP, S_MSEP, P|S_STOP, 917/* S_FIRST */ S_DATA, S_POST, P|S_SEP, P|S_MSEP, P|S_STOP, 918/* S_DATA */ S_DATA, S_POST, P|S_SEP, P|S_MSEP, P|S_STOP, 919/* S_POST */ S_DATA, S_POST, P|S_SEP, P|S_MSEP, P|S_STOP, 920/* S_SEP */ S_FIRST, S_PRE, P|S_SEP, P|S_MSEP, P|S_STOP, 921/* S_MSEP */ S_FIRST, S_PRE, P|S_SEP, S_MSEP, S_STOP 922}; 923 924static int 925p_split_string(value vstr, type tstr, value vsep, type tsep, value vpad, type tpad, value v, type t) 926{ 927 pword result; 928 pword *tail = &result; 929 char *first, *last; 930 char *s, *stop; 931 int state, cc; 932 933 Check_String(tstr); 934 Check_String(tsep); 935 Check_String(tpad); 936 Check_Output_List(t); 937 938 last = s = StringStart(vstr); 939 stop = s-- + StringLength(vstr); 940 first = last+1; 941 942 for (state = S_START; ; state = transitions[state][cc]) 943 { 944 if (state & P) 945 { 946 char *ss; 947 Make_List(tail, TG); /* create list element with substring */ 948 tail = TG; 949 Push_List_Frame(); 950 tail->val.ptr = TG; 951 tail++->tag.kernel = TSTRG; 952 ss = (char *) BufferStart(TG); 953 Push_Buffer(last-first+2); 954 while (first <= last) 955 *ss++ = *first++; 956 *ss = 0; 957 first = last + 1; 958 state &= ~P; 959 } 960 switch (state) 961 { 962 case S_FIRST: 963 first = s; 964 case S_DATA: 965 last = s; 966 break; 967 case S_STOP: 968 Make_Nil(tail); 969 Return_Unify_Pw(v, t, result.val, result.tag); 970 } 971 if (++s == stop) /* get next character class */ 972 cc = C_STOP; 973 else 974 { 975 int i; 976 char c = *s; 977 cc = C_DATA; 978 for (i=0; i<StringLength(vpad); ++i) 979 if (c == StringStart(vpad)[i]) { cc |= C_PAD; break; } 980 for (i=0; i<StringLength(vsep); ++i) 981 if (c == StringStart(vsep)[i]) { cc |= C_SEP; break; } 982 } 983 } 984} 985 986 987/* 988 * FUNCTION NAME: p_concat_strings(v1, t1, v2, t2, vconc, tconc) logical 989 * 990 * PARAMETERS: v1, t1 - the left string 991 * v2, t2 - the right string 992 * vconc, tconc - a variable or a string 993 * it is unified with the concatenation 994 * of the other two strings 995 * 996 * DESCRIPTION: concat_strings(+String1, +String2, ?String3) 997 * 998 * Used to concatenate string1 with string2 to form the 999 * string string3. 1000 */ 1001 1002static int 1003p_concat_strings(value v1, type t1, value v2, type t2, value vconc, type tconc) 1004{ 1005 value v; 1006 register char *s, *t; 1007 register int l1, l2; 1008 1009 Check_Output_String(tconc); 1010 Check_Output_String(t1); 1011 Check_Output_String(t2); 1012 if (IsRef(t1)) 1013 { Bip_Error(PDELAY_1); } 1014 if (IsRef(t2)) 1015 { Bip_Error(PDELAY_2); } 1016 Kill_DE; 1017 1018 l1 = StringLength(v1); 1019 l2 = StringLength(v2); 1020 1021 Make_Stack_String(l1 + l2, v, s); 1022 1023 t = StringStart(v1); /* copy the strings */ 1024 while (l1--) 1025 *s++ = *t++; 1026 t = StringStart(v2); 1027 while (l2--) 1028 *s++ = *t++; 1029 *s = '\0'; 1030 1031 Return_Unify_String(vconc, tconc, v.ptr); 1032} 1033 1034 1035 1036/* 1037 * first_substring(+String, +Position, +Length, ?SubString) 1038 * deterministic substring extraction 1039 */ 1040 1041static int 1042p_first_substring(value vstr, type tstr, value vpos, type tpos, value vlen, type tlen, value vsub, type tsub) 1043{ 1044 char *s; 1045 value v; 1046 1047 Check_String(tstr); 1048 Check_Integer(tpos); 1049 Check_Integer(tlen); 1050 Check_Output_String(tsub); 1051 if (vpos.nint + vlen.nint > StringLength(vstr) + 1) 1052 { Fail_ } 1053 1054 Make_Stack_String(vlen.nint, v, s); 1055 Copy_Bytes(s, StringStart(vstr) + vpos.nint - 1, vlen.nint); 1056 s[vlen.nint] = '\0'; 1057 Return_Unify_String(vsub, tsub, v.ptr); 1058} 1059 1060/* 1061 * Find out the print length of a given string up to a given 1062 * character, taken into account 1063 * tabs and backspaces and a starting position 1064 * string_print_length(+String, +Start, +CharPos, -Length) 1065*/ 1066#define TAB_LENGTH 8 1067static int 1068p_string_print_length(value v1, type t1, value vs, type ts, value ve, type te, value vl, type tl) 1069{ 1070 register char *p; 1071 register int size; 1072 int pl; 1073 int tabs; 1074 char c; 1075 1076 Check_String(t1) 1077 Check_Integer(ts) 1078 Check_Integer(te) 1079 Check_Output_Integer(tl) 1080 p = StringStart(v1); 1081 size = StringLength(v1); 1082 if (ve.nint < size && ve.nint >= 0) 1083 size = ve.nint; 1084 /* the number of spaces to make up to the next tab stop */ 1085 tabs = TAB_LENGTH - vs.nint % TAB_LENGTH; 1086 pl = vs.nint/TAB_LENGTH*TAB_LENGTH; 1087 while (size--) { 1088 if ((c = *p++) == '\t') { 1089 pl += tabs; 1090 tabs = TAB_LENGTH; 1091 } 1092 else if (c == '\b') { 1093 pl--; 1094 tabs++; 1095 if (tabs > TAB_LENGTH) 1096 tabs = 1; 1097 } 1098 else { 1099 pl++; 1100 tabs--; 1101 if (tabs == 0) 1102 tabs = TAB_LENGTH; 1103 } 1104 } 1105 Return_Unify_Integer(vl, tl, pl); 1106} 1107 1108 1109static int 1110p_utf8_list(value vs, type ts, value vl, type tl) 1111{ 1112 register pword *pw, *list; 1113 register char *s; 1114 register int len; 1115 pword *old_tg = TG; 1116 1117 if (IsRef(ts)) /* no string given */ 1118 { 1119 if (IsRef(tl)) /* we need at least one */ 1120 { 1121 Bip_Error(PDELAY_1_2); 1122 } 1123 else if (IsList(tl)) /* make a string from a list */ 1124 { 1125 list = vl.ptr; /* space for the string header */ 1126 Push_Buffer(1); /* make minimum buffer */ 1127 s = (char *) BufferStart(old_tg); /* start of the new string */ 1128 for(;;) /* loop through the list */ 1129 { 1130 uint32 ch; 1131 pw = list++; 1132 Dereference_(pw); /* get the list element */ 1133 if (IsRef(pw->tag)) /* check it */ 1134 { 1135 TG = old_tg; 1136 Push_var_delay(vs.ptr, ts.all); 1137 Push_var_delay(pw, pw->tag.all); 1138 Bip_Error(PDELAY); 1139 } 1140 else if (!IsInteger(pw->tag)) 1141 { 1142 TG = old_tg; 1143 Bip_Error(TYPE_ERROR); 1144 } 1145 1146 if (s + 6 >= (char*) TG) 1147 { 1148 TG += 1; 1149 Check_Gc; 1150 } 1151 ch = pw->val.nint; 1152 if (ch < 0x80) { 1153 *s++ = ch; 1154 } else if (ch < 0x800) { 1155 s[1] = ch & 0xBF | 0x80; ch >>= 6; 1156 s[0] = ch | 0xC0; 1157 s += 2; 1158 } else if (ch < 0x10000) { 1159 s[2] = ch & 0xBF | 0x80; ch >>= 6; 1160 s[1] = ch & 0xBF | 0x80; ch >>= 6; 1161 s[0] = ch | 0xE0; 1162 s += 3; 1163 } else if (ch < 0x200000) { 1164 s[3] = ch & 0xBF | 0x80; ch >>= 6; 1165 s[2] = ch & 0xBF | 0x80; ch >>= 6; 1166 s[1] = ch & 0xBF | 0x80; ch >>= 6; 1167 s[0] = ch | 0xF0; 1168 s += 4; 1169 } else if (ch < 0x4000000) { 1170 s[4] = ch & 0xBF | 0x80; ch >>= 6; 1171 s[3] = ch & 0xBF | 0x80; ch >>= 6; 1172 s[2] = ch & 0xBF | 0x80; ch >>= 6; 1173 s[1] = ch & 0xBF | 0x80; ch >>= 6; 1174 s[0] = ch | 0xF8; 1175 s += 5; 1176 } else { 1177 s[5] = ch & 0xBF | 0x80; ch >>= 6; 1178 s[4] = ch & 0xBF | 0x80; ch >>= 6; 1179 s[3] = ch & 0xBF | 0x80; ch >>= 6; 1180 s[2] = ch & 0xBF | 0x80; ch >>= 6; 1181 s[1] = ch & 0xBF | 0x80; ch >>= 6; 1182 s[0] = ch | 0xFC; 1183 s += 6; 1184 } 1185 1186 Dereference_(list); /* get the list tail */ 1187 if (IsRef(list->tag)) 1188 { 1189 TG = old_tg; 1190 Push_var_delay(vs.ptr, ts.all); 1191 Push_var_delay(list, list->tag.all); 1192 Bip_Error(PDELAY); 1193 } 1194 else if (IsList(list->tag)) 1195 list = list->val.ptr; 1196 else if (IsNil(list->tag)) 1197 break; /* end of the list */ 1198 else 1199 { 1200 TG = old_tg; 1201 Bip_Error(TYPE_ERROR); 1202 } 1203 } 1204 *s = '\0'; /* terminate the string */ 1205 Trim_Buffer(old_tg, s - (char *)(old_tg + 1) + 1); 1206 Kill_DE; 1207 Return_Unify_String(vs, ts, old_tg); 1208 } 1209 else if (IsNil(tl)) 1210 { 1211 Kill_DE; 1212 Return_Unify_String(vs, ts, empty_string); 1213 } 1214 else 1215 { 1216 Bip_Error(TYPE_ERROR); 1217 } 1218 } 1219 else if (IsString(ts)) 1220 { 1221 pword result; 1222 1223 Kill_DE; 1224 Check_Output_List(tl); 1225 s = StringStart(vs); /* get a pointer to the string */ 1226 len = StringLength(vs); 1227 /* Additional a-priori overflow check because adding to TG may 1228 * may wrap around the address space and break Check_Gc below 1229 */ 1230 Check_Available_Pwords(2*len); 1231 pw = TG; /* reserve space for the list */ 1232 TG += 2*len; 1233 Check_Gc; 1234 list = &result; 1235 while (len > 0) 1236 { 1237 int c, upper_shift; 1238 uint8 first = *s++; 1239 --len; 1240 1241 if (first < 0xc0) 1242 { 1243 c = first; 1244 } 1245 else 1246 { 1247 upper_shift = -1; 1248 c = 0; 1249 while ((first <<= 1) & 0x80) 1250 { 1251 upper_shift += 5; 1252 c = (c<<6) + (*s++ & 0x3F); 1253 --len; 1254 } 1255 c += first << upper_shift; 1256 } 1257 Make_List(list, pw); 1258 Make_Integer(pw, c); 1259 list = pw + 1; 1260 pw += 2; 1261 } 1262 if (len < 0) 1263 { 1264 TG = old_tg; 1265 Bip_Error(BAD_FORMAT_STRING); 1266 } 1267 Make_Nil(list); 1268 Return_Unify_Pw(vl, tl, result.val, result.tag); 1269 } 1270 else 1271 { 1272 Bip_Error(TYPE_ERROR); 1273 } 1274} 1275 1276 1277/* 1278 * get_string_code(+Index,+String,-Code) is det 1279 * - type and strict range check on +Index 1280 * - no checks on -Code 1281 */ 1282 1283static int 1284p_get_string_code(value vi, type ti, value vs, type ts, value vc, type tc) 1285{ 1286 word i = vi.nint; 1287 Check_Integer(ti); 1288 Check_String(ts); 1289 if (i > 0) 1290 { 1291 i -= 1; 1292 if (i >= StringLength(vs)) { Bip_Error(RANGE_ERROR); } 1293 } 1294#ifdef ALLOW_NEGATIVE_STRING_INDICES 1295 else if (i < 0) 1296 { 1297 i += StringLength(vs); 1298 if (i < 0) { Bip_Error(RANGE_ERROR); } 1299 } 1300#endif 1301 else { Bip_Error(RANGE_ERROR); } 1302 Return_Unify_Integer(vc, tc, ((unsigned char *)StringStart(vs))[i]); 1303} 1304 1305 1306/* 1307 * string_code(+Index, +String, -Code, 0) is det 1308 * string_code(-Index, +String, +Code, +RememberedStartIndex) is semidet 1309 * string_code(-Index, +String, -Code, +RememberedStartIndex) is semidet 1310 * - type and >=0 check on +Index 1311 * - type and >=0 check on +Code 1312 * string_code(+String, +Index, -Code, 0) is det BACKWARD COMPATIBILITY 1313 * - same type checks as get_string_code/3 1314 */ 1315 1316static int 1317p_string_code(value vi, type ti, value vs, type ts, value vc, type tc, value vfi, type tfi) 1318{ 1319 if (IsInteger(ti)) 1320 { 1321 word i = vi.nint; 1322 Cut_External; 1323 Check_String(ts); 1324 if (i < 1 || i > StringLength(vs)) 1325 { 1326 if (i < 0) { Bip_Error(RANGE_ERROR); } 1327 Fail_; 1328 } 1329 if (IsRef(tc)) 1330 { 1331 Return_Bind_Var(vc, tc, ((unsigned char *)StringStart(vs))[i-1], TINT); 1332 } 1333 else if (!IsInteger(tc)) 1334 { 1335 Bip_Error(TYPE_ERROR); 1336 } 1337 else if (vc.nint < 0) 1338 { 1339 Bip_Error(RANGE_ERROR); 1340 } 1341 Succeed_If(((unsigned char *)StringStart(vs))[i-1] == vc.nint); 1342 } 1343 if (IsRef(ti)) 1344 { 1345 word i; 1346 Check_String(ts); 1347 Check_Integer(tfi); 1348 i = vfi.nint; /* i==1, or the position of the next match */ 1349 if (IsRef(tc)) 1350 { 1351 /* string_code(-, +, -) is semidet */ 1352 Prepare_Requests; 1353 if (i >= StringLength(vs)) { 1354 Cut_External; 1355 if (i > StringLength(vs)) { Fail_; } 1356 } 1357 Request_Unify_Integer(vi, ti, i); 1358 Request_Unify_Integer(vc, tc, ((unsigned char *)StringStart(vs))[i-1]); 1359 vfi.nint = i+1; 1360 Remember(4, vfi, tfi); 1361 Return_Unify; 1362 } 1363 else if (!IsInteger(tc)) 1364 { 1365 Bip_Error(TYPE_ERROR); 1366 } 1367 else if (vc.nint < 0) 1368 { 1369 Bip_Error(RANGE_ERROR); 1370 } 1371 else 1372 { 1373 /* string_code(-, +, +) is semidet */ 1374 for(; i <= StringLength(vs); ++i) 1375 { 1376 word c = ((unsigned char *)StringStart(vs))[i-1]; 1377 if (c == vc.nint) 1378 { 1379 int j; 1380 for(j=i+1; ; ++j) 1381 { 1382 if (j > StringLength(vs)) 1383 { 1384 Cut_External; 1385 break; 1386 } 1387 if (((unsigned char *)StringStart(vs))[j-1] == vc.nint) 1388 { 1389 vfi.nint = j; 1390 Remember(4, vfi, tfi); 1391 break; 1392 } 1393 } 1394 Return_Unify_Integer(vi, ti, i); 1395 } 1396 } 1397 Cut_External; 1398 Fail_; 1399 } 1400 } 1401 if (IsString(ti)) 1402 { 1403 /* string_code(+String, +Index, -Code, 0) is det BACKWARD COMPATIBILITY */ 1404 word i = vs.nint-1; 1405 Cut_External; 1406 Check_Integer(ts); 1407 if (i < 0 || StringLength(vi) <= i) { Bip_Error(RANGE_ERROR); } 1408 Return_Unify_Integer(vc, tc, ((unsigned char *)StringStart(vi))[i]); 1409 } 1410 Check_Integer(ti); /* RANGE_ERROR/TYPE_ERROR/ARITH_TYPE_ERROR */ 1411} 1412 1413 1414static int 1415p_string_lower(value vs, type ts, value v, type t) 1416{ 1417 uword i; 1418 char *d; 1419 unsigned char *s; 1420 pword *res = TG; 1421 1422 Check_String(ts); 1423 i = StringLength(vs); 1424 s = StringStart(vs); 1425 Push_Buffer(i+1); 1426 d = (char*) BufferStart(res); 1427 do 1428 *d++ = tolower(*s++); 1429 while(i-- > 0); 1430 Return_Unify_String(v, t, res); 1431} 1432 1433 1434static int 1435p_string_upper(value vs, type ts, value v, type t) 1436{ 1437 uword i; 1438 char *d; 1439 unsigned char *s; 1440 pword *res = TG; 1441 1442 Check_String(ts); 1443 i = StringLength(vs); 1444 s = StringStart(vs); 1445 Push_Buffer(i+1); 1446 d = (char*) BufferStart(res); 1447 do 1448 *d++ = toupper(*s++); 1449 while(i-- > 0); 1450 Return_Unify_String(v, t, res); 1451} 1452 1453 1454/* 1455 * hash_secure(+String, -Hash, +Method) 1456 * 1457 * Computes a secure hash value for String. 1458 * The only method currently implemented is 'sha'. 1459 * The hash value is returned in Hash as a bignum. 1460 * 1461 * We use a free implementation by Jim Gillogly (sha.c) 1462 */ 1463 1464#undef A 1465#undef B 1466#undef E 1467#undef S 1468#ifdef WORDS_BIGENDIAN 1469#undef LITTLE_ENDIAN 1470#else 1471#ifndef LITTLE_ENDIAN 1472#define LITTLE_ENDIAN 1473#endif 1474#endif 1475#define ONT_WRAP 1476#define MEMORY_ONLY 1477#include "sha.c" 1478 1479static int 1480p_hash_secure(value v, type t, value vhash, type thash, value vmethod, type tmethod) 1481{ 1482 Check_Atom(tmethod); 1483 1484 if (vmethod.did == d_sha_) 1485 { 1486 pword result; 1487 uword hash[5]; 1488 1489 if (IsString(t)) 1490 { 1491 sha_memory(StringStart(v), StringLength(v), hash); 1492 } 1493 else 1494 { 1495 pword pw; 1496 value vstring; 1497 extern pword *term_to_dbformat(pword *, dident); 1498 1499 pw.val.all = v.all; 1500 pw.tag.all = t.all; 1501 vstring.ptr = term_to_dbformat(&pw, D_UNKNOWN); 1502 sha_memory(StringStart(vstring), StringLength(vstring), hash); 1503 } 1504 1505 ec_array_to_big((const void *) hash, 5, 1, sizeof(word), 1506#ifdef WORDS_BIGENDIAN 1507 1, 1508#else 1509 0, 1510#endif 1511#if (SIZEOF_WORD == 8) 1512 32, 1513#else 1514 0, 1515#endif 1516 &result); 1517 Return_Unify_Pw(vhash, thash, result.val, result.tag); 1518 } 1519 else 1520 { 1521 Bip_Error(RANGE_ERROR); 1522 } 1523} 1524 1525