Ejemplo n.º 1
0
prolog_term intern_rec(CTXTdeclc prolog_term term) {

  int areaindex, reclen, i, j;
  CPtr hc_term;
  Cell dterm[255];
  Cell arg;

  //  printf("intern_rec\n");
  // create term-record with all fields dereffed in dterm
  XSB_Deref(term);
  if (isinternstr(term)) {printf("old\n"); return term;}
  if (isconstr(term)) {
    areaindex = get_arity(get_str_psc(term)); 
    reclen = areaindex + 1;
    cell(dterm) = (Cell)get_str_psc(term); // copy psc ptr
    j=1;
  } else if (islist(term)) {
    areaindex = LIST_INDEX; 
    reclen = 2;
    j=0;
  } else return 0;
  for (i=j; i<reclen; i++) {
    arg = get_str_arg(term,i);  // works for lists and strs
    XSB_Deref(arg);
    if (isref(arg) || (isstr(arg) && !isinternstr(arg)) || isattv(arg)) {
      return 0;
    }
    cell(dterm+i) = arg;
  }
  hc_term = insert_interned_rec(reclen, areaindex, dterm);
  if (islist(term)) return makelist(hc_term); else return makecs(hc_term);
}
Ejemplo n.º 2
0
void unify(char x[],char y[])
{char a[100],b[100];
	
	if(strcmp(theta,"FAILURE")==0)
		return;

	if(strcmp(x,y)==0)
		return;

	else if(isvariable(x))
		unify_var(x,y);

	else if(isvariable(y))
		unify_var(x,y);

	else if(iscompound(x) && iscompound(y))
	{
		
		strcpy(a,arg(x));
		strcpy(b,arg(y));
		unify(a,b);

		strcpy(a,op(x));
		strcpy(b,op(y));
		unify(a,b);

	}

	else if(islist(x) && islist(y))
	{

		strcpy(a,rest(x));
		strcpy(b,rest(y));
		unify(a,b);
		
		strcpy(a,first(x));
		strcpy(b,first(y));
		unify(a,b);

	}
	
	else 
		sprintf(theta,"FAILURE",theta);

	


return;

}
Ejemplo n.º 3
0
static DL intern_delay_list(CPtr dlist) /* assumes that dlist != NULL	*/
{
  DE head = NULL, de;
  DL dl = NULL;

  while (islist(dlist)) {
    dlist = clref_val(dlist);
    if ((de = intern_delay_element(cell(dlist))) != NULL) {
      de_next(de) = head;
      head = de;
    }
    dlist = (CPtr) cell(dlist+1);
  }
  if (head) {
    new_entry(dl,
	      released_dls,
	      next_free_dl,
	      current_dl_block,
	      current_dl_block_top,
	      dl_next,
	      DL,
	      dl_block_size,
	      "Not enough memory to expand DL space");
    dl_de_list(dl) = head;
    dl_asl(dl) = NULL;
    return dl;
  }
  else return NULL;
}
Ejemplo n.º 4
0
static inline expr *eval_varargs(scope *scope, expr *e) {
  assert(islist(e));
  if (e == NULL)
    return NULL;
  else
    return create_cell(eval(scope, e->head), eval_varargs(scope, e->tail));
}
Ejemplo n.º 5
0
static Line *
enumerated_block(Paragraph *top, int clip, MMIOT *f, int list_class)
{
    ParagraphRoot d = { 0, 0 };
    Paragraph *p;
    Line *q = top->text, *text;
    int para = 0, z;

    while (( text = q )) {
	
	p = Pp(&d, text, LISTITEM);
	text = listitem(p, clip, f->flags, 0);

	p->down = compile(p->text, 0, f);
	p->text = 0;

	if ( para && p->down ) p->down->align = PARA;

	if ( (q = skipempty(text)) == 0
			     || islist(q, &clip, f->flags, &z) != list_class )
	    break;

	if ( para = (q != text) ) {
	    Line anchor;

	    anchor.next = text;
	    ___mkd_freeLineRange(&anchor, q);

	    if ( p->down ) p->down->align = PARA;
	}
    }
    top->text = 0;
    top->down = T(d);
    return text;
}
Ejemplo n.º 6
0
/*
 * pull in a list block.  A list block starts with a list marker and
 * runs until the next list marker, the next non-indented paragraph,
 * or EOF.   You do not have to indent nonblank lines after the list
 * marker, but multiple paragraphs need to start with a 4-space indent.
 */
static Line *
listitem(Paragraph *p, int indent, DWORD flags, linefn check)
{
    Line *t, *q;
    int clip = indent;
    int z;

    for ( t = p->text; t ; t = q) {
	CLIP(t->text, 0, clip);
	UNCHECK(t);
	t->dle = mkd_firstnonblank(t);

        /* even though we had to trim a long leader off this item,
         * the indent for trailing paragraphs is still 4...
	 */
	if (indent > 4) {
	    indent = 4;
	}
	if ( (q = skipempty(t->next)) == 0 ) {
	    ___mkd_freeLineRange(t,q);
	    return 0;
	}

	/* after a blank line, the next block needs to start with a line
	 * that's indented 4(? -- reference implementation allows a 1
	 * character indent, but that has unfortunate side effects here)
	 * spaces, but after that the line doesn't need any indentation
	 */
	if ( q != t->next ) {
	    if (q->dle < indent) {
		q = t->next;
		t->next = 0;
		return q;
	    }
	    /* indent at least 2, and at most as
	     * as far as the initial line was indented. */
	    indent = clip ? clip : 2;
	}

	if ( (q->dle < indent) && (ishr(q) || islist(q,&z,flags,&z)
					   || (check && (*check)(q)))
			       && !issetext(q,&z) ) {
	    q = t->next;
	    t->next = 0;
	    return q;
	}

	clip = (q->dle > indent) ? indent : q->dle;
    }
    return t;
}
Ejemplo n.º 7
0
static int
endoftextblock(Line *t, int toplevelblock, DWORD flags)
{
    int z;

    if ( end_of_block(t) || isquote(t) )
	return 1;

    /* HORRIBLE STANDARDS KLUDGES:
     * 1. non-toplevel paragraphs absorb adjacent code blocks
     * 2. Toplevel paragraphs eat absorb adjacent list items,
     *    but sublevel blocks behave properly.
     * (What this means is that we only need to check for code
     *  blocks at toplevel, and only check for list items at
     *  nested levels.)
     */
    return toplevelblock ? 0 : islist(t,&z,flags,&z);
}
Ejemplo n.º 8
0
/* must be called with interned term (isinternstr(term)is true) */
int is_interned_rec(Cell term) {
  int areaindex, reclen;
  struct intterm_rec *recptr;
  CPtr term_rec;
  UInteger hashindex; 

  if (islist(term)) {areaindex = LIST_INDEX; reclen = 2; }
  else {areaindex = get_arity(get_str_psc(term)); reclen = areaindex + 1; }
  if (!hc_block[areaindex].base) return FALSE;
  term_rec = (CPtr)cs_val(term);

  hashindex = it_hash(hc_block[areaindex].hashtab_size,reclen,term_rec);
  recptr = hc_block[areaindex].hashtab[hashindex];
  while (recptr) {
    if (term_rec == &(recptr->intterm_psc)) {return TRUE;}
    recptr = recptr->next;
  }
  return FALSE;
}
Ejemplo n.º 9
0
static int
endoftextblock(Line *t, int toplevelblock, DWORD flags)
{
    int z;

    if ( blankline(t)||isquote(t)||ishdr(t,&z)||ishr(t) )
	return 1;

    /* HORRIBLE STANDARDS KLUDGE: non-toplevel paragraphs absorb adjacent
     * code blocks
     */
    if ( toplevelblock && iscode(t) )
	return 1;

    /* HORRIBLE STANDARDS KLUDGE: Toplevel paragraphs eat absorb adjacent
     * list items, but sublevel blocks behave properly.
     */
    return toplevelblock ? 0 : islist(t,&z,flags, &z);
}
Ejemplo n.º 10
0
Archivo: prim.c Proyecto: l0stman/loot
/* Apply a procedure expression to a list of expressions */
static exp_t *
prim_apply(exp_t *args)
{
        exp_t *op, *prev, *last;

        if (isnull(args) || isnull(cdr(args)))
                everr("apply: expects at least 2 arguments, given", args);
        op = car(args);
        if (!isnull(last = cddr(args))) {
                for (prev = cdr(args); !isnull(cdr(last)); last = cdr(last))
                        prev = last;
                cdr(prev) = car(last);
                args = cdr(args);
        } else {
                last = cdr(args);
                args = car(last);
        }
        if (!islist(car(last)))
                everr("apply: should be a proper list", car(last));
        return apply(op, args);
}
Ejemplo n.º 11
0
xsbBool answer_is_junk(CPtr dlist)	  /* assumes that dlist != NULL */
{
    CPtr    cptr;
    VariantSF subgoal;
    NODEptr ans_subst;
    Cell tmp_cell;

    while (islist(dlist)) {
      dlist = clref_val(dlist);
      cptr = (CPtr) cs_val(cell(dlist));
      tmp_cell = cell(cptr + 1);
      subgoal = (VariantSF) addr_val(tmp_cell);
      tmp_cell = cell(cptr + 2);
      ans_subst = (NODEptr) addr_val(tmp_cell);
      if (is_failing_delay_element(subgoal,ans_subst)) {
	return TRUE;
      }
      dlist = (CPtr) cell(dlist+1);
    }
    return FALSE;
}
Ejemplo n.º 12
0
static action_t cont_fn() {
  ref_t formals = car(expr), body = cdr(expr);
  size_t arity = 0;
  bool rest = NO;
  if (!islist(formals))
    error("invalid function: formals must be a list");
  for(; !isnil(formals); arity++, formals = cdr(formals)) {
    ref_t sym = car(formals);
    if (sym == sym_amp) {
      if (length(cdr(formals)) != 1)
        error("invalid function: must have exactly one symbol after &");
      rest = YES;
      set_car(formals, cadr(formals));
      set_cdr(formals, NIL);
      break;
    }
  }
  formals = car(expr);
  pop_cont();
  expr = lambda(formals, body, C(cont)->closure, arity, rest);
  return ACTION_APPLY_CONT;
}
Ejemplo n.º 13
0
/* should be passed a term which is dereffed for which isinternstr is true! */
int isinternstr_really(prolog_term term) {
  int areaindex, reclen, i;
  CPtr termrec;
  CPtr hc_term;
  struct intterm_rec *recptr;
  Integer hashindex; 
  int found;
  
  XSB_Deref(term);
  if (isconstr(term)) {
    areaindex = get_arity(get_str_psc(term)); 
    reclen = areaindex + 1;
  } else if (islist(term)) {
    areaindex = LIST_INDEX; 
    reclen = 2;
  } else return FALSE;
  if (!hc_block[areaindex].hashtab) return FALSE;
  termrec = (CPtr)dec_addr(term);
  hashindex = it_hash(hc_block[areaindex].hashtab_size,reclen,termrec);
  recptr = hc_block[areaindex].hashtab[hashindex];
  while (recptr) {
    found = 1;
    hc_term = &(recptr->intterm_psc);
    for (i=0; i<reclen; i++) {
      if (cell(hc_term+i) != cell(termrec+i)) {
	found = 0; break;
      }
    }
    //    if (found && (hc_term == termrec)) printf("found interned term\n");
    if (found) return (hc_term == termrec);
    recptr = recptr->next;
  }
  return FALSE;

 
}
Ejemplo n.º 14
0
xsbBool glstack_realloc(CTXTdeclc size_t new_size, int arity)
{
  CPtr   new_heap_bot=NULL ;       /* bottom of new Global Stack area */
  CPtr   new_ls_bot ;         /* bottom of new Local Stack area */

  size_t heap_offset ;        /* offsets between the old and new */
  size_t local_offset ;       /* stack bottoms, measured in Cells */

  CPtr   *cell_ptr ;
  Cell   cell_val ;
  size_t i, rnum_in_trieinstr_unif_stk = (trieinstr_unif_stkptr-trieinstr_unif_stk)+1;

  size_t  new_size_in_bytes, new_size_in_cells ; /* what a mess ! */
  double   expandtime ;

  if (new_size <= glstack.size) { // asked to shrink
    // new_size is space needed + half of init_size, rounded to K
    new_size = (((glstack.high - (byte *)top_of_localstk) +
		 ((byte *)hreg - glstack.low)) + glstack.init_size*K/2 + (K-1)) / K;
    // but not smaller than init_size
    if (new_size < glstack.init_size) new_size = glstack.init_size;
    if (new_size >= glstack.size) return 0;  // computed new_size won't shrink
    //    printf("shrinking glstack from %dK to %dK\n",glstack.size,new_size);
  }

  //  fprintf(stddbg,"Reallocating the Heap and Local Stack data area");
#ifdef DEBUG_VERBOSE
  if (LOG_REALLOC <= cur_log_level) {
    if (glstack.size == glstack.init_size) {
      xsb_dbgmsg((LOG_REALLOC,"\tBottom:\t\t%p\t\tInitial Size: %" Intfmt "K",
		 glstack.low, glstack.size));
      xsb_dbgmsg((LOG_REALLOC,"\tTop:\t\t%p", glstack.high));
    }
  }
#endif
  expandtime = cpu_time();

  new_size_in_bytes = new_size*K ;
  new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
  		/* and let's hope K stays divisible by sizeof(Cell) */

  stack_boundaries ;

  /* Expand the data area and push the Local Stack to the high end. */

  if (new_size < glstack.size) { //shrinking
    // move local stack down
    memmove(glstack.low + new_size_in_bytes-(glstack.high-(byte *)ls_top),  // to
	    ls_top,  // from
	    glstack.high - (byte *)ls_top  // size
	    );
    new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
    heap_offset = new_heap_bot - heap_bot ;
    new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
    local_offset = new_ls_bot - ls_bot ;
  } else { // expanding
    if (!USER_MEMORY_LIMIT_EXHAUSTED(new_size)) 
      new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
    if (new_heap_bot == NULL) {
      if (2*glstack.size == new_size) { /* if trying to double, try backing off, may not help */
	size_t increment = new_size;
	while (new_heap_bot == NULL && increment > 40) {
	  increment = increment/2;
	  new_size = glstack.size + increment;
	  new_size_in_bytes = new_size*K ;
	  new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
	  if (!USER_MEMORY_LIMIT_EXHAUSTED(new_size))
	    new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
	}
	if (new_heap_bot == NULL) {
	  //	  xsb_mesg("Not enough core to resize the Heap/Local Stack! (current: %"Intfmt"; resize %"Intfmt")",
	  //   glstack.size*K,new_size_in_bytes);
	  return 1; /* return an error output -- will be picked up later */
	}
      } else {
	xsb_mesg("Not enough core to resize the Heap and Local Stack! (%" Intfmt ")",new_size_in_bytes);
	return 1; /* return an error output -- will be picked up later */
      }
    }
    //    printf("realloced heap %d -> %d\n",glstack.size,new_size);
    heap_offset = new_heap_bot - heap_bot ;
    new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
    local_offset = new_ls_bot - ls_bot ;

#if defined(GENERAL_TAGGING)
    //  printf("glstack expand %p %p\n",(void *)new_heap_bot,(void *)new_ls_bot+1);
    extend_enc_dec_as_nec(new_heap_bot,new_ls_bot+1);
#endif

    memmove(ls_top + local_offset,             /* move to */
	    ls_top + heap_offset,              /* move from */
	    (ls_bot - ls_top + 1)*sizeof(Cell) );      /* number of bytes */
  }

  initialize_glstack(heap_top + heap_offset,ls_top+local_offset);

  /* TLS: below, the condition should not need to be commented out.
     If the heap expands, there should be no pointers from heap into
     the local stack, so we shouldnt need to traverse the heap.
     However, call subumption code actually copies the substitution
     factor from the CPS to heap (I dont know why, but see the comment
     after the call to subsumptive_call_search() in slginsts_xsb_i.h),
     so that substitution factor pointers may point from the heap to
     local stack.  Therefore the pointer update causes the heap-ls
     pointers to be harmless at glstack expansion.
  */

  /* Update the Heap links */
  //  if (heap_offset != 0) {
    for (cell_ptr = (CPtr *)(heap_top + heap_offset);
	 cell_ptr-- > (CPtr *)new_heap_bot;
	 )
      { reallocate_heap_or_ls_pointer(cell_ptr) ; }
    //  }

  /* Update the pointers in the Local Stack */
  for (cell_ptr = (CPtr *)(ls_top + local_offset);
       cell_ptr <= (CPtr *)new_ls_bot;
       cell_ptr++)
  { reallocate_heap_or_ls_pointer(cell_ptr) ; }

  /* Update the trailed variable pointers */
  for (cell_ptr = (CPtr *)top_of_trail - 1;
       cell_ptr > (CPtr *)tcpstack.low;
       cell_ptr = cell_ptr - 2)
  { /* first the value */
    reallocate_heap_or_ls_pointer(cell_ptr);
    /* now the address */
    cell_ptr-- ;
    cell_val = (Cell)*cell_ptr ;
#ifdef PRE_IMAGE_TRAIL
    if ((size_t) cell_val & PRE_IMAGE_MARK) {
      /* remove tag */
      cell_val = (Cell) ((Cell) cell_val & ~PRE_IMAGE_MARK);
      /* realloc and tag */
      realloc_ref_pre_image(cell_ptr,(CPtr)cell_val) ;
      cell_ptr--;
      /* realoc pre-image */
      reallocate_heap_or_ls_pointer(cell_ptr);
    } else
#endif
      realloc_ref(cell_ptr,(CPtr)cell_val) ;
  }

  /* Update the CP Stack pointers */
  for (cell_ptr = (CPtr *)top_of_cpstack;
       cell_ptr < (CPtr *)tcpstack.high;
       cell_ptr++)
  { reallocate_heap_or_ls_pointer(cell_ptr) ; }

  /* Update the argument registers */
  while (arity)
  { cell_ptr = (CPtr *)(reg+arity) ;
    reallocate_heap_or_ls_pointer(cell_ptr) ;
    arity-- ;  
  }

  i = 0;
  while (i < rnum_in_trieinstr_unif_stk) {
    cell_ptr = (CPtr *)(trieinstr_unif_stk+i);
    //    printf(" reallocate trieinstr_unif_stk[%d]=%p\n",i,cell_ptr);
    reallocate_heap_or_ls_pointer(cell_ptr) ;
    i++;
  }

  /* Update the system variables */
  glstack.low = (byte *)new_heap_bot ;
  glstack.high = (byte *)(new_ls_bot + 1) ;
  pspace_tot_gl = pspace_tot_gl + (new_size - glstack.size)*K;
  glstack.size = new_size ;

  hreg = (CPtr)hreg + heap_offset ;
  hbreg = (CPtr)hbreg + heap_offset ;
  hfreg = (CPtr)hfreg + heap_offset ;
  ereg = (CPtr)ereg + local_offset ;
  ebreg = (CPtr)ebreg + local_offset ;
  efreg = (CPtr)efreg + local_offset ;

  if (islist(delayreg))
    delayreg = (CPtr)makelist(clref_val(delayreg) + heap_offset);

  expandtime = cpu_time() - expandtime;

  xsb_dbgmsg((LOG_REALLOC,"\tNew Bottom:\t%p\t\tNew Size: %" Intfmt "K",
	     glstack.low, glstack.size));
  xsb_dbgmsg((LOG_REALLOC,"\tNew Top:\t%p", glstack.high));
  xsb_dbgmsg((LOG_REALLOC,
	     "Heap/Local Stack data area expansion - finished in %lf secs\n",
	     expandtime));

  return 0;
} /* glstack_realloc */
Ejemplo n.º 15
0
 string emitCode(Form* form/*, emissionContext ctx = Bottom*/)
 {
   string out;
   if(form == NULL)
     error(form,"Can't emit code for the null form.");
   else if(isatom(form))
   {
     switch(analyze(val(form)))
     {
       case BooleanTrue:
       {
         out = constant(get_unique_res("i1"),"i1","true");
         break;
       }
       case BooleanFalse:
       {
         out = constant(get_unique_res("i1"),"i1","false");
         break;
       }
       case Integer:
       {
         out = constant(get_unique_res("i64"),"i64",val(form));
         break;
       }
       case Character:
       {
         string c = string(val(form),1,val(form).length()-2);
         string address = "@___string" + to_string<unsigned long>(++string_version);
         push(address + " = global [2 x i8] c\"" + c + "\0\0\"");
         out += get_unique_res("i8") + " = load i8* getelementptr inbounds ([2 x i8]* " + address + ", i32 0, i64 0)";
         break;
       }
       case Real:
       {
         out = constant(get_unique_res("double"),"double",val(form));
         break;
       }
       case String:
       {
         //Remember strings come with their double quotes
         //Also convert them to unicode
         string str = cutboth(val(form));
         unsigned long length = str.length();
         stringstream ss;
         string result;
         for(unsigned long i = 0; i < str.length(); i++)
         { 
           string tmp;
           if(str[i] == '\\')
           {
             //Oh goodness, escape sequences
             i++;
             switch(str[i])
             {
               case 'n':
                 ss << "0A";
                 break;
               case '\\':
                 ss << "5C";
                 break;
               case '"':
                 ss << "22";
                 break;
               case '0':
                 ss << "00";
                 break;
               case 'a':
                 ss << "07";
                 break;
               case 'b':
                 ss << "08";
                 break;
               case 'f':
                 ss << "0C";
                 break;
               case 'r':
                 ss << "0D";
                 break;
               case 't':
                 ss << "09";
                 break;
               case 'v':
                 ss << "0B";
                 break;
               case 'x':
                 //TODO: Manage hex input
                 break;
               case 'o':
                 //TODO: Manage octal input
                 break;
               case 'U':
                 //TODO: Great, a unicode codepoint...
                 break;
               default:
                 error(form,"Unknown character escape sequence.");
             }
             length--;
           }
           else
           {
             ss << hex << (int)str[i];
           }
           tmp = ss.str();
           if(tmp.length() > 2)
           {
             tmp = string(tmp,tmp.length()-2);
           }
           result += '\\' + tmp;
           //cerr << "Result: " << result << endl;
         }
         string type = "[" + to_string<unsigned long>(length+1) + " x i8]";
         push("@___string" + to_string<unsigned long>(++string_version) + " = global " + type + " c\"" + result + "\\00\"");
         out = get_unique_res("i8*") + " = getelementptr " + type + "* @___string" + to_string<unsigned long>(string_version) + ", i64 0, i64 0";
         break;
       }
       case Symbol:
       {
         string sym = val(form);
         Variable* tmp = lookup(sym);
         if(tmp == NULL)
           error_unbound(form);
         else
           out = load(get_unique_res_address(tmp->type,tmp->address,true),tmp->type,((tmp->global) ? "@" : "%")
               + sym+to_string(tmp->scope_address));
         break;
       }
       case Unidentifiable:
       {
         error(form,"Received an unidentifiable form as input.");
         break;
       }
     }
   }
   else
   {
     if(islist(car(form)))
       error(form,"Lists can't be used as function names in calls. Until I implement lambda.");
     string func = val(car(form));
     map<string,hFuncPtr>::iterator seeker = Core.find(func);
     if(seeker != Core.end())
       out = seeker->second(form);
     else
       out = callFunction(form);
   }
   return out+"\n";
 }
Ejemplo n.º 16
0
expr *eval(scope *scope, expr *e) {
  if (e == NULL)
    return NULL;

  switch (e->type) {
  // String and Integer expressions evaluate to themselves.
  case STRING_EXPR:
  case INT_EXPR:
  case FUNC_EXPR:
  case BUILTIN_EXPR:
  case BOOL_EXPR:
    return e;
  case SYMBOL_EXPR: {
    expr *value = scope_lookup(scope, e->string_value);
    // if (!value)
    //  PANIC("Symbol %s not bound to any value\n", e->string_value);
    return value;
  }
  case CELL_EXPR: {
    expr *head = eval(scope, e->head);
    if (head == NULL)
      PANIC("() is not a function.");
    if (head->type == BUILTIN_EXPR) {
      // Call the built-in construct.
      return head->func_ptr(scope, e->tail);
    } else if (head->type == FUNC_EXPR) {
      // Call the function.
      struct scope *new_scope = scope_create(head->closure);

      if (islist(head->arguments)) {
        expr *actuals = e->tail;
        for (expr *formal = head->arguments; formal != NULL; formal = formal->tail) {
          expr *formal_expr = formal->head;
          assert(formal_expr->type == SYMBOL_EXPR);
          if (actuals != NULL) {
            // If this is a regular function, evaluate the argument. Otherwise, return expression,
            // Since macros take in their arguments literally.
            expr *actual_value = head->ismacro ? actuals->head : eval(scope, actuals->head);
            // Bind the actual value to the formal symbol.
            scope_add_mapping(new_scope, formal_expr->string_value, actual_value);
            // Proceed to the next actual.
            actuals = actuals->tail;
          } else {
            // No more actuals, so simply bind the symbol to the empty list (NIL).
            scope_add_mapping(new_scope, formal_expr->string_value, NULL);
          }
        }
      } else if (issymbol(head->arguments)) {
        if (head->ismacro)
          scope_add_mapping(new_scope, head->arguments->string_value, e->tail);
        else
          scope_add_mapping(new_scope, head->arguments->string_value, eval_varargs(scope, e->tail));
      }

      // Evaulate the body of the function
      struct expr *last_value = NULL;
      for (struct expr *statement = head->body; statement != NULL; statement = statement->tail) {
        last_value = eval(new_scope, statement->head);
      }

      // If this is a regular function, we simply return the result.
      return head->ismacro ? eval(scope, last_value) : last_value;
    } else {
      PANIC("Tried to execute something which is not a function or a macro.");
    }
  }
  default:
    PANIC("Unkown expression type.\n");
  }
}
Ejemplo n.º 17
0
/* XSB string substitution entry point
   In:
      Arg1: string
      Arg2: beginning offset
      Arg3: ending offset. `_' or -1: end of string, -2: char before last, etc.
   Out:
      Arg4: new (output) string
   Always succeeds, unless error.
*/
xsbBool substring(CTXTdecl)
{
    /* Prolog args are first assigned to these, so we could examine the types
       of these objects to determine if we got strings or atoms. */
    prolog_term input_term, output_term;
    prolog_term beg_offset_term, end_offset_term;
    char *input_string=NULL;    /* string where matches are to be found */
    Integer beg_offset=0, end_offset=0, input_len=0, substring_len=0;
    int conversion_required=FALSE;

    XSB_StrSet(&output_buffer,"");

    input_term = reg_term(CTXTc 1);  /* Arg1: string to find matches in */
    if (isatom(input_term)) /* check it */
        input_string = string_val(input_term);
    else if (islist(input_term)) {
        input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
                                              "SUBSTRING", "input string");
        conversion_required = TRUE;
    } else
        xsb_abort("[SUBSTRING] Arg 1 (the input string) must be an atom or a character list");

    input_len = strlen(input_string);

    /* arg 2: beginning offset */
    beg_offset_term = reg_term(CTXTc 2);
    if (! (isointeger(beg_offset_term)))
        xsb_abort("[SUBSTRING] Arg 2 (the beginning offset) must be an integer");
    beg_offset = oint_val(beg_offset_term);
    if (beg_offset < 0)
        beg_offset = 0;
    else if (beg_offset > input_len)
        beg_offset = input_len;

    /* arg 3: ending offset */
    end_offset_term = reg_term(CTXTc 3);
    if (isref(end_offset_term))
        end_offset = input_len;
    else if (! (isointeger(end_offset_term)))
        xsb_abort("[SUBSTRING] Arg 3 (the end offset) must be integer or _");
    else end_offset = oint_val(end_offset_term);

    if (end_offset < 0)
        end_offset = input_len + 1 + end_offset;
    else if (end_offset > input_len)
        end_offset = input_len;
    else if (end_offset < beg_offset)
        end_offset = beg_offset;

    output_term = reg_term(CTXTc 4);
    if (! isref(output_term))
        xsb_abort("[SUBSTRING] Arg 4 (the output string) must be an unbound variable");

    /* do the actual replacement */
    substring_len = end_offset-beg_offset;
    XSB_StrAppendBlk(&output_buffer, input_string+beg_offset, (int)substring_len);
    XSB_StrNullTerminate(&output_buffer);

    /* get result out */
    if (conversion_required)
        c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
                               4, "SUBSTRING", "Arg 4");
    else
        c2p_string(CTXTc output_buffer.string, output_term);

    return(TRUE);
}
Ejemplo n.º 18
0
/*
 * break a collection of markdown input into
 * blocks of lists, code, html, and text to
 * be marked up.
 */
static Paragraph *
compile(Line *ptr, int toplevel, MMIOT *f)
{
    ParagraphRoot d = { 0, 0 };
    Paragraph *p = 0;
    Line *r;
    int para = toplevel;
    int blocks = 0;
    int hdr_type, list_type, list_class, indent;

    ptr = consume(ptr, &para);

    while ( ptr ) {
	if ( iscode(ptr) ) {
	    p = Pp(&d, ptr, CODE);
	    
	    if ( f->flags & MKD_1_COMPAT) {
		/* HORRIBLE STANDARDS KLUDGE: the first line of every block
		 * has trailing whitespace trimmed off.
		 */
		___mkd_tidy(&p->text->text);
	    }
	    
	    ptr = codeblock(p);
	}
#if WITH_FENCED_CODE
	else if ( iscodefence(ptr,3,0) && (p=fencedcodeblock(&d, &ptr)) )
	    /* yay, it's already done */ ;
#endif
	else if ( ishr(ptr) ) {
	    p = Pp(&d, 0, HR);
	    r = ptr;
	    ptr = ptr->next;
	    ___mkd_freeLine(r);
	}
	else if ( list_class = islist(ptr, &indent, f->flags, &list_type) ) {
	    if ( list_class == DL ) {
		p = Pp(&d, ptr, DL);
		ptr = definition_block(p, indent, f, list_type);
	    }
	    else {
		p = Pp(&d, ptr, list_type);
		ptr = enumerated_block(p, indent, f, list_class);
	    }
	}
	else if ( isquote(ptr) ) {
	    p = Pp(&d, ptr, QUOTE);
	    ptr = quoteblock(p, f->flags);
	    p->down = compile(p->text, 1, f);
	    p->text = 0;
	}
	else if ( ishdr(ptr, &hdr_type) ) {
	    p = Pp(&d, ptr, HDR);
	    ptr = headerblock(p, hdr_type);
	}
	else {
	    p = Pp(&d, ptr, MARKUP);
	    ptr = textblock(p, toplevel, f->flags);
	    /* tables are a special kind of paragraph */
	    if ( actually_a_table(f, p->text) )
		p->typ = TABLE;
	}

	if ( (para||toplevel) && !p->align )
	    p->align = PARA;

	blocks++;
	para = toplevel || (blocks > 1);
	ptr = consume(ptr, &para);

	if ( para && !p->align )
	    p->align = PARA;

    }
    return T(d);
}
Ejemplo n.º 19
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;
}
Ejemplo n.º 20
0
/* caller must ensure enough heap space (term_size(term)*sizeof(Cell)) */
prolog_term intern_term(CTXTdeclc prolog_term term) {
  Integer ti = 0;
  Cell arg, newterm, interned_term, orig_term;
  unsigned int subterm_index;

  XSB_Deref(term);
  if (!(islist(term) || isconstr(term))) {return term;}
  if (isinternstr(term)) {return term;}
  if (is_cyclic(CTXTc term)) {xsb_abort("Cannot intern a cyclic term\n");}
  //  if (!ground(term)) {return term;}

  orig_term = term;
  //  printf("iti: ");printterm(stdout,orig_term,100);printf("\n");

  if (!ts_array) {
    ts_array = mem_alloc(init_ts_array_len*sizeof(*ts_array),OTHER_SPACE);
    if (!ts_array) xsb_abort("No space for interning term\n");
    ts_array_len = init_ts_array_len;
  }
  
  ts_array[0].term = term;
  if (islist(term)) {
    ts_array[0].subterm_index = 0;
    ts_array[0].newterm = makelist(hreg);
    hreg += 2;
  }
  else {
    //    if (isboxedinteger(term)) printf("interning boxed int\n");
    //    else if (isboxedfloat(term)) printf("interning boxed float %f\n",boxedfloat_val(term));
    ts_array[0].subterm_index = 1;
    ts_array[0].newterm = makecs(hreg);
    new_heap_functor(hreg, get_str_psc(term));
    hreg += get_arity(get_str_psc(term));
  }
  ts_array[ti].ground = 1;

  while (ti >= 0) {
    term = ts_array[ti].term;
    newterm = ts_array[ti].newterm;
    subterm_index = ts_array[ti].subterm_index;
    if ((islist(term) && subterm_index >= 2) ||
	(isconstr(term) && subterm_index > get_arity(get_str_psc(term)))) {
      if (ts_array[ti].ground) {
	interned_term = intern_rec(CTXTc newterm);
	if (!interned_term) xsb_abort("error term should have been interned\n");
	hreg = clref_val(newterm);  // reclaim used stack space
	if (!ti) {
	  if (compare(CTXTc (void*)orig_term,(void*)interned_term) != 0) printf("NOT SAME\n");
	  //printf("itg: ");printterm(stdout,interned_term,100);printf("\n"); 
	  return interned_term;
	}
	ti--;
	get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = interned_term;
      } else {
	//printf("hreg = %p, ti=%d\n",hreg,ti);
	if (!ti) {
	  if (compare(CTXTc (void*)orig_term,(void*)newterm) != 0) printf("NOT SAME\n");
	  //printf("ito: ");printterm(stdout,newterm,100);printf("\n"); 
	  return newterm;
	}
	ti--;
	get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = newterm;
	ts_array[ti].ground = 0;
      }
    } else {
      arg = get_str_arg(term, (ts_array[ti].subterm_index)++);
      XSB_Deref(arg);
      switch (cell_tag(arg)) {
      case XSB_FREE:
      case XSB_REF1:
      case XSB_ATTV:
	ts_array[ti].ground = 0;
	get_str_arg(newterm,subterm_index) = arg;
	break;
      case XSB_STRING:
	if (string_find_safe(string_val(arg)) != string_val(arg)) printf("uninterned string?\n");
      case XSB_INT:
      case XSB_FLOAT:
	get_str_arg(newterm,subterm_index) = arg;
	break;
      case XSB_LIST:
	if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg;
	else {
	  ti++;
	  check_ts_array_overflow;
	  ts_array[ti].term = arg;
	  ts_array[ti].subterm_index = 0;
	  ts_array[ti].ground = 1;
	  ts_array[ti].newterm = makelist(hreg);
	  hreg += 2;
	}
	break;
      case XSB_STRUCT:
	if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg;
	else {
	  //	  if (isboxedinteger(arg)) printf("interning boxed int\n");
	  //	  else if (isboxedfloat(arg)) printf("interning boxed float %f\n",boxedfloat_val(arg));
	  ti++;
	  check_ts_array_overflow;
	  ts_array[ti].term = arg;
	  ts_array[ti].subterm_index = 1;
	  ts_array[ti].ground = 1;
	  ts_array[ti].newterm = makecs(hreg);
	  new_heap_functor(hreg,get_str_psc(arg));
	  hreg += get_arity(get_str_psc(arg));
	}
      }
    }
  }
  printf("intern_term: shouldn't happen\n");
  return 0;
}
Ejemplo n.º 21
0
/* XSB string substitution entry point: replace substrings specified in Arg2
   with strings in Arg3.
   In:
       Arg1: string
       Arg2: substring specification, a list [s(B1,E1),s(B2,E2),...]
       Arg3: list of replacement strings
   Out:
       Arg4: new (output) string
   Always succeeds, unless error.
*/
xsbBool string_substitute(CTXTdecl)
{
    /* Prolog args are first assigned to these, so we could examine the types
       of these objects to determine if we got strings or atoms. */
    prolog_term input_term, output_term;
    prolog_term subst_reg_term, subst_spec_list_term, subst_spec_list_term1;
    prolog_term subst_str_term=(prolog_term)0,
                subst_str_list_term, subst_str_list_term1;
    char *input_string=NULL;    /* string where matches are to be found */
    char *subst_string=NULL;
    prolog_term beg_term, end_term;
    Integer beg_offset=0, end_offset=0, input_len;
    Integer last_pos = 0; /* last scanned pos in input string */
    /* the output buffer is made large enough to include the input string and the
       substitution string. */
    int conversion_required=FALSE; /* from C string to Prolog char list */

    XSB_StrSet(&output_buffer,"");

    input_term = reg_term(CTXTc 1);  /* Arg1: string to find matches in */
    if (isatom(input_term)) /* check it */
        input_string = string_val(input_term);
    else if (islist(input_term)) {
        input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
                                              "STRING_SUBSTITUTE", "input string");
        conversion_required = TRUE;
    } else
        xsb_abort("[STRING_SUBSTITUTE] Arg 1 (the input string) must be an atom or a character list");

    input_len = strlen(input_string);

    /* arg 2: substring specification */
    subst_spec_list_term = reg_term(CTXTc 2);
    if (!islist(subst_spec_list_term) && !isnil(subst_spec_list_term))
        xsb_abort("[STRING_SUBSTITUTE] Arg 2 must be a list [s(B1,E1),s(B2,E2),...]");

    /* handle substitution string */
    subst_str_list_term = reg_term(CTXTc 3);
    if (! islist(subst_str_list_term))
        xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");

    output_term = reg_term(CTXTc 4);
    if (! isref(output_term))
        xsb_abort("[STRING_SUBSTITUTE] Arg 4 (the output) must be an unbound variable");

    subst_spec_list_term1 = subst_spec_list_term;
    subst_str_list_term1 = subst_str_list_term;

    if (isnil(subst_spec_list_term1)) {
        XSB_StrSet(&output_buffer, input_string);
        goto EXIT;
    }
    if (isnil(subst_str_list_term1))
        xsb_abort("[STRING_SUBSTITUTE] Arg 3 must not be an empty list");

    do {
        subst_reg_term = p2p_car(subst_spec_list_term1);
        subst_spec_list_term1 = p2p_cdr(subst_spec_list_term1);

        if (!isnil(subst_str_list_term1)) {
            subst_str_term = p2p_car(subst_str_list_term1);
            subst_str_list_term1 = p2p_cdr(subst_str_list_term1);

            if (isatom(subst_str_term)) {
                subst_string = string_val(subst_str_term);
            } else if (islist(subst_str_term)) {
                subst_string = p_charlist_to_c_string(CTXTc subst_str_term, &subst_buf,
                                                      "STRING_SUBSTITUTE",
                                                      "substitution string");
            } else
                xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
        }

        beg_term = p2p_arg(subst_reg_term,1);
        end_term = p2p_arg(subst_reg_term,2);

        if (!(isointeger(beg_term)) ||
                !(isointeger(end_term)))
            xsb_abort("[STRING_SUBSTITUTE] Non-integer in Arg 2");
        else {
            beg_offset = oint_val(beg_term);
            end_offset = oint_val(end_term);
        }
        /* -1 means end of string */
        if (end_offset < 0)
            end_offset = input_len;
        if ((end_offset < beg_offset) || (beg_offset < last_pos))
            xsb_abort("[STRING_SUBSTITUTE] Substitution regions in Arg 2 not sorted");

        /* do the actual replacement */
        XSB_StrAppendBlk(&output_buffer,input_string+last_pos,(int)(beg_offset-last_pos));
        XSB_StrAppend(&output_buffer, subst_string);

        last_pos = end_offset;

    } while (!isnil(subst_spec_list_term1));

    XSB_StrAppend(&output_buffer, input_string+end_offset);

EXIT:
    /* get result out */
    if (conversion_required)
        c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
                               4, "STRING_SUBSTITUTE", "Arg 4");
    else
        c2p_string(CTXTc output_buffer.string, output_term);

    return(TRUE);
}
Ejemplo n.º 22
0
Archivo: subp.c Proyecto: flavioc/XSB
int compare(CTXTdeclc const void * v1, const void * v2)
{
  int comp;
  CPtr cptr1, cptr2;
  Cell val1 = (Cell) v1 ;
  Cell val2 = (Cell) v2 ;

  XSB_Deref(val2);		/* val2 is not in register! */
  XSB_Deref(val1);		/* val1 is not in register! */
  if (val1 == val2) return 0;
  switch(cell_tag(val1)) {
  case XSB_FREE:
  case XSB_REF1:
    if (isattv(val2))
      return vptr(val1) - (CPtr)dec_addr(val2);
    else if (isnonvar(val2)) return -1;
    else { /* in case there exist local stack variables in the	  */
	   /* comparison, globalize them to guarantee that their  */
	   /* order is retained as long as nobody "touches" them  */
	   /* in the future -- without copying garbage collection */
      if ((top_of_localstk <= vptr(val1)) &&
	  (vptr(val1) <= (CPtr)glstack.high-1)) {
	bld_free(hreg);
	bind_ref(vptr(val1), hreg);
	hreg++;
	val1 = follow(val1);	/* deref again */
      }
      if ((top_of_localstk <= vptr(val2)) &&
	  (vptr(val2) <= (CPtr)glstack.high-1)) {
	bld_free(hreg);
	bind_ref(vptr(val2), hreg);
	hreg++;
	val2 = follow(val2);	/* deref again */
      }
      return vptr(val1) - vptr(val2);
    }
  case XSB_FLOAT:
    if (isref(val2) || isattv(val2)) return 1;
    else if (isofloat(val2)) 
      return sign(float_val(val1) - ofloat_val(val2));
    else return -1;
  case XSB_INT:
    if (isref(val2) || isofloat(val2) || isattv(val2)) return 1;
    else if (isinteger(val2)) 
      return int_val(val1) - int_val(val2);
    else if (isboxedinteger(val2))
      return int_val(val1) - boxedint_val(val2);
    else return -1;
  case XSB_STRING:
    if (isref(val2) || isofloat(val2) || isinteger(val2) || isattv(val2)) 
      return 1;
    else if (isstring(val2)) {
      return strcmp(string_val(val1), string_val(val2));
    }
    else return -1;
  case XSB_STRUCT:
    // below, first 2 if-checks test to see if this struct is actually a number representation,
    // (boxed float or boxed int) and if so, does what the number case would do, only with boxed_val
    // macros.
    if (isboxedinteger(val1)) {
      if (isref(val2) || isofloat(val2) || isattv(val2)) return 1;
      else if (isinteger(val2)) 
	return boxedint_val(val1) - int_val(val2);
      else if (isboxedinteger(val2))
	return boxedint_val(val1) - boxedint_val(val2);
      else return -1;
    } else if (isboxedfloat(val1)) {
        if (isref(val2) || isattv(val2)) return 1;
        else if (isofloat(val2)) 
          return sign(boxedfloat_val(val1) - ofloat_val(val2));
        else return -1;            
    } else if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
    else {
      int arity1, arity2;
      Psc ptr1 = get_str_psc(val1);
      Psc ptr2 = get_str_psc(val2);

      arity1 = get_arity(ptr1);
      if (islist(val2)) arity2 = 2; 
      else arity2 = get_arity(ptr2);
      if (arity1 != arity2) return arity1-arity2;
      if (islist(val2)) comp = strcmp(get_name(ptr1), ".");
      else comp = strcmp(get_name(ptr1), get_name(ptr2));
      if (comp || (arity1 == 0)) return comp;
      cptr1 = clref_val(val1);
      cptr2 = clref_val(val2);
      for (arity2 = 1; arity2 <= arity1; arity2++) {
	if (islist(val2))
	  comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2-1));  
	else
	  comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2));
	if (comp) break;
      }
      return comp;
    }
    break;
  case XSB_LIST:
    if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
    else if (isconstr(val2)) return -(compare(CTXTc (void*)val2, (void*)val1));
    else {	/* Here we are comparing two list structures. */
      cptr1 = clref_val(val1);
      cptr2 = clref_val(val2);
      comp = compare(CTXTc (void*)cell(cptr1), (void*)cell(cptr2));
      if (comp) return comp;
      return compare(CTXTc (void*)cell(cptr1+1), (void*)cell(cptr2+1));
    }
    break;
  case XSB_ATTV:
    if (isattv(val2))
      return (CPtr)dec_addr(val1) - (CPtr)dec_addr(val2);
    else if (isref(val2))
      return (CPtr)dec_addr(val1) - vptr(val2);
    else
      return -1;
  default:
    xsb_abort("Compare (unknown tag %ld); returning 0", cell_tag(val1));
    return 0;
  }
}
Ejemplo n.º 23
0
xsbBool glstack_realloc(int new_size, int arity)
{
  CPtr   new_heap_bot ;       /* bottom of new Global Stack area */
  CPtr   new_ls_bot ;         /* bottom of new Local Stack area */

  long   heap_offset ;        /* offsets between the old and new */
  long   local_offset ;       /* stack bottoms, measured in Cells */

  CPtr   *cell_ptr ;
  Cell   cell_val ;

  size_t new_size_in_bytes, new_size_in_cells ; /* what a mess ! */
  long   expandtime ;

  if (new_size <= glstack.size) return 0;

  xsb_dbgmsg((LOG_REALLOC, 
	     "Reallocating the Heap and Local Stack data area"));
#ifdef DEBUG_VERBOSE
  if (LOG_REALLOC <= cur_log_level) {
    if (glstack.size == glstack.init_size) {
      xsb_dbgmsg((LOG_REALLOC,"\tBottom:\t\t%p\t\tInitial Size: %ldK",
		 glstack.low, glstack.size));
      xsb_dbgmsg((LOG_REALLOC,"\tTop:\t\t%p", glstack.high));
    }
  }
#endif

  expandtime = (long)(1000*cpu_time()) ;

  new_size_in_bytes = new_size*K ;
  new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
  		/* and let's hope K stays divisible by sizeof(Cell) */

  stack_boundaries ;

  /* Expand the data area and push the Local Stack to the high end. */

  new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
  if (new_heap_bot == NULL) {
    xsb_mesg("Not enough core to resize the Heap and Local Stack!");
    return 1; /* return an error output -- will be picked up later */
  }
  heap_offset = new_heap_bot - heap_bot ;
  new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
  local_offset = new_ls_bot - ls_bot ;
  memmove(ls_top + local_offset,             /* move to */
	  ls_top + heap_offset,              /* move from */
	  (ls_bot - ls_top + 1)*sizeof(Cell) );      /* number of bytes */

  /* Update the Heap links */
  for (cell_ptr = (CPtr *)(heap_top + heap_offset);
       cell_ptr-- > (CPtr *)new_heap_bot;
      )
  { reallocate_heap_or_ls_pointer(cell_ptr) ; }

  /* Update the pointers in the Local Stack */
  for (cell_ptr = (CPtr *)(ls_top + local_offset);
       cell_ptr <= (CPtr *)new_ls_bot;
       cell_ptr++)
  { reallocate_heap_or_ls_pointer(cell_ptr) ; }

  /* Update the trailed variable pointers */
  for (cell_ptr = (CPtr *)top_of_trail - 1;
       cell_ptr > (CPtr *)tcpstack.low;
       cell_ptr = cell_ptr - 2)
  { /* first the value */
    reallocate_heap_or_ls_pointer(cell_ptr);
    /* now the address */
    cell_ptr-- ;
    cell_val = (Cell)*cell_ptr ;
    realloc_ref(cell_ptr,(CPtr)cell_val) ;
  }

  /* Update the CP Stack pointers */
  for (cell_ptr = (CPtr *)top_of_cpstack;
       cell_ptr < (CPtr *)tcpstack.high;
       cell_ptr++)
  { reallocate_heap_or_ls_pointer(cell_ptr) ; }

  /* Update the argument registers */
  while (arity)
  { cell_ptr = (CPtr *)(reg+arity) ;
    reallocate_heap_or_ls_pointer(cell_ptr) ;
    arity-- ;  
  }

  /* Update the system variables */
  glstack.low = (byte *)new_heap_bot ;
  glstack.high = (byte *)(new_ls_bot + 1) ;
  glstack.size = new_size ;

  hreg = (CPtr)hreg + heap_offset ;
  hbreg = (CPtr)hbreg + heap_offset ;
  hfreg = (CPtr)hfreg + heap_offset ;
  ereg = (CPtr)ereg + local_offset ;
  ebreg = (CPtr)ebreg + local_offset ;
  efreg = (CPtr)efreg + local_offset ;

  if (islist(delayreg))
    delayreg = (CPtr)makelist(clref_val(delayreg) + heap_offset);

  expandtime = (long)(1000*cpu_time()) - expandtime;

  xsb_dbgmsg((LOG_REALLOC,"\tNew Bottom:\t%p\t\tNew Size: %ldK",
	     glstack.low, glstack.size));
  xsb_dbgmsg((LOG_REALLOC,"\tNew Top:\t%p", glstack.high));
  xsb_dbgmsg((LOG_REALLOC,
	     "Heap/Local Stack data area expansion - finished in %ld msecs\n",
	     expandtime));

  return 0;
} /* glstack_realloc */
Ejemplo n.º 24
0
/*
 * break a collection of markdown input into
 * blocks of lists, code, html, and text to
 * be marked up.
 */
static Paragraph *
compile(Line *ptr, int toplevel, MMIOT *f)
{
    ParagraphRoot d = { 0, 0 };
    Paragraph *p = 0;
    Line *r;
    int para = toplevel;
    int blocks = 0;
    int hdr_type, list_type, list_class, indent;

    ptr = consume(ptr, &para);

    while ( ptr ) {
	if ( iscode(ptr) ) {
	    p = Pp(&d, ptr, CODE);
	    
	    if ( f->flags & MKD_1_COMPAT) {
		/* HORRIBLE STANDARDS KLUDGE: the first line of every block
		 * has trailing whitespace trimmed off.
		 */
		___mkd_tidy(&p->text->text);
	    }
	    
	    ptr = codeblock(p);
	}
	else if ( ishr(ptr) ) {
	    p = Pp(&d, 0, HR);
	    r = ptr;
	    ptr = ptr->next;
	    ___mkd_freeLine(r);
	}
	else if (( list_class = islist(ptr, &indent, f->flags, &list_type) )) {
	    if ( list_class == DL ) {
		p = Pp(&d, ptr, DL);
		ptr = definition_block(p, indent, f, list_type);
	    }
	    else {
		p = Pp(&d, ptr, list_type);
		ptr = enumerated_block(p, indent, f, list_class);
	    }
	}
	else if ( isquote(ptr) ) {
	    p = Pp(&d, ptr, QUOTE);
	    ptr = quoteblock(p, f->flags);
	    p->down = compile(p->text, 1, f);
	    p->text = 0;
	}
	else if ( ishdr(ptr, &hdr_type) ) {
	    p = Pp(&d, ptr, HDR);
	    ptr = headerblock(p, hdr_type);
	}
	else if ( istable(ptr) && !(f->flags & (MKD_STRICT|MKD_NOTABLES)) ) {
	    p = Pp(&d, ptr, TABLE);
	    ptr = tableblock(p);
	}
	else {
	    p = Pp(&d, ptr, MARKUP);
	    ptr = textblock(p, toplevel, f->flags);
	}

	if ( (para||toplevel) && !p->align )
	    p->align = PARA;

	blocks++;
	para = toplevel || (blocks > 1);
	ptr = consume(ptr, &para);

	if ( para && !p->align )
	    p->align = PARA;

    }
    return T(d);
}