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_load.c,v 1.3 2012/02/11 17:09:31 jschimpf Exp $ 25 */ 26 27/**************************************************************************** 28 * 29 * SEPIA Built-in Predicates for dynamic loading 30 * 31 * 32 *****************************************************************************/ 33 34#include "config.h" 35 36#ifdef _WIN32 37#include <windows.h> 38#else 39#include <sys/types.h> 40#include <stdio.h> 41#include <errno.h> 42#include <fcntl.h> 43#ifdef HAVE_UNISTD_H 44# include <unistd.h> 45#endif 46#endif 47 48#ifdef STDC_HEADERS 49#include <stdlib.h> 50#else 51extern char *getenv(); 52#endif 53 54#ifdef HAVE_STRING_H 55#include <string.h> 56#else 57extern char *strcpy(); 58#endif 59 60#include "sepia.h" 61#include "types.h" 62#include "embed.h" 63#include "mem.h" 64#include "dict.h" 65#include "emu_export.h" 66#include "error.h" 67#include "opcode.h" 68#include "ec_io.h" 69#include "property.h" 70#include "module.h" 71#include "os_support.h" 72 73#ifdef SBRK_UNDEF 74extern char *sbrk(); 75#endif 76 77#if defined(HAVE_DLOPEN) || defined(HAVE_NLIST) || defined(_WIN32) || defined(HAVE_MACH_O_DYLD_H) 78#define D_DEF 79#endif 80 81#if defined(HAVE_DLOPEN) || defined(_WIN32) || defined(D_LOAD) || defined(HAVE_MACH_O_DYLD_H) 82# ifndef D_LOAD 83# define D_LOAD 84# endif 85#endif 86 87/* We consider BSD-type dynamic loading with ld -A, or SVR4 88 * dynamic linking or AIX (IBM rs6000) using load() 89 */ 90 91#if (defined(HAVE_DLOPEN) && !defined(sun4_0)) || defined(HAVE_MACH_O_DYLD_H) 92# define OS_SUPPORTS_DL 93#endif 94 95#if defined(HAVE_DLOPEN) && !defined(sun4_0) 96# include <dlfcn.h> 97#elif defined(HAVE_MACH_O_DYLD_H) 98# include "dlfcn_simple.h" 99#else 100#ifndef _WIN32 101# if defined(D_LOAD) || defined(D_DEF) 102# include <sys/file.h> 103# include <a.out.h> 104 105# ifdef hpux 106# define N_TXTOFF(f, hr) hr.exec_tfile 107# define TD_SIZE(hr) (hr.exec_tsize + hr.exec_dsize) 108# define BS_SIZE(hr) (hr.exec_bsize) 109# define FileHeader header 110# define AoutHeader som_exec_auxhdr 111# else 112# if defined(mips) || defined(__alpha) 113# define TD_SIZE(hr) (hr.tsize + hr.dsize) 114# define BS_SIZE(hr) (hr.bsize) 115# define FileHeader filehdr 116# define AoutHeader aouthdr 117# else 118# define TD_SIZE(hr) (hr.a_text + hr.a_data) 119# define BS_SIZE(hr) (hr.a_bss) 120# define AoutHeader exec 121# endif 122# endif 123# endif /* D_LOAD || D_DEF */ 124#endif /* _WIN32 */ 125#endif /* HAVE_DLOPEN */ 126 127 128#define SEPIA_TMP "/tmp" 129 130unsigned ec_vers = 0; 131 132pword *p_whoami_; 133pword *p_binary_; 134 135dident d_hostarch_; 136 137 138#if defined(D_LOAD) && defined(D_DEF) 139 140/**************************************************************** 141 * Dynamic loading and related 142 ****************************************************************/ 143 144 145/* 146 * p_load() dload(file + options) 147 * dynamic loading of an object file. 148 * MUCH system dependent 149 */ 150 151#ifdef _WIN32 152 153struct dload_info { 154 HINSTANCE handle; 155 struct dload_info *next; 156}; 157 158static struct dload_info *dload_list = 0; 159 160static int 161p_load(v, t) 162value v; 163type t; 164{ 165 char *name; 166 char buf1[MAX_PATH_LEN]; 167 char winname[MAX_PATH_LEN]; 168 HINSTANCE dloaded; 169 struct dload_info *dli; 170 171 Get_Name(v,t,name) /* get the name of the file */ 172 /* Make an absolute pathname, needed on Windows 95 */ 173 name = expand_filename(name, buf1, EXPAND_ABSOLUTE); 174 dloaded = LoadLibrary(os_filename(name, winname)); 175 if (!dloaded) 176 { 177 Set_Sys_Errno(GetLastError(), ERRNO_WIN32) 178 Bip_Error(SYS_ERROR); 179 } 180 dli = (struct dload_info *) hp_alloc_size(sizeof(struct dload_info)); 181 dli->handle = dloaded; 182 dli->next = dload_list; 183 dload_list = dli; 184 Succeed_; 185} 186 187void 188bip_load_fini(void) 189{ 190 while (dload_list) 191 { 192 struct dload_info *dli = dload_list; 193 dload_list = dli->next; 194 (void) FreeLibrary(dli->handle); 195 hp_free_size(dli, sizeof(struct dload_info)); 196 } 197} 198 199#else 200#ifdef OS_SUPPORTS_DL 201 202#ifndef RTLD_GLOBAL 203#define RTLD_GLOBAL 0 204#endif 205/* 206 * We have operating system support for dynamic loading, which 207 * makes things simpler. The object to be loaded must be a 208 * shared object. Compile it with 209 * 210 * cc -I... -G -o <name>.so name.c 211 */ 212 213/* 214 * Remember the loaded objects in dload_list, which will be used 215 * by external/2 and symbol_address/2. 216 */ 217 218struct dload_info { 219 void *handle; 220 struct dload_info *next; 221}; 222 223static struct dload_info *dload_list = 0; 224 225 226static int 227p_load(value v, type t) 228{ 229 char buf1[MAX_PATH_LEN]; 230 char *name; 231 void *dloaded; 232 struct dload_info *dli; 233 234 Get_Name(v,t,name) /* get the name of the file */ 235 /* Make an absolute pathname because dlopen sometimes 236 * seems to have a wrong idea of the cwd. 237 */ 238 name = expand_filename(name, buf1, EXPAND_ABSOLUTE); 239 dloaded = dlopen(name, RTLD_NOW|RTLD_GLOBAL); 240 if (!dloaded) 241 { 242 ec_outfs(current_err_, dlerror()); ec_newline(current_err_); 243 Bip_Error(NO_SHARED_LIB); 244 } 245 dli = (struct dload_info *) hp_alloc_size(sizeof(struct dload_info)); 246 dli->handle = dloaded; 247 dli->next = dload_list; 248 dload_list = dli; 249 Succeed_; 250} 251 252void 253bip_load_fini(void) 254{ 255 while (dload_list) 256 { 257 struct dload_info *dli = dload_list; 258 dload_list = dli->next; 259 (void) dlclose(dli->handle); 260 hp_free_size(dli, sizeof(struct dload_info)); 261 } 262} 263 264#else /*!OS_SUPPORTS_DL */ 265#ifdef _AIX 266/* In AIX we have to keep track of each dynamically loaded file in order 267to use nlist with it in ec_getaddress(). */ 268 269struct dload_info { 270 char *filename; 271 char *entryproc; 272 void (*funcp)(); 273 struct dload_info *next; 274}; 275 276static struct dload_info *dload_list; 277 278static int 279p_load(value v, type t) 280{ 281 char *name; 282 int res; 283 char fullname[MAX_PATH_LEN]; 284 long tsize; 285 char *tmpdir; 286 char *loader; 287 288 Get_Name(v,t,name) /* get the name of the file */ 289 name = expand_filename(name, fullname, EXPAND_ABSOLUTE); 290 if(!IsString(p_whoami_->tag)) { 291 Bip_Error(TYPE_ERROR) 292 } 293 /* identifier for temporary */ 294 tmpdir = getenv("ECLIPSETMP"); 295 if (!tmpdir) 296 tmpdir = SEPIA_TMP; 297 loader = getenv("ECLIPSELOADER"); 298 if (!loader) 299 loader = "ld"; 300 301 res = _load_once(loader, name, tmpdir); 302 if (res < 0) 303 { 304 Bip_Error(res); 305 } 306 ec_vers++; 307 return(PSUCCEED); 308} 309 310_load_once(char *loader, char *vstr, char *tmpdir) 311{ 312 FILE *f; 313 extern int sys_nerr; 314 int res; 315 char buf[1024]; /* buf will hold the loader command */ 316 char *temp, *entryproc; 317 char dummy[MAX_PATH_LEN + 30]; 318 char expsympath[1024], tmpsympath[1024]; 319 void (*funcp)(); 320 struct dload_info *cur; 321 322 temp = (char *) hg_alloc(MAX_PATH_LEN + 30); 323 entryproc = (char *) hg_alloc(MAX_PATH_LEN + 30); 324 325 (void) sprintf(temp, "%s/eclipse.%d.%d", tmpdir, getpid(), ec_vers); 326 /* file which will hold linked code */ 327 (void) sprintf(dummy,"%s/eclipse_dummy.%d.%d",tmpdir,getpid(),ec_vers); 328 /* dummy file needed to defiine a 329 known entry point */ 330 (void) sprintf(entryproc,"eclipse_dummy_entry%d",ec_vers); 331 /* name of entry procedure */ 332 333 /* create dummy entry proc */ 334 335 if(!(f = fopen(dummy,"w"))) 336 { 337 if (!errno) 338 errno = sys_nerr; 339 Set_Errno 340 return(SYS_ERROR); 341 } 342 343 (void) fprintf(f,"int %s() \n { return(0); } \n",entryproc); 344 (void) fclose(f); 345 346 (void) sprintf(buf,"cd %s; mv %s %s.c; cc -c %s.c; /bin/rm %s.c\n", 347 tmpdir, dummy, dummy, dummy, dummy); 348 349 strcat(dummy,".o"); 350 res = system(buf); 351 if (res != 0) { 352 (void) unlink(dummy); 353 Set_Errno 354 return(SYS_ERROR); 355 } 356 357 (void) sprintf(tmpsympath, "%s/tmpsymXXXXXX",tmpdir); 358 mktemp(tmpsympath); 359 360 { 361 pword *library; 362 Get_Kernel_Var(in_dict("library",0), library); 363 364 /* the loader command we will execute */ 365 (void) sprintf(buf,"echo \"#! %s\" > %s; cat %s/%s/%s>>%s; %s -H512 -T512 %s %s -e %s -bI:%s -bfl -bgcbypass:2 -o %s -lc", 366 StringStart(p_whoami_->val),tmpsympath, 367 StringStart(library->val), HOSTARCH, "expsymtab", tmpsympath, 368 loader,dummy,vstr,entryproc, tmpsympath,temp); 369 } 370 371 res = system(buf); 372 (void) unlink(dummy); 373 (void) unlink(tmpsympath); 374 375 if(res != 0) { 376 (void) unlink(temp); /* if there was a problem, remove temporary */ 377 if (!errno) 378 errno = sys_nerr; 379 Set_Errno 380 return(SYS_ERROR); 381 } /* everything was ok */ 382 383 /* Now dynamically link code in temp using load() */ 384 if (!(funcp=(void (*)())load(temp, 0, NULL))) 385 { 386 (void) unlink(temp); 387 Set_Errno 388 return(SYS_ERROR); 389 } 390 391 /* keep track of the loaded file and its entrypoint */ 392 if (ec_vers == 0) 393 { 394 dload_list = (struct dload_info *) 395 hg_alloc(sizeof(struct dload_info)); 396 cur = dload_list; 397 cur->next = NULL; 398 } 399 else 400 { 401 cur = (struct dload_info *) 402 hg_alloc(sizeof(struct dload_info)); 403 cur->next = dload_list; 404 dload_list = cur; 405 } 406 cur->filename = temp; 407 cur->funcp = funcp; 408 cur->entryproc = entryproc; 409 return PSUCCEED; 410} 411 412void 413bip_load_fini() 414{ 415 if (ec_vers > 0) 416 { 417 struct dload_info *cur = dload_list; 418 419 while(cur != NULL) 420 { 421 unlink(cur->filename); 422 cur = cur->next; 423 } 424 } 425} 426 427#else 428 429static generic_ptr dload_list = 0; 430 431static int 432p_load(value v, type t) 433{ 434 char *name; 435 char *end; 436 int size, res; 437 int fd; 438 char buf[1024]; /* buf will hold the loader command */ 439 char temp[MAX_PATH_LEN + 30]; 440 char fullname[MAX_PATH_LEN]; 441 long tsize; 442 char *tmpdir; 443 char *loader; 444 445 Get_Name(v,t,name) /* get the name of the file */ 446 name = expand_filename(name, fullname, EXPAND_ABSOLUTE); 447 if(!IsString(p_whoami_->tag)) { 448 Bip_Error(TYPE_ERROR) 449 } 450 end = (char *) sbrk(0); /* end of memory */ 451 /* identifier for temporary */ 452 tmpdir = getenv("ECLIPSETMP"); 453 if (!tmpdir) 454 tmpdir = SEPIA_TMP; 455 loader = getenv("ECLIPSELOADER"); 456 if (!loader) 457 loader = "ld"; 458 (void) sprintf(temp, "%s/eclipse.%d.%d", tmpdir, getpid(), ec_vers); 459 /* file which will keep the symbol */ 460 /* table and the linked code */ 461 res = _load_once(buf, loader, end, name, temp, &size, &tsize, &fd); 462 if (res < 0) 463 { 464 Bip_Error(res); 465 } 466 467 end = (char *) sbrk((int) tsize); 468 469 if(size != read(fd, end, size)) /* read in the code */ 470 { 471 (void) close(fd); 472 (void) unlink(temp); 473 Set_Errno 474 Bip_Error(SYS_ERROR) 475 } 476 (void) close(fd); /* that is all */ 477 478 if (ec_vers > 0) /* remove previous temporary if any */ 479 (void) unlink(StringStart(p_whoami_->val)); 480 481 free_heapterm(p_whoami_); 482 set_string(p_whoami_, temp); 483 ec_vers++; 484 return(PSUCCEED); 485} 486 487_load_once(char buf[], char *loader, char *end, char *vstr, char *temp, 488 int *size, long *tsize, int *fd) 489{ 490 extern int sys_nerr; 491 int res; 492#ifdef FileHeader 493 struct FileHeader filehdr; 494#endif 495 struct AoutHeader hr; 496 497 /* the loader command we will execute */ 498 /* "-N" needed to avoid wasting space and avoid alignment problems */ 499#ifdef sun4_0 500/* 501 * There is a bug in SUNOS 4.0: when a file is dynamically loaded with 502 * ld -A, the new symbol table which is created contains a wrong 503 * _DYNAMIC_ symbol so that when a savecore with this table is made, 504 * dbx is unable to work on the resulting binary. We fix it by loading 505 * the file aux.o which contains a reference to the _DYNAMIC_ symbol 506 * so that it is defined in the new symbol table. 507 */ 508 { 509 pword *library; 510 Get_Kernel_Var(in_dict("library",0), library); 511 512 (void) sprintf(buf, 513 "%s -N -A %s -T %x -o %s %s/%s/%s %s -lc 1>&2", 514 loader, 515 StringStart(p_whoami_->val), end, temp, 516 StringStart(library->val), HOSTARCH, "auxiliary.o", vstr); 517 } 518#else 519 (void) sprintf(buf, 520#ifdef hpux 521 "%s -a archive -N -A %s -R %x -o %s %s /lib/dyncall.o -lc 1>&2", 522#else 523 "%s -N -A %s -T %x -o %s %s -lc 1>&2", 524#endif 525 loader, 526 StringStart(p_whoami_->val), end, temp, vstr); 527#endif 528 res = system(buf); 529 if(res != 0) { 530 (void) unlink(temp); /* if there was a problem, remove temporary */ 531 if (!errno) 532 errno = sys_nerr; 533 Set_Errno 534 return(SYS_ERROR); 535 } /* everything was ok */ 536 if((*fd = open(temp, O_RDWR)) < 0) { /* try to open temp */ 537 Set_Errno 538 return(SYS_ERROR); 539 } 540 541 /* read in the header information */ 542#ifdef FileHeader 543 (void) read(*fd, (char *) &filehdr, sizeof(filehdr)); 544 (void) read(*fd, (char *) &hr, sizeof(hr)); 545 (void) lseek(*fd, (long) N_TXTOFF(filehdr, hr), L_SET); 546#else 547 (void) read(*fd, (char *) &hr, sizeof(hr)); 548 (void) lseek(*fd, (long) N_TXTOFF(hr), L_SET); 549#endif 550 *size = TD_SIZE(hr); 551 *tsize = (((*size + BS_SIZE(hr)) + 511)/ 512) * 512; 552 return PSUCCEED; 553} 554 555void 556bip_load_fini() 557{ 558 if (IsString(p_whoami_->tag) && ec_vers > 0) 559 (void) unlink(StringStart(p_whoami_->val)); 560} 561 562#endif /* _AIX */ 563#endif /* OS_SUPPORTS_DL */ 564#endif /* _WIN32 */ 565 566#else /* D_LOAD && D_DEF */ 567Not_Available_Built_In(p_load) 568#endif /* D_LOAD && D_DEF */ 569 570 571 572#ifdef D_DEF 573 574/**************************************************************** 575 * Dynamic definitions and related 576 ****************************************************************/ 577 578/* 579 * ec_getaddress(function_name) 580 * fetch the address of a symbol from the symbol table 581 * returns -1 if it was not possible. 582 */ 583 584#ifdef _WIN32 585 586word 587ec_getaddress(char *s) 588{ 589 struct dload_info *dli; 590 591 for (dli = dload_list; dli; dli = dli->next) 592 { 593 word addr = (word) GetProcAddress(dli->handle, s); 594 if (addr) 595 return addr; 596 } 597 return (word) 0; 598} 599 600#else 601#ifdef OS_SUPPORTS_DL 602 603static void *myself = (void *) 0; 604 605word 606ec_getaddress(char *s) 607{ 608 word addr = 0; 609 610 if (!myself) 611 { 612 if (!(myself = dlopen((char *) 0, RTLD_LAZY))) 613 { 614 return 0; 615 } 616 } 617 addr = (word) dlsym(myself, s); 618 if (!addr) 619 { 620 struct dload_info *dli; 621 for (dli = dload_list; dli; dli = dli->next) 622 { 623 addr = (word) dlsym(dli->handle, s); 624 if (addr) 625 return addr; 626 } 627 } 628 return addr; 629} 630 631#else 632#ifdef _AIX 633/* For AIX we have to return a function descriptor which contains 634not only the address of the function, but also the location of 635the table of contents (toc). */ 636 637struct func_descriptor { 638 int address; 639 int toc; 640}; 641 642word 643ec_getaddress(char *s) 644{ 645 struct nlist lis[4]; 646 struct func_descriptor *fdesc; 647 extern char _text[ ], _data[ ]; 648 int found = 0; 649 int n = strlen(s); 650 uword *wp = (uword *) hg_alloc( n + 2); 651 char *p = (char *) wp; 652 653 *p = '.'; 654 (void) strcpy(p + 1, s); 655 656 lis[0].n_value = 0; 657 lis[0].n_name = p; 658 lis[1].n_value = 0; 659 lis[1].n_name = "_text"; 660 lis[2].n_value = 0; 661 lis[2].n_name = "TOC"; 662 lis[3].n_name = ""; 663 n = nlist(StringStart(p_whoami_->val),lis); 664 if (lis[0].n_value && lis[1].n_value && lis[2].n_value) 665 { 666 fdesc = (struct func_descriptor *) 667 hg_alloc(sizeof(struct func_descriptor)); 668 fdesc->address = (int) _text + lis[0].n_value - lis[1].n_value; 669 fdesc->toc = (int) _data + lis[2].n_value; 670 found = 1; 671 } 672#ifdef D_LOAD 673 if (!found && (ec_vers > 0)) /* a dynamic load has been performed */ 674 { 675 struct dload_info *cur = dload_list; 676 while ((!found) && cur) 677 { 678 char *real_entryproc = (char *) 679 hg_alloc((long)strlen(cur->entryproc) + 2); 680 681 *real_entryproc = '.'; 682 (void) strcpy(real_entryproc + 1, cur->entryproc); 683 684 lis[0].n_value = 0; 685 lis[0].n_name = real_entryproc; 686 lis[1].n_value = 0; 687 lis[1].n_name = p; 688 lis[2].n_name = ""; 689 690 n = nlist(cur->filename,lis); 691 if (lis[0].n_value && lis[1].n_value) 692 { 693 int temp; 694 695 fdesc = (struct func_descriptor *) 696 hg_alloc(sizeof(struct func_descriptor)); 697 fdesc->address = (* (int *) (cur->funcp)) + 698 lis[1].n_value - lis[0].n_value; 699 temp = (int) (cur->funcp); 700 fdesc->toc = *(((int *) temp) + 1); 701 found = 1; 702 } 703 else 704 cur = cur->next; 705 hg_free(real_entryproc); 706 } 707 } 708#endif 709 hg_free(wp); 710 if (found) 711 return( (int) fdesc); 712 else 713 return 0; 714 } 715 716#else 717 718word 719ec_getaddress(char *s) 720{ 721 struct nlist lis[2]; 722 lis[0].n_value = 0; 723 lis[0].N_NAME = s; 724 lis[1].N_NAME = 0; 725 726 if(nlist(StringStart(p_whoami_->val), lis) < 0 || lis[0].n_value == 0) 727 { 728 int n = strlen(s); 729 uword *wp = (uword *) hg_alloc(n + 2); 730 char *p = (char *) wp; 731 *p = '_'; 732 (void) strcpy(p + 1, s); 733 lis[0].n_value = 0; 734 lis[0].N_NAME = p; 735 lis[1].N_NAME = 0; 736 n = nlist(StringStart(p_whoami_->val), lis); 737 hg_free((generic_ptr) wp); 738 if(n < 0 || lis[0].n_value == 0) 739 return 0; 740 } 741 return(lis[0].n_value); 742} 743 744#endif 745#endif 746#endif 747 748/* 749 * p_call_c() call_c(foo(a1,...an),Value) 750 * calls the function whose system name is foo after 751 * translating the arguments, and 752 * unifies Value with the value returned by the function, taken as 753 * an integer. 754 */ 755 756#define MAX_CALL_C_ARITY 10 757static int 758p_call_c(value v, type t, value vr, type tr) 759{ 760 word foo, aux; 761 int arity; 762 pword *p, *pw; 763 value arg[MAX_CALL_C_ARITY]; 764 dident mydid; 765 double f; 766 int res_type; 767 value resv; 768 type rest; 769 770 Error_If_Ref(t) 771 if (IsStructure(tr)) { 772 mydid = vr.ptr->val.did; 773 if (mydid == d_.float1) 774 res_type = TDBL; 775 else if (mydid == d_.integer) 776 res_type = TINT; 777 else if (mydid == d_.string) 778 res_type = TSTRG; 779 else { 780 Bip_Error(RANGE_ERROR) 781 } 782 resv.all = vr.ptr[1].val.all; 783 rest.all = vr.ptr[1].tag.all; 784 } 785 else if (IsRef(tr) || IsInteger(tr)) { 786 res_type = TINT; 787 resv.all = vr.all; 788 rest.all = tr.all; 789 } 790 else { 791 Bip_Error(TYPE_ERROR) 792 } 793 if(IsStructure(t)) 794 mydid = v.ptr->val.did; 795 else if(IsAtom(t)) 796 mydid = v.did; 797 else 798 { 799 Bip_Error(TYPE_ERROR); 800 } 801 arity = DidArity(mydid); 802 mydid = add_dict(mydid, 0); 803 if(pw = get_property(mydid, SYSCALL_PROP)) 804 { 805 if(IsInteger(pw->tag)) 806 { 807 foo = pw->val.nint; 808 } 809 else 810 { 811 foo = ec_getaddress(DidName(mydid)); 812 if(!foo) 813 { 814 Bip_Error(NOCODE); 815 } 816 pw->tag.kernel = TINT; 817 pw->val.nint = foo; 818 } 819 } 820 else 821 { 822 foo = ec_getaddress(DidName(mydid)); 823 if(!foo) 824 { 825 Bip_Error(NOCODE); 826 } 827 pw = set_property(mydid, SYSCALL_PROP); 828 pw->tag.kernel = TINT; 829 pw->val.nint = foo; 830 } 831 aux = 0; 832 /* arguments translation */ 833 while(arity-- > 0) 834 { 835 p = ++(v.ptr); 836 Dereference_(p) 837 if(IsRef(p->tag)) 838 { 839 Bip_Error(TYPE_ERROR); 840 } 841 else 842 { 843 switch (TagType(p->tag)) 844 { 845 case TINT: 846 arg[aux++] = p->val; 847 break; 848 849 case TDBL: 850 arg[aux++].nint = ((long *) &Dbl(p->val))[0]; 851 arg[aux++].nint = ((long *) &Dbl(p->val))[1]; 852 break; 853 854 case TSTRG: 855 arg[aux++].str = StringStart(p->val); 856 break; 857 case TDICT: 858 arg[aux++].str = DidName(p->val.did); 859 break; 860 case TCOMP: 861 { 862 uword kind, size; 863 int err; 864 word res; 865 type tm; 866 867 tm.kernel = ModuleTag(d_.kernel_sepia); 868 869 p = p->val.ptr; 870 if(p->val.did == d_.quotient) 871 { 872 res = get_first_elt(p+1, p+2, &kind, &size, 873 d_.kernel_sepia, tm); 874 if (res < 0) 875 { 876 Bip_Error(res); 877 } 878 } 879 else 880 { 881 value v1; 882 883 v1.all = (word) p; 884 res = (word) get_elt_address(v1, tcomp, &kind, 885 d_.kernel_sepia, tm, &err); 886 if (!res) 887 { 888 Bip_Error(err); 889 } 890 } 891 arg[aux++].nint = res; 892 } 893 break; 894 895 default: 896 Bip_Error(TYPE_ERROR) 897 } 898 } 899 } 900 if (res_type == TDBL) 901 switch(aux) { 902 case 0: f = (* (double (*)()) foo)(); 903 break; 904 case 1: f = (* (double (*)()) foo)(arg[0].nint); 905 break; 906 case 2: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint); 907 break; 908 case 3: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint, 909 arg[2].nint); 910 break; 911 case 4: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint, 912 arg[2].nint, arg[3].nint); 913 break; 914 case 5: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint, 915 arg[2].nint, arg[3].nint,arg[4].nint); 916 break; 917 case 6: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint, 918 arg[2].nint, arg[3].nint,arg[4].nint, arg[5].nint); 919 break; 920 case 7: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint, 921 arg[2].nint, arg[3].nint,arg[4].nint, arg[5].nint, 922 arg[6].nint); 923 break; 924 case 8: 925 case 9: 926 case 10: f = (* (double (*)()) foo)(arg[0].nint,arg[1].nint, 927 arg[2].nint,arg[3].nint,arg[4].nint, arg[5].nint, 928 arg[6].nint,arg[7].nint, arg[8].nint,arg[9].nint); 929 break; 930 default: 931 Bip_Error(ARITY_LIMIT) 932 } 933 else 934 switch(aux) { 935 case 0: aux = (* (int (*)()) foo)(); 936 break; 937 case 1: aux = (* (int (*)()) foo)(arg[0].nint); 938 break; 939 case 2: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint); 940 break; 941 case 3: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint, 942 arg[2].nint); 943 break; 944 case 4: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint, 945 arg[2].nint, arg[3].nint); 946 break; 947 case 5: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint, 948 arg[2].nint, arg[3].nint,arg[4].nint); 949 break; 950 case 6: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint, 951 arg[2].nint, arg[3].nint,arg[4].nint, arg[5].nint); 952 break; 953 case 7: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint, 954 arg[2].nint, arg[3].nint,arg[4].nint, arg[5].nint, 955 arg[6].nint); 956 break; 957 case 8: 958 case 9: 959 case 10: aux = (* (int (*)()) foo)(arg[0].nint,arg[1].nint, 960 arg[2].nint,arg[3].nint,arg[4].nint, arg[5].nint, 961 arg[6].nint,arg[7].nint, arg[8].nint,arg[9].nint); 962 break; 963 default: 964 Bip_Error(ARITY_LIMIT) 965 } 966 Set_Errno; /* in case something went wrong */ 967 if (res_type == TINT) { 968 Return_Unify_Integer(resv, rest, aux); 969 } else if (res_type == TDBL) { 970 Return_Unify_Float(resv, rest, f); 971 } 972 else /* if (res_type == TSTRG) */ 973 { 974 value sv; 975 Cstring_To_Prolog((char *) aux, sv); 976 Return_Unify_String(resv, rest, sv.ptr); 977 } 978} 979 980static int 981p_symbol_address(value vals, type tags, value vala, type taga) 982{ 983 char *name; 984 word symbol; 985 986 Get_Name(vals, tags, name); 987 Check_Output_Integer(taga); 988 symbol = ec_getaddress(name); 989 if (!symbol) 990 { 991 Fail_; 992 } 993 Return_Unify_Integer(vala, taga, symbol); 994} 995 996#else /* D_DEF */ 997Not_Available_Built_In(p_symbol_address) 998Not_Available_Built_In(p_call_c) 999#endif /* D_DEF */ 1000 1001 1002 1003/* 1004 * Licence checking 1005 * 1006 * If there is a pteclipse.so library, we load it dynamically. 1007 * It contains proper definitions of licence_checkout/6 etc. 1008 * If there is no pteclipse.so, we use the dummies defined here. 1009 */ 1010 1011/*ARGSUSED*/ 1012static int 1013p_licence_checkout(value vfeature, type tfeature, value vpol, type tpol, value vversion, type tversion, value vlicloc, type tlicloc, value vmsg, type tmsg, value vstat, type tstat) 1014{ 1015 pword pw; 1016 Prepare_Requests; 1017 Make_String(&pw, "ECLiPSe licence check failed\n"); 1018 Request_Unify_Pw(vmsg, tmsg, pw.val, pw.tag); 1019 Request_Unify_Atom(vstat, tstat, d_.err); 1020 Return_Unify; 1021} 1022 1023/*ARGSUSED*/ 1024static int 1025p_licence_held(value vfeature, type tfeature) 1026{ 1027 Fail_; 1028} 1029 1030/*ARGSUSED*/ 1031static int 1032p_licence_checkin(value vfeature, type tfeature) 1033{ 1034 Succeed_; 1035} 1036 1037/*ARGSUSED*/ 1038static int 1039p_licence_heartbeat(value vfeature, type tfeature, value vminutes, type tminutes, value vrec, type trec, value vfrec, type tfrec) 1040{ 1041 Fail_; 1042} 1043 1044 1045static void 1046_pt_init(int flags) 1047{ 1048 char pteclipse[MAX_PATH_LEN]; 1049 1050 /* these are the dummies - they may be replaced by pteclipse */ 1051 (void) exported_built_in(in_dict("licence_checkout", 6), p_licence_checkout, B_UNSAFE|U_SIMPLE); 1052 (void) exported_built_in(in_dict("licence_checkin", 1), p_licence_checkin, B_SAFE); 1053 (void) exported_built_in(in_dict("licence_heartbeat", 4), p_licence_heartbeat, B_SAFE); 1054 (void) exported_built_in(in_dict("licence_held", 1), p_licence_held, B_SAFE); 1055 1056 strcpy(pteclipse, ec_eclipse_home); /* check for pteclipse lib */ 1057 strcat(pteclipse, "/lib/"); 1058 strcat(pteclipse, HOSTARCH); 1059 strcat(pteclipse, "/pteclipse."); 1060 strcat(pteclipse, OBJECT_SUFFIX_STRING); 1061 if (ec_access(pteclipse, R_OK) == 0) 1062 { 1063 pword pw; 1064 int (*init_fct)(); 1065 1066 Make_Atom(&pw, in_dict(pteclipse,0)); /* load it */ 1067 if (p_load(pw.val, pw.tag) != PSUCCEED) 1068 ec_panic("Can't load library file", pteclipse); 1069 1070 init_fct = (int(*)()) ec_getaddress("pteclipse_init"); 1071 if (!init_fct) 1072 ec_panic("Library file corrupted", pteclipse); 1073 1074 switch ((*init_fct)(flags)) /* initialise */ 1075 { 1076 case PSUCCEED: 1077 return; 1078 case PFAIL: 1079 ec_panic("Licensing problem", "initialisation"); 1080 break; 1081 case UNIMPLEMENTED: 1082 default: 1083 break; /* pteclipse not available, keep the dummies */ 1084 } 1085 } 1086} 1087 1088 1089/**************************************************************** 1090 * Common Initialization and Finalization 1091 ****************************************************************/ 1092 1093void 1094bip_load_init(int flags) 1095{ 1096 value dummy_v1; 1097 1098 if (flags & INIT_SHARED) 1099 { 1100 (void) built_in(in_dict("load",1), p_load, B_SAFE); 1101 (void) exported_built_in(in_dict("symbol_address", 2), 1102 p_symbol_address, B_UNSAFE|U_SIMPLE); 1103 built_in(in_dict("call_c",2), p_call_c, B_UNSAFE|U_SIMPLE) 1104 -> mode = BoundArg(2, CONSTANT); 1105 1106 _pt_init(flags); 1107 } 1108 1109 /* whoami and binary are properly initialized in top.pl */ 1110 dummy_v1.nint = 0; 1111 p_whoami_ = init_kernel_var(flags, in_dict("whoami", 0), dummy_v1, tint); 1112 p_binary_ = init_kernel_var(flags, in_dict("binary", 0), dummy_v1, tint); 1113 1114 d_hostarch_ = in_dict(HOSTARCH, 0); 1115 1116 ec_vers = 0; 1117 1118 dload_list = 0; 1119#ifndef _WIN32 1120#ifdef OS_SUPPORTS_DL 1121 myself = 0; 1122#endif 1123#endif 1124} 1125 1126 1127