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_tconv.c,v 1.10 2015/05/20 23:55:36 jschimpf Exp $ 25 */ 26 27/* 28 * IDENTIFICATION: bip_tconv.c 29 * 30 * DESCRIPTION: SEPIA Built-in Predicates: Type testing and conversion. 31 * 32 * CONTENTS: 33 * 34 * AUTHOR VERSION DATE REASON 35 * Micha Meier 0.0 880906 Created file. 36 * E.Falvey 0.1 890302 Added ICL standards, corrected 3 bugs. 37 * E.Falvey 0.2 890629 Rewrote "univ" in C. 38 */ 39 40#include "config.h" 41#include "sepia.h" 42#include "types.h" 43#include "embed.h" 44#include "mem.h" 45#include "error.h" 46#include "dict.h" 47#include "emu_export.h" 48#include "ec_io.h" 49#include "lex.h" 50#include "property.h" 51#include "module.h" 52 53#ifdef HAVE_STRING_H 54#include <string.h> 55#endif 56 57#ifdef HAVE_CTYPE_H 58#include <ctype.h> 59#endif 60 61static int p_atom_string(value va, type ta, value vs, type ts), 62 p_array_flat(value vdepth, type tdepth, value varr, type tarr, value vflat, type tflat), 63 p_is_array(value varr, type tarr), 64 p_dim(value va, type ta, value vdim, type tdim), 65 p_array_list(value varr, type tarr, value vl, type tl), 66 p_array_list3(value varr, type tarr, value vl, type tl, value ev, type et), 67 p_array_concat(value v1, type t1, value v2, type t2, value v, type t), 68 p_char_code(value v1, type t1, value v2, type t2), 69 p_functor(value vt, type t, value vf, type tf, value va, type ta), 70 p_integer_atom(value vn, type tn, value vs, type ts), 71 p_number_string(value vn, type tn, value vs, type ts, value vm, type tm), 72 p_term_hash(value vterm, type tterm, value vdepth, type tdepth, value vrange, type trange, value vhash, type thash), 73 p_canonical_copy(value v, type t, value vi, type ti), 74 p_setarg(value vn, type tn, value vt, type tt, value va, type ta), 75 p_type_of(value vterm, type term, value votype, type ttype), 76 p_get_var_type(value vvar, type tvar, value vvtype, type ttype), 77 p_get_var_name(value vvar, type tvar, value vname, type tname), 78 p_univ(value tv, type tt, value lv, type lt); 79 80/* 81 * FUNCTION NAME: bip_tconv_init() 82 * 83 * PARAMETERS: NONE. 84 * 85 * DESCRIPTION: links the 'C' functions in this file with SEPIA 86 * built-in predicates. 87 */ 88void 89bip_tconv_init(int flags) 90{ 91 if (flags & INIT_SHARED) 92 { 93 /* functor/3 is U_UNIFY because the bound argument is not known */ 94 built_in(in_dict("functor", 3), p_functor, B_UNSAFE|U_UNIFY|PROC_DEMON) 95 -> mode = BoundArg(1, NONVAR) | BoundArg(2, CONSTANT) | 96 BoundArg(3, CONSTANT); 97 built_in(in_dict("char_code", 2), p_char_code, B_UNSAFE|U_GROUND) 98 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 99 built_in(in_dict("atom_string", 2), p_atom_string, B_UNSAFE|U_GROUND) 100 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 101 built_in(in_dict("integer_atom", 2), p_integer_atom, B_UNSAFE|U_GROUND) 102 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 103 (void) built_in(in_dict("type_of", 2), p_type_of, B_UNSAFE|U_SIMPLE); 104 (void) local_built_in(in_dict("get_var_type", 2), 105 p_get_var_type, B_UNSAFE|U_SIMPLE); 106 (void) local_built_in(in_dict("get_var_name", 2), 107 p_get_var_name, B_UNSAFE|U_SIMPLE); 108 built_in(in_dict("=..", 2), p_univ, B_UNSAFE|U_UNIFY|PROC_DEMON) 109 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 110 (void) built_in(in_dict("array_flat", 3), p_array_flat, B_UNSAFE|U_UNIFY|PROC_DEMON); 111 (void) built_in(in_dict("array_list", 2), p_array_list, B_UNSAFE|U_UNIFY|PROC_DEMON); 112 (void) built_in(in_dict("array_list", 3), p_array_list3, B_UNSAFE|U_UNIFY|PROC_DEMON); 113 (void) built_in(in_dict("array_concat", 3), p_array_concat, B_UNSAFE|U_UNIFY|PROC_DEMON); 114 (void) built_in(in_dict("is_array", 1), p_is_array, B_SAFE); 115 (void) built_in(in_dict("dim", 2), p_dim, B_UNSAFE|U_UNIFY); 116 built_in(in_dict("number_string_",3), p_number_string, B_UNSAFE|U_GROUND) 117 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 118 119 (void) built_in(in_dict("term_hash", 4), p_term_hash, B_UNSAFE|U_SIMPLE); 120 (void) built_in(in_dict("canonical_copy", 2), p_canonical_copy, B_UNSAFE|U_GROUND); 121 (void) built_in(in_dict("setarg", 3), p_setarg, B_UNSAFE); 122 } 123} 124 125/* 126 * FUNCTION NAME: p_functor(vt, t, vf, tf, va, ta) - logical 127 * 128 * PARAMETERS: vt - term1->val 129 * t - term1->tag, where term1 is the compound term 130 * or list passed. 131 * term1 must be a compound term or a list or a variable. 132 * 133 * vf - functor1->val 134 * tf - functor1->tag, where functor1 is the functor passed. 135 * functor1 must be a functor (incl. an atom) or a variable. 136 * 137 * va - arity1->val 138 * ta - arity1->tag, where arity1 is the arity passed. 139 * arity1 must be an integer or a variable. 140 * 141 * DESCRIPTION: Used to instantiate variable(s) to either the functor 142 * and / or the arity of the compound term term1. In this 143 * case, term1 is instantiated to a compound term (i.e. a 144 * structure or a list) and either functor1 is not instant- 145 * iated (to an atom) or arity1 is not instantiated (to an 146 * integer) (or neither). 147 * 148 * Also used to test that functor1 is the functor and 149 * arity1 is the arity of the compound term term1. In this 150 * case, all arguments of functor/3 are instantiated. 151 * 152 * Also used to build the compound term term1 from the 153 * functor functor1 and the arity arity1. In this case, 154 * term1 is a variable, functor1 is an atom and arity1 is 155 * an integer. 156 * 157 * Also used to instantiate the variable functor1 to the 158 * atomic term1 (or vice versa). In this case, arity1 is 0. 159 */ 160static int 161p_functor(value vt, type t, value vf, type tf, value va, type ta) 162{ 163 int i; 164 register word arity; 165 pword *p; 166 167 if (IsRef(t)) 168 { 169 /* 170 * Case of: term1 uninstantiated. 171 * Thus functor1 must be instantiated to an atomic, 172 * arity1 must be instantiated to an integer. 173 */ 174 175 if (IsRef(ta)) 176 { 177 if (IsCompound(tf)) 178 { 179 Bip_Error(TYPE_ERROR) 180 } 181 Bip_Error(PDELAY_1_3) 182 } 183 else if (!IsInteger(ta)) 184 { 185 if (IsBignum(ta)) { Bip_Error(RANGE_ERROR) }; 186 Bip_Error(TYPE_ERROR) 187 } 188 else 189 { 190 /* arity must be a positive integer */ 191 if ((arity = va.nint) < 0) 192 { 193 Bip_Error(RANGE_ERROR); 194 } 195 if (IsRef(tf)) 196 { 197 Bip_Error(PDELAY_1_2); 198 } 199 } 200 201 /* if arity = 0, term1 is unified with (atomic) functor1. */ 202 if (arity == 0) 203 { 204 if (IsCompound(tf)) 205 { 206 Bip_Error(TYPE_ERROR) 207 } 208 Kill_DE; 209 Return_Bind_Var(vt, t, vf.all, tf.kernel); 210 } 211 Kill_DE; 212 213 if (!IsAtom(tf) && !IsNil(tf)) 214 { 215 Bip_Error(TYPE_ERROR) 216 } 217 218 if (vf.did == d_.eocl && arity == 2) /* a list functor */ 219 { 220 /* 221 * This is for the case of a list functor: functor1 is 222 * '.', and arity1 is 2. This is a special case; 223 * functor1 = '.' and arity1 != 2 is treated normally. 224 */ 225 p = Gbl_Tg; 226 Gbl_Tg += 2; 227 Check_Gc; 228 Bind_Var(vt, t, p, TLIST); 229 } 230 else 231 { 232 /* 233 * this is for the case of a structure defined by 234 * functor1 and arity1. Thus, term1's arguments are 235 * variables. 236 */ 237 238 register dident d; 239 240 p = Gbl_Tg; 241 /* Additional a-priori overflow check because adding arity to TG 242 * may may wrap around the address space and break Check_Gc below 243 */ 244 Check_Available_Pwords(arity+1); 245 Gbl_Tg += arity + 1; 246 Check_Gc; 247 248 /* create the structure functor */ 249 if (IsNil(tf)) 250 d = d_.nil; 251 else 252 d = vf.did; 253 Add_Dict(d, (int) arity); 254 Bind_Var(vt, t, p, TCOMP); 255 p->val.did = (dident) d; 256 (p++)->tag.kernel = TDICT; 257 } 258 for (i = 0; i < arity; i++) 259 { 260 p->val.ptr = p; 261 (p++)->tag.kernel = TREF; 262 } 263 Succeed_; 264 } 265 266 /* Case of: term1 instantiated. */ 267 268 Kill_DE; 269 if (IsRef(tf) && IsRef(ta) && vf.ptr == va.ptr) 270 { 271 /* catch functor(Term,F,F) - only call BindVar once! */ 272 if (!(IsInteger(t) && vt.nint == 0)) 273 { 274 Fail_; 275 } 276 Bind_Var(va, ta, 0, TINT); 277 Succeed_; 278 } 279 280 if (IsStructure(t)) 281 { 282 /* 283 * term1 is a compound term. Its value, accessed by 284 * vt.ptr, points to the functor1 (which is accessed by 285 * val.did), followed by (next addresses) the arguments, 286 * though the latter are not required. 287 * Thus, one can get the functor1, then use DidArity 288 * to get the arity1. 289 * 290 * Since term1 is instantiated, functor1's DID is 291 * in the dictionary, so DidArity and DidName work. 292 */ 293 294 register dident d; 295 296 d = vt.ptr->val.did; 297 arity = DidArity(d); 298 Add_Dict(d, 0); 299 if (IsRef(tf)) 300 { 301 Bind_Var(vf, tf, d, (d == d_.nil ? TNIL : TDICT)); 302 } 303 else if (!(d == d_.nil ? IsNil(tf) : IsAtom(tf) && vf.did == d)) 304 { 305 Fail_; 306 } 307 } 308 else if (IsList(t)) 309 { 310 /* 311 * This is the case where term1 is the functor list. 312 * Thus, functor is '.' and arity is 2. 313 */ 314 arity = 2; 315 if (IsRef(tf)) 316 { 317 Bind_Var(vf, tf, d_.eocl, TDICT); 318 } 319 else if (!IsAtom(tf) || vf.did != d_.eocl) 320 { 321 Fail_; 322 } 323 } 324 else 325 { 326 int res = Unify_Pw(vf, tf, vt, t); 327 Return_If_Not_Success(res); 328 arity = 0; 329 } 330 331 /* arity1 must be a variable or a positive integer */ 332 if (!IsRef(ta)) 333 { 334 if (!IsInteger(ta) || va.nint != arity) 335 { 336 Fail_; 337 } 338 } 339 else 340 { 341 Bind_Var(va, ta, arity, TINT); 342 } 343 Succeed_; 344} 345 346 347/* 348 * FUNCTION NAME: p_type_of(vterm, term, votype,ttype) - logical 349 * 350 * PARAMETERS: vterm - term1->val 351 * term - term1->tag, where term1 is the expression 352 * whose type is to be evaluated / tested. 353 * term1 can be of any type. 354 * 355 * votype - type1->val 356 * ttype - type1->tag, where type1 is one of the atoms 357 * in the set {atom, var, integer, string, real, 358 * compound}. 359 * 360 * DESCRIPTION: Used to find the data type of an expression. In this 361 * case, Expression is instantiated and Type is a variable. 362 * 363 * Also used to test whether Type is the data type of 364 * Expression. In this case, Expression is instantiated 365 * and Type is an atom that is in the above set. 366 */ 367/*ARGSUSED*/ 368static int 369p_type_of(value vterm, type term, value votype, type ttype) 370{ 371 dident dtype; 372 373 /* atom1 should be an atom or a variable. */ 374 375 Check_Output_Atom_Or_Nil(votype, ttype); 376 377 if (IsRef(term)) 378 { 379 dtype = d_.var0; 380 } 381 else if (TagType(term) >= 0 && TagType(term) <= NTYPES) 382 { 383 dtype = tag_desc[tag_desc[TagType(term)].super].type_name; 384 } 385 else 386 { Bip_Error(UNIFY_OVNI); } 387 388 /* unify (the assigned) dtype with the passed argument type1. */ 389 390 Return_Unify_Atom(votype, ttype, dtype); 391} 392 393 394/* 395 * FUNCTION NAME: p_atom_string(va, ta, vs, ts) - logical 396 * 397 * PARAMETERS: va - atom1->val 398 * ta - atom1->tag, where atom1 is the atom corresponding 399 * to the string string1. 400 * atom1 must be an atom or a variable. 401 * 402 * vs - string1->val 403 * ts - string1->tag, where string1 is the string 404 * corresponding to the atom atom1. 405 * string1 must be a string or a variable. 406 * 407 * DESCRIPTION: Used to convert an atom to its string form. In this 408 * case, atom1 is an atom and string1 is a variable. 409 * 410 * Also used to convert a string to its string form. In 411 * this case, aom1 is a variable and string1 is a string. 412 * 413 * Also used to check whether string1 is the string form 414 * of atom1. In this case, atom1 is an atom and string1 is 415 * a string. 416 */ 417static int 418p_atom_string(value va, type ta, value vs, type ts) 419{ 420 if (IsRef(ts)) 421 { 422 if (IsRef(ta)) 423 { 424 Bip_Error(PDELAY_1_2); 425 } 426 Check_Output_Atom_Or_Nil(va, ta); 427 Return_Unify_String(vs, ts, DidString(va.did)); 428 } 429 else if IsString(ts) 430 { 431 if (IsRef(ta)) 432 { 433 /* 434 * if only string1 is instantiated, unify its DID 435 * with atom1. 436 */ 437 dident wdid = enter_dict_n(StringStart(vs), 438 StringLength(vs), 0); 439 if (wdid == d_.nil) /* necessary !!! */ 440 { 441 Return_Unify_Nil(va, ta); 442 } 443 else 444 { 445 Return_Unify_Atom(va, ta, wdid); 446 } 447 } 448 else if (IsAtom(ta)) 449 { 450 /* both arguments are instantiated. */ 451 452 value v1; 453 v1.ptr = DidString(va.did); 454 Succeed_If(!compare_strings(vs, v1)); 455 } 456 else if (IsNil(ta)) 457 { 458 /* as before, IsAtom([]) fails, so deal with it now. */ 459 460 Succeed_If(!strcmp(StringStart(vs), DidName(d_.nil))) 461 } 462 } 463 464 /* any other types => type error. */ 465 466 Bip_Error(TYPE_ERROR); 467} 468 469 470/* 471 * FUNCTION NAME: p_integer_atom(vn, tn, vs, ts) 472 * 473 * PARAMETERS: vn, tn variable or integer 474 * vs, ts variable or atom 475 * 476 * DESCRIPTION: Used to convert integer to string and vice versa. 477 * Fails if this is not possible. 478 * Mainly for backward compatibility, superseded 479 * now by number_string/2. 480 */ 481 482static int 483p_integer_atom(value vn, type tn, value vs, type ts) 484{ 485 pword result; 486 487 if (IsRef(ts)) 488 { 489 if (IsRef(tn)) 490 { Bip_Error(PDELAY_1_2); } 491 else /* integer to atom */ 492 { 493 char *s; 494 dident wdid; 495 pword *old_tg = TG; 496 497 if (IsInteger(tn) || IsBignum(tn)) 498 { 499 int len = tag_desc[TagType(tn)].string_size(vn, tn, 1); 500 Make_Stack_String(len, result.val, s); /* maybe too long */ 501 len = tag_desc[TagType(tn)].to_string(vn, tn, s, 1); 502 wdid = enter_dict_n(s, len, 0); 503 } 504 else 505 { Bip_Error(TYPE_ERROR); } 506 507 TG = old_tg; /* pop the temporary string */ 508 Return_Unify_Atom(vs, ts, wdid); 509 } 510 } 511 else if (IsRef(tn) || IsInteger(tn) || IsBignum(tn)) 512 { 513 Check_Atom_Or_Nil(vs, ts); /* atom to integer */ 514 if (string_to_number(DidName(vs.did), &result, (stream_id) 0, 0) == 515 DidName(vs.did) + DidLength(vs.did) 516 && (IsInteger(result.tag) || IsBignum(result.tag))) 517 { 518 Return_Unify_Pw(vn, tn, result.val, result.tag); 519 } 520 else { Fail_; } 521 } 522 else { Bip_Error(TYPE_ERROR); } 523} 524 525 526 527/* 528 * FUNCTION NAME: p_number_string(vn, tn, vs, ts) 529 * 530 * PARAMETERS: vn, tn variable or number 531 * vs, ts variable or string 532 * 533 * DESCRIPTION: Used to convert a string to an integer or real, 534 * and vice versa. Fails if this is not possible. 535 */ 536 537static int 538p_number_string(value vn, type tn, value vs, type ts, value vm, type tm) 539{ 540 pword result; 541 542 if (IsRef(ts)) 543 if (IsRef(tn)) 544 { Bip_Error(PDELAY_1_2); } 545 else if (!IsNumber(tn)) 546 { Bip_Error(TYPE_ERROR); } 547 else /* number to string */ 548 { 549 char *s; 550 int len = tag_desc[TagType(tn)].string_size(vn, tn, 1); 551 Make_Stack_String(len, result.val, s); /* maybe too long */ 552 len = tag_desc[TagType(tn)].to_string(vn, tn, s, 1); 553 Trim_Buffer(result.val.ptr, len+1); /* adjust length */ 554 Return_Unify_String(vs, ts, result.val.ptr); 555 } 556 else if (IsString(ts) /* string to number */ 557 && (IsRef(tn) || IsNumber(tn))) 558 { 559 Check_Module_And_Access(vm, tm); 560 if (string_to_number(StringStart(vs), &result, (stream_id) 0, ModuleSyntax(vm.did)) == 561 StringStart(vs) + StringLength(vs) 562 && !IsTag(result.tag.kernel, TEND)) 563 { 564 Return_Unify_Pw(vn, tn, result.val, result.tag); 565 } 566 else { Fail_; } 567 } 568 else { Bip_Error(TYPE_ERROR); } 569} 570 571 572/* 573 * FUNCTION NAME: p_char_code(tv, tt, lv, lt) - logical 574 * 575 */ 576 577static int 578p_char_code(value v1, type t1, value v2, type t2) 579{ 580 int len; 581 char *s; 582 583 if (IsRef(t1)) { 584 if (IsRef(t2)) { /* char_code(-,-) */ 585 Bip_Error(PDELAY_1_2); 586 } else if (IsInteger(t2)) { /* char_code(-Char, +Code) */ 587 char buf[2]; 588 if (v2.nint < 0 || v2.nint > 255) { 589 Bip_Error(RANGE_ERROR); 590 } 591 buf[0] = (char) v2.nint; 592 buf[1] = 0; 593 Return_Unify_Atom(v1, t1, enter_dict_n(buf,1,0)); 594 } else { 595 Bip_Error(TYPE_ERROR); 596 } 597 } else { /* char_code(+Char, ?Code) */ 598 if (IsAtom(t1)) { 599 len = DidLength(v1.did); 600 s = DidName(v1.did); 601 } else if (IsString(t1)) { 602 len = StringLength(v1); 603 s = StringStart(v1); 604 } else { 605 Bip_Error(TYPE_ERROR) 606 } 607 if (len != 1) { 608 Bip_Error(TYPE_ERROR) 609 } 610 if (IsRef(t2)) { 611 } else if (IsInteger(t2)) { 612 if (v2.nint < 0 || v2.nint > 255) { 613 Bip_Error(RANGE_ERROR); 614 } 615 } else { 616 Bip_Error(TYPE_ERROR) 617 } 618 Return_Unify_Integer(v2, t2, *(unsigned char *)s); 619 } 620} 621 622/* 623 * FUNCTION NAME: p_univ(tv, tt, lv, lt) - logical 624 * 625 * PARAMETERS: tv - Term->val 626 * tt - Term->tag, where Term is the term passed 627 * lv - List->val 628 * lt - List->tag, where List is the list passed. 629 * 630 * DESCRIPTION: Pronounced "univ". 631 * 632 * If Term is atomic and/or List is a single-element list, unifies this 633 * element with Term. 634 * 635 * Otherwise, either Term is instantiated to a compound term, or List 636 * is instantiated to a list, or both. In which case, "univ" unifies Term 637 * with functor(Arg1, Arg2, ..., ArgN), and List with 638 * [Functor', Arg1', Arg2', .., argN'], where functor is unified with 639 * Functor', Arg1 is unified with Arg1', etc. 640 * functor must be an atom, and it must be possible to determine the length 641 * of List from either Term or List. 642 * 643 * NOTE: The structure arguments are simply copied to the list elements 644 * and vice versa. We assume that it is always possible to copy 645 * a pword from the global stack to the global stack if it occurs inside 646 * a compound term (ie no nonstandard variables/mutable objects inside) 647 */ 648 649 650static int 651p_univ(value tv, type tt, value lv, type lt) 652{ 653 word arity, i; 654 pword *tail, *head, *newel, *tvptr, *elem; 655 dident fd; 656 657 tvptr = tv.ptr; 658 659 if (IsRef(tt)) 660 { 661 /* case of: converting List to Term. */ 662 663 if (IsRef(lt)) { Bip_Error(PDELAY_1_2); } 664 Check_Output_Pair(lt); 665 666 elem = lv.ptr; 667 tail = elem + 1; 668 Dereference_(tail) 669 if (IsRef(tail->tag)) 670 { 671 /* partial list -> error 4. */ 672 Push_var_delay(tv.ptr, tt.all); 673 Push_var_delay(tail, tail->tag.all); 674 Bip_Error(PDELAY) 675 } 676 else if (IsList(tail->tag)) 677 { 678 /* converting List to Compound Term. */ 679 680 Dereference_(elem) 681 if (IsRef(elem->tag)) 682 { 683 /* no functor given */ 684 Push_var_delay(tv.ptr, tt.all); 685 Push_var_delay(elem, elem->tag.all); 686 Bip_Error(PDELAY) 687 } 688 Check_Output_Atom_Or_Nil(elem->val,elem->tag); 689 690 fd = elem->val.did; 691 692 head = Gbl_Tg++; 693 head->val.did = fd; 694 head->tag.kernel = TDICT; 695 696 for (i = 0; IsList(tail->tag); i++) 697 { 698 elem = tail->val.ptr; 699 head = Gbl_Tg++; 700 Check_Gc; 701 *head = *elem; 702 tail = elem + 1; 703 Dereference_(tail) 704 } 705 706 if (IsRef(tail->tag)) 707 { 708 /* partial list -> error 4. */ 709 Gbl_Tg = head - i; 710 Push_var_delay(tv.ptr, tt.all); 711 Push_var_delay(tail, tail->tag.all); 712 Bip_Error(PDELAY) 713 } 714 else if (!IsNil(tail->tag)) 715 { 716 /* bad list -> error 5. */ 717 Gbl_Tg = head - i; 718 Bip_Error(TYPE_ERROR) 719 } 720 721 /* go back to write functor with now known arity i. */ 722 723 Kill_DE; 724 if (fd == d_.eocl && i == 2) 725 { 726 head--; /* ignore the functor */ 727 Return_Unify_List(tv, tt, head); 728 } 729 else 730 { 731 head -= i; 732 head->val.did = add_dict(fd, (int) i); 733 Return_Unify_Structure(tv, tt, head); 734 } 735 } 736 else if (IsNil(tail->tag)) 737 { 738 /* single element list */ 739 Dereference_(elem) 740 if (IsRef(elem->tag)) 741 { 742 Push_var_delay(tv.ptr, tt.all); 743 Push_var_delay(elem, elem->tag.all); 744 Bip_Error(PDELAY) 745 } 746 Kill_DE; 747 if (!IsCompound(elem->tag)) 748 { 749 Return_Unify_Pw(tv, tt, elem->val, elem->tag); 750 } 751 else 752 { 753 Bip_Error(TYPE_ERROR); 754 } 755 } 756 else 757 { 758 /* bad list -> error 5. */ 759 Bip_Error(TYPE_ERROR) 760 } 761 } 762 763 /** case of: converting Term to List. **/ 764 765 else if (IsCompound(tt)) 766 { 767 /* converting Compound Term to List. */ 768 769 Kill_DE; 770 if (!IsRef(lt) && !IsList(lt)) 771 { 772 Bip_Error(TYPE_ERROR); 773 } 774 775 newel = Gbl_Tg; 776 Gbl_Tg += 2; 777 778 if (IsList(tt)) 779 { 780 arity = 2; 781 newel->tag.kernel = TDICT; 782 (newel++)->val.did = d_.eocl; 783 tvptr--; 784 } 785 else 786 { 787 arity = DidArity(tvptr->val.did); 788 fd = add_dict(tvptr->val.did, 0); 789 if (fd == d_.nil) 790 (newel++)->tag.kernel = TNIL; 791 else 792 { 793 newel->tag.kernel = TDICT; 794 (newel++)->val.did = fd; 795 } 796 } 797 798 /* Additional a-priori overflow check because adding arity to TG 799 * may may wrap around the address space and break Check_Gc below 800 */ 801 Check_Available_Pwords(2*arity); 802 Gbl_Tg += 2*arity; 803 Check_Gc 804 for (i = 0; i < arity; i++) 805 { 806 newel->val.ptr = newel + 1; 807 (newel++)->tag.kernel = TLIST; 808 *newel++ = *(++tvptr); 809 } 810 newel->tag.kernel = TNIL; 811 812 newel -= (2*arity + 1); 813 814 Return_Unify_List(lv, lt, newel); 815 } 816 else 817 { 818 /* the rare case of atomic term -> 1-element list. */ 819 820 Kill_DE; 821 if (!IsRef(lt) && !IsList(lt)) 822 { 823 Bip_Error(TYPE_ERROR); 824 } 825 826 newel = Gbl_Tg; 827 Gbl_Tg += 2; 828 newel->val = tv; 829 (newel++)->tag = tt; 830 (newel--)->tag.kernel = TNIL; 831 Check_Gc 832 Return_Unify_List(lv, lt, newel); 833 } 834} 835 836 837pword * 838ec_chase_arg(value vn, type tn, value vt, type tt, int *perr) 839{ 840 pword *pw1; 841 word argi, arity; 842 if (IsInteger(tn)) 843 { 844 argi = vn.nint; 845 if (IsStructure(tt)) 846 { 847 pw1 = vt.ptr; 848 arity = DidArity(pw1->val.did); 849 } 850 else if IsList(tt) 851 { 852 pw1 = vt.ptr-1; 853 arity = 2; 854 } 855 else 856 { 857 *perr = IsRef(tt) ? INSTANTIATION_FAULT : TYPE_ERROR; 858 return 0; 859 } 860 if (argi < 1 || argi > arity) 861 { 862 *perr = RANGE_ERROR; 863 return 0; 864 } 865 return pw1 + argi; /* not dereferenced! (for setarg) */ 866 } 867 else if (IsList(tn)) 868 { 869 pword *plist = vn.ptr; 870 for(;;) 871 { 872 pword *car = plist++; 873 Dereference_(car); 874 if (IsInteger(car->tag)) /* list element must be integer */ 875 { 876 argi = car->val.nint; 877 if (IsStructure(tt)) 878 { 879 pw1 = vt.ptr; 880 arity = DidArity(pw1->val.did); 881 } 882 else if IsList(tt) 883 { 884 pw1 = vt.ptr-1; 885 arity = 2; 886 } 887 else 888 { 889 *perr = IsRef(tt) ? INSTANTIATION_FAULT : TYPE_ERROR; 890 return 0; 891 } 892 if (argi < 1 || argi > arity) 893 { 894 *perr = RANGE_ERROR; 895 return 0; 896 } 897 pw1 += argi; /* get argument */ 898 Dereference_(plist); 899 if (IsNil(plist->tag)) 900 { 901 return pw1; /* not dereferenced! (for setarg) */ 902 } 903 else if (!IsList(plist->tag)) 904 { 905 *perr = IsRef(plist->tag) ? INSTANTIATION_FAULT : TYPE_ERROR; 906 return 0; 907 } 908 plist = plist->val.ptr; 909 Dereference_(pw1); 910 vt.all = pw1->val.all; 911 tt.all = pw1->tag.all; 912 } 913 else 914 { 915 *perr = IsRef(car->tag) ? INSTANTIATION_FAULT : 916 IsBignum(car->tag) ? RANGE_ERROR : 917 tag_desc[TagType(car->tag)].numeric ? TYPE_ERROR : 918 ARITH_TYPE_ERROR; 919 return 0; 920 } 921 } 922 } 923 else 924 { 925 *perr = IsRef(tn) ? INSTANTIATION_FAULT : 926 IsBignum(tn) ? RANGE_ERROR : 927 TYPE_ERROR; 928 return 0; 929 } 930} 931 932 933 934/* 935 * FUNCTION NAME: p_setarg(vn, tn, vt, tt, va, ta) 936 * 937 * PARAMETERS: setarg(+N, +Term, ?NewArg) 938 * 939 * DESCRIPTION: Destructively replaces the Nth argument of Term. 940 * This is undone on backtracking. 941 */ 942 943static int 944p_setarg(value vn, type tn, value vt, type tt, value va, type ta) 945{ 946 pword *argp; 947 word arity; 948 int err; 949 950 if (IsInteger(tn)) 951 { 952 if (IsRef(tt)) 953 { 954 Bip_Error(INSTANTIATION_FAULT) 955 } 956 else if (IsStructure(tt)) 957 { 958 argp = vt.ptr; 959 arity = DidArity(argp->val.did); 960 } 961 else if (IsList(tt)) 962 { 963 argp = vt.ptr - 1; 964 arity = 2; 965 } 966 else if (SameTypeC(tt, THANDLE)) 967 { 968 pword pw; 969 pw.val = va; 970 pw.tag = ta; 971 Check_Type(vt.ptr->tag, TEXTERN); 972 if (!ExternalData(vt.ptr)) 973 { Bip_Error(STALE_HANDLE); } 974 if (!ExternalClass(vt.ptr)->set) 975 { Bip_Error(UNIMPLEMENTED); } 976 return ExternalClass(vt.ptr)->set(ExternalData(vt.ptr), vn.nint, pw); 977 } 978 else 979 { 980 Bip_Error(TYPE_ERROR) /* no compound term */ 981 } 982 if (vn.nint < 1 || vn.nint > arity) 983 { 984 Bip_Error(RANGE_ERROR); 985 } 986 argp += vn.nint; 987 } 988 else /* deal with IsList(tn) and errors */ 989 { 990 argp = ec_chase_arg(vn, tn, vt, tt, &err); 991 if (!argp) 992 { 993 Bip_Error(err); 994 } 995 } 996#if 0 997 /* this is a sensible restriction, but not imposed for compatibility */ 998 if (IsRef(argp->tag) && argp == argp->val.ptr) 999 { 1000 Bip_Error(INSTANTIATION_FAULT); /* trying to destroy a variable! */ 1001 } 1002#endif 1003 if (argp < TG_ORIG || TG <= argp) 1004 { 1005 Bip_Error(GROUND_CONST_MODIFY); /* trying to modify a heap term! */ 1006 } 1007 return ec_assign(argp, va, ta); /* succeeds */ 1008} 1009 1010 1011/* 1012 * term_hash(+Term, +Depth, +Range, -Hash) 1013 * 1014 * Hash is not instantiated when the Term is not sufficiently 1015 * instantiated (ie. up to Depth) 1016 */ 1017 1018/* compute hash value of a string of given length */ 1019#if 0 1020#define Hashl(id, hash, n) { \ 1021 register char *str = (id); \ 1022 register int length = (n); \ 1023 for (hash = 0; length > 0; str++, --length) \ 1024 hash += (hash<<3) + *(unsigned char *)str; \ 1025} 1026 1027#else 1028 1029/* 1030 * This hash function is the same as the simple one above as long as 1031 * the string is shorter than MAX_SAMPLED_CHARS. If it is longer, we 1032 * look only at every incr'th character, where incr is chosen such 1033 * that we look at no more than MAX_SAMPLED_CHARS characters to compute 1034 * the hash value. The code is a bit tricky because we want to make sure 1035 * that we always consider the last character. We achieve that by making 1036 * one possibly smaller step (< incr) in the middle of the string. 1037 */ 1038 1039#define MAX_SAMPLED_CHARS 32 1040#define Hashl(id, hash, n) { \ 1041 unsigned char *str = (unsigned char *) (id); \ 1042 int incr = 1 + (n)/MAX_SAMPLED_CHARS; \ 1043 int _i, _j; \ 1044 hash = 0; \ 1045 for (_i= 0, _j=(n)-1; _i < _j; _i+=incr, _j-=incr) \ 1046 hash += (hash<<3) + str[_i]; \ 1047 if (_j < _i) _j+=incr; \ 1048 for (; _j < (n); _j+=incr) \ 1049 hash += (hash<<3) + str[_j]; \ 1050} 1051#endif 1052 1053static uword 1054_term_hash(value vterm, 1055 type tterm, 1056 uword maxdepth, /* > 0 */ 1057 uword hash, 1058 int *pres) 1059{ 1060 uword h; 1061 int arity; 1062 dident d; 1063 pword *arg_i; 1064 1065 for(;;) /* tail recursion loop */ 1066 { 1067 switch(TagType(tterm)) 1068 { 1069 case TVAR_TAG: 1070 case TNAME: 1071 case TMETA: 1072 case TUNIV: 1073 *pres = INSTANTIATION_FAULT; 1074 return hash; 1075 1076 case TINT: 1077 return hash+vterm.nint; 1078 1079 case TDBL: 1080#ifdef UNBOXED_DOUBLES 1081 Hashl((char*) &vterm.all, h, SIZEOF_DOUBLE); 1082#else 1083 Hashl(StringStart(vterm), h, SIZEOF_DOUBLE); 1084#endif 1085 return hash+h; 1086 1087 case TSTRG: 1088 Hashl(StringStart(vterm), h, StringLength(vterm)); 1089 return hash+h; 1090 1091 case TDICT: 1092 Hashl(DidName(vterm.did), h, DidLength(vterm.did)); 1093 return hash+h; 1094 1095 case TCOMP: 1096 d = (vterm.ptr++)->val.did; 1097 Hashl(DidName(d), h, DidLength(d)); 1098 arity = DidArity(d); 1099 break; 1100 1101 case TLIST: 1102 h = 0; 1103 arity = 2; 1104 break; 1105 1106 default: 1107 if (ISPointer(tterm.kernel) && IsTag(vterm.ptr->tag.kernel, TBUFFER)) 1108 { 1109 Hashl(StringStart(vterm), h, StringLength(vterm)+1); 1110 return hash+h; 1111 } 1112 return hash; 1113 } 1114 1115 if (--maxdepth == 0) 1116 return hash+h; 1117 1118 for(;arity > 1; arity--) 1119 { 1120 pword *pvar; 1121 arg_i = vterm.ptr++; 1122 Dereference_(arg_i); 1123 h = _term_hash(arg_i->val, arg_i->tag, maxdepth, h+(h<<3), pres); 1124 } 1125 /* last argument */ 1126 arg_i = vterm.ptr; 1127 Dereference_(arg_i); 1128 vterm = arg_i->val; /* tail recursion optimised */ 1129 tterm = arg_i->tag; 1130 hash += h + (h<<3); 1131 } 1132} 1133 1134uword 1135ec_term_hash(value vterm, 1136 type tterm, 1137 uword maxdepth, /* > 0 */ 1138 int *pres) 1139{ 1140 return _term_hash(vterm, tterm, maxdepth, 0, pres); 1141} 1142 1143 1144static int 1145p_term_hash(value vterm, type tterm, value vdepth, type tdepth, value vrange, type trange, value vhash, type thash) 1146{ 1147 uword h; 1148 int res = PSUCCEED; 1149 1150 Check_Integer(tdepth); 1151 Check_Integer(trange); 1152 if (vrange.nint <= 0) { Bip_Error(RANGE_ERROR); } 1153 if (vdepth.nint < -1) { Bip_Error(RANGE_ERROR); } 1154 1155 h = vdepth.nint ? ec_term_hash(vterm, tterm, (uword)vdepth.nint, &res) : 0; 1156 if (res == INSTANTIATION_FAULT) 1157 { 1158 Succeed_; /* don't bind the hash value if variable */ 1159 } 1160 h = (h % vrange.nint); 1161 Return_Unify_Integer(vhash, thash, h); 1162} 1163 1164 1165static int 1166p_canonical_copy(value v, type t, value vi, type ti) 1167{ 1168 pword pw; 1169 int res = ec_constant_table_enter(v, t, &pw); 1170 if (res != PSUCCEED) 1171 return res; 1172 Return_Unify_Pw(vi, ti, pw.val, pw.tag); 1173} 1174 1175 1176/*----------------------------------------------------------------------* 1177 * Arrays 1178 *----------------------------------------------------------------------*/ 1179 1180static int 1181p_is_array(value v, type t) 1182{ 1183 Succeed_If(IsArray(v, t) || IsNil(t)); 1184} 1185 1186 1187/* 1188 * Auxiliary for dim(-Array, +Dimensions) 1189 * returns PFAIL if the dimensions contain a zero 1190 * dims is a TLIST.ptr 1191 */ 1192 1193static int 1194_make_dim(pword *dims, pword *result) 1195{ 1196 int res; 1197 word arity, i; 1198 pword *pw = TG; 1199 1200 pword *elem = dims++; 1201 Dereference_(elem); 1202 Check_Integer(elem->tag); 1203 arity = elem->val.nint; 1204 if (arity <= 0) { 1205 if (arity == 0) return PFAIL; 1206 Bip_Error(RANGE_ERROR); 1207 } 1208 Make_Struct(result, pw); 1209 /* Additional a-priori overflow check because adding arity to TG 1210 * may may wrap around the address space and break Check_Gc below 1211 */ 1212 Check_Available_Pwords(arity+1); 1213 TG += arity+1; 1214 Check_Gc; 1215 pw->val.did = add_dict(d_.nil, (int) arity); 1216 pw++->tag.kernel = TDICT; 1217 1218 Dereference_(dims); 1219 if (IsNil(dims->tag)) { 1220 for (i = 0; i < arity; i++,pw++) { 1221 Make_Var(pw) 1222 } 1223 } else if (IsList(dims->tag)) { 1224 for (i = 0; i < arity; i++) { 1225 res = _make_dim(dims->val.ptr, pw++); 1226 Return_If_Not_Success(res); 1227 } 1228 } else { 1229 Error_If_Ref(dims->tag); 1230 Bip_Error(TYPE_ERROR); 1231 } 1232 Succeed_; 1233} 1234 1235static int 1236p_dim(value va, type ta, value vdim, type tdim) 1237{ 1238 int res; 1239 pword result; 1240 pword *pw; 1241 1242 /* 1243 * dim(-Array, +Dimensions) 1244 */ 1245 if (IsRef(ta)) { 1246 if (IsList(tdim)) 1247 { 1248 pword *old_tg = TG; 1249 res = _make_dim(vdim.ptr, &result); 1250 if (res == PSUCCEED) { 1251 Return_Unify_Pw(va, ta, result.val, result.tag); 1252 } 1253 TG = old_tg; /* pop any partially constructed array */ 1254 if (res == PFAIL) { 1255 Return_Unify_Nil(va, ta); 1256 } 1257 return res; 1258 } 1259 if (IsNil(tdim)) { 1260 Bip_Error(RANGE_ERROR); 1261 } 1262 Error_If_Ref(tdim); 1263 Bip_Error(TYPE_ERROR); 1264 } 1265 1266 /* 1267 * dim(+Array, -Dimensions) 1268 */ 1269 pw = &result; 1270 if (IsArray(va, ta)) { 1271 do { 1272 pword *paux = va.ptr; 1273 Make_List(pw, TG); 1274 Make_Integer(TG, DidArity(paux->val.did)); 1275 pw = TG+1; 1276 Push_List_Frame(); 1277 ++paux; /* examine first array element (only) */ 1278 Dereference_(paux); 1279 ta.all = paux->tag.all; 1280 va.all = paux->val.all; 1281 } while(IsArray(va, ta)); 1282 1283 } else if (IsNil(ta)) { 1284 Make_List(pw, TG); 1285 Make_Integer(TG, 0); 1286 pw = TG+1; 1287 Push_List_Frame(); 1288 1289 } else { 1290 Error_If_Ref(ta); 1291 Bip_Error(TYPE_ERROR); 1292 } 1293 Make_Nil(pw); 1294 Return_Unify_Pw(vdim, tdim, result.val, result.tag); 1295} 1296 1297 1298static int 1299_flatten_array(uword d, word n, pword *from) 1300{ 1301 if (d > 0) { 1302 do { 1303 pword *pw = from++; 1304 Dereference_(pw); 1305 if (IsArray(pw->val, pw->tag)) { 1306 int res = _flatten_array(d-1, DidArity(pw->val.ptr->val.did), pw->val.ptr+1); 1307 Return_If_Not_Success(res); 1308 } else if (!IsNil(pw->tag)) { 1309 ++TG; Check_Gc; 1310 *(TG-1) = *pw; 1311 } 1312 } while(--n > 0); 1313 } else { 1314 pword *to = TG; 1315 Check_Available_Pwords(n); /* extra check, because n may be large */ 1316 TG += n; Check_Gc; 1317 /* could use memcpy() here */ 1318 do { 1319 *to++ = *from++; 1320 } while(--n > 0); 1321 } 1322 return PSUCCEED; 1323} 1324 1325static int 1326p_array_flat(value vdepth, type tdepth, value varr, type tarr, value vflat, type tflat) 1327{ 1328 int res; 1329 uword arity; 1330 pword result; 1331 1332 Check_Integer(tdepth); 1333 if (vdepth.nint < -1) { Bip_Error(RANGE_ERROR); } 1334 Check_Array_Or_Nil(varr, tarr, &arity); 1335 1336 if (IsNil(tarr)) { 1337 Return_Unify_Nil(vflat, tflat); 1338 } 1339 if (vdepth.nint == 0) { 1340 Return_Unify_Pw(vflat, tflat, varr, tarr); 1341 } 1342 Make_Struct(&result, TG); 1343 ++TG; /* leave space for functor */ 1344 res = _flatten_array((uword)vdepth.nint, arity, varr.ptr+1); 1345 Return_If_Not_Success(res); 1346 arity = TG-result.val.ptr-1; 1347 if (arity > 0) { 1348 Make_Atom(result.val.ptr, add_dict(d_.nil, arity)); 1349 } else { 1350 TG = result.val.ptr; 1351 Make_Nil(&result); 1352 } 1353 Return_Unify_Pw(vflat, tflat, result.val, result.tag); 1354} 1355 1356 1357static int 1358p_array_concat(value v1, type t1, value v2, type t2, value v, type t) 1359{ 1360 int res; 1361 pword result; 1362 1363 if (!(IsArray(v, t) || IsNil(t) || IsRef(t))) { 1364 Bip_Error(TYPE_ERROR); 1365 } 1366 if (IsRef(t1)) { 1367 Bip_Error(PDELAY_1); 1368 } 1369 if (IsRef(t2)) { 1370 Bip_Error(PDELAY_2); 1371 } 1372 Kill_DE; 1373 if (IsNil(t1)) { 1374 if (IsArray(v2, t2) || IsNil(t2)) { 1375 Return_Unify_Pw(v, t, v2, t2); 1376 } 1377 } 1378 else if (IsNil(t2)) { 1379 if (IsArray(v1, t1) || IsNil(t1)) { 1380 Return_Unify_Pw(v, t, v1, t1); 1381 } 1382 } 1383 else if (IsArray(v1,t1) && IsArray(v2,t2)) { 1384 pword *pw1 = v1.ptr; 1385 pword *pw2 = v2.ptr; 1386 pword *pw = TG; 1387 pword result; 1388 word n = DidArity(pw1->val.did) + DidArity(pw2->val.did); 1389 Check_Available_Pwords(n+1); /* extra check, because n may be large */ 1390 TG += n+1; Check_Gc; 1391 Make_Struct(&result, pw); 1392 Make_Atom(pw, add_dict(d_.nil, n)); 1393 for(n=DidArity(pw1->val.did); n; --n) *++pw = *++pw1; 1394 for(n=DidArity(pw2->val.did); n; --n) *++pw = *++pw2; 1395 Return_Unify_Pw(v, t, result.val, result.tag); 1396 } 1397 1398 Bip_Error(TYPE_ERROR); 1399} 1400 1401 1402static int 1403p_array_list3(value varr, type tarr, value vl, type tl, value vt, type tt) 1404{ 1405 Check_Output_List(tt); 1406 if (IsRef(tarr)) 1407 { 1408 if (IsList(tl)) 1409 { 1410 pword *head = TG++; /* leave space for functor */ 1411 pword *elem = vl.ptr; 1412 pword *stop = IsNil(tt) ? NULL : vt.ptr; /* list or var address */ 1413 1414 for(;;) 1415 { 1416 pword *arg = TG++; 1417 Check_Gc; 1418 *arg = *elem++; 1419 Dereference_(elem); 1420 if (IsList(elem->tag)) 1421 { 1422 if (IsList(tt) && 0==ec_compare_terms(elem->val, elem->tag, vt, tt)) 1423 break; 1424 elem = elem->val.ptr; 1425 } 1426 else if (IsRef(elem->tag)) 1427 { 1428 elem = elem->val.ptr; 1429 if (elem == stop) 1430 break; 1431 1432 /* ideally: suspend [Arr]->inst, [End,Tail]->bound */ 1433 TG = head; 1434 Push_var_delay(varr.ptr, tarr.all); 1435 if (IsRef(tt)) { 1436 Push_var_delay_unif(elem, elem->tag.all); 1437 Push_var_delay_unif(vt.ptr, tt.all); 1438 } else { 1439 Push_var_delay(elem, elem->tag.all); 1440 } 1441 Bip_Error(PDELAY) /* |PDELAY_BOUND in some cases... */ 1442 } 1443 else if (IsNil(elem->tag)) 1444 { 1445 if (!IsNil(tt)) { Fail_; } /* tail must be == */ 1446 break; 1447 } 1448 else 1449 { 1450 Bip_Error(TYPE_ERROR) 1451 } 1452 } 1453 /* go back to write functor with now known arity */ 1454 Kill_DE; 1455 word arity = TG-head-1; 1456 if (arity == 0) { 1457 Return_Unify_Nil(varr, tarr); 1458 } else { 1459 Make_Atom(head, add_dict(d_.nil, arity)); 1460 Return_Unify_Structure(varr, tarr, head); 1461 } 1462 } 1463 else if (IsNil(tl)) 1464 { 1465 Kill_DE; 1466 if (!IsNil(tt)) { Fail_; } /* tail must be == */ 1467 Return_Unify_Nil(varr, tarr); 1468 } 1469 else if (IsRef(tl)) 1470 { 1471 Bip_Error(PDELAY_1_2) 1472 } 1473 Bip_Error(TYPE_ERROR) 1474 } 1475 else if (IsArray(varr, tarr)) /* converting Array to List */ 1476 { 1477 word arity; 1478 pword result; 1479 pword *elem, *arg; 1480 1481 Check_Output_List(tl); 1482 Kill_DE; 1483 arg = varr.ptr; 1484 arity = DidArity(arg->val.did); 1485 elem = TG; 1486 Make_List(&result, elem); 1487 /* Additional a-priori overflow check because adding arity to TG 1488 * may may wrap around the address space and break Check_Gc below 1489 */ 1490 Check_Available_Pwords(2*arity); 1491 TG += 2*arity; 1492 Check_Gc 1493 while(--arity) 1494 { 1495 *elem = *(++arg); 1496 Make_List(elem+1, elem+2); 1497 elem += 2; 1498 } 1499 *elem = *++arg; 1500 elem[1].val = vt; 1501 elem[1].tag = tt; 1502 Return_Unify_Pw(vl, tl, result.val, result.tag); 1503 } 1504 else if (IsNil(tarr)) 1505 { 1506 Check_Output_List(tl); 1507 Kill_DE; 1508 Return_Unify_Pw(vl, tl, vt, tt); 1509 } 1510 Bip_Error(TYPE_ERROR) 1511} 1512 1513 1514static int 1515p_array_list(value tv, type tt, value lv, type lt) 1516{ 1517 return p_array_list3(tv, tt, lv, lt, lv, tag_desc[TNIL].tag); 1518} 1519 1520 1521/* The following builtins use the global error variable ! */ 1522#undef Bip_Error 1523#define Bip_Error(N) Bip_Error_Fail(N) 1524 1525/* 1526 get_var_type(Var, Type) unify the type of the free variable Var with Type. 1527 Fails if Var is nonvar. 1528*/ 1529/*ARGSUSED*/ 1530static int 1531p_get_var_type(value vvar, type tvar, value vvtype, type ttype) 1532{ 1533 dident dtype; 1534 1535 Check_Output_Atom_Or_Nil(vvtype, ttype); 1536 1537 if (IsRef(tvar)) 1538 { 1539 switch (TagType(tvar)) 1540 { 1541 case TNAME: 1542 case TVAR_TAG: 1543 dtype = d_.free; 1544 break; 1545 case TUNIV: 1546 dtype = d_.universally_quantified; 1547 break; 1548 case TMETA: 1549 dtype = d_.meta0; 1550 break; 1551 1552 default: 1553 Bip_Error(UNIFY_OVNI); 1554 } 1555 Return_Unify_Atom(vvtype, ttype, dtype); 1556 } 1557 else 1558 { 1559 Set_Bip_Error(0); 1560 Fail_; 1561 } 1562} 1563 1564/*ARGSUSED*/ 1565static int 1566p_get_var_name(value vvar, type tvar, value vname, type tname) 1567{ 1568 dident dname; 1569 1570 Check_Output_Atom_Or_Nil(vname, tname); 1571 1572 if (IsRef(tvar) && IsNamed(tvar.kernel)) 1573 { 1574 dname = TagDid(tvar.kernel); 1575 Return_Unify_Atom(vname, tname, dname); 1576 } 1577 else 1578 { 1579 Set_Bip_Error(0); 1580 Fail_; 1581 } 1582} 1583 1584