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_array.c,v 1.3 2010/03/19 05:52:16 jschimpf Exp $ 25 */ 26 27/**************************************************************************** 28 * 29 * SEPIA Built-in Predicates for arrays and global variables 30 * 31 * name C func type file 32 * ---------------------------------------------------------------- 33 * make_array_ p_make_array_ B_SAFE 34 * setval_body p_setval_body B_SAFE 35 * getval_body p_getval_body B_UNSAFE 36 * incval_body p_incval_body B_SAFE 37 * decval_body p_decval_body B_SAFE 38 * array_info p_array_info B_UNSAFE 39 * 40 *****************************************************************************/ 41 42 43/* 44 * Arrays are implemented as values of the property ARRAY_PROP. 45 * The tag part holds a type (using the general type of prolog objects) 46 * and the value part holds relevant information for this type: 47 * If the arity of the dictionary entry is greater than 0: 48 * - TINT: integer array. The second word is a pointer to the array. 49 * - TDBL: double float array. The second word is a pointer to the array. 50 * - TSTRG: byte array. The second word is a pointer to the array. 51 * - TCOMP: prolog array. The second word is a pointer to the array. 52 * the header of an array looks as follows (in dident): 53 * did (backpointer and arity can be deduced (questionable approach)) 54 * dim1 55 * ... 56 * dimn 57 * contents ... 58 * 59 * Global variables are implemented as the property GLOBVAR_PROP. 60 * The property value is the value of the global variable. 61 */ 62 63 64 65#include "config.h" 66#include "sepia.h" 67#include "types.h" 68#include "embed.h" 69#include "error.h" 70#include "mem.h" 71#include "dict.h" 72#include "emu_export.h" 73#include "property.h" 74#include "module.h" 75 76#if defined(PRINTAM) || defined(LASTPP) 77 78#include "opcode.h" 79 80extern char *inst_name[]; 81char *vm_inst_flag_; 82uword *vm_inst_ctr_; 83 84#endif /* PRINTAM */ 85 86/* set and get ARRAY_PROP */ 87#define NewArrayItem(did, mod, mod_tag, vis, perr)\ 88 set_modular_property(did, ARRAY_PROP, mod, mod_tag, vis, perr) 89 90#define NewGlobVarItem(did, mod, mod_tag, scope, perr)\ 91 set_modular_property(did, GLOBVAR_PROP, mod, mod_tag, scope, perr) 92 93#define VisibleAV(did, prop, mod, mod_tag, perr)\ 94 get_modular_property(did, prop, mod, mod_tag, VISIBLE_PROP, perr) 95 96#define EraseAV(did, prop, mod, mod_tag, vis)\ 97 erase_modular_property(did, prop, mod, mod_tag, vis) 98 99int 100 p_setval_body(value a, type ta, value v, type t, value vmod, type tmod), 101 p_make_array_(value v, type t, value vt, type tt, value vscope, type tscope, value vmod, type tmod), 102 p_erase_array_body(value val1, type tag1, value vmod, type tmod), 103 p_erase_array_(value val1, type tag1, value vscope, type tscope, value vmod, type tmod); 104 105static int 106 p_xget(value vhandle, type thandle, value vi, type ti, value vval, type tval), 107 p_xset(value vhandle, type thandle, value vi, type ti, value vval, type tval), 108 p_array_info(value varr, type tarr, value vopt, type topt, value vmod, type tmod), 109 p_getval_body(value a, type ta, value v, type t, value vmod, type tmod), 110 p_incval_body(value a, type ta, value vmod, type tmod), 111 p_decval_body(value a, type ta, value vmod, type tmod), 112 p_test_and_setval_body(value a, type ta, value vc, type tc, value v, type t, value vmod, type tmod); 113 114static dident d_reference_; 115static dident d_reference1_; 116static dident d_global_reference_; 117static dident d_global_reference_index_; 118 119pword *get_array_header(dident adid), 120 *get_kernel_array(dident adid), 121 *get_visible_array_header(dident adid, value vm, type tm, int *res); 122 123pword *p_installation_dir_; /* accessed from megalog! */ 124 125 126/* 127 * For aligning arrays 128 */ 129 130#define RoundUp(n) ((n) - ((n)-1)%sizeof(maxelsize) - 1 + sizeof(maxelsize)) 131 132typedef union { 133 uword w; 134 word l; 135 double d; 136} maxelsize; 137 138 139 140void 141bip_array_init(int flags, char *installation_dir) 142{ 143 pri *pd; 144 value v1; 145 146 if (flags & INIT_SHARED) 147 { 148 GlobalVarIndex = 0; 149 local_built_in(in_dict("array_info", 3), p_array_info, B_UNSAFE) 150 -> mode = BoundArg(1, GROUND) | BoundArg(2, GROUND); 151 (void) local_built_in(in_dict("make_array_", 4), 152 p_make_array_, B_SAFE); 153 (void) exported_built_in(in_dict("erase_array_body", 2), 154 p_erase_array_body, B_SAFE); 155 (void) local_built_in(in_dict("erase_array_", 3), 156 p_erase_array_, B_SAFE); 157 pd = exported_built_in(in_dict("test_and_setval_body", 4), p_test_and_setval_body, B_SAFE); 158 pd = exported_built_in(in_dict("setval_body", 3), p_setval_body, B_SAFE); 159 pd = exported_built_in(in_dict("getval_body", 3), p_getval_body, B_UNSAFE|U_FRESH); 160 pd -> mode = BoundArg(2, NONVAR); 161 pd = exported_built_in(in_dict("incval_body",2), p_incval_body, B_UNSAFE); 162 pd = exported_built_in(in_dict("decval_body",2), p_decval_body, B_UNSAFE); 163 built_in(in_dict("xget",3), p_xget, B_UNSAFE)->mode = GROUND; 164 built_in(in_dict("xset",3), p_xset, B_SAFE); 165 } 166 167 if (flags & INIT_PRIVATE) 168 { 169 value vv, vm, vn, vt; 170 171 d_reference_ = in_dict("reference", 0); 172 d_reference1_ = in_dict("reference", 1); 173 d_global_reference_ = in_dict("global_reference", 0); 174 d_global_reference_index_ = in_dict("global_reference_index", 0); 175 176#ifdef DFID 177 /* Initialization of predefined global Prolog variables */ 178 vv.did = d_.local0; 179 vm.did = d_.kernel_sepia; 180 181 /* temporary: use old style globvar-index for DFID variables */ 182 vt.did = d_global_reference_index_; 183 184 /* global var 0 - unused (used to be postponed list) */ 185 GlobalVarIndex++; 186 vm.did = in_dict("dfid", 0); 187 /* global var 1 - DfidDepth */ 188 vn.did = in_dict("depth", 0); 189 (void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict); 190 /* global var 2 - MaxDepth */ 191 vn.did = in_dict("max_depth", 0); 192 (void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict); 193 /* global var 3 - DepthLimit */ 194 vn.did = in_dict("depth_limit", 0); 195 (void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict); 196 /* global var 4 - DepthOV */ 197 vn.did = in_dict("depth_ov", 0); 198 (void) p_make_array_(vn, tdict, vt, tdict, vv, tdict, vm, tdict); 199#endif 200 } 201 202 /* 203 * Initialize some global Prolog variables in sepia_kernel 204 * that need to be accessed from C as well. 205 */ 206 v1.nint = 0; 207 p_installation_dir_ = init_kernel_var(flags, 208 in_dict("sepiadir", 0), v1, tint); 209 if (flags & INIT_SHARED) 210 { 211 set_string(p_installation_dir_, installation_dir); 212 } 213 214#if defined(PRINTAM) || defined(LASTPP) 215 if (flags & INIT_SHARED) 216 { /* some facilities for statistics and debugging */ 217 register int i; 218 pword *pw; 219 220 /* array of flags for every VM instruction */ 221 (void) make_kernel_array(in_dict("vm_inst_flag",1), 222 NUMBER_OP, d_.byte, d_.global0); 223 224 /* array of VM instruction counters */ 225 (void) make_kernel_array(in_dict("vm_inst_ctr",1), 226 NUMBER_OP, d_.integer0, d_.global0); 227 228 /* array of VM instruction names */ 229 (void) make_kernel_array(in_dict("vm_inst_name",1), 230 NUMBER_OP, d_.prolog, d_.global0); 231 232 pw = get_kernel_array(in_dict("vm_inst_name",1))->val.ptr + 1; 233 for(i=0; i<NUMBER_OP; i++, pw++) 234 { 235 pw->tag.kernel = TNIL; /* must be initialised */ 236 set_string(pw, inst_name[i]); 237 } 238 } 239 vm_inst_flag_ = (char*) 240 (get_kernel_array(in_dict("vm_inst_flag",1))->val.ptr + 1); 241 vm_inst_ctr_ = (uword*) 242 (get_kernel_array(in_dict("vm_inst_ctr",1))->val.ptr + 1); 243#endif /* PRINTAM */ 244 245#ifdef lint 246 { 247 pword *pw; 248 int r; 249 pw = get_array_header(d_.nil); /* dummy calls for lint */ 250 pw = get_visible_array_header(d_.nil, pw->val, pw->tag, &r); 251 } 252#endif 253 254} 255/* 256 * function to initialise sepia_kernel global variable from within C 257 */ 258pword * 259init_kernel_var(int flags, dident vdid, value v, type t) 260{ 261 int res; 262 pword module; 263 264 module.tag.kernel = ModuleTag(d_.kernel_sepia); 265 module.val.did = d_.kernel_sepia; 266 if (flags & INIT_SHARED) 267 { 268 value v_name, v_type, v_vis; 269 v_name.did = vdid; 270 v_type.did = d_.prolog; 271 v_vis.did = d_.local0; 272 (void) p_make_array_(v_name, tdict, v_type, tdict, 273 v_vis, tdict, module.val, module.tag); 274 (void) p_setval_body(v_name, tdict, v, t, module.val, module.tag); 275 } 276 return get_modular_property(vdid, GLOBVAR_PROP, 277 module.val.did, module.tag, VISIBLE_PROP, &res); 278} 279 280 281 282pword * 283get_kernel_array(dident adid) 284{ 285 int res; 286 pword module; 287 if (DidArity(adid) != 1) 288 return 0; 289 module.tag.kernel = ModuleTag(d_.kernel_sepia); 290 module.val.did = d_.kernel_sepia; 291 return get_modular_property(adid, ARRAY_PROP, 292 module.val.did, module.tag, VISIBLE_PROP, &res); 293} 294 295int 296make_kernel_array(dident adid, int length, dident atype, dident avisib) 297{ 298 pword module; 299 pword buf[5]; 300 301 if (DidArity(adid) != 1) 302 return RANGE_ERROR; 303 module.tag.kernel = ModuleTag(d_.kernel_sepia); 304 module.val.did = d_.kernel_sepia; 305 buf[0].val.ptr = &buf[3]; 306 buf[0].tag.kernel = TCOMP; 307 buf[1].val.did = atype; 308 buf[1].tag.kernel = TDICT; 309 buf[2].val.did = avisib; 310 buf[2].tag.kernel = TDICT; 311 buf[3].val.did = adid; /* must be arity 1 !!! */ 312 buf[3].tag.kernel = TDICT; 313 buf[4].val.nint = (word) length; 314 buf[4].tag.kernel = TINT; 315 return p_make_array_(buf[0].val, buf[0].tag, buf[1].val, buf[1].tag, 316 buf[2].val, buf[2].tag, module.val, module.tag); 317} 318 319/* 320 * this function is used to implement the macros in external.h 321 */ 322 323pword * 324get_array_header(dident adid) 325{ 326 if (DidArity(adid) > 0) 327 return get_property(adid, ARRAY_PROP); 328 else 329 return get_property(adid, GLOBVAR_PROP); 330} 331 332pword * 333get_visible_array_header(dident adid, value vm, type tm, int *res) 334{ 335 if (DidArity(adid) > 0) 336 return get_modular_property(adid, ARRAY_PROP, 337 vm.did, tm, VISIBLE_PROP, res); 338 else 339 return get_modular_property(adid, GLOBVAR_PROP, 340 vm.did, tm, VISIBLE_PROP, res); 341} 342 343 344/* 345 * erase(Array/Dim) 346 * erase the given array 347 */ 348int 349p_erase_array_body(value val1, type tag1, value vmod, type tmod) 350{ 351 value vscope; 352 353 vscope.did = d_.nil; /* visible (not local nor global) */ 354 return (p_erase_array_(val1, tag1, vscope, tdict, vmod, tmod)); 355} 356 357/* 358 erase_array_(Array, Module, Visibility) 359*/ 360/*ARGSUSED*/ 361int 362p_erase_array_(value val1, type tag1, value vscope, type tscope, value vmod, type tmod) 363{ 364 dident adid; 365 int prop; 366 int err; 367 int scope = (vscope.did == d_.local0 ? LOCAL_PROP 368 : (vscope.did == d_.global0 ? GLOBAL_PROP 369 : VISIBLE_PROP)); 370 371 Get_Functor_Did(val1, tag1, adid); 372 373 if (DidArity(adid) > 0) 374 prop = ARRAY_PROP; 375 else 376 prop = GLOBVAR_PROP; 377 if ((err = EraseAV(adid, prop, vmod.did, tmod, scope)) 378 < PSUCCEED) 379 { 380 if (err == PERROR) 381 err = NOGLOBAL; 382 Bip_Error(err); 383 } 384 Succeed_; 385} 386 387static int 388p_test_and_setval_body(value a, type ta, value vc, type tc, value v, type t, value vmod, type tmod) 389{ 390 int err; 391 392 Error_If_Ref(ta); 393 if (IsAtom(ta) || IsNil(ta)) 394 { 395 pword *pw; 396 pword copy_pw; 397 398 a_mutex_lock(&PropertyLock); 399 if (!(pw = VisibleAV(IsNil(ta) ? d_.nil : a.did, 400 GLOBVAR_PROP, vmod.did, tmod, &err))) 401 { 402 if (err == PERROR) 403 err = NOGLOBAL; 404 a_mutex_unlock(&PropertyLock); 405 Bip_Error(err); 406 } 407 if (IsGlobalPrologRefIndex(pw) || IsGlobalPrologRef(pw)) 408 { 409 a_mutex_unlock(&PropertyLock); 410 Bip_Error(TYPE_ERROR); 411 } 412 if (ec_compare_terms(vc, tc, pw->val, pw->tag)) 413 { 414 a_mutex_unlock(&PropertyLock); 415 Fail_; 416 } 417 err = create_heapterm(©_pw, v, t); 418 if (err != PSUCCEED) 419 { 420 a_mutex_unlock(&PropertyLock); 421 Bip_Error(err); 422 } 423 free_heapterm(pw); 424 move_heapterm(©_pw, pw); 425 a_mutex_unlock(&PropertyLock); 426 Succeed_; 427 } 428 else 429 { 430 Bip_Error(TYPE_ERROR); 431 } 432} 433 434int 435p_setval_body(value a, type ta, value v, type t, value vmod, type tmod) 436{ 437 int err; 438 pword copy_pw; 439 440 Error_If_Ref(ta); 441 if (IsAtom(ta) || IsNil(ta)) 442 { 443 pword *pw; 444 445 a_mutex_lock(&PropertyLock); 446 if (!(pw = VisibleAV(IsNil(ta) ? d_.nil : a.did, 447 GLOBVAR_PROP, vmod.did, tmod, &err))) 448 { 449 if (err == PERROR) 450 err = NOGLOBAL; 451 a_mutex_unlock(&PropertyLock); 452 Bip_Error(err); 453 } 454 if (IsGlobalPrologRef(pw)) 455 { 456 copy_pw.val.all = v.all; 457 copy_pw.tag.all = t.all; 458 ec_ref_set((ec_ref) pw->val.wptr, copy_pw); 459 a_mutex_unlock(&PropertyLock); 460 Succeed_; 461 } 462 else if (IsGlobalPrologRefIndex(pw)) 463 { 464 (void) ec_assign(&GLOBVAR[pw->val.nint], v, t); 465 a_mutex_unlock(&PropertyLock); 466 Succeed_; 467 } 468 err = create_heapterm(©_pw, v, t); 469 if (err != PSUCCEED) 470 { 471 a_mutex_unlock(&PropertyLock); 472 Bip_Error(err); 473 } 474 free_heapterm(pw); 475 move_heapterm(©_pw, pw); 476 a_mutex_unlock(&PropertyLock); 477 Succeed_; 478 } 479 if (IsStructure(ta) || IsList(ta)) 480 { 481 uword *adr; 482 uword kind; 483 484 a_mutex_lock(&PropertyLock); 485 if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err))) 486 { 487 a_mutex_unlock(&PropertyLock); 488 Bip_Error(err); 489 } 490 err = PSUCCEED; 491 switch (kind) 492 { 493 case TCOMP: 494 free_heapterm((pword *)adr); 495 err = create_heapterm((pword *)adr,v,t); 496 break; 497 case TSTRG: 498 if (IsRef(t)) err = INSTANTIATION_FAULT; 499 else if (!IsInteger(t)) err = TYPE_ERROR; 500 else *((unsigned char *) adr) = (v.nint & 0XFF); 501 break; 502 case TINT: 503 if (IsRef(t)) err = INSTANTIATION_FAULT; 504 else if (!IsInteger(t)) err = TYPE_ERROR; 505 else *((word *) adr) = v.nint; 506 break; 507 case TDBL: 508 if (IsRef(t)) err = INSTANTIATION_FAULT; 509 else if (!IsDouble(t)) err = TYPE_ERROR; 510 else *((double *) adr) = Dbl(v); 511 break; 512 } 513 a_mutex_unlock(&PropertyLock); 514 return err; 515 } 516 else 517 { 518 Bip_Error(TYPE_ERROR); 519 } 520} 521 522 523/* make it fail if no global variable associated */ 524static int 525p_getval_body(value a, type ta, value v, type t, value vmod, type tmod) 526{ 527 int err; 528 dident wd; 529 530 Error_If_Ref(ta); 531 if (IsNil(ta)) 532 wd = d_.nil; 533 else 534 wd = a.did; 535 if (IsAtom(ta) || IsNil(ta)) 536 { 537 pword *p; 538 pword result; 539 540 a_mutex_lock(&PropertyLock); 541 if (!(p = VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err))) 542 { 543 if (err == PERROR) 544 err = NOGLOBAL; 545 a_mutex_unlock(&PropertyLock); 546 Bip_Error(err); 547 } 548 get_heapterm(p, &result); 549 a_mutex_unlock(&PropertyLock); 550 551 if (IsRef(result.tag) && result.val.ptr == &result) 552 { 553 Succeed_; /* a free variable */ 554 } 555 else if (IsGlobalPrologRef(&result)) 556 { 557 result = ec_ref_get((ec_ref) result.val.wptr); 558 Return_Unify_Pw(v, t, result.val, result.tag); 559 } 560 else if (IsGlobalPrologRefIndex(&result)) 561 { 562 if (!IsSimple(GLOBVAR[result.val.nint].tag) 563 && GLOBVAR[result.val.nint].val.ptr >= TG 564 && GLOBVAR[result.val.nint].val.ptr < B_ORIG ) 565 { 566 Fail_; 567 } 568 Return_Unify_Pw(v, t, GLOBVAR[result.val.nint].val, 569 GLOBVAR[result.val.nint].tag); 570 } 571 else 572 { 573 Return_Unify_Pw(v,t,result.val,result.tag); 574 } 575 } 576 else if (IsStructure(ta) || IsList(ta)) 577 { 578 uword *adr; 579 uword kind; 580 pword result; 581 582 a_mutex_lock(&PropertyLock); 583 if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err))) 584 { 585 a_mutex_unlock(&PropertyLock); 586 Bip_Error(err); 587 } 588 switch (kind) 589 { 590 case TCOMP: 591 get_heapterm((pword *)adr, &result); 592 if (IsRef(result.tag) && result.val.ptr == &result) 593 { 594 a_mutex_unlock(&PropertyLock); 595 Succeed_; /* a free variable */ 596 } 597 break; 598 case TSTRG: 599 result.val.nint = (word) *((unsigned char *) adr); 600 result.tag.kernel = TINT; 601 break; 602 case TINT: 603 result.val.nint = (word) *((word *) adr); 604 result.tag.kernel = TINT; 605 break; 606 case TDBL: 607 Make_Float(&result, *((double *) adr)) 608 break; 609 } 610 a_mutex_unlock(&PropertyLock); 611 Return_Unify_Pw(v,t,result.val,result.tag); 612 } 613 else 614 { 615 Bip_Error(TYPE_ERROR); 616 } 617} 618 619 620static int 621p_incval_body(value a, type ta, value vmod, type tmod) 622{ 623 pword *p; 624 int err; 625 dident wd; 626 627 Error_If_Ref(ta); 628 if (IsNil(ta)) 629 wd = d_.nil; 630 else 631 wd = a.did; 632 if (IsAtom(ta) || IsNil(ta)) 633 { 634 a_mutex_lock(&PropertyLock); 635 if (!(p = VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err))) 636 { 637 if (err == PERROR) 638 err = NOGLOBAL; 639 a_mutex_unlock(&PropertyLock); 640 Bip_Error(err); 641 } 642 if((!IsInteger(p->tag))) 643 { 644 a_mutex_unlock(&PropertyLock); 645 Bip_Error(TYPE_ERROR); 646 } 647 p->val.nint++; 648 a_mutex_unlock(&PropertyLock); 649 Succeed_; 650 } 651 if (IsStructure(ta) || IsList(ta)) 652 { 653 uword *adr; 654 uword kind; 655 pword *pi; 656 657 a_mutex_lock(&PropertyLock); 658 if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err))) 659 { 660 a_mutex_unlock(&PropertyLock); 661 Bip_Error(err); 662 } 663 if (kind == TINT) 664 { 665 (*((int *) adr))++; 666 } 667 else if (kind == TCOMP) 668 { 669 pi = (pword *) adr; 670 if (IsInteger(pi->tag)) 671 { 672 pi->val.nint++; 673 } 674 else 675 { 676 a_mutex_unlock(&PropertyLock); 677 Bip_Error(TYPE_ERROR); 678 } 679 } 680 else 681 { 682 a_mutex_unlock(&PropertyLock); 683 Bip_Error(TYPE_ERROR); 684 } 685 a_mutex_unlock(&PropertyLock); 686 Succeed_; 687 } 688 else 689 { 690 Bip_Error(TYPE_ERROR); 691 } 692} 693 694static int 695p_decval_body(value a, type ta, value vmod, type tmod) 696{ 697 pword *p; 698 int err; 699 dident wd; 700 701 Error_If_Ref(ta); 702 if (IsNil(ta)) 703 wd = d_.nil; 704 else 705 wd = a.did; 706 if (IsAtom(ta) || IsNil(ta)) 707 { 708 a_mutex_lock(&PropertyLock); 709 if (!(p = VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err))) 710 { 711 if (err == PERROR) 712 err = NOGLOBAL; 713 a_mutex_unlock(&PropertyLock); 714 Bip_Error(err); 715 } 716 if((!IsInteger(p->tag))) 717 { 718 a_mutex_unlock(&PropertyLock); 719 Bip_Error(TYPE_ERROR); 720 } 721 p->val.nint--; 722 a_mutex_unlock(&PropertyLock); 723 Succeed_; 724 } 725 if (IsStructure(ta) || IsList(ta)) 726 { 727 uword *adr; 728 uword kind; 729 pword *pi; 730 731 a_mutex_lock(&PropertyLock); 732 if (!(adr = get_elt_address(a, ta, &kind, vmod.did, tmod, &err))) 733 { 734 a_mutex_unlock(&PropertyLock); 735 Bip_Error(err); 736 } 737 if (kind == TINT) 738 { 739 (*((int *) adr))--; 740 } 741 else if (kind == TCOMP) 742 { 743 pi = (pword *) adr; 744 if (IsInteger(pi->tag)) 745 { 746 pi->val.nint--; 747 } 748 else 749 { 750 a_mutex_unlock(&PropertyLock); 751 Bip_Error(TYPE_ERROR); 752 } 753 } 754 else 755 { 756 a_mutex_unlock(&PropertyLock); 757 Bip_Error(TYPE_ERROR); 758 } 759 a_mutex_unlock(&PropertyLock); 760 Succeed_; 761 } 762 else 763 { 764 Bip_Error(TYPE_ERROR); 765 } 766} 767 768/* 769 * array_info(+Array, ?OptionList, +Module) 770 * 771 * The arguments of Array will be unified with the dimension sizes, 772 * OptionList is unified with a two element list [<type>, <visibility>] 773 */ 774 775static int 776p_array_info(value varr, type tarr, value vopt, type topt, value vmod, type tmod) 777{ 778 pword *prop; 779 pword *pw = (pword *) 0; 780 int i, arity, err, prop_name; 781 dident wdid, vis; 782 uword *w; 783 value v; 784 Prepare_Requests 785 786 Check_Output_List(topt); 787 switch (TagType(tarr)) 788 { 789 case TLIST: 790 wdid = d_.list; 791 pw = varr.ptr; 792 break; 793 case TCOMP: 794 wdid = varr.ptr->val.did; 795 pw = varr.ptr + 1; 796 break; 797 case TDICT: 798 wdid = varr.did; 799 break; 800 case TNIL: 801 wdid = d_.nil; 802 break; 803 default: 804 Bip_Error(IsRef(tarr) ? INSTANTIATION_FAULT : TYPE_ERROR); 805 } 806 807 a_mutex_lock(&PropertyLock); 808 arity = DidArity(wdid); 809 prop_name = arity ? ARRAY_PROP : GLOBVAR_PROP; 810 prop = VisibleAV(wdid, prop_name, vmod.did, tmod, &err); 811 if (!prop) 812 { 813 if (err == PERROR) /* no array */ 814 err = PFAIL; 815 a_mutex_unlock(&PropertyLock); 816 Bip_Error(err); 817 } 818 vis = (err == LOCAL_PROP) ? d_.local0 : d_.global0; 819 820 if (arity == 0) 821 { 822 if (IsGlobalPrologRef(prop) || IsGlobalPrologRefIndex(prop)) 823 wdid = d_reference_; 824 else 825 wdid = d_.prolog; 826 } 827 else 828 { 829 switch(TagType(prop->tag)) /* get the type */ 830 { 831 case TCOMP: 832 wdid = d_.prolog; 833 break; 834 case TSTRG: 835 wdid = d_.byte; 836 break; 837 case TINT: 838 wdid = d_.integer0; 839 break; 840 case TDBL: 841 wdid = d_.float0; 842 break; 843 default: 844 p_fprintf(current_err_, 845 "internal error: array structure corrupted\n"); 846 ec_flush(current_err_); 847 } 848 849 w = ((uword *)(prop -> val.ptr) + 1); /* unify the dimensions */ 850 for(i = 0; i < arity; i++) 851 { 852 v.nint = (word) *w++; 853 Request_Unify_Pw(pw->val, pw->tag, v, tint); 854 pw++; 855 } 856 } 857 a_mutex_unlock(&PropertyLock); 858 859 pw = TG; /* make options list */ 860 TG += 4; 861 Check_Gc; 862 pw[0].val.did = wdid; /* [type, visibility] */ 863 pw[0].tag.kernel = TDICT; 864 pw[1].val.ptr = &pw[2]; 865 pw[1].tag.kernel = TLIST; 866 pw[2].val.did = vis; 867 pw[2].tag.kernel = TDICT; 868 pw[3].tag.kernel = TNIL; 869 Request_Unify_List(vopt, topt, pw); 870 Return_Unify 871} 872 873 874/* get_elt_address must be called in an interrupt protected area */ 875 876uword * 877get_elt_address(value v, type t, uword *kind, dident mod_did, type mod_tag, int *perr) 878{ 879 pword *pw, *q, *h, *p; 880 int ndim1, ndim2, i, n; 881 dident arraydid; 882 uword *w; 883 884 if (IsList(t)) 885 arraydid = d_.list; 886 else 887 arraydid = v.ptr->val.did; 888 ndim1 = DidArity(arraydid); 889 if (IsList(t)) 890 p = h = v.ptr - 1; 891 else 892 p = h = v.ptr; 893 for (i=0; i < ndim1; i++) 894 { 895 q = ++h; 896 Dereference_(q) 897 if(IsRef(q->tag)) 898 { 899 *perr = INSTANTIATION_FAULT; 900 return 0; 901 } 902 if(DifferTypeC(q->tag,TINT)) 903 { 904 *perr = TYPE_ERROR; 905 return 0; 906 } 907 } 908 909 if (!(pw = VisibleAV(arraydid, ARRAY_PROP, mod_did, mod_tag, perr))) 910 { 911 if (*perr == PERROR) 912 *perr = NOGLOBAL; 913 return 0; 914 } 915 *kind = pw->tag.kernel; 916 pw = pw->val.ptr; 917 ndim2 = DidArity((pw)->val.did); 918 n = 0; 919 w = ((uword *) pw) + 1; 920 for(i = 0; i < ndim2; i++) 921 { 922 q = ++p; 923 Dereference_(q) 924 n *= *w; 925 if(*w++ <= q->val.nint || q->val.nint < 0) 926 { 927 *perr = RANGE_ERROR; 928 return 0; 929 } 930 n += q->val.nint; 931 } 932 w = (uword *)pw + RoundUp((ndim2+1)*sizeof(uword))/sizeof(uword); 933 switch (*kind) 934 { 935 case TCOMP: return (uword *) (((pword *) w) + n); 936 case TSTRG: return (uword *) (((unsigned char *)w) + n); 937 case TINT: return (uword *) (((word *)w) + n); 938 case TDBL: return (uword *) (((double *)w) + n); 939 default: return (uword *) 0; 940 } 941} 942 943/* get_first_elt must be called in an interrupt protected area */ 944word 945get_first_elt(pword *p, pword *q, uword *kind, uword *size, dident vmod_did, type mod_tag) 946{ 947 dident mydid; 948 uword *w; 949 int i, n, err; 950 951 Dereference_(p) 952 if (IsRef(p->tag)) 953 return(INSTANTIATION_FAULT); 954 if (DifferTypeC(p->tag,TDICT)) 955 return(TYPE_ERROR); 956 Dereference_(q) 957 if (IsRef(q->tag)) 958 return(INSTANTIATION_FAULT); 959 if (DifferTypeC(q->tag,TINT)) 960 return(TYPE_ERROR); 961 mydid = check_did(p->val.did, (int) q->val.nint); 962 if (mydid == D_UNKNOWN) 963 return(NOGLOBAL); 964 if (!(p = VisibleAV(mydid, ARRAY_PROP, vmod_did, mod_tag, &err))) 965 { 966 if (err == PERROR) 967 err = NOGLOBAL; 968 return (err); 969 } 970 *size = 4; 971 *kind = p->tag.kernel; 972 if(q->val.nint == 0) 973 { 974 return((word) (&(p->val))); 975 } 976 switch (*kind) 977 { 978 case TCOMP: *size = sizeof(pword); break; 979 case TSTRG: *size = sizeof(char); break; 980 case TINT: *size = sizeof(word); break; 981 case TDBL: *size = sizeof(double); break; 982 } 983 p = p->val.ptr; 984 w = ((uword *) p) + 1; 985 n = DidArity(mydid); 986 for(i = 0; i < n ; i++) 987 *size *= *w++; 988 w = (uword *)p + RoundUp((n+1)*sizeof(uword))/sizeof(uword); 989 return((word) w); 990} 991 992 993/* 994 * free all the memory occupied by the array 995 */ 996 997void 998free_array(pword *prop_value) 999{ 1000 uword *array_header = (uword *) prop_value->val.ptr; 1001 1002 if (IsStructure(prop_value->tag)) 1003 { 1004 int dim = DidArity(array_header[0]); 1005 pword *array_contents = (pword *) 1006 (array_header + RoundUp((dim+1)*sizeof(uword))/sizeof(uword)); 1007 uword size; 1008 1009 for (size = 1; dim > 0; --dim) /* compute number of elements */ 1010 size *= array_header[dim]; 1011 1012 for (; size > 0; --size) 1013 free_heapterm(array_contents++); 1014 } 1015 hg_free((generic_ptr) array_header); 1016} 1017 1018 1019/* 1020 * Support function for the dictionary garbage collector: 1021 * Mark all DID's inside the array (applies only to 'prolog' arrays) 1022 */ 1023 1024void 1025mark_dids_from_array(pword *prop_value) 1026{ 1027 extern void mark_dids_from_heapterm(pword *root); 1028 1029 if (IsStructure(prop_value->tag)) 1030 { 1031 uword *array_header = (uword *) prop_value->val.ptr; 1032 int dim = DidArity(array_header[0]); 1033 pword *array_contents = (pword *) 1034 (array_header + RoundUp((dim+1)*sizeof(uword))/sizeof(uword)); 1035 register uword size; 1036 1037 for (size = 1; dim > 0; --dim) /* compute number of elements */ 1038 size *= array_header[dim]; 1039 1040 for (; size > 0; --size) 1041 mark_dids_from_heapterm(array_contents++); 1042 } 1043} 1044 1045static int 1046p_xset(value vhandle, type thandle, value vi, type ti, value vval, type tval) 1047{ 1048 pword pw; 1049 pw.val = vval; 1050 pw.tag = tval; 1051 Check_Type(thandle, THANDLE); 1052 Check_Type(vhandle.ptr->tag, TEXTERN); 1053 Check_Integer(ti); 1054 if (!(ExternalData(vhandle.ptr))) 1055 Bip_Error(STALE_HANDLE); 1056 if (!ExternalClass(vhandle.ptr)->set) 1057 { Bip_Error(UNIMPLEMENTED); } 1058 return ExternalClass(vhandle.ptr)->set(ExternalData(vhandle.ptr), vi.nint, pw); 1059} 1060 1061static int 1062p_xget(value vhandle, type thandle, value vi, type ti, value vval, type tval) 1063{ 1064 pword pw; 1065 pw.val = vval; 1066 pw.tag = tval; 1067 Check_Type(thandle, THANDLE); 1068 Check_Type(vhandle.ptr->tag, TEXTERN); 1069 Check_Integer(ti); 1070 if (!(ExternalData(vhandle.ptr))) 1071 Bip_Error(STALE_HANDLE); 1072 if (!ExternalClass(vhandle.ptr)->get) 1073 { Bip_Error(UNIMPLEMENTED); } 1074 pw = ExternalClass(vhandle.ptr)->get(ExternalData(vhandle.ptr), vi.nint); 1075 Return_Unify_Pw(vval, tval, pw.val, pw.tag); 1076} 1077 1078 1079/* The following builtins use the global error variable ! */ 1080#undef Bip_Error 1081#define Bip_Error(N) Bip_Error_Fail(N) 1082 1083/* 1084 Create an array v of type vt in module vmod, vscope can 1085 be local or global. 1086 1087 vt = prolog nonlogical variable 1088 vt = global_reference reference (via ec_ref) 1089 vt = global_reference_index reference (via GLOBVAR[] array) 1090*/ 1091/*ARGSUSED*/ 1092int 1093p_make_array_(value v, type t, value vt, type tt, value vscope, type tscope, value vmod, type tmod) 1094{ 1095 int ndim, size, i, nitem, err; 1096 pword *p, *pp, *spw; 1097 type tag; 1098 dident arraydid; 1099 uword *w; 1100 int header_size; 1101 int scope = (vscope.did == d_.local0 ? LOCAL_PROP : GLOBAL_PROP); 1102 1103 Check_Module(tmod, vmod); 1104 Check_Module_Access(vmod, tmod); 1105 /* no need to check for tscope, system use only */ 1106 1107 if (IsAtom(t) || IsNil(t)) /* global variable */ 1108 { 1109 dident wd; 1110 pword init_pw; 1111 1112 if (IsNil(t)) 1113 wd = d_.nil; 1114 else 1115 wd = v.did; 1116 1117#ifdef GLOBALREFS_ARE_ECREFS 1118 if (IsStructure(tt) && vt.ptr[0].val.did == d_reference1_) 1119 { 1120 init_pw = vt.ptr[1]; 1121 err = ec_constant_table_enter(vt.ptr[1].val, vt.ptr[1].tag, &init_pw); 1122 if (err != PSUCCEED) 1123 { 1124 Bip_Error(err == PFAIL ? UNIMPLEMENTED : err); 1125 } 1126 vt.did = d_global_reference_; 1127 } 1128 else 1129#endif 1130 { 1131 Check_Atom(tt); 1132 Make_Integer(&init_pw, 0); 1133 } 1134#ifdef GLOBALREFS_ARE_ECREFS 1135 if (vt.did == d_global_reference_index_) 1136#else 1137 if (vt.did == d_global_reference_index_ 1138 || vt.did == d_global_reference_) 1139#endif 1140 { 1141 if (GlobalVarIndex >= GLOBAL_VARS_NO) { 1142 Bip_Error(RANGE_ERROR); 1143 } 1144 } 1145#ifdef GLOBALREFS_ARE_ECREFS 1146 else if (vt.did != d_global_reference_ && vt.did != d_.prolog) 1147#else 1148 else if (vt.did != d_.prolog) 1149#endif 1150 { 1151 Bip_Error(RANGE_ERROR); 1152 } 1153 if (VisibleAV(wd, GLOBVAR_PROP, vmod.did, tmod, &err)) { 1154 Bip_Error(ARRAY_EXISTS); 1155 } 1156 a_mutex_lock(&PropertyLock); 1157 if (!(p = NewGlobVarItem(wd, vmod.did, tmod, scope, &err))) 1158 { 1159 /* trying to define a global when there is a global or 1160 a local when there is a local here */ 1161 a_mutex_unlock(&PropertyLock); 1162 Bip_Error(ARRAY_EXISTS); 1163 } 1164#ifdef GLOBALREFS_ARE_ECREFS 1165 if (vt.did == d_global_reference_) 1166 { 1167 p->val.wptr = (uword *) ec_ref_create(init_pw); 1168 p->tag.kernel = GlobalPrologRefTag; 1169 } else if (vt.did == d_global_reference_index_) 1170#else 1171 if (vt.did == d_global_reference_ 1172 || vt.did == d_global_reference_index_) 1173#endif 1174 { 1175 p->val.nint = GlobalVarIndex; 1176 GlobalVarIndex++; 1177 p->tag.kernel = GlobalPrologRefIndexTag; 1178 } else { 1179 p->val.ptr = p; 1180 p->tag.kernel = TREF; 1181 } 1182 a_mutex_unlock(&PropertyLock); 1183 Succeed_; 1184 } 1185 else if (IsList(t)) 1186 { 1187 arraydid = d_.list; 1188 } 1189 else 1190 { 1191 Check_Structure(t); 1192 arraydid = v.ptr->val.did; 1193 } 1194 1195 Check_Atom(tt); 1196 if (vt.did == d_.prolog) 1197 { 1198 tag.kernel = TCOMP; 1199 size = sizeof(pword); 1200 } 1201 else if(vt.did == d_.byte) 1202 { 1203 tag.kernel = TSTRG; 1204 size = 1; 1205 } 1206 else if(vt.did == d_.integer0) 1207 { 1208 tag.kernel = TINT; 1209 size = sizeof(word); 1210 } 1211 else if(vt.did == d_.float0) 1212 { 1213 tag.kernel = TDBL; 1214 size = sizeof(double); 1215 } 1216 else 1217 { 1218 Bip_Error(RANGE_ERROR); 1219 } 1220 1221 ndim = DidArity(arraydid); 1222 nitem = 1; 1223 1224 /* compute the number of items which will be held by the array */ 1225 if (IsList(t)) 1226 p = v.ptr - 1; 1227 else 1228 p = v.ptr; 1229 for(i = 0; i < ndim; i++) 1230 { 1231 spw = ++p; 1232 Dereference_(spw); 1233 Check_Integer(spw->tag); 1234 if (spw->val.nint <= 0) 1235 { 1236 Bip_Error(RANGE_ERROR); 1237 } 1238 nitem *= spw->val.nint; 1239 } 1240 1241 /* We might need padding to properly align the array */ 1242 header_size = RoundUp((ndim+1)*sizeof(uword)); 1243 1244 a_mutex_lock(&PropertyLock); 1245 if (!(p = NewArrayItem(arraydid, vmod.did, tmod, scope, &err))) 1246 { 1247 /* trying to define a global when there is a global or 1248 a local when there is a local here */ 1249 a_mutex_unlock(&PropertyLock); 1250 Bip_Error(ARRAY_EXISTS); 1251 } 1252 1253 /* grab space for this array */ 1254 p->tag.all = tag.all; /* type of the array */ 1255 p->val.ptr = (pword *)hg_alloc(size*nitem + header_size); 1256 p = p->val.ptr; 1257 /* initialize the header of the array */ 1258 1259 p->val.did = arraydid; /* thus backward pointer and 1260 the number of dimensions */ 1261 w = ((uword *) p) + 1; /* skip did information */ 1262 1263 if (IsList(t)) 1264 pp = v.ptr - 1; 1265 else 1266 pp = v.ptr; 1267 for(i = 0; i < ndim; i++) 1268 { 1269 spw = ++pp; 1270 Dereference_(spw); 1271 *w++ = spw->val.nint; /* size of each dimension */ 1272 } 1273 1274 /* initialize the elements */ 1275 w = (uword *)p + header_size/sizeof(uword); 1276 switch (tag.kernel) 1277 { 1278 case TCOMP: 1279 p = (pword *) w; 1280 for(i = 0; i < nitem; i++) 1281 { 1282 p->val.ptr = p; 1283 (p++)->tag.kernel = TREF; 1284 } 1285 break; 1286 case TSTRG: 1287 { 1288 unsigned char *s = (unsigned char *) w; 1289 for(i = 0; i < nitem ; i++) *s++ = 0; 1290 } 1291 break; 1292 case TINT: 1293 { 1294 word *s = (word *) w; 1295 for(i = 0; i < nitem ; i++) *s++ = 0; 1296 } 1297 break; 1298 case TDBL: 1299 { 1300 double *s = (double *) w; 1301 for(i = 0; i < nitem ; i++) *s++ = 0.0; 1302 } 1303 break; 1304 } 1305 a_mutex_unlock(&PropertyLock); 1306 Succeed_; 1307} 1308