diff options
author | Erlang/OTP <[email protected]> | 2009-11-20 14:54:40 +0000 |
---|---|---|
committer | Erlang/OTP <[email protected]> | 2009-11-20 14:54:40 +0000 |
commit | 84adefa331c4159d432d22840663c38f155cd4c1 (patch) | |
tree | bff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/erl_interface/src/legacy/erl_format.c | |
download | otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2 otp-84adefa331c4159d432d22840663c38f155cd4c1.zip |
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/erl_interface/src/legacy/erl_format.c')
-rw-r--r-- | lib/erl_interface/src/legacy/erl_format.c | 729 |
1 files changed, 729 insertions, 0 deletions
diff --git a/lib/erl_interface/src/legacy/erl_format.c b/lib/erl_interface/src/legacy/erl_format.c new file mode 100644 index 0000000000..9848e9296a --- /dev/null +++ b/lib/erl_interface/src/legacy/erl_format.c @@ -0,0 +1,729 @@ +/* + * %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 */ + + |