Пример #1
0
static pointer cconv(context *ctx, int n, pointer *argv)
{
  iconv_t cd;
  size_t inbytesleft, outbytesleft;
  char *outbufp1, *outbufp2, *instrp;
  size_t ret;
  pointer instr=argv[2], outstr;
  size_t len=vecsize(instr); 

  inbytesleft=len;
  outbytesleft=len*2;
  outbufp1= outbufp2= malloc(outbytesleft);
  instrp= &(instr->c.str.chars[0]);

  /* get acceptable codings by 'iconv --list' */
  /* cd=iconv_open(to_code, from_code); */
  /* cd=iconv_open("Shift_JIS", "EUC-JP"); */
  cd=iconv_open(argv[1]->c.str.chars, argv[0]->c.str.chars);
  if (cd == (iconv_t)-1) { outstr= (pointer)makeint(errno); goto conv_end;}

  ret=iconv(cd, &instrp, &inbytesleft, &outbufp2, &outbytesleft);
  if (ret == -1) { outstr=makeint(-errno); goto conv_end;}
  else  outstr=makestring(outbufp1, len*2-outbytesleft);

  conv_end: 
  iconv_close(cd);
  cfree(outbufp1);
  return(outstr);
  }
Пример #2
0
static u16 global_add(struct global_state *gstate,
		      struct string *name, value val)
{
  struct symbol *pos;
  ivalue old_size, aindex;

  GCCHECK(val);

  GCPRO2(gstate, name);
  old_size = vector_len(gstate->environment->values);
  aindex = env_add_entry(gstate->environment, val);
  if (vector_len(gstate->environment->values) != old_size) /* Increase mvars too */
    {
      struct vector *new_mvars = alloc_vector(vector_len(gstate->environment->values));

      memcpy(new_mvars->data, gstate->mvars->data,
	     gstate->mvars->o.size - sizeof(struct obj));
      gstate->mvars = new_mvars;
    }
  GCPOP(2);
  gstate->mvars->data[aindex] = makeint(var_normal);
  pos = table_add_fast(gstate->global, name, makeint(aindex));
  SET_READONLY(pos); /* index of global vars never changes */

  return aindex;
}
Пример #3
0
/*
  Input:
      Arg1: +Substr
      Arg2: + String
      Arg3: +forward/reverse (checks only f/r)
        f means the first match from the start of String
	r means the first match from the end of String
  Output:
      Arg4: Beg
        Beg is the offset where Substr matches. Must be a variable or an
	integer
      Arg5: End
	End is the offset of the next character after the end of Substr
	Must be a variable or an integer.

      Both Beg and End can be negative, in which case they represent the offset
      from the 2nd character past the end of String.
      For instance, -1 means the next character past the end of String,
      so End = -1 means that Substr must be a suffix of String..

      The meaning of End and of negative offsets is consistent with substring
      and string_substitute predicates.
*/
xsbBool str_match(CTXTdecl)
{
    static char *subptr, *stringptr, *direction, *matchptr;
    static size_t substr_beg, substr_end;
    int reverse=TRUE; /* search in reverse */
    int beg_bos_offset=TRUE; /* measure beg offset from the beg of string */
    int end_bos_offset=TRUE; /* measure end offset from the beg of string */
    Integer str_len, sub_len; /* length of string and substring */
    Cell beg_offset_term, end_offset_term;

    term = ptoc_tag(CTXTc 1);
    term2 = ptoc_tag(CTXTc 2);
    term3 = ptoc_tag(CTXTc 3);
    beg_offset_term = ptoc_tag(CTXTc 4);
    end_offset_term = ptoc_tag(CTXTc 5);
    if (!isatom(term) || !isatom(term2) || !isatom(term3)) {
        xsb_abort("STR_MATCH: Arguments 1,2,3 must be bound to strings");
    }
    subptr = string_val(term);
    stringptr = string_val(term2);
    direction = string_val(term3);

    if (*direction == 'f')
        reverse=FALSE;
    else if (*direction != 'r')
        xsb_abort("STR_MATCH: Argument 3 must be bound to forward/reverse");

    str_len=strlen(stringptr);
    sub_len=strlen(subptr);

    if (isointeger(beg_offset_term)) {
        if (oint_val(beg_offset_term) < 0) {
            beg_bos_offset = FALSE;
        }
    }
    if (isointeger(end_offset_term)) {
        if (oint_val(end_offset_term) < 0) {
            end_bos_offset = FALSE;
        }
    }

    if (reverse)
        matchptr = xsb_strrstr(stringptr, subptr);
    else
        matchptr = strstr(stringptr, subptr);

    if (matchptr == NULL) return FALSE;

    substr_beg = (beg_bos_offset?
                  matchptr - stringptr : -(str_len - (matchptr - stringptr))
                 );
    substr_end = (end_bos_offset?
                  (matchptr - stringptr) + sub_len
                  : -(str_len + 1 - (matchptr - stringptr) - sub_len)
                 );

    return
        (p2p_unify(CTXTc beg_offset_term, makeint(substr_beg))
         && p2p_unify(CTXTc end_offset_term, makeint(substr_end)));
}
Пример #4
0
void motlle_run1(void)
{
  int err = protect(exec, NULL);

  if (err >= 0)
    mthrow(SIGNAL_ERROR, makeint(err));
}
Пример #5
0
void CalculateInfoData()
{
	int i,cn,crewQ;
	ref mchref,chref;

	crewQ = 0;
	mchref = GetMainCharacter();
	for(i=0; i<4; i++)
	{
		cn = GetCompanionIndex(mchref,i);
		if( cn>=0 && GetRemovable(&Characters[cn]) )
		{
			chref = GetCharacter(cn);
			crewQ += GetCrewQuantity(chref);
		}
	}

	int nLeaderShip = GetSummonSkillFromName(mchref,SKILL_LEADERSHIP);
	nPaymentQ = 5 + crewQ*(16-nLeaderShip);
	if( CheckAttribute(mchref,"CrewPayment") ) {
		nPaymentQ += makeint( stf(mchref.CrewPayment)*(11.0-SKILL_LEADERSHIP)/10.0 );
	}

	nMoraleDecreaseQ = 30-nLeaderShip;
	if( CheckCharacterPerk(mchref,"IronWill") ) nMoraleDecreaseQ /= 2;

	CreateString(true,"payment",""+nPaymentQ,FONT_NORMAL,COLOR_NORMAL,320,258,SCRIPT_ALIGN_CENTER,1.0);

	if( sti(mchref.Money) < nPaymentQ )
	{
		SetSelectable("B_OK",false);
		SetCurrentNode("B_CANCEL");
	}
}
Пример #6
0
Statement *ParseCatchStatement()
{
	Statement *snp;
	SYM *sp;
	TYP *tp,*tp1,*tp2;

	snp = NewStatement(st_catch, TRUE);
	if (lastst != openpa) {
		snp->label = NULL;
		snp->s2 = 99999;
		snp->s1 = ParseStatement();
		return snp;
	}
    needpunc(openpa);
	tp = head;
	tp1 = tail;
	catchdecl = TRUE;
	ParseAutoDeclarations();
	catchdecl = FALSE;
	tp2 = head;
	head = tp;
	tail = tp1;
    needpunc(closepa);

	if( (sp = search(declid,&lsyms)) == NULL)
        sp = makeint(declid);
	snp->s1 = ParseStatement();
	snp->label = (char *)sp;	// save off symbol pointer
	if (sp->tp->typeno >= bt_last)
		error(ERR_CATCHSTRUCT);
	snp->s2 = GetTypeHash(sp->tp);
	return snp;
}
int immediate_depends_ptrlist(CTXTdeclc callnodeptr call1){

  VariantSF subgoal;
  int  count = 0;
  CPtr oldhreg = NULL;
  calllistptr cl;

  reg[4] = makelist(hreg);
  new_heap_free(hreg);
  new_heap_free(hreg);
  if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */
    cl= call1->inedges;
    
    while(IsNonNULL(cl)){
      subgoal = (VariantSF) cl->inedge_node->callnode->goal;    
      if(IsNonNULL(subgoal)){/* fact check */
	count++;
	check_glstack_overflow(4,pcreg,2); 
	oldhreg = hreg-2;
	follow(oldhreg++) = makeint(subgoal);
	follow(oldhreg) = makelist(hreg);
	new_heap_free(hreg);
	new_heap_free(hreg);
      }
      cl=cl->next;
    }
    if (count>0)
      follow(oldhreg) = makenil;
    else
      reg[4] = makenil;
  }
  return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
Пример #8
0
pointer ICONVCLOSE(context *ctx, int n, pointer *argv)
{ int cd, ret;
  ckarg(1);
  cd=bigintval(argv[0]);
  ret=iconv_close(cd);
  return(makeint(ret));
  }
Пример #9
0
  CellCardImpl( InputDeck& deck, const token_list_t& tokens ) : 
    CellCard( deck ), trcl(NULL), fill(NULL), universe(0), likenbut(false), likeness_cell_n(0), 
    lat_type(NONE), lattice(NULL)
  {
    
    unsigned int idx = 0;

    ident = makeint(tokens.at(idx++));
    
    if(tokens.at(idx) == "like"){

      idx++;
      likenbut = true;
      likeness_cell_n = makeint(tokens.at(idx++));
      idx++; // skip the "but" token
      while(idx < tokens.size()){
        data.push_back(tokens[idx++]);
      }
      return;
    }

    material = makeint(tokens.at(idx++));
    rho = 0.0;
    if(material != 0){
      rho = makedouble(tokens.at(idx++)); // material density
    }

    token_list_t temp_geom;
    
    // while the tokens appear in geometry-specification syntax, store them into temporary list
    while(idx < tokens.size() && tokens.at(idx).find_first_of("1234567890:#-+()") == 0){
      temp_geom.push_back(tokens[idx++]);
    }

    // retokenize the geometry list, which follows a specialized syntax.
    retokenize_geometry( temp_geom );
    shunt_geometry();

    // store the rest of the tokens into the data list
    while(idx < tokens.size()){
      data.push_back(tokens[idx++]);
    }

    makeData();

  }
Пример #10
0
void spn_dbg_emit_source_location(
	SpnHashMap *debug_info,
	size_t begin,
	size_t end,
	SpnHashMap *ast,
	int regno
)
{
	SpnValue vinsns;
	SpnArray *insns;
	SpnValue vexpr;
	SpnValue line, column;
	SpnValue vbegin, vend;
	SpnValue vregno;
	SpnHashMap *expr;

	/* if we are not asked to emit debug info, give up */
	if (debug_info == NULL) {
		return;
	}

	vinsns = spn_hashmap_get_strkey(debug_info, "insns");
	insns = arrayvalue(&vinsns);

	vexpr = makehashmap();
	expr = hashmapvalue(&vexpr);

	line = spn_hashmap_get_strkey(ast, "line");
	column = spn_hashmap_get_strkey(ast, "column");

	vbegin = makeint(begin);
	vend = makeint(end);
	vregno = makeint(regno);

	spn_hashmap_set_strkey(expr, "line", &line);
	spn_hashmap_set_strkey(expr, "column", &column);
	spn_hashmap_set_strkey(expr, "begin", &vbegin);
	spn_hashmap_set_strkey(expr, "end", &vend);
	spn_hashmap_set_strkey(expr, "register", &vregno);

	spn_array_push(insns, &vexpr);
	spn_value_release(&vexpr);
}
Пример #11
0
SurfaceCard::SurfaceCard( InputDeck& deck, const token_list_t tokens ):
  Card(deck)
{
    size_t idx = 0;
    std::string token1 = tokens.at(idx++);
    if(token1.find_first_of("*+") != token1.npos){
      std::cerr << "Warning: no special handling for reflecting or white-boundary surfaces" << std::endl;
    token1[0] = ' ';
    }
    ident = makeint(token1);

    std::string token2 = tokens.at(idx++);
    if(token2.find_first_of("1234567890-") != 0){
      //token2 is the mnemonic
      coord_xform = new NullRef<Transform>();
      mnemonic = token2;
    }
    else{
      // token2 is a coordinate transform identifier
      int tx_id = makeint(token2);

      if( tx_id == 0 ){
        std::cerr << "I don't think 0 is a valid surface transformation ID, so I'm ignoring it." << std::endl;
        coord_xform = new NullRef<Transform>();
      }
      else if ( tx_id < 0 ){
        // abs(tx_id) is the ID of surface with respect to which this surface is periodic.
        std::cerr << "Warning: surface " << ident << " periodic, but this program has no special handling for periodic surfaces";
      }
      else{ // tx_id is positive and nonzero
        coord_xform = new CardRef<Transform>( deck, DataCard::TR, makeint(token2) );
      }

      mnemonic = tokens.at(idx++);
      
    }

    while( idx < tokens.size() ){
      args.push_back( makedouble(tokens[idx++]) );
    }

}
Пример #12
0
Statement *ParseCatchStatement()
{
	Statement *snp;
	SYM *sp;
	TYP *tp,*tp1,*tp2;
    ENODE *node;
    static char buf[200];
    
	snp = NewStatement(st_catch, TRUE);
	currentStmt = snp;
	if (lastst != openpa) {
		snp->label = (int64_t *)NULL;
		snp->s2 = (Statement *)99999;
		snp->s1 = ParseStatement();
		// Empty statements return NULL
		if (snp->s1)
			snp->s1->outer = snp;
		return snp;
	}
    needpunc(openpa,33);
	tp = head;
	tp1 = tail;
	catchdecl = TRUE;
	AutoDeclaration::Parse(NULL,&snp->ssyms);
	cseg();
	catchdecl = FALSE;
	tp2 = head;
	head = tp;
	tail = tp1;
    needpunc(closepa,34);
    
	if( (sp = snp->ssyms.Find(*declid,false)) == NULL)
        sp = makeint((char *)declid->c_str());
    node = makenode(sp->storage_class==sc_static ? en_labcon : en_autocon,NULL,NULL);
    // nameref looks up the symbol using lastid, so we need to back it up and
    // restore it.
    strncpy(buf,lastid,199);
    strncpy(lastid, declid->c_str(),sizeof(lastid)-1);
    nameref(&node,FALSE);
    strcpy(lastid,buf);
	snp->s1 = ParseStatement();
	// Empty statements return NULL
	if (snp->s1)
		snp->s1->outer = snp;
	snp->label = (int64_t *)node;	// save name reference
	if (sp->tp->typeno >= bt_last)
		error(ERR_CATCHSTRUCT);
	snp->s2 = (Statement *)GetTypeHash(sp->tp);
	// Empty statements return NULL
//	if (snp->s2)
//		snp->s2->outer = snp;
	return snp;
}
Пример #13
0
int
setbuiltin(char *p)
{
  int i;

  p += strlen("_set");
  while (strncmp(p, " ", 1) == 0) p++; // chomp spaces
  if (strncmp("uid", p, 3) == 0) {
    p += strlen("uid");
    while (strncmp(p, " ", 1) == 0) p++; // chomp spaces
    i = makeint(p); // ugly
    return (setuid(i));
  } else 
  if (strncmp("gid", p, 3) == 0) {
    p += strlen("gid");
    while (strncmp(p, " ", 1) == 0) p++; // chomp spaces
    i = makeint(p); // ugly
    return (setgid(i));
  }
  printf(2, "Invalid _set parameter\n");
  return -1;
}
Пример #14
0
void printprogram(FILE * f, unsigned char * program)
{
	int i;
	OPCODE op;

	// header
	int size = makeint(program[0], program[1]);
	int variables = makeint(program[2], program[3]);
	int code = makeint(program[4], program[5]);
	int stack = makeint(program[6], program[7]);
	fprintf(f, "header->\n");
	fprintf(f, "    size      = 0x%04x\n", size);
	fprintf(f, "    variables = 0x%04x\n", variables);
	fprintf(f, "    code      = 0x%04x\n", code);
	fprintf(f, "    stack     = 0x%04x\n", stack);
	fprintf(f, "<-header\n");

	// static variables
	fprintf(f, "static variables->\n");
	i = variables;
	fprintf(f, "    0x%04x bytes reserved\n", code - variables);
	fprintf(f, "<-static variables\n");
	
	// code
	fprintf(f, "code->\n");
	i = code;
	do
	{
		op = (OPCODE)program[i];
		i = printopcode(f, program, i);
	}
	while (op != OPCODE_EXIT);
	fprintf(f, "<-code\n");

	// stack
	fprintf(f, "stack->\n");
	fprintf(f, "    0x%04x bytes reserved\n", size - stack);
	fprintf(f, "<-stack\n");
}
Пример #15
0
static struct vector *make_arg_types(function f)
{
  if (f->varargs)
    return NULL;

  int i = 0;
  for (vlist a = f->args; a; a = a->next)
    ++i;

  struct vector *result = alloc_vector(i);
  for (vlist a = f->args; a; a = a->next)
    result->data[--i] = makeint(a->typeset);

  result->o.flags |= OBJ_READONLY | OBJ_IMMUTABLE;
  return result;
}
Пример #16
0
static value make_gsymbol(const char *name, fncode fn)
{
  struct table *gsymbols = (fn ? fnglobals(fn) : globals)->gsymbols;
  struct symbol *gsym;

  if (!table_lookup(gsymbols, name, &gsym)) 
    {
      struct string *s;

      GCPRO1(gsymbols);
      s = alloc_string(name);
      SET_READONLY(s);
      GCPOP(1);
      gsym = table_add_fast(gsymbols, s, makeint(table_entries(gsymbols)));
    }
  return gsym;
}
int return_scc_list(CTXTdeclc SCCNode * nodes, int num_nodes){
 
  VariantSF subgoal;
  TIFptr tif;

  int cur_node = 0,arity, j;
  Psc psc;
  CPtr oldhreg = NULL;

  reg[4] = makelist(hreg);
  new_heap_free(hreg);  new_heap_free(hreg);
  do {
    subgoal = (VariantSF) nodes[cur_node].node;
    tif = (TIFptr) subgoal->tif_ptr;
    psc = TIF_PSC(tif);
    arity = get_arity(psc);
    //    printf("subgoal %p, %s/%d\n",subgoal,get_name(psc),arity);
    check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args..
    oldhreg=hreg-2;                          // ptr to car
    if(arity>0){
      sreg = hreg;
      follow(oldhreg++) = makecs(sreg);      
      new_heap_functor(sreg,get_ret_psc(2)); //  car pts to ret/2  psc
      hreg += 3;                             //  hreg pts past ret/2
      sreg = hreg;
      follow(hreg-1) = makeint(nodes[cur_node].component);  // arg 2 of ret/2 pts to component
      follow(hreg-2) = makecs(sreg);         
      new_heap_functor(sreg, psc);           //  arg 1 of ret/2 pts to goal psc
      hreg += arity + 1;
      for (j = 1; j <= arity; j++) {
	new_heap_free(sreg);
	cell_array1[arity-j] = cell(sreg-1);
      }
      build_subgoal_args(subgoal);		
    } else{
      follow(oldhreg++) = makestring(get_name(psc));
    }
    follow(oldhreg) = makelist(hreg);        // cdr points to next car
    new_heap_free(hreg); new_heap_free(hreg);
    cur_node++;
  } while (cur_node  < num_nodes);
  follow(oldhreg) = makenil;                // cdr points to next car
  return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
Пример #18
0
value make_constant(constant c)
{
  struct obj *cst;

  switch (c->vclass)
    {
    case cst_string:
      cst = (value)alloc_string_length(c->u.string.str, c->u.string.len);
      cst->flags |= OBJ_READONLY | OBJ_IMMUTABLE;
      return cst;
    case cst_list: return make_list(c->u.constants);
    case cst_array: return make_array(c->u.constants);
    case cst_int: return makeint(c->u.integer);
    case cst_float: return (value)alloc_mudlle_float(c->u.mudlle_float);
    case cst_bigint: return make_bigint(c->u.bigint_str);
    case cst_table: return make_table(c->u.constants);
    case cst_symbol: return make_symbol(c->u.constpair);
    default:
      abort();
    }
}
Пример #19
0
static void generate_typeset_check(unsigned typeset, unsigned arg,
                                   fncode newfn)
{
  if (typeset == TYPESET_ANY)
    return;
  mtype t;
  if (typeset == TYPESET_FUNCTION)
    t = stype_function;
  else if (typeset == TYPESET_LIST)
    t = stype_list;
  else if (typeset == 0)
    t = stype_none;
  else if ((typeset & (typeset - 1)) == 0)
    t = ffs(typeset) - 1;
  else
    {
      ins_constant(makeint(typeset), newfn);
      ins1(op_typeset_check, arg, newfn);
      return;
    }
  ins1(op_typecheck + t, arg, newfn);
}
Пример #20
0
value make_constant(constant c, bool save_location, fncode fn)
{
  struct obj *cst;

  switch (c->vclass)
    {
    case cst_string:
      cst = (value)alloc_string(c->u.string);
      SET_READONLY(cst); SET_IMMUTABLE(cst);
      return cst;
    case cst_gsymbol: return make_gsymbol(c->u.string, fn);
    case cst_quote: return make_quote(c, save_location, fn);
    case cst_list: return make_list(c, c->u.constants, 1, save_location, fn);
    case cst_array: return make_array(c->u.constants, fn);
    case cst_int: return makeint(c->u.integer);
    case cst_float: return alloc_mudlle_float(c->u.mudlle_float);
    case cst_table: return make_table(c->u.constants, fn);
    case cst_symbol: return make_symbol(c->u.constpair, fn);
    default:
      abort();
    }
}
int immediate_affects_ptrlist(CTXTdeclc callnodeptr call1){
 
  VariantSF subgoal;
  int count = 0;
  CPtr oldhreg = NULL;
  struct hashtable *h;	
  struct hashtable_itr *itr;
  callnodeptr cn;
    
  reg[4] = makelist(hreg);
  new_heap_free(hreg);
  new_heap_free(hreg);
  
  if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */
    h=call1->outedges->hasht;
    
    itr = hashtable1_iterator(h);       
    if (hashtable1_count(h) > 0){
      do {
	cn = hashtable1_iterator_value(itr);
	if(IsNonNULL(cn->goal)){
	  count++;
	  subgoal = (VariantSF) cn->goal;      
	  check_glstack_overflow(4,pcreg,2); 
	  oldhreg=hreg-2;
          follow(oldhreg++) = makeint(subgoal);
	  follow(oldhreg) = makelist(hreg);
	  new_heap_free(hreg);
	  new_heap_free(hreg);
	}
      } while (hashtable1_iterator_advance(itr));
    }
    if (count>0)
      follow(oldhreg) = makenil;
    else
      reg[4] = makenil;
  }
  return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
Пример #22
0
u16 global_add(struct global_state *gstate, const char *name, mtype t)
/* Effects: adds name to global environment gstate, along with its type (t)
     If variable already exists, change its type to t.
   Returns: the new variable's index
   Modifies: gstate
*/
{
  struct string *tname;
  mtype current_type;
  u16 pos = global_lookup(gstate, name, &current_type);

  if (pos != GLOBAL_INVALID)
    {
      gstate->types->data[pos] = makeint(t);
      return pos;
    }

  GCPRO1(gstate);
  tname = alloc_string(name);
  GCPOP(1);

  return global_add1(gstate, tname, t, NULL);
}
Пример #23
0
void ProcessDialogEvent()
{
	ref NPChar;

	DeleteAttribute(&Dialog,"Links");

	aref Link, NextDiag;
	makeref(NPChar,CharacterRef);
	makearef(Link, Dialog.Links);
	makearef(NextDiag, NPChar.Dialog);
	int iTest;
	itest = 0;

	ref PChar;
	PChar = GetMainCharacter();

	switch(Dialog.CurrentNode)
	{

		// -----------------------------------ƒиалог первый - перва¤ встреча
		case "First time":
			Dialog.defAni = "dialog_stay1";
			Dialog.defCam = "1";
			Dialog.defSnd = "dialogs\0\017";
			Dialog.defLinkAni = "dialog_1";
			Dialog.defLinkCam = "1";
			Dialog.defLinkSnd = "dialogs\woman\024";
			Dialog.ani = "dialog_stay2";
			Dialog.cam = "1";
			Dialog.snd = "dialogs\0\009";

			if (Characters[GetCharacterIndex("Milon Blacque")].quest.first_talk == "1")
			{
				Dialog.Text = DLG_TEXT[0] + Address_Form.Fra + DLG_TEXT[1] + Characters[GetCharacterIndex(DLG_TEXT[2])].name + DLG_TEXT[3];
				Link.l1 = DLG_TEXT[4];
				Link.l1.go = "exit";
				Link.l2 = DLG_TEXT[5];
				Link.l2.go = "MilonTalk_1";
			}
			else
			{
				Dialog.Text = DLG_TEXT[6] + Address_Form.Fra + DLG_TEXT[7];
				Link.l1 = DLG_TEXT[8] + PChar.ship.name + DLG_TEXT[9];
				Link.l1.go = "node_2";
				NextDiag.TempNode = "Second Time";
			}
		break;

		case "node_2":
			Dialog.Text = DLG_TEXT[10];
			Link.l1 = DLG_TEXT[11];
			Link.l1.go = "node_3";
		break;

		case "node_3":
			Dialog.Text = DLG_TEXT[12];
			Link.l1 = DLG_TEXT[13];
			Link.l1.go = "node_4";
		break;

		case "node_4":
			Dialog.Text = DLG_TEXT[14] + Address_Form.Fra + DLG_TEXT[15] + NPChar.name + " " + NPChar.lastname + DLG_TEXT[16];
			Link.l1 = DLG_TEXT[17] + PChar.name + " " + PChar.lastname + DLG_TEXT[18] + PChar.ship.name + DLG_TEXT[19];
			Link.l1.go = "node_5";
		break;

		case "node_5":
			Dialog.Text = DLG_TEXT[20] + Address_Form.fra + DLG_TEXT[21];
			Link.l1 = DLG_TEXT[22];
			Link.l1.go = "node_6";
		break;

		case "node_6":
			Dialog.Text = DLG_TEXT[23];
			Link.l1 = DLG_TEXT[24];
			Link.l1.go = "node_7";
			if (makeint(PChar.money) > 1)
			{
				Link.l2 = DLG_TEXT[25];
				Link.l2.go = "node_9";
			}
		break;

		case "node_7":
			Dialog.Text = DLG_TEXT[26] + Address_Form.Fra + DLG_TEXT[27];
			Link.l1 = DLG_TEXT[28];
			Link.l1.go = "Exit";
			if (makeint(PChar.money) > 1)
			{
				Link.l2 = DLG_TEXT[29];
				Link.l2.go = "node_9";
			}
		break;

		case "node_9":
			AddMoneyToCharacter(pchar, -1);
			Dialog.Text = DLG_TEXT[30] + Address_Form.Fra + DLG_TEXT[31];
			Link.l1 = DLG_TEXT[32];
			if (Characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers == "0")
			{
				Link.l1.go = "node_10";
			}
			else 
			{
				if (Characters[GetCharacterIndex("Thierry Bosquet")].quest.gambling == "0")
				{
					Link.l1.go = "node_12";
				}

				else
				{
					Link.l1.go = "rumours";
				}
			}
		break;

		case "node_10":
			Dialog.Text = DLG_TEXT[33] + Characters[GetCharacterIndex(DLG_TEXT[34])].name + " " + Characters[GetCharacterIndex(DLG_TEXT[35])].lastname + DLG_TEXT[36];
			Characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers = "1";
			Link.l1 = DLG_TEXT[37];
			Link.l1.go = "node_11";
			Link.l2 = DLG_TEXT[38];
			Link.l2.go = "port watcher";
		break;

		case "node_11":
			Dialog.Text = DLG_TEXT[39];
			Link.l1 = DLG_TEXT[40];
			Link.l1.go = "node_12";
			Link.l2 = DLG_TEXT[41] + NPChar.name + DLG_TEXT[42];
			Link.l2.go = "exit";
		break;

		case "node_12":
			Dialog.Text = DLG_TEXT[43];
			Link.l1 = DLG_TEXT[44];
			Link.l1.go = "exit";
			Link.l2 = DLG_TEXT[45];
			Link.l2.go = "node_13";
		break;

		case "node_13":
			Dialog.Text = DLG_TEXT[46];
			Link.l1 = DLG_TEXT[47];
			Link.l1.go = "exit";
			Link.l2 = DLG_TEXT[48];
			Link.l2.go = "Rumours";
		break;

		case "port watcher":
			Dialog.Text = DLG_TEXT[49];
			Link.l1 = DLG_TEXT[50];
			Link.l1.go = "exit";
			Link.l2 = DLG_TEXT[51];
			Link.l2.go = "node_12";
		break;

		// -----------------------------------ƒиалог если игрок поговорил с Milon Blacque
		case "MilonTalk_1":
			Dialog.Text = DLG_TEXT[52] + Address_Form.Fra + DLG_TEXT[53] + Characters[GetCharacterIndex(DLG_TEXT[54])].name + DLG_TEXT[55];
			Link.l1 = DLG_TEXT[56];
			Link.l1.go = "MilonTalk_11";
		break;

		case "MilonTalk_11":
			Dialog.Text = DLG_TEXT[57];
			Link.l1 = DLG_TEXT[58];
			Link.l1.go = "exit";
			Link.l2 = DLG_TEXT[59];
			Link.l2.go = "MilonTalk_2";
		break;

		case "MilonTalk_2":
			Dialog.Text = DLG_TEXT[60];
			Link.l1 = DLG_TEXT[61];
			Link.l1.go = "MilonTalk_3";
		break;

		case "MilonTalk_3":
			Characters[GetCharacterIndex("Milon Blacque")].quest.first_talk = "done";
			Dialog.Text = DLG_TEXT[62] + Characters[GetCharacterIndex(DLG_TEXT[63])].name + DLG_TEXT[64];
			Link.l1 = DLG_TEXT[65];
			Link.l1.go = "Exit";
			Link.l2 = DLG_TEXT[66];
			Link.l2.go = "node_6";
		break;

		// -----------------------------------ƒиалог при последующих встречах
		case "Second Time":
			if (Characters[GetCharacterIndex("Milon Blacque")].quest.first_talk == "1")
			{
				Dialog.Text = DLG_TEXT[67] + Address_Form.Fra + DLG_TEXT[68] + Characters[GetCharacterIndex(DLG_TEXT[69])].name + DLG_TEXT[70];
				Link.l1 = DLG_TEXT[71];
				Link.l1.go = "exit";
				Link.l2 = DLG_TEXT[72];
				Link.l2.go = "MilonTalk_1";
			}
			else
			{
				Dialog.Text = DLG_TEXT[73] + Address_Form.Fra + DLG_TEXT[74];
				Link.l1 = DLG_TEXT[75];
				if (Characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers == "0")
				{
					Link.l1.go = "node_10";
				}
				else 
				{
					if (Characters[GetCharacterIndex("Thierry Bosquet")].quest.gambling == "0")
					{
						Link.l1.go = "node_12";
					}

					else
					{
						Link.l1.go = "rumours";
					}
				}
				iTest = iTest + 1;
				if ((Characters[GetCharacterIndex("rachel Blacque")].quest.badguy == "1")&&(iTest < QUEST_COUNTER))
				{
					Link.l2 = DLG_TEXT[76] + characters[getCharacterIndex(DLG_TEXT[77])].name + DLG_TEXT[78];
					Link.l2.go = "Rachel";
					iTest = iTest + 1;
				}
				if ((characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers == "teodoro")&&(iTest < QUEST_COUNTER))
				{
					dialog.text = DLG_TEXT[79] + address_form.fra + DLG_TEXT[80];
					link.l3 = pcharrepphrase(DLG_TEXT[81], DLG_TEXT[82]);
					link.l3.go = "smugglers";
					iTest = iTest + 1;
				}
				Link.l99 = DLG_TEXT[83];
				Link.l99.go = "exit";
			}
		break;

		case "smugglers":
			dialog.text = DLG_TEXT[84] + address_form.fra + DLG_TEXT[85];
			link.l1 = pcharrepphrase(DLG_TEXT[86], DLG_TEXT[87]);
			link.l1.go = "smugglers_1";
		break;

		case "smugglers_1":
			dialog.text = DLG_TEXT[88];
			link.l1 = pcharrepphrase(DLG_TEXT[89], DLG_TEXT[90]);
			link.l1.go = "smugglers_2";
		break;

		case "smugglers_2":
			dialog.text = DLG_TEXT[91];
			link.l1 = pcharrepphrase(DLG_TEXT[92], DLG_TEXT[93]);
			link.l1.go = "smugglers_3";
		break;

		case "smugglers_3":
			dialog.text = DLG_TEXT[94];
			link.l1 = pcharrepphrase(DLG_TEXT[95], DLG_TEXT[96]);
			link.l1.go = "exit";
			///////////////////////////////////////////////
			//активизируем ветку, когда на игрока нападают!
			characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers = "orable";
			///////////////////////////////////////////////
			link.l2 = pcharrepphrase(DLG_TEXT[97], DLG_TEXT[98]);
			link.l2.go = pcharrepphrase("smugglers_good", "smugglers_bad");
		break;

		case "smugglers_good":
			dialog.text = DLG_TEXT[99] + address_form.fra + DLG_TEXT[100];
			if (makeint(pchar.money)>=500)
			{
				link.l1 = DLG_TEXT[101];
				link.l1.go = "smugglers_good_1";
			}
			link.l2 = DLG_TEXT[102];
			link.l2.go = "smugglers_good_denied";
		break;

		case "smugglers_good_denied":
			dialog.text = DLG_TEXT[103] + address_form.fra + DLG_TEXT[104];
			link.l1 = DLG_TEXT[105];
			characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers = "orable";
		break;

		case "smugglers_good_1":
			dialog.text = DLG_TEXT[106] + characters[GetCharacterIndex(DLG_TEXT[107])].name + " " + characters[GetCharacterIndex(DLG_TEXT[108])].lastname + DLG_TEXT[109];
			link.l1 = DLG_TEXT[110];
			link.l1.go = "exit";
			AddMoneyToCharacter(pchar, -500);
			characters[GetCharacterIndex("Turpin Cabanel")].quest.smugglers = "orable_truth";
		break;

		case "smugglers_bad":
			dialog.text = DLG_TEXT[111];
			link.l1 = DLG_TEXT[112];
			link.l1.go = "smugglers_bad_1";
		break;

		case "smugglers_bad_1":
			dialog.text = DLG_TEXT[113];
			link.l1 = DLG_TEXT[114];
			link.l1.go = "smugglers_bad_2";
		break;

		case "smugglers_bad_2":
			dialog.text = DLG_TEXT[115];
			link.l1 = DLG_TEXT[116];
			link.l1.go = "smugglers_good_1";
		break;

		case "Rumours":
			Dialog.Text = SelectRumour();
			Link.l1 = DLG_TEXT[117];
			Link.l1.go = "exit";
		break;

		case "Rachel":
			Dialog.Text = DLG_TEXT[118] + Address_Form.Fra + DLG_TEXT[119];
			Link.l1 = DLG_TEXT[120];
			Link.l1.go = "Rachel_good";
			Link.l2 = DLG_TEXT[121];
			Link.l2.go = "Rachel_bad";
		break;

		case "Rachel_good":
			Dialog.Text = DLG_TEXT[122];
			Link.l1 = DLG_TEXT[123];
			Link.l1.go = "exit";
			Characters[GetCharacterIndex("Rachel Blacque")].quest.badguy = "done";
		break;

		case "Rachel_bad":
			Dialog.Text = DLG_TEXT[124] + Address_Form.Fra + DLG_TEXT[125];
			Link.l1 = DLG_TEXT[126];
			Link.l1.go  = "Rachel_good";
			Link.l2 = DLG_TEXT[127];
			Link.l2.go = "Rachel_bad_2";
		break;

		case "Rachel_bad_2":
			Dialog.Text = DLG_TEXT[128];
			Link.l1 = DLG_TEXT[129] + Characters[GetCharacterIndex(DLG_TEXT[130])].name + DLG_TEXT[131];
			Link.l1.go = "Rachel_bad_3";
		break;

		case "Rachel_bad_3":
			Dialog.Text = DLG_TEXT[132] + Address_Form.Fra + DLG_TEXT[133];
			Link.l1 = DLG_TEXT[134];
			Link.l1.go = "exit";
			Characters[GetCharacterIndex("Rachel Blacque")].quest.badguy = "money";
			NextDiag.TempNode = "MilonTalk";
			characters[GetCharacterIndex("Rachel Blacque")].location = "none";
			npchar.location = "none";
			Rumour[3].state = "active";
		break;

		case "Exit":
			NextDiag.CurrentNode = NextDiag.TempNode;
			DialogExit();
		break;

	}
}
Пример #24
0
int printopcode(FILE * f, unsigned char * program, int i)
{
	REGISTER r1;
	REGISTER r2;
	unsigned char valh;
	unsigned char vall;
	unsigned char var1h;
	unsigned char var1l;
	unsigned char var2h;
	unsigned char var2l;
	unsigned char deltah;
	unsigned char deltal;
	unsigned char addrh;
	unsigned char addrl;
	TURTLE_OPERATION t;

	// print memory address first
	fprintf(f, "    %04x ", i & 0xffff);

	// find the opcode
	OPCODE op = program[i++];

	switch (op)
	{
	case OPCODE_LOAD_R:
		r1 = program[i++];
		valh = program[i++];
		vall = program[i++];
		fprintf(f, "LOAD_R %s %04x\n", registername(r1), makeint(valh, vall));
		break;

	case OPCODE_LOAD_V:
		var1h = program[i++];
		var1l = program[i++];
		valh = program[i++];
		vall = program[i++];
		fprintf(f, "LOAD_V %04x %04x\n", makeint(var1h, var1l), makeint(valh, vall));
		break;

	case OPCODE_MOVE_RR:
		r1 = program[i++];
		r2 = program[i++];
		fprintf(f, "MOVE_RR %s %s\n", registername(r1), registername(r2));
		break;

	case OPCODE_MOVE_RV:
		r1 = program[i++];
		var1h = program[i++];
		var1l = program[i++];
		fprintf(f, "MOVE_RV %s %04x\n", registername(r1), makeint(var1h, var1l));
		break;

	case OPCODE_MOVE_VR:
		var1h = program[i++];
		var1l = program[i++];
		r1 = program[i++];
		fprintf(f, "MOVE_VR %04x %s\n", makeint(var1h, var1l), registername(r1));
		break;

	case OPCODE_MOVE_VV:
		var1h = program[i++];
		var1l = program[i++];
		var2h = program[i++];
		var2l = program[i++];
		fprintf(f, "MOVE_VV %04x %04x\n", makeint(var1h, var1l), makeint(var2h, var2l));
		break;

	case OPCODE_CMP_RR:
		r1 = program[i++];
		r2 = program[i++];
		fprintf(f, "CMP_RR %s %s\n", registername(r1), registername(r2));
		break;

	case OPCODE_JMPRe:
		deltah = program[i++];
		deltal = program[i++];
		fprintf(f, "JMPRe %04x\n", makeint(deltah, deltal));
		break;

	case OPCODE_JMPTo:
		addrh = program[i++];
		addrl = program[i++];
		fprintf(f, "JMPTo %04x\n", makeint(addrh, addrl));
		break;

	case OPCODE_JEq:
		deltah = program[i++];
		deltal = program[i++];
		fprintf(f, "JEq %04x\n", makeint(deltah, deltal));
		break;

	case OPCODE_JGt:
		deltah = program[i++];
		deltal = program[i++];
		fprintf(f, "JGt %04x\n", makeint(deltah, deltal));
		break;

	case OPCODE_JLt:
		deltah = program[i++];
		deltal = program[i++];
		fprintf(f, "JLt %04x\n", makeint(deltah, deltal));
		break;

	case OPCODE_DEC_R:
		r1 = program[i++];
		fprintf(f, "DEC_R %s\n", registername(r1));
		break;

	//Added this case to solve unknown listing	
	case OPCODE_INC_R:
		r1 = program[i++];
		fprintf(f, "INC_R %s\n", registername(r1));
		break;

	case OPCODE_ADD_R:
		r1 = program[i++];
		r2 = program[i++];
		fprintf(f, "ADD_R %s %s\n", registername(r1), registername(r2));
		break;

	case OPCODE_SUB_R:
		r1 = program[i++];
		r2 = program[i++];
		fprintf(f, "SUB_R %s %s\n", registername(r1), registername(r2));
		break;

	case OPCODE_MUL_R:
		r1 = program[i++];
		r2 = program[i++];
		fprintf(f, "MUL_R %s %s\n", registername(r1), registername(r2));
		break;

	case OPCODE_DIV_R:
		r1 = program[i++];
		r2 = program[i++];
		fprintf(f, "DIV_R %s %s\n", registername(r1), registername(r2));
		break;

	case OPCODE_PUSH_R:
		r1 = program[i++];
		fprintf(f, "PUSH_R %s\n", registername(r1));
		break;

	case OPCODE_POP_R:
		r1 = program[i++];
		fprintf(f, "POP_R %s\n", registername(r1));
		break;

	case OPCODE_PEEK_R:
		r1 = program[i++];
		fprintf(f, "PEEK_R %s\n", registername(r1));
		break;

	case OPCODE_TURTLE:
		t = (TURTLE_OPERATION)program[i++];
		fprintf(f, "TURTLE %s\n", turtle_operation_string(t));
		break;

	case OPCODE_EXIT:
		fprintf(f, "EXIT\n");
		break;

	default:
		fprintf(f, "UNKNOWN\n");
		break;
	}

	return i;
}
Пример #25
0
int getprogramsize(unsigned char * program)
{
	return makeint(program[0], program[1]);
}
void find_the_visitors(CTXTdeclc VariantSF subgoal) {
  CPtr cp_top1,cp_bot1 ; CPtr cp_root; CPtr cp_first;
  byte cp_inst; Cell listHead;
  int ans_subst_num, i, attv_num;
  BTNptr trieNode;
  ALNptr ALNlist;

  //  printf("find the visitors: subg %p trie root %p\n",subgoal,subg_ans_root_ptr(subgoal));
  cp_top1 = breg ;				 
  cp_bot1 = (CPtr)(tcpstack.high) - CP_SIZE;
  if (xwammode && hreg < hfreg) {
    printf("uh-oh! hreg was less than hfreg in in find the visitors\n");
    hreg = hfreg;
  }
  while ( cp_top1 < cp_bot1 ) {
    //    printf("1 cp_top1 %p cp_bot1 %p prev %p\n",cp_top1,cp_bot1,cp_prevtop(cp_top1));
    cp_inst = *(byte *)*cp_top1;
    // Want trie insts, but need to distinguish from asserted and interned tries
    //    printf("cp_inst %x\n",cp_inst);
    if ( is_trie_instruction(cp_inst) ) {
      //      printf("found trie instr\n");
      // Below we want basic_answer_trie_tt, ts_answer_trie_tt
      trieNode = TrieNodeFromCP(cp_top1);
      if (IsInAnswerTrie(trieNode)) {
	//	printf("in answer trie\n");
	if (subgoal == get_subgoal_frame_for_answer_trie_cp(CTXTc trieNode))  {
	  //	  printf("found top of run %p \n",cp_top1);
	  //	  print_subgoal(CTXTc stdout, subgoal); printf("\n");
	  cp_root = cp_top1; cp_first = cp_top1;
	  while (*cp_pcreg(cp_root) != trie_fail) {
	    cp_first = cp_root;
	    cp_root = cp_prevbreg(cp_root);
	    if (*cp_pcreg(cp_root) != trie_fail && subgoal != get_subgoal_frame_for_answer_trie_cp(CTXTc TrieNodeFromCP(cp_root)))
	      printf(" couldn't find incr trie root -- whoa, whu? (%p\n",cp_root);
	  }
	  ALNlist = traverse_variant_answer_trie(subgoal, cp_root,cp_top1);
	  ans_subst_num = (int)int_val(cell(cp_root + CP_SIZE + 1)) ;  // account for sf ptr of trie root cp
	  attv_num = (int)int_val(cell(breg+CP_SIZE+1+ans_subst_num)) + 1;;
	  // printf("found root %p first %p top %p ans_subst_num %d & %p attv_num %d\n",cp_root,cp_first,cp_top1,ans_subst_num,breg+CP_SIZE, attv_num); 
	  listHead = list_of_answers_from_answer_list(subgoal,ans_subst_num,attv_num,ALNlist);
	  // Free ALNlist;
	  cp_pcreg(cp_top1) = (byte *) &completed_trie_member_inst;
       	  cp_ebreg(cp_top1) = cp_ebreg(cp_root);
	  cp_hreg(cp_top1) = hreg;	  
	  cp_ereg(cp_top1) = cp_ereg(cp_root);
	  cp_trreg(cp_top1) = cp_trreg(cp_root);
	  cp_prevbreg(cp_top1) = cp_prevbreg(cp_root);	  cp_prevtop(cp_top1) = cp_prevtop(cp_root);
	  // cpreg, ereg, pdreg, ptcpreg should not need to be reset (prob not ebreg?)
	  //	  printf("sf %p\n",* (cp_root + CP_SIZE + 2));
	  * (cp_top1 + CP_SIZE) = makeint(ans_subst_num);
	  for (i = 0;i < ans_subst_num ;i++) {                              // Use registers for root of trie, not leaf (top)
	    * (cp_top1 + CP_SIZE + 1 + i) =  * (cp_root + CP_SIZE + 2 +i);  // account for sf ptr or root
	  }
	  * (cp_top1 + CP_SIZE + 1+ ans_subst_num) = listHead;
	  * (cp_top1 + CP_SIZE + 2+ ans_subst_num) = (Cell)hfreg;
	  //	  printf("4 cp_root %p prev %p\n",cp_root,cp_prevtop(cp_root));
	  //	  printf("constructed listhead hreg %x\n",hreg);
	  //	  cp_top1 = cp_root;  // next iteration
	  //	  printf("7 cp_top1 %p cp_bot1 %p prev %p\n",cp_top1,cp_bot1,cp_prevtop(cp_top1));
	}
      }
    }
    cp_top1 = cp_prevtop(cp_top1);
  }
  if (xwammode) hfreg = hreg;
  //  printf("constructed listhead hreg %x hfreg %x\n",hreg,hfreg);
  subg_visitors(subgoal) = 0;
  //  instr_flag = 1;  printf("setting instr_flag\n");  hreg_pos = hreg;
}
Пример #27
0
int gc_heap(int arity)
{
#ifdef GC
  CPtr p;
  unsigned long  begin_marktime, end_marktime,
    end_slidetime, end_copy_time;
  int  marked = 0, marked_dregs = 0, i;
  int  start_heap_size;
  DECL_GC_PROFILE;
  
  INIT_GC_PROFILE;
  if (flags[GARBAGE_COLLECT] != NO_GC) {
    num_gc++ ;
    GC_PROFILE_PRE_REPORT;
    slide = (flags[GARBAGE_COLLECT] == SLIDING_GC) | 
      (flags[GARBAGE_COLLECT] == INDIRECTION_SLIDE_GC);
    
    if (fragmentation_only) 
      slide = FALSE;
    heap_early_reset = ls_early_reset = 0;
    
    GC_PROFILE_START_SUMMARY;
    
    begin_marktime = cpu_time();
    start_heap_size = hreg+1-(CPtr)glstack.low;
    
    /* make sure the top choice point heap pointer 
       that might not point into heap, does */
    if (hreg == cp_hreg(breg)) {
      *hreg = makeint(666) ;
      hreg++ ;
    }
#ifdef SLG_GC
    /* same for the freeze heap pointer */
    if (hfreg == hreg && hreg == cp_hreg(bfreg)) {
      *hreg = makeint(66600);
      hreg++;
    }
#endif
    
    /* copy the aregs to the top of the heap - only if sliding */
    /* just hope there is enough space */
    /* this happens best before the stack_boundaries are computed */
    if (slide) {
      if (delayreg != NULL) {
	arity++;
	reg[arity] = (Cell)delayreg;
      }
      for (i = 1; i <= arity; i++) {
	*hreg = reg[i];
	hreg++;
      }
    }
    
#ifdef SLG_GC
    /* in SLGWAM, copy hfreg to the heap */
    if (slide) {
      *hreg = (unsigned long) hfreg;
      hreg++;
    }
#endif

    marked = mark_heap(arity, &marked_dregs);
    
    end_marktime = cpu_time();
    
    if (fragmentation_only) {
      /* fragmentation is expressed as ratio not-marked/total heap in use
	 this is internal fragmentation only.  we print marked and total,
	 so that postprocessing can do what it wants with this info. */
      xsb_dbgmsg((LOG_GC, "marked_used_missed(%d,%d,%d,%d).",
		 marked,hreg+1-(CPtr)glstack.low,
		 heap_early_reset,ls_early_reset));
    free_marks:
      /* get rid of the marking areas - if they exist */
      if (heap_marks)  { free((heap_marks-1)); heap_marks = NULL; }
      if (tr_marks)    { free(tr_marks); tr_marks = NULL; }
      if (ls_marks)    { free(ls_marks); ls_marks = NULL; }
      if (cp_marks)    { free(cp_marks); cp_marks = NULL; }
      goto end;
    }
    
    GC_PROFILE_MARK_SUMMARY;
    
    /* An attempt to add some gc/expansion policy;
       ideally this should be user-controlled */
#if (! defined(GC_TEST))
    if (marked > ((hreg+1-(CPtr)glstack.low)*mark_threshold))
      {
	GC_PROFILE_QUIT_MSG;
        if (slide)
          hreg -= arity;
	total_time_gc += (double) 
	  (end_marktime-begin_marktime)*1000/CLOCKS_PER_SEC;
        goto free_marks; /* clean-up temp areas and get out of here... */
      }
#endif
    
    total_collected += (start_heap_size - marked);

    if (slide)
      {
	GC_PROFILE_SLIDE_START_TIME;

	hreg = slide_heap(marked) ;

	if (hreg != (heap_bot+marked))
	  xsb_dbgmsg((LOG_GC, "heap sliding gc - inconsistent hreg"));
#ifdef SLG_GC
	/* copy hfreg back from the heap */
	hreg--;
	hfreg = (unsigned long*) *hreg;
#endif

	/* copy the aregs from the top of the heap back */
	hreg -= arity;
	hbreg = cp_hreg(breg);
	
	p = hreg;
	
	for (i = 1; i <= arity; i++)
	  reg[i] = *p++ ;
	if (delayreg != NULL)
	  delayreg = (CPtr)reg[arity--];

	end_slidetime = cpu_time();
	
	total_time_gc += (double) 
	  (end_slidetime - begin_marktime)*1000/CLOCKS_PER_SEC;
	
	GC_PROFILE_SLIDE_FINAL_SUMMARY;
      }
    else
      { /* else we call the copying collector a la Cheney */
	CPtr begin_new_heap, end_new_heap;
	
	GC_PROFILE_COPY_START_TIME;
	
	begin_new_heap = (CPtr)malloc(marked*sizeof(Cell));
	if (begin_new_heap == NULL)
	  xsb_exit("copying garbage collection could not allocate new heap");
	end_new_heap = begin_new_heap+marked;

	hreg = copy_heap(marked,begin_new_heap,end_new_heap,arity);

	free(begin_new_heap);
	adapt_hfreg_from_choicepoints(hreg);
	hbreg = cp_hreg(breg);

#ifdef SLG_GC
	hfreg = hreg;
#endif
	end_copy_time = cpu_time();
	
	total_time_gc += (double) 
	  (end_copy_time - begin_marktime)*1000/CLOCKS_PER_SEC;
	
	GC_PROFILE_COPY_FINAL_SUMMARY;
      }
    
    if (print_on_gc) print_all_stacks(arity);
    
    /* get rid of the marking areas - if they exist */
    if (heap_marks)  { 
      check_zero(heap_marks,(heap_top - heap_bot),"heap") ;
      free((heap_marks-1)) ; /* see its calloc */
      heap_marks = NULL ;
    }
    if (tr_marks)    { 
      check_zero(tr_marks,(tr_top - tr_bot + 1),"tr") ;
      free(tr_marks) ;
      tr_marks = NULL ;
    }
    if (ls_marks)    { 
      check_zero(ls_marks,(ls_bot - ls_top + 1),"ls") ;
      free(ls_marks) ;
      ls_marks = NULL ;
    }
    if (cp_marks)    {  
      check_zero(cp_marks,(cp_bot - cp_top + 1),"cp") ;
      free(cp_marks) ;
      cp_marks = NULL ;
    }
#ifdef SAFE_GC
    p = hreg;
    while (p < heap_top)
      *p++ = 0;
#endif
    
  } /* if (flags[GARBAGE_COLLECT]) */
#else
  /* for no-GC, there is no gc, but stack expansion can be done */
#endif
  
#ifdef GC
 end:
  
  GC_PROFILE_POST_REPORT;
  
#endif /* GC */
  return(TRUE);

} /* gc_heap */
Пример #28
0
void ProcessDialogEvent()
{
	ref NPChar, PChar, d;
	PChar = GetMainCharacter();
	aref Link, Diag;
	string NPC_Meeting, PeaceGroup;
	int Nation, Sum;
	
	DeleteAttribute(&Dialog,"Links");

	makeref(NPChar,CharacterRef);
	makearef(Link, Dialog.Links);
	makeref(d, Dialog);
	makearef(Diag, NPChar.Dialog);
	
	switch(Dialog.CurrentNode)
	{
		// -----------------------------------Диалог первый - первая встреча
		case "exit":
			Diag.CurrentNode = Diag.TempNode;
			NPChar.quest.meeting = NPC_Meeting;
			DialogExit();
		break;

		case "First time":
			Dialog.defAni = "dialog_stay2";
			Dialog.defCam = "2";
			Dialog.defSnd = "dialogs\0\017";
			Dialog.defLinkAni = "dialog_1";
			Dialog.defLinkCam = "1";
			Dialog.defLinkSnd = "dialogs\woman\024";
			Dialog.ani = "dialog_stay2";
			Dialog.cam = "1";
			
			if(Pchar.quest.RelationAgentMet == "0")
			{
				Dialog.snd = "voice\REDI\REDI001";
				d.Text = DLG_TEXT[0] + address_form.eng + DLG_TEXT[1];
				Link.l1 = DLG_TEXT[2];
				Link.l1.go = "Tutorial";
				NPC_Meeting = "1"; 
			}
			else
			{
				if(NPChar.quest.meeting == "0")
				{
					Dialog.snd = "voice\REDI\REDI002";
					d.Text = DLG_TEXT[3];
					Link.l1 = DLG_TEXT[4] + Pchar.name + DLG_TEXT[5];
					Link.l1.go = "Service";
					Link.l2 = DLG_TEXT[6];
					Link.l2.go = "Exit";					
				}
				else
				{
					Dialog.snd = "voice\REDI\REDI003";
					d.Text = DLG_TEXT[7] + Pchar.name"?" ;
					Link.l1 = DLG_TEXT[8];
					Link.l1.go = "Service";
					Link.l2 = DLG_TEXT[9];
					Link.l2.go = "exit";

				}
			}

		break;

		case "Service":
			Dialog.snd = "voice\REDI\REDI004";
			d.Text = DLG_TEXT[10];
			if(GetNationRelation2MainCharacter(ENGLAND) == RELATION_ENEMY)
			{
				Link.l1 = DLG_TEXT[11];
				Link.l1.go = "England";

			}
			if(GetNationRelation2MainCharacter(SPAIN) == RELATION_ENEMY)
			{
				Link.l2 = DLG_TEXT[12];
				Link.l2.go = "Spain";
			}
			if(GetNationRelation2MainCharacter(PORTUGAL) == RELATION_ENEMY)
			{
				Link.l3 = DLG_TEXT[13];
				Link.l3.go = "Portugal";			
			}
			if(GetNationRelation2MainCharacter(HOLLAND) == RELATION_ENEMY)
			{
				Link.l4 = DLG_TEXT[14];
				Link.l4.go = "Holland";			
			}
			if(GetNationRelation2MainCharacter(FRANCE) == RELATION_ENEMY)
			{
				Link.l5 = DLG_TEXT[15];
				Link.l5.go = "France";			
			}
			Link.l6 = DLG_TEXT[16];
			Link.l6.go = "exit";			
		break;

		case "Tutorial":
			Dialog.snd = "voice\REDI\REDI005";
			d.Text = DLG_TEXT[17];
			Link.l99 = DLG_TEXT[18];
			Link.l99.go = "Tutorial_1";
		break;

		case "Tutorial_1":
			Dialog.snd = "voice\REDI\REDI006";
			d.Text = DLG_TEXT[19];
			Link.l99 = DLG_TEXT[20];
			Link.l99.go = "Tutorial_2";
		break;

		case "Tutorial_2":
			Dialog.snd = "voice\REDI\REDI007";
			d.Text = DLG_TEXT[21];
			Link.l99 = DLG_TEXT[22];
			Link.l99.go = "Tutorial_3";
		break;

		case "Tutorial_3":
			Dialog.snd = "voice\REDI\REDI008";
			d.Text = DLG_TEXT[23];
			Link.l99 = DLG_TEXT[24];
			Link.l99.go = "Tutorial_4";
		break;

		case "Tutorial_4":
			Dialog.snd = "voice\REDI\REDI009";
			d.Text = DLG_TEXT[25];
			Link.l99 = DLG_TEXT[26];
			Link.l99.go = "Service";
		break;

		case "England":
			Pchar.quest.Relations.nation = ENGLAND;
			Pchar.quest.Relations.PeaceGroup = "ENGLAND_SOLDIERS";
			Pchar.quest.Relations.sum = makeint(stf(Pchar.rank)/stf(Pchar.reputation)*20000);	
			Dialog.snd = "voice\REDI\REDI010";
			d.Text = DLG_TEXT[27] + Pchar.quest.Relations.sum + DLG_TEXT[28];
			Link.l1 = DLG_TEXT[29];
			if(makeint(Pchar.money) < makeint(Pchar.quest.Relations.sum))
			{
				Link.l1.go = "No_money";			
			}
			else
			{
				Link.l1.go = "Agreed";			
			}
			Link.l2 = DLG_TEXT[30];
			Link.l2.go = "exit";			
		break;

		case "Spain":
			Pchar.quest.Relations.nation = SPAIN;
			Pchar.quest.Relations.PeaceGroup = "SPAIN_SOLDIERS";
			Pchar.quest.Relations.sum = makeint(stf(Pchar.rank)/stf(Pchar.reputation)*20000);	
			Dialog.snd = "voice\REDI\REDI011";
			d.Text = DLG_TEXT[31] + Pchar.quest.Relations.sum + DLG_TEXT[32];
			Link.l1 = DLG_TEXT[33];
			if(makeint(Pchar.money) < makeint(Pchar.quest.Relations.sum))
			{
				Link.l1.go = "No_money";			
			}
			else
			{
				Link.l1.go = "Agreed";			
			}
			Link.l2 = DLG_TEXT[34];
			Link.l2.go = "exit";			
		break;

		case "France":
			Pchar.quest.Relations.nation = FRANCE;
			Pchar.quest.Relations.PeaceGroup = "FRANCE_SOLDIERS";
			Pchar.quest.Relations.sum = makeint(stf(Pchar.rank)/stf(Pchar.reputation)*20000);	
			Dialog.snd = "voice\REDI\REDI012";
			d.Text = DLG_TEXT[35] + Pchar.quest.Relations.sum + DLG_TEXT[36];
			Link.l1 = DLG_TEXT[37];
			if(makeint(Pchar.money) < makeint(Pchar.quest.Relations.sum))
			{
				Link.l1.go = "No_money";			
			}
			else
			{
				Link.l1.go = "Agreed";			
			}
			Link.l2 = DLG_TEXT[38];
			Link.l2.go = "exit";			
		break;

		case "Portugal":
			Pchar.quest.Relations.nation = PORTUGAL;
			Pchar.quest.Relations.PeaceGroup = "CONCEICAO_SOLDIERS";
			Pchar.quest.Relations.sum = makeint(stf(Pchar.rank)/stf(Pchar.reputation)*20000);	
			Dialog.snd = "voice\REDI\REDI013";
			d.Text = DLG_TEXT[39] + Pchar.quest.Relations.sum + DLG_TEXT[40];
			Link.l1 = DLG_TEXT[41];
			if(makeint(Pchar.money) < makeint(Pchar.quest.Relations.sum))
			{
				Link.l1.go = "No_money";			
			}
			else
			{
				Link.l1.go = "Agreed";			
			}
			Link.l2 = DLG_TEXT[42];
			Link.l2.go = "exit";			
		break;

		case "Holland":
			Pchar.quest.Relations.nation = HOLLAND;
			Pchar.quest.Relations.PeaceGroup = "DOUWESEN_SOLDIERS";
			Pchar.quest.Relations.sum = makeint(stf(Pchar.rank)/stf(Pchar.reputation)*20000);	
			Dialog.snd = "voice\REDI\REDI014";
			d.Text = DLG_TEXT[43] + Pchar.quest.Relations.sum + DLG_TEXT[44];
			Link.l1 = DLG_TEXT[45];
			if(makeint(Pchar.money) < makeint(Pchar.quest.Relations.sum))
			{
				Link.l1.go = "No_money";			
			}
			else
			{
				Link.l1.go = "Agreed";			
			}
			Link.l2 = DLG_TEXT[46];
			Link.l2.go = "exit";			
		break;

		case "No_Money":
			Dialog.snd = "voice\REDI\REDI015";
			d.Text = DLG_TEXT[47];
			Link.l1 = DLG_TEXT[48];
			Link.l1.go = "exit";			
		break;

		case "Agreed":
			Dialog.snd = "voice\REDI\REDI016";
			SetNationRelation2MainCharacter(makeint(Pchar.quest.Relations.nation), RELATION_FRIEND);
			LAi_group_SetRelation(Pchar.quest.Relations.PeaceGroup, LAI_GROUP_PLAYER, LAI_GROUP_FRIEND);
			AddMoneyToCharacter(PChar, -(makeint(Pchar.quest.Relations.sum)));
			DeleteAttribute(Pchar, "quest.Relations");
			d.Text = DLG_TEXT[49];
			Link.l1 = DLG_TEXT[50];
			Link.l1.go = "Exit";
			Link.l2 = DLG_TEXT[51];
			Link.l2.go = "Service";
		break;
				

	}
}
Пример #29
0
/* TLS: making a conservative guess at which system calls need to be
   mutexed.  I'm doing it whenever I see the process table altered or
   affected, so this is the data structure that its protecting.

   At some point, the SET_FILEPTRs should be protected against other
   threads closing that stream.  Perhaps for such things a
   thread-specific stream table should be used.
*/
xsbBool sys_system(CTXTdeclc int callno)
{
  //  int pid;
  Integer pid;

  switch (callno) {
  case PLAIN_SYSTEM_CALL: /* dumb system call: no communication with XSB */
    /* this call is superseded by shell and isn't used */
    ctop_int(CTXTc 3, system(ptoc_string(CTXTc 2)));
    return TRUE;
  case SLEEP_FOR_SECS:
#ifdef WIN_NT
    Sleep((int)iso_ptoc_int_arg(CTXTc 2,"sleep/1",1) * 1000);
#else
    sleep(iso_ptoc_int_arg(CTXTc 2,"sleep/1",1));
#endif
    return TRUE;
  case GET_TMP_FILENAME:
    ctop_string(CTXTc 2,tempnam(NULL,NULL));
    return TRUE;
  case IS_PLAIN_FILE:
  case IS_DIRECTORY:
  case STAT_FILE_TIME:
  case STAT_FILE_SIZE:
    return file_stat(CTXTc callno, ptoc_longstring(CTXTc 2));
  case EXEC: {
#ifdef HAVE_EXECVP
    /* execs a new process in place of XSB */
    char *params[MAX_SUBPROC_PARAMS+2];
    prolog_term cmdspec_term;
    int index = 0;
    
    cmdspec_term = reg_term(CTXTc 2);
    if (islist(cmdspec_term)) {
      prolog_term temp, head;
      char *string_head=NULL;

      if (isnil(cmdspec_term))
	xsb_abort("[exec] Arg 1 must not be an empty list.");
      
      temp = cmdspec_term;
      do {
	head = p2p_car(temp);
	temp = p2p_cdr(temp);
	if (isstring(head)) 
	  string_head = string_val(head);
	else
	  xsb_abort("[exec] non-string argument passed in list.");
	
	params[index++] = string_head;
	if (index > MAX_SUBPROC_PARAMS)
	  xsb_abort("[exec] Too many arguments.");
      } while (!isnil(temp));
      params[index] = NULL;
    } else if (isstring(cmdspec_term)) {
      char *string = string_val(cmdspec_term);
      split_command_arguments(string, params, "exec");
    } else
      xsb_abort("[exec] 1st argument should be term or list of strings.");

    if (execvp(params[0], params)) 
      xsb_abort("[exec] Exec call failed.");
#else
    xsb_abort("[exec] builtin not supported in this architecture.");
#endif
  }
    
  case SHELL: /* smart system call: like SPAWN_PROCESS, but returns error code
		 instead of PID. Uses system() rather than execvp.
		 Advantage: can pass arbitrary shell command. */
  case SPAWN_PROCESS: { /* spawn new process, reroute stdin/out/err to XSB */
    /* +CallNo=2, +ProcAndArgsList,
       -StreamToProc, -StreamFromProc, -StreamFromProcStderr,
       -Pid */
    static int pipe_to_proc[2], pipe_from_proc[2], pipe_from_stderr[2];
    int toproc_stream=-1, fromproc_stream=-1, fromproc_stderr_stream=-1;
    int pid_or_status;
    FILE *toprocess_fptr=NULL,
      *fromprocess_fptr=NULL, *fromproc_stderr_fptr=NULL;
    char *params[MAX_SUBPROC_PARAMS+2]; /* one for progname--0th member,
				       one for NULL termination*/
    prolog_term cmdspec_term, cmdlist_temp_term;
    prolog_term cmd_or_arg_term;
    xsbBool toproc_needed=FALSE, fromproc_needed=FALSE, fromstderr_needed=FALSE;
    char *cmd_or_arg=NULL, *shell_cmd=NULL;
    int idx = 0, tbl_pos;
    char *callname=NULL;
    xsbBool params_are_in_a_list=FALSE;

    SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );

    init_process_table();

    if (callno == SPAWN_PROCESS)
      callname = "spawn_process/5";
    else
      callname = "shell/[1,2,5]";

    cmdspec_term = reg_term(CTXTc 2);
    if (islist(cmdspec_term))
      params_are_in_a_list = TRUE;
    else if (isstring(cmdspec_term))
      shell_cmd = string_val(cmdspec_term);
    else if (isref(cmdspec_term))
      xsb_instantiation_error(CTXTc callname,1);
    else    
      xsb_type_error(CTXTc "atom or list e.g. [command, arg, ...]",cmdspec_term,callname,1);
    
    // xsb_abort("[%s] Arg 1 must be an atom or a list [command, arg, ...]",
    // callname);

    /* the user can indicate that he doesn't want either of the streams created
       by putting an atom in the corresponding argument position */
    if (isref(reg_term(CTXTc 3)))
      toproc_needed = TRUE;
    if (isref(reg_term(CTXTc 4)))
      fromproc_needed = TRUE;
    if (isref(reg_term(CTXTc 5)))
      fromstderr_needed = TRUE;

    /* if any of the arg streams is already used by XSB, then don't create
       pipes --- use these streams instead. */
    if (isointeger(reg_term(CTXTc 3))) {
      SET_FILEPTR(toprocess_fptr, oint_val(reg_term(CTXTc 3)));
    }
    if (isointeger(reg_term(CTXTc 4))) {
      SET_FILEPTR(fromprocess_fptr, oint_val(reg_term(CTXTc 4)));
    }
    if (isointeger(reg_term(CTXTc 5))) {
      SET_FILEPTR(fromproc_stderr_fptr, oint_val(reg_term(CTXTc 5)));
    }

    if (!isref(reg_term(CTXTc 6)))
      xsb_type_error(CTXTc "variable (to return process id)",reg_term(CTXTc 6),callname,5);
    //      xsb_abort("[%s] Arg 5 (process id) must be a variable", callname);

    if (params_are_in_a_list) {
      /* fill in the params[] array */
      if (isnil(cmdspec_term))
	xsb_abort("[%s] Arg 1 must not be an empty list", callname);
      
      cmdlist_temp_term = cmdspec_term;
      do {
	cmd_or_arg_term = p2p_car(cmdlist_temp_term);
	cmdlist_temp_term = p2p_cdr(cmdlist_temp_term);
	if (isstring(cmd_or_arg_term)) {
	  cmd_or_arg = string_val(cmd_or_arg_term);
	}
	else 
	  xsb_abort("[%s] Non string list member in the Arg",
		    callname);
	
	params[idx++] = cmd_or_arg;
	if (idx > MAX_SUBPROC_PARAMS)
	  xsb_abort("[%s] Too many arguments passed to subprocess",
		    callname);
	
      } while (!isnil(cmdlist_temp_term));

      params[idx] = NULL; /* null termination */

    } else { /* params are in a string */
      if (callno == SPAWN_PROCESS)
	split_command_arguments(shell_cmd, params, callname);
      else {
	/* if callno==SHELL => call system() => don't split shell_cmd */
	params[0] = shell_cmd;
	params[1] = NULL;
      }
    }
    
    /* -1 means: no space left */
    if ((tbl_pos = get_free_process_cell()) < 0) {
      xsb_warn(CTXTc "Can't create subprocess because XSB process table is full");
      SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
      return FALSE;
    }

      /* params[0] is the progname */
    pid_or_status = xsb_spawn(CTXTc params[0], params, callno,
			      (toproc_needed ? pipe_to_proc : NULL),
			      (fromproc_needed ? pipe_from_proc : NULL),
			      (fromstderr_needed ? pipe_from_stderr : NULL),
			      toprocess_fptr, fromprocess_fptr,
			      fromproc_stderr_fptr);
      
    if (pid_or_status < 0) {
      xsb_warn(CTXTc "[%s] Subprocess creation failed, Error: %d, errno: %d, Cmd: %s", callname,pid_or_status,errno,params[0]);
      SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
      return FALSE;
    }

    if (toproc_needed) {
      toprocess_fptr = fdopen(pipe_to_proc[1], "w");
      toproc_stream =  xsb_intern_fileptr(CTXTc toprocess_fptr,callname,"pipe","w",CURRENT_CHARSET); 
      ctop_int(CTXTc 3, toproc_stream);
    }
    if (fromproc_needed) {
      fromprocess_fptr = fdopen(pipe_from_proc[0], "r");
      fromproc_stream =  xsb_intern_fileptr(CTXTc fromprocess_fptr,callname,"pipe","r",CURRENT_CHARSET); 
      ctop_int(CTXTc 4, fromproc_stream);
    }
    if (fromstderr_needed) {
      fromproc_stderr_fptr = fdopen(pipe_from_stderr[0], "r");
      fromproc_stderr_stream
	= xsb_intern_fileptr(CTXTc fromproc_stderr_fptr,callname,"pipe","r",CURRENT_CHARSET); 
      ctop_int(CTXTc 5, fromproc_stderr_stream);
    }
    ctop_int(CTXTc 6, pid_or_status);

    xsb_process_table.process[tbl_pos].pid = pid_or_status;
    xsb_process_table.process[tbl_pos].to_stream = toproc_stream;
    xsb_process_table.process[tbl_pos].from_stream = fromproc_stream;
    xsb_process_table.process[tbl_pos].stderr_stream = fromproc_stderr_stream;
    concat_array(CTXTc params, " ",
		 xsb_process_table.process[tbl_pos].cmdline,MAX_CMD_LEN);
    
    SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
    return TRUE;
  }

  case GET_PROCESS_TABLE: { /* sys_system(3, X). X is bound to the list
	       of the form [process(Pid,To,From,Stderr,Cmdline), ...] */
    int i;
    prolog_term table_term_tail, listHead;
    prolog_term table_term=reg_term(CTXTc 2);

    SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
    init_process_table();

    if (!isref(table_term))
      xsb_abort("[GET_PROCESS_TABLE] Arg 1 must be a variable");

    table_term_tail = table_term;
    for (i=0; i<MAX_SUBPROC_NUMBER; i++) {
      if (!FREE_PROC_TABLE_CELL(xsb_process_table.process[i].pid)) {
	c2p_list(CTXTc table_term_tail); /* make it into a list */
	listHead = p2p_car(table_term_tail);

	c2p_functor(CTXTc "process", 5, listHead);
	c2p_int(CTXTc xsb_process_table.process[i].pid, p2p_arg(listHead,1));
	c2p_int(CTXTc xsb_process_table.process[i].to_stream, p2p_arg(listHead,2));
	c2p_int(CTXTc xsb_process_table.process[i].from_stream, p2p_arg(listHead,3));
	c2p_int(CTXTc xsb_process_table.process[i].stderr_stream,
		p2p_arg(listHead,4));
	c2p_string(CTXTc xsb_process_table.process[i].cmdline, p2p_arg(listHead,5));

	table_term_tail = p2p_cdr(table_term_tail);
      }
    }
    c2p_nil(CTXTc table_term_tail); /* bind tail to nil */
    SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
    return p2p_unify(CTXTc table_term, reg_term(CTXTc 2));
  }

  case PROCESS_STATUS: {
    prolog_term pid_term=reg_term(CTXTc 2), status_term=reg_term(CTXTc 3);

    SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );

    init_process_table();

    if (!(isointeger(pid_term)))
      xsb_abort("[PROCESS_STATUS] Arg 1 (process id) must be an integer");
    pid = (int)oint_val(pid_term);

    if (!isref(status_term))
      xsb_abort("[PROCESS_STATUS] Arg 2 (process status) must be a variable");
    
    switch (process_status(pid)) {
    case RUNNING:
      c2p_string(CTXTc "running", status_term);
      break;
    case STOPPED:
      c2p_string(CTXTc "stopped", status_term);
      break;
    case EXITED_NORMALLY:
      c2p_string(CTXTc "exited_normally", status_term);
      break;
    case EXITED_ABNORMALLY:
      c2p_string(CTXTc "exited_abnormally", status_term);
      break;
    case ABORTED:
      c2p_string(CTXTc "aborted", status_term);
      break;
    case INVALID:
      c2p_string(CTXTc "invalid", status_term);
      break;
    default:
      c2p_string(CTXTc "unknown", status_term);
    }
    SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
    return TRUE;
  }

  case PROCESS_CONTROL: {
    /* sys_system(PROCESS_CONTROL, +Pid, +Signal). Signal: wait, kill */
    int status;
    prolog_term pid_term=reg_term(CTXTc 2), signal_term=reg_term(CTXTc 3);

    SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
    init_process_table();

    if (!(isointeger(pid_term)))
      xsb_abort("[PROCESS_CONTROL] Arg 1 (process id) must be an integer");
    pid = (int)oint_val(pid_term);

    if (isstring(signal_term) && strcmp(string_val(signal_term), "kill")==0) {
      if (KILL_FAILED(pid)) {
	SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
	return FALSE;
      }
#ifdef WIN_NT
      CloseHandle((HANDLE) pid);
#endif
      SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
      return TRUE;
    }
    if (isconstr(signal_term)
	&& strcmp(p2c_functor(signal_term),"wait") == 0
	&& p2c_arity(signal_term)==1) {
      int exit_status;

      if (WAIT(pid, status) < 0) {
	SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
	return FALSE;
      }

#ifdef WIN_NT
      exit_status = status;
#else
      if (WIFEXITED(status))
	exit_status = WEXITSTATUS(status);
      else
	exit_status = -1;
#endif

      p2p_unify(CTXTc p2p_arg(signal_term,1), makeint(exit_status));
      SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
      return TRUE;
    }

    xsb_warn(CTXTc "[PROCESS_CONTROL] Arg 2: Invalid signal specification. Must be `kill' or `wait(Var)'");
    return FALSE;
  }
   
  case LIST_DIRECTORY: {
    /* assume all type- and mode-checking is done in Prolog */
    prolog_term handle = reg_term(CTXTc 2); /* ref for handle */
    char *dir_name = ptoc_longstring(CTXTc 3); /* +directory name */
    prolog_term filename = reg_term(CTXTc 4); /* reference for name of file */
    
    if (is_var(handle)) 
      return xsb_find_first_file(CTXTc handle,dir_name,filename);
    else
      return xsb_find_next_file(CTXTc handle,dir_name,filename);
  }

  default:
    xsb_abort("[SYS_SYSTEM] Wrong call number (an XSB bug)");
  } /* end case */
  return TRUE;
}
Пример #30
0
int gc_heap(CTXTdeclc int arity, int ifStringGC)
{
#ifdef GC
  CPtr p;
  double  begin_marktime, end_marktime,
    end_slidetime, end_copy_time,
    begin_stringtime, end_stringtime;
  size_t  marked = 0, marked_dregs = 0, i;
  int ii;
  size_t  start_heap_size;
  size_t  rnum_in_trieinstr_unif_stk = (trieinstr_unif_stkptr-trieinstr_unif_stk)+1;
  DECL_GC_PROFILE;
  garbage_collecting = 1;  // flag for profiling that we are gc-ing

  //  printf("start gc(%ld): e:%p,h:%p,hf:%p\n",(long)(cpu_time()*1000),ereg,hreg,hfreg);
  INIT_GC_PROFILE;
  if (pflags[GARBAGE_COLLECT] != NO_GC) {
    num_gc++ ;
    GC_PROFILE_PRE_REPORT;
    slide = (pflags[GARBAGE_COLLECT] == SLIDING_GC) | 
      (pflags[GARBAGE_COLLECT] == INDIRECTION_SLIDE_GC);
    
    if (fragmentation_only) 
      slide = FALSE;
    heap_early_reset = ls_early_reset = 0;
    
    GC_PROFILE_START_SUMMARY;
    
    begin_marktime = cpu_time();
    start_heap_size = hreg+1-(CPtr)glstack.low;
    
    /* make sure the top choice point heap pointer 
       that might not point into heap, does */
    if (hreg == cp_hreg(breg)) {
      *hreg = makeint(666) ;
      hreg++;
    }
#ifdef SLG_GC
    /* same for the freeze heap pointer */
    if (hfreg == hreg && hreg == cp_hreg(bfreg)) {
      *hreg = makeint(66600);
      hreg++;
    }
#endif
    
    /* copy the aregs to the top of the heap - only if sliding */
    /* just hope there is enough space */
    /* this happens best before the stack_boundaries are computed */
    if (slide) {
      if (delayreg != NULL) {
	arity++;
	reg[arity] = (Cell)delayreg;
      }
      for (ii = 1; ii <= arity; ii++) {
	//	printf("reg[%d] to heap: %lx\n",ii,(size_t)reg[i]);
	*hreg = reg[ii];
	hreg++;
      }
      arity += (int)rnum_in_trieinstr_unif_stk;
      for (i = 0; i < rnum_in_trieinstr_unif_stk; i++) {
	//	printf("trieinstr_unif_stk[%d] to heap: %lx\n",i,(size_t)trieinstr_unif_stk[i]);
	*hreg = trieinstr_unif_stk[i];
	hreg++;
      }
      //      printf("extended heap: hreg=%p, arity=%d, rnum_in=%d\n",hreg,arity, rnum_in_trieinstr_unif_stk);
#ifdef SLG_GC
      /* in SLGWAM, copy hfreg to the heap */
      //      printf("hfreg to heap is %p at %p, rnum_in_trieinstr_unif_stk=%d,arity=%d,delay=%p\n",hfreg,hreg,rnum_in_trieinstr_unif_stk,arity,delayreg);
      *(hreg++) = (Cell) hfreg;
#endif
    }

    if (top_of_localstk < hreg) {
      fprintf(stderr,"stack clobbered: no space for gc_heap\n"); 
      xsb_exit( "stack clobbered");
    }

    gc_strings = ifStringGC; /* default */
    gc_strings = should_gc_strings();  // collect strings for any reason?
    marked = mark_heap(CTXTc arity, &marked_dregs);
    
    end_marktime = cpu_time();
    
    if (fragmentation_only) {
      /* fragmentation is expressed as ratio not-marked/total heap in use
	 this is internal fragmentation only.  we print marked and total,
	 so that postprocessing can do what it wants with this info. */
      xsb_dbgmsg((LOG_GC, "marked_used_missed(%d,%d,%d,%d).",
		 marked,hreg+1-(CPtr)glstack.low,
		 heap_early_reset,ls_early_reset));

    free_marks:

#ifdef PRE_IMAGE_TRAIL
      /* re-tag pre image cells in trail */
      for (p = tr_bot; p <= tr_top ; p++ ) {
	if (tr_pre_marked(p-tr_bot)) {
	  *p = *p | PRE_IMAGE_MARK;
	  tr_clear_pre_mark(p-tr_bot);
	}
      }
#endif

      /* get rid of the marking areas - if they exist */
      if (heap_marks)  { mem_dealloc((heap_marks-1),heap_marks_size,GC_SPACE); heap_marks = NULL; }
      if (tr_marks)    { mem_dealloc(tr_marks,tr_top-tr_bot+1,GC_SPACE); tr_marks = NULL; }
      if (ls_marks)    { mem_dealloc(ls_marks,ls_bot - ls_top + 1,GC_SPACE); ls_marks = NULL; }
      if (cp_marks)    { mem_dealloc(cp_marks,cp_bot - cp_top + 1,GC_SPACE); cp_marks = NULL; }
      if (slide_buf)   { mem_dealloc(slide_buf,(slide_buf_size+1)*sizeof(CPtr),GC_SPACE); slide_buf = NULL; }
      goto end;
    }
    
    GC_PROFILE_MARK_SUMMARY;
    
    /* An attempt to add some gc/expansion policy;
       ideally this should be user-controlled */
#if (! defined(GC_TEST))
    if (marked > ((hreg+1-(CPtr)glstack.low)*mark_threshold))
      {
	GC_PROFILE_QUIT_MSG;
        if (slide)
          hreg -= arity;
	total_time_gc += (double) 
	  (end_marktime-begin_marktime);
        goto free_marks; /* clean-up temp areas and get out of here... */
      }
#endif
    
    total_collected += (start_heap_size - marked);

    if (slide)
      {
	GC_PROFILE_SLIDE_START_TIME;
	hreg = slide_heap(CTXTc marked) ;

#ifdef DEBUG_VERBOSE
	if (hreg != (heap_bot+marked))
	  xsb_dbgmsg((LOG_GC, "heap sliding gc - inconsistent hreg"));
#endif

#ifdef SLG_GC
	/* copy hfreg back from the heap */
	hreg--;
	hfreg = (CPtr) *hreg;
#endif

	/* copy the aregs from the top of the heap back */
	hreg -= arity;
	hbreg = cp_hreg(breg);
	
	p = hreg;
	
	arity -= (int)rnum_in_trieinstr_unif_stk;
	for (ii = 1; ii <= arity; ii++) {
	  reg[ii] = *p++;
	  //	  printf("heap to reg[%d]: %lx\n",ii,(size_t)reg[i]);
	}
	if (delayreg != NULL)
	  delayreg = (CPtr)reg[arity--];
	for (i = 0; i < rnum_in_trieinstr_unif_stk; i++) {
	  trieinstr_unif_stk[i] = *p++;
	  //	  printf("heap to trieinstr_unif_stk[%d]: %lx\n",i,(size_t)trieinstr_unif_stk[i]);
	}

	end_slidetime = cpu_time();
	
	total_time_gc += (double) 
	  (end_slidetime - begin_marktime);
	
	GC_PROFILE_SLIDE_FINAL_SUMMARY;
      }
    else
      { /* else we call the copying collector a la Cheney */
	CPtr begin_new_heap, end_new_heap;
	
	GC_PROFILE_COPY_START_TIME;
	
	begin_new_heap = (CPtr)mem_alloc(marked*sizeof(Cell),GC_SPACE);
	if (begin_new_heap == NULL)
	  xsb_exit( "copying garbage collection could not allocate new heap");
	end_new_heap = begin_new_heap+marked;

	hreg = copy_heap(CTXTc marked,begin_new_heap,end_new_heap,arity);

	mem_dealloc(begin_new_heap,marked*sizeof(Cell),GC_SPACE);
	adapt_hfreg_from_choicepoints(CTXTc hreg);
	hbreg = cp_hreg(breg);

#ifdef SLG_GC
	hfreg = hreg;
#endif
	end_copy_time = cpu_time();
	
	total_time_gc += (double) 
	  (end_copy_time - begin_marktime);
	
	GC_PROFILE_COPY_FINAL_SUMMARY;
      }
    
    if (print_on_gc) print_all_stacks(CTXTc arity);
    
    /* get rid of the marking areas - if they exist */
    if (heap_marks)  { 
      check_zero(heap_marks,(heap_top - heap_bot),"heap") ;
      mem_dealloc((heap_marks-1),heap_marks_size,GC_SPACE) ; /* see its calloc */
      heap_marks = NULL ;
    }
    if (tr_marks)    { 
      check_zero(tr_marks,(tr_top - tr_bot + 1),"tr") ;
      mem_dealloc(tr_marks,tr_top-tr_bot+1,GC_SPACE) ;
      tr_marks = NULL ;
    }
    if (ls_marks)    { 
      check_zero(ls_marks,(ls_bot - ls_top + 1),"ls") ;
      mem_dealloc(ls_marks,ls_bot - ls_top + 1,GC_SPACE) ;
      ls_marks = NULL ;
    }
    if (cp_marks)    {  
      check_zero(cp_marks,(cp_bot - cp_top + 1),"cp") ;
      mem_dealloc(cp_marks,cp_bot - cp_top + 1,GC_SPACE) ;
      cp_marks = NULL ;
    }
    if (slide_buf)   { 
      mem_dealloc(slide_buf,(slide_buf_size+1)*sizeof(CPtr),GC_SPACE); 
      slide_buf = NULL; 
    }
#ifdef SAFE_GC
    p = hreg;
    while (p < heap_top)
      *p++ = 0;
#endif
    
  } /* if (pflags[GARBAGE_COLLECT]) */
#else
  /* for no-GC, there is no gc, but stack expansion can be done */
#endif
  
#ifdef GC
 end:
  
  /*************** GC STRING-TABLE (already marked from heap) *******************/
#ifndef NO_STRING_GC
#ifdef MULTI_THREAD
  if (flags[NUM_THREADS] == 1) {
#endif
    if (gc_strings && (flags[STRING_GARBAGE_COLLECT] == 1)) {
      num_sgc++;
      begin_stringtime = cpu_time();
      mark_nonheap_strings(CTXT);
      free_unused_strings();
      //      printf("String GC reclaimed: %d bytes\n",beg_string_space_size - pspacesize[STRING_SPACE]);
      gc_strings = FALSE;
      end_stringtime = cpu_time();
      total_time_gc += end_stringtime - begin_stringtime;
    }
    /* update these even if no GC, to avoid too many calls just to gc strings */
    last_string_space_size = pspacesize[STRING_SPACE];
    last_assert_space_size = pspacesize[ASSERT_SPACE];
    force_string_gc = FALSE;
#ifdef MULTI_THREAD
  }
#endif
#endif /* ndef NO_STRING_GC */

  GC_PROFILE_POST_REPORT;
  garbage_collecting = 0;
  
#endif /* GC */
  //  printf("   end gc(%ld), hf:%p,h:%p, space=%d\n",(long)(cpu_time()*1000),hfreg,hreg,(pb)top_of_localstk - (pb)top_of_heap);

  return(TRUE);

} /* gc_heap */