path: root/lib/erl_interface/src/legacy/erl_format.c

/*
 * %CopyrightBegin%
 * 
 * Copyright Ericsson AB 1996-2009. All Rights Reserved.
 * 
 * The contents of this file are subject to the Erlang Public License,
 * Version 1.1, (the "License"); you may not use this file except in
 * compliance with the License. You should have received a copy of the
 * Erlang Public License along with this software. If not, it can be
 * retrieved online at http://www.erlang.org/.
 * 
 * Software distributed under the License is distributed on an "AS IS"
 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
 * the License for the specific language governing rights and limitations
 * under the License.
 * 
 * %CopyrightEnd%
 */
/*
 * Function: Provides two primitives: erl_format to build
 *    Erlang terms in an easy way, and erl_match to perform
 *    pattern match similar to what is done in Erlang.
 * 
 */

#include "eidef.h"

#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <ctype.h>

#ifdef VRTX
#define __READY_EXTENSIONS__
#include <errno.h>
#endif
#include "erl_interface.h"
#include "erl_eterm.h"
#include "erl_malloc.h"
#include "erl_error.h"
#include "erl_internal.h"

#define ERL_TRUE 1
#define ERL_FALSE 0
#define ERL_OK 0
#define ERL_FORMAT_ERROR -1

#define ERL_MAX_ENTRIES 255      /* Max entries in a tuple/list term */
#define ERL_MAX_NAME_LENGTH 255  /* Max length of variable names */

#define PRINT(t) \
{ \
    print_term(stderr,t); \
			    fprintf(stderr,"\n"); \
						    }


typedef struct lvar {
  ETERM *var;             
  struct lvar *next; 
} lvar;


/* Forward */
static ETERM *eformat(char**, va_list*);
static int ematch(ETERM*, ETERM*);

/* FIXME not thread safe */
struct _ef {
  lvar *chain;  /* Chain of local variables */
  lvar *idle;   /* Idle list of lvar's */
} ef;

/* Find local variable in term.
 */
static ETERM *find_lvar(char *name)
{
  lvar *tmp=ef.chain;

  while (tmp != NULL) {
    if (strcmp(tmp->var->uval.vval.name,name) == 0)
      return tmp->var->uval.vval.v;
    tmp = tmp->next;
  }
  return (ETERM *) NULL;

} /* find_lvar */

static void lvar_free(lvar *lv)
{
  lvar *tmp=ef.chain;

  /* Link in the chain into the idle list */
  if (ef.idle == NULL)
    ef.idle = lv;
  else {
    tmp = ef.idle;
    while (tmp->next != NULL)
      tmp = tmp->next;
    tmp->next = lv;
  }


  /* Clear out the variable information */
  tmp = lv;
  while (tmp != NULL) {
    tmp->var = (ETERM *) NULL;
    tmp = tmp->next;
  }

} /* lvar_free */

static lvar *lvar_alloc(void)
{
  lvar *tmp;
  
  if ((tmp = ef.idle) == NULL) {
    tmp = (lvar *) malloc(sizeof(lvar)); /* FIXME check result */
  }
  else {
    tmp = ef.idle;
    ef.idle = tmp->next;
  }
  return tmp;

} /* lvar_alloc */ 

static void undo_bindings(void)
{
  lvar *tmp=ef.chain;

  while (tmp != NULL) {
    erl_free_term(tmp->var->uval.vval.v);
    tmp->var->uval.vval.v = (ETERM *) NULL;
    tmp = tmp->next;
  }

} /* undo_bindings */

static void release_chain(void)
{

  lvar_free(ef.chain);
  ef.chain = (lvar *) NULL;

} /* release_chain */

static void add_lvar(ETERM *t)
{
  lvar *lv;

  lv = lvar_alloc();
  lv->var = t;
  lv->next = ef.chain;
  ef.chain = lv;

} /* add_lvar */

static char *pvariable(char **fmt, char *buf)
{
  char *start=*fmt;
  char c;
  int len;
  
  while (1) {
    c = *(*fmt)++;
    if (isalnum((int) c) || (c == '_'))
      continue;
    else
      break;
  } 
  (*fmt)--;
  len = *fmt - start;
  memcpy(buf, start, len);
  buf[len] = 0;
  
  return buf;
  
} /* pvariable */

static char *patom(char **fmt, char *buf)
{
  char *start=*fmt;
  char c;
  int len;
  
  while (1) {
    c = *(*fmt)++;
    if (isalnum((int) c) || (c == '_') || (c == '@'))
      continue;
    else
      break;
  } 
  (*fmt)--;
  len = *fmt - start;
  memcpy(buf, start, len);
  buf[len] = 0;
  
  return buf;
  
} /* patom */

/* Check if integer or float
 */
static char *pdigit(char **fmt, char *buf)
{
  char *start=*fmt;
  char c;
  int len,dotp=0;
  
  while (1) {
    c = *(*fmt)++;
    if (isdigit((int) c))
      continue;
    else if (!dotp && (c == '.')) {
      dotp = 1;
      continue;
    }
    else
      break;
  } 
  (*fmt)--;
  len = *fmt - start;
  memcpy(buf, start, len);
  buf[len] = 0;
  
  return buf;
  
} /* pdigit */

static char *pstring(char **fmt, char *buf)
{
  char *start=++(*fmt); /* skip first quote */
  char c;
  int len;
  
  while (1) {
    c = *(*fmt)++;
    if (c == '"') {
      if (*((*fmt)-1) == '\\')
	continue;
      else
	break;
    } else 
      continue;
  } 
  len = *fmt - 1 - start; /* skip last quote */
  memcpy(buf, start, len);
  buf[len] = 0;
  
  return buf;
  
} /* pstring */

static char *pquotedatom(char **fmt, char *buf)
{
  char *start=++(*fmt); /* skip first quote */
  char c;
  int len;
  
  while (1) {
    c = *(*fmt)++;
    if (c == '\'') {
      if (*((*fmt)-1) == '\\')
	continue;
      else
	break;
    } else 
      continue;
  } 
  len = *fmt - 1 - start; /* skip last quote */
  memcpy(buf, start, len);
  buf[len] = 0;
  
  return buf;
  
} /* pquotedatom */


/* 
 * The format letters are:
 *   w  -  Any Erlang term
 *   a  -  An Atom
 *   b  -  A Binary
 *   s  -  A String
 *   i  -  An Integer
 *   f  -  A Float (double)
 */
static int pformat(char **fmt, va_list *pap, ETERM *v[], int size)
{
  int rc=ERL_OK;
  
  /* this next section hacked to remove the va_arg calls */
  switch (*(*fmt)++) {

  case 'w':
    v[size] = va_arg(*pap, ETERM*);  
    ERL_COUNT(v[size])++;
    break;
    
  case 'a':
    v[size] = erl_mk_atom(va_arg(*pap, char *));   
    break;
    
  case 's':
    v[size] = erl_mk_string(va_arg(*pap, char *));  
    break;
    
  case 'i':
    v[size] = erl_mk_int(va_arg(*pap, int));   
    break;
    
  case 'f':
    v[size] = erl_mk_float(va_arg(*pap, double));  
    break;

  case 'b': {
    char *sarg = va_arg(*pap, char *);
    v[size] = erl_mk_binary(sarg, strlen(sarg));
    break;
  }
    
  default:
    rc = ERL_FORMAT_ERROR;
    break;
  }

  return rc;

} /* pformat */

static int ptuple(char **fmt, va_list *pap, ETERM *v[], int size)
{
  int res=ERL_FORMAT_ERROR;

  switch (*(*fmt)++) {

  case '}':
    res = size;
    break;

  case ',':
    res = ptuple(fmt, pap, v, size);
    break;

  case '~': 

    if (pformat(fmt, pap, v, size) == ERL_OK) 
      res = ptuple(fmt, pap, v, ++size);
    else
      erl_err_msg("ptuple(1):  Wrong format sequence !");
    break;

  case ' ':
    return ptuple(fmt, pap, v, size);
    break;

  default: {
      (*fmt)--;
      if ((v[size++] = eformat(fmt, pap)) != (ETERM *) NULL)
	res = ptuple(fmt, pap, v, size);
      break;

      /*
	if (isupper(**fmt)) {
	v[size++] = erl_mk_var(pvariable(fmt, wbuf));
	res = ptuple(fmt, pap, v, size);
	}
	else if ((v[size++] = eformat(fmt, pap)) != (ETERM *) NULL)
	res = ptuple(fmt, pap, v, size);
	break;
	*/
    }

  } /* switch */

  return res;

} /* ptuple */


static int plist(char **fmt, va_list *pap, ETERM *v[], int size)
{
  int res=ERL_FORMAT_ERROR;

  switch (*(*fmt)++) {

  case ']':
    res = size;
    break;

  case ',':
    res = plist(fmt, pap, v, size);
    break;

  case '~': 

    if (pformat(fmt, pap, v, size) == ERL_OK) 
      res = plist(fmt, pap, v, ++size);
    else 
      erl_err_msg("plist(1):  Wrong format sequence !");
    break;

  case ' ':
    return plist(fmt, pap, v, size);
    break;

  default: {
      (*fmt)--;
      if ((v[size++] = eformat(fmt, pap)) != (ETERM *) NULL)
	res = plist(fmt, pap, v, size);
      break;

      /*
	if (isupper(**fmt)) {
	v[size++] = erl_mk_var(pvariable(fmt, wbuf));
	res = plist(fmt, pap, v, size);
	}
	else if ((v[size++] = eformat(fmt, pap)) != (ETERM *) NULL)
	res = plist(fmt, pap, v, size);
	break;
	*/
    }

  } /* switch */

  return res;

} /* plist */


static ETERM *eformat(char **fmt, va_list *pap)
{
  int size;
  ETERM *v[ERL_MAX_ENTRIES],*ep;

  switch (*(*fmt)++) {
  case '{':
    if ((size = ptuple(fmt, pap , v, 0)) != ERL_FORMAT_ERROR) {
      ep = erl_mk_tuple(v, size);
      erl_free_array(v, size);
      return ep;
    }
    else
      return (ETERM *) NULL;
    break;

  case '[':
    if (**fmt == ']') {
      (*fmt)++;
      return erl_mk_empty_list();
    } else if ((size = plist(fmt, pap , v, 0)) != ERL_FORMAT_ERROR) {
      ep = erl_mk_list(v, size);
      erl_free_array(v, size);
      return ep;
    } else
      return (ETERM *) NULL;
    break;

  case '$': /* char-value? */
    return erl_mk_int((int)(*(*fmt)++));
    break;

  case '~':
    if (pformat(fmt, pap, v, 0) == ERL_OK) {
      ep = erl_copy_term(v[0]);
      erl_free_term(v[0]);
      return ep;
    }
    break;

  case ' ':
    return eformat(fmt, pap);
    break;

    /* handle negative numbers too...
     * case '-':
     * {
     * ETERM *tmp;
     *     
     * tmp = eformat(fmt,pap);
     *     if (ERL_IS_INTEGER(tmp)) ERL_INT_VALUE(tmp) = -(ERL_INT_VALUE(tmp));
     * return tmp;
     * }
     * 
     * 
     * break;
     */
    
  default:
    {
      char wbuf[BUFSIZ];  /* now local to this function for reentrancy */

      (*fmt)--;
      if (islower((int)**fmt)) {         /* atom  ? */
	char *atom=patom(fmt, wbuf);
	return erl_mk_atom(atom);
      }
      else if (isupper((int)**fmt) || (**fmt == '_')) {
	char *var=pvariable(fmt, wbuf);
	return erl_mk_var(var);
      }
      else if (isdigit((int)**fmt)) {    /* integer/float ? */
	char *digit=pdigit(fmt, wbuf);
	if (strchr(digit,(int) '.') == NULL)
	  return erl_mk_int(atoi((const char *) digit));
	else
	  return erl_mk_float(atof((const char *) digit));
      }
      else if (**fmt == '"') {      /* string ? */
	char *string=pstring(fmt, wbuf);
	return erl_mk_string(string);
      }
      else if (**fmt == '\'') {     /* quoted atom ? */
	char *qatom=pquotedatom(fmt, wbuf);
	return erl_mk_atom(qatom); 
      }
    }
    break;

  }

  erl_err_msg("<ERROR> Syntax error in eformat, char was: %c !", **fmt);
  return (ETERM *) NULL;

} /* eformat */
      

ETERM *erl_format(char *fmt, ... )
{
  ETERM *res=NULL;
  va_list ap;

  va_start(ap, fmt);
  res = eformat(&fmt, &ap);
  va_end(ap);

  return res;
} /* erl_format */


/* 
 * Perform a pattern match between a pattern p and a term t. 
 * As a side effect bind any unbound variables in p.
 * Return true or false.
 */
static int ematch(ETERM *p, ETERM *t)
{
    unsigned int type_p;
    unsigned int type_t;
  ETERM *tmp;

  /* two NULLs are equal, one is not... */
  if (!p && !t) return ERL_TRUE;
  if (!p || !t) return ERL_FALSE;
  /*
   * ASSERT(p != NULL);
   * ASSERT(t != NULL);
   */

  type_p = ERL_TYPE(p);
  type_t = ERL_TYPE(t);

  if (type_t == ERL_VARIABLE) {
    if (t->uval.vval.v == NULL)
      return ERL_FALSE; /* Can't have an unbound variable here ! */
    else 
      t = t->uval.vval.v;
  }

  if (type_p != ERL_VARIABLE && type_p != type_t)
    return ERL_FALSE;

  switch (type_p) {

  case ERL_ATOM:
    return p->uval.aval.len == t->uval.aval.len &&
      memcmp(p->uval.aval.a, t->uval.aval.a, p->uval.aval.len) == 0;
	
  case ERL_VARIABLE:
    if (strcmp(p->uval.vval.name, "_") == 0) /* anon. variable */
      return ERL_TRUE;
    else if ((tmp = find_lvar(p->uval.vval.name)) != (ETERM *) NULL) {
      /* v points to NULL in cases like erl_format("{X,X}") for the
	 second variable */
      if (p->uval.vval.v == NULL) 	  
	p->uval.vval.v = erl_copy_term(tmp); 
      return ematch(p->uval.vval.v, t);
    }
    else {
      /* check if the variable is bound already */
      if (p->uval.vval.v != NULL) {
	if (ematch(p->uval.vval.v, t) == ERL_TRUE ){
	  add_lvar(p);
	  return ERL_TRUE;
	} 
	else
	  return ERL_FALSE;
      }
      else {
	p->uval.vval.v = erl_copy_term(t);
	add_lvar(p);
	return ERL_TRUE;
      }
    }
    break;
	
  case ERL_PID:
    if ((strcmp(ERL_PID_NODE(p), ERL_PID_NODE(t)) == 0) &&
	(ERL_PID_NUMBER(p) == ERL_PID_NUMBER(t)) &&
	(ERL_PID_SERIAL(p) == ERL_PID_SERIAL(t)) &&
	(ERL_PID_CREATION(p) == ERL_PID_CREATION(t)))
      return ERL_TRUE;
    else
      return ERL_FALSE;
    break;
	
  case ERL_PORT:
    if ((strcmp(ERL_PORT_NODE(p), ERL_PORT_NODE(t)) == 0) &&
	(ERL_PORT_NUMBER(p) == ERL_PORT_NUMBER(t)) &&
	(ERL_PORT_CREATION(p) == ERL_PORT_CREATION(t)))
      return ERL_TRUE;
    else
      return ERL_FALSE;
    break;
	
  case ERL_REF: {
      int i, len;

      if (strcmp(ERL_REF_NODE(p), ERL_REF_NODE(t)) != 0 ||
	  ERL_REF_CREATION(p) != ERL_REF_CREATION(t))
	  return ERL_FALSE;

      /* FIXME: {len=1, n={42}} and {len=3, n={42, 17, 13}} tests equal. */
      len = ERL_REF_LEN(p);
      if (len > ERL_REF_LEN(t))
	  len = ERL_REF_LEN(t);

      for (i = 0; i < len; i++)
	  if (ERL_REF_NUMBERS(p)[i] != ERL_REF_NUMBERS(t)[i])
	  return ERL_FALSE;

      return ERL_TRUE;
      break;
  }
	
  case ERL_EMPTY_LIST:
    return ERL_TRUE;
	
  case ERL_LIST: 
    while (ERL_IS_CONS(p) && ERL_IS_CONS(t)) {
      if (ematch(p->uval.lval.head, t->uval.lval.head) == ERL_FALSE)
	return ERL_FALSE;
      p = p->uval.lval.tail;
      t = t ->uval.lval.tail;
    }
    return ematch(p, t);
	
  case ERL_TUPLE: 
    {
      int i;
      if (erl_size(p) != erl_size(t))
	return ERL_FALSE;
      else {
	for(i=0; i<erl_size(p); i++)
	  if (ematch(p->uval.tval.elems[i],t->uval.tval.elems[i]) == ERL_FALSE)
	    return ERL_FALSE;
	return ERL_TRUE;
      }
    }
  break;
	
  case ERL_BINARY: 
    {
      int i;
      if ((i = p->uval.bval.size) != t->uval.bval.size)
	return ERL_FALSE;
      else
	return (memcmp(p->uval.bval.b,t->uval.bval.b,i)==0) ? ERL_TRUE : ERL_FALSE;
    }
  break;
	
  case ERL_INTEGER:
    return (p->uval.ival.i == t->uval.ival.i) ? ERL_TRUE : ERL_FALSE;
    break;
	
  case ERL_SMALL_BIG:
  case ERL_U_SMALL_BIG:
    /* This case can't happend since it is impossible
     * to create a bignum from the C code.
     */
    return ERL_FALSE; 
    break;
	
  case ERL_FLOAT:
#if defined(VXWORKS) && CPU == PPC860
      {
	return (erl_fp_compare((unsigned *)&(p->uval.fval.f),
			       (unsigned *)&(t->uval.fval.f)) == 0) 
	    ? ERL_TRUE : ERL_FALSE;
      }
#else
    return (p->uval.fval.f == t->uval.fval.f) ? ERL_TRUE : ERL_FALSE;
#endif
    break;
  default:
    return ERL_FALSE;
    break;
  }
    
  /* erl_err_msg("ematch: Unknown type == %c\n", type_p);   */
  return ERL_FALSE;
    
} /* ematch */


int erl_match(ETERM *p, ETERM *t)
{
  int i; 

  if ((i = ematch(p, t)) == ERL_FALSE)
    undo_bindings();
  release_chain();
  return i;

} /* erl_match */