/* used here and in subset.c and subassign.c */
R_xlen_t attribute_hidden
get1index(SEXP s, SEXP names, R_xlen_t len, int pok, int pos, SEXP call)
{
/* Get a single index for the [[ and [[<- operators.
Checks that only one index is being selected.
Returns -1 for no match.
s is the subscript
len is the length of the object or dimension, with names its (dim)names.
pos is len-1 or -1 for [[, -1 for [[<-
-1 means use the only element of length-1 s.
pok : is "partial ok" ?
if pok is -1, warn if partial matching occurs, but allow.
*/
int warn_pok = 0;
const char *ss, *cur_name;
R_xlen_t indx;
const void *vmax;
if (pok == -1) {
pok = 1;
warn_pok = 1;
}
if (pos < 0 && length(s) != 1) {
if (length(s) > 1) {
ECALL(call, _("attempt to select more than one element"));
} else {
ECALL(call, _("attempt to select less than one element"));
}
} else
if(pos >= length(s)) {
ECALL(call, _("internal error in use of recursive indexing"));
}
if(pos < 0) pos = 0;
indx = -1;
switch (TYPEOF(s)) {
case LGLSXP:
case INTSXP:
{
int i = INTEGER(s)[pos];
if (i != NA_INTEGER)
indx = integerOneIndex(i, len, call);
break;
}
case REALSXP:
{
double dblind = REAL(s)[pos];
if(!ISNAN(dblind)) {
/* see comment above integerOneIndex */
if (dblind > 0) indx = (R_xlen_t)(dblind - 1);
else if (dblind == 0 || len < 2) {
ECALL(call, _("attempt to select less than one element"));
} else if (len == 2 && dblind > -3)
indx = (R_xlen_t)(2 + dblind);
else {
ECALL(call, _("attempt to select more than one element"));
}
}
break;
}
case STRSXP:
/* NA matches nothing */
if(STRING_ELT(s, pos) == NA_STRING) break;
/* "" matches nothing: see names.Rd */
if(!CHAR(STRING_ELT(s, pos))[0]) break;
/* Try for exact match */
vmax = vmaxget();
ss = translateChar(STRING_ELT(s, pos));
for (R_xlen_t i = 0; i < xlength(names); i++)
if (STRING_ELT(names, i) != NA_STRING) {
if (streql(translateChar(STRING_ELT(names, i)), ss)) {
indx = i;
break;
}
}
/* Try for partial match */
if (pok && indx < 0) {
size_t len = strlen(ss);
for(R_xlen_t i = 0; i < xlength(names); i++) {
if (STRING_ELT(names, i) != NA_STRING) {
cur_name = translateChar(STRING_ELT(names, i));
if(!strncmp(cur_name, ss, len)) {
if(indx == -1) {/* first one */
indx = i;
if (warn_pok) {
if (call == R_NilValue)
warning(_("partial match of '%s' to '%s'"),
ss, cur_name);
else
warningcall(call,
_("partial match of '%s' to '%s'"),
ss, cur_name);
}
}
else {
indx = -2;/* more than one partial match */
if (warn_pok) /* already given context */
warningcall(R_NilValue,
_("further partial match of '%s' to '%s'"),
ss, cur_name);
break;
}
}
}
}
}
vmaxset(vmax);
break;
case SYMSXP:
vmax = vmaxget();
for (R_xlen_t i = 0; i < xlength(names); i++)
if (STRING_ELT(names, i) != NA_STRING &&
streql(translateChar(STRING_ELT(names, i)),
CHAR(PRINTNAME(s)))) {
indx = i;
vmaxset(vmax);
break;
}
default:
if (call == R_NilValue)
error(_("invalid subscript type '%s'"), type2char(TYPEOF(s)));
else
errorcall(call, _("invalid subscript type '%s'"),
type2char(TYPEOF(s)));
}
return indx;
}
/* Utility used (only in) do_subassign2_dflt(), i.e. "[[<-" in ./subassign.c : */
R_xlen_t attribute_hidden
OneIndex(SEXP x, SEXP s, R_xlen_t len, int partial, SEXP *newname,
int pos, SEXP call)
{
SEXP names;
R_xlen_t i, indx, nx;
const void *vmax;
if (pos < 0 && length(s) > 1) {
ECALL(call, _("attempt to select more than one element"));
}
if (pos < 0 && length(s) < 1) {
ECALL(call, _("attempt to select less than one element"));
}
if(pos < 0) pos = 0;
indx = -1;
*newname = R_NilValue;
switch(TYPEOF(s)) {
case LGLSXP:
case INTSXP:
indx = integerOneIndex(INTEGER(s)[pos], len, call);
break;
case REALSXP:
indx = integerOneIndex((int)REAL(s)[pos], len, call);
break;
case STRSXP:
vmax = vmaxget();
nx = xlength(x);
names = PROTECT(getAttrib(x, R_NamesSymbol));
if (names != R_NilValue) {
/* Try for exact match */
for (i = 0; i < nx; i++) {
const char *tmp = translateChar(STRING_ELT(names, i));
if (!tmp[0]) continue;
if (streql(tmp, translateChar(STRING_ELT(s, pos)))) {
indx = i;
break;
}
}
/* Try for partial match */
if (partial && indx < 0) {
size_t l = strlen(translateChar(STRING_ELT(s, pos)));
for(i = 0; i < nx; i++) {
const char *tmp = translateChar(STRING_ELT(names, i));
if (!tmp[0]) continue;
if(!strncmp(tmp, translateChar(STRING_ELT(s, pos)), l)) {
if(indx == -1 )
indx = i;
else
indx = -2;
}
}
}
}
UNPROTECT(1); /* names */
if (indx == -1)
indx = nx;
*newname = STRING_ELT(s, pos);
vmaxset(vmax);
break;
case SYMSXP:
vmax = vmaxget();
nx = xlength(x);
names = getAttrib(x, R_NamesSymbol);
if (names != R_NilValue) {
PROTECT(names);
for (i = 0; i < nx; i++)
if (streql(translateChar(STRING_ELT(names, i)),
translateChar(PRINTNAME(s)))) {
indx = i;
break;
}
UNPROTECT(1); /* names */
}
if (indx == -1)
indx = nx;
*newname = STRING_ELT(s, pos);
vmaxset(vmax);
break;
default:
if (call == R_NilValue)
error(_("invalid subscript type '%s'"), type2char(TYPEOF(s)));
else
errorcall(call, _("invalid subscript type '%s'"),
type2char(TYPEOF(s)));
}
return indx;
}
/* iconv(x, from, to, sub, mark) */
SEXP attribute_hidden do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, x = CAR(args), si;
void * obj;
const char *inbuf;
char *outbuf;
const char *sub;
size_t inb, outb, res;
R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
Rboolean isRawlist = FALSE;
checkArity(op, args);
if(isNull(x)) { /* list locales */
#ifdef HAVE_ICONVLIST
cnt = 0;
iconvlist(count_one, NULL);
PROTECT(ans = allocVector(STRSXP, cnt));
cnt = 0;
iconvlist(write_one, (void *)ans);
#else
PROTECT(ans = R_NilValue);
#endif
} else {
int mark, toRaw;
const char *from, *to;
Rboolean isLatin1 = FALSE, isUTF8 = FALSE;
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "from");
from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "to");
to = CHAR(STRING_ELT(CAR(args), 0));
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "sub");
if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;
else sub = translateChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
mark = asLogical(CAR(args));
if(mark == NA_LOGICAL)
error(_("invalid '%s' argument"), "mark");
args = CDR(args);
toRaw = asLogical(CAR(args));
if(toRaw == NA_LOGICAL)
error(_("invalid '%s' argument"), "toRaw");
/* some iconv's allow "UTF8", but libiconv does not */
if(streql(from, "UTF8") || streql(from, "utf8") ) from = "UTF-8";
if(streql(to, "UTF8") || streql(to, "utf8") ) to = "UTF-8";
/* Should we do something about marked CHARSXPs in 'from = ""'? */
if(streql(to, "UTF-8")) isUTF8 = TRUE;
if(streql(to, "latin1") || streql(to, "ISO_8859-1")
|| streql(to, "CP1252")) isLatin1 = TRUE;
if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;
if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;
obj = Riconv_open(to, from);
if(obj == (iconv_t)(-1))
#ifdef Win32
error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
from, to, localeCP);
#else
error(_("unsupported conversion from '%s' to '%s'"), from, to);
#endif
isRawlist = (TYPEOF(x) == VECSXP);
if(isRawlist) {
if(toRaw)
PROTECT(ans = duplicate(x));
else {
PROTECT(ans = allocVector(STRSXP, LENGTH(x)));
DUPLICATE_ATTRIB(ans, x);
}
} else {
if(TYPEOF(x) != STRSXP)
error(_("'x' must be a character vector"));
if(toRaw) {
PROTECT(ans = allocVector(VECSXP, LENGTH(x)));
DUPLICATE_ATTRIB(ans, x);
} else
PROTECT(ans = duplicate(x));
}
R_AllocStringBuffer(0, &cbuff); /* 0 -> default */
for(R_xlen_t i = 0; i < XLENGTH(x); i++) {
if (isRawlist) {
si = VECTOR_ELT(x, i);
if (TYPEOF(si) == NILSXP) {
if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
continue;
} else if (TYPEOF(si) != RAWSXP)
error(_("'x' must be a list of NULL or raw vectors"));
} else {
si = STRING_ELT(x, i);
if (si == NA_STRING) {
if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
continue;
}
}
top_of_loop:
inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si);
inb = LENGTH(si);
outbuf = cbuff.data; outb = cbuff.bufsize - 1;
/* First initialize output */
Riconv (obj, NULL, NULL, &outbuf, &outb);
next_char:
/* Then convert input */
res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
*outbuf = '\0';
/* other possible error conditions are incomplete
and invalid multibyte chars */
if(res == -1 && errno == E2BIG) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
} else if(res == -1 && sub &&
(errno == EILSEQ || errno == EINVAL)) {
/* it seems this gets thrown for non-convertible input too */
if(strcmp(sub, "byte") == 0) {
if(outb < 5) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
}
snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
outbuf += 4; outb -= 4;
} else {
size_t j;
if(outb < strlen(sub)) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
}
memcpy(outbuf, sub, j = strlen(sub));
outbuf += j;
outb -= j;
}
inbuf++; inb--;
goto next_char;
}
if(toRaw) {
if(res != -1 && inb == 0) {
size_t nout = cbuff.bufsize - 1 - outb;
SEXP el = allocVector(RAWSXP, nout);
memcpy(RAW(el), cbuff.data, nout);
SET_VECTOR_ELT(ans, i, el);
} /* otherwise is already NULL */
} else {
if(res != -1 && inb == 0) {
cetype_t ienc = CE_NATIVE;
size_t nout = cbuff.bufsize - 1 - outb;
if(mark) {
if(isLatin1) ienc = CE_LATIN1;
else if(isUTF8) ienc = CE_UTF8;
}
SET_STRING_ELT(ans, i,
mkCharLenCE(cbuff.data, (int) nout, ienc));
} else SET_STRING_ELT(ans, i, NA_STRING);
}
}
Riconv_close(obj);
R_FreeStringBuffer(&cbuff);
}
UNPROTECT(1);
return ans;
}
/* "do_parse" - the user interface input/output to files.
The internal R_Parse.. functions are defined in ./gram.y (-> gram.c)
.Internal( parse(file, n, text, prompt, srcfile, encoding) )
If there is text then that is read and the other arguments are ignored.
*/
SEXP attribute_hidden do_parse(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP text, prompt, s, source;
Rconnection con;
Rboolean wasopen, old_latin1 = known_to_be_latin1,
old_utf8 = known_to_be_utf8, allKnown = TRUE;
int ifile, num, i;
const char *encoding;
ParseStatus status;
checkArity(op, args);
R_ParseError = 0;
R_ParseErrorMsg[0] = '\0';
ifile = asInteger(CAR(args)); args = CDR(args);
con = getConnection(ifile);
wasopen = con->isopen;
num = asInteger(CAR(args)); args = CDR(args);
if (num == 0)
return(allocVector(EXPRSXP, 0));
PROTECT(text = coerceVector(CAR(args), STRSXP));
if(length(CAR(args)) && !length(text))
errorcall(call, _("coercion of 'text' to character was unsuccessful"));
args = CDR(args);
prompt = CAR(args); args = CDR(args);
source = CAR(args); args = CDR(args);
if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error(_("invalid '%s' value"), "encoding");
encoding = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
known_to_be_latin1 = known_to_be_utf8 = FALSE;
/* allow 'encoding' to override declaration on 'text'. */
if(streql(encoding, "latin1")) {
known_to_be_latin1 = TRUE;
allKnown = FALSE;
} else if(streql(encoding, "UTF-8")) {
known_to_be_utf8 = TRUE;
allKnown = FALSE;
} else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc"))
warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding);
if (prompt == R_NilValue)
PROTECT(prompt);
else
PROTECT(prompt = coerceVector(prompt, STRSXP));
if (length(text) > 0) {
/* If 'text' has known encoding then we can be sure it will be
correctly re-encoded to the current encoding by
translateChar in the parser and so could mark the result in
a Latin-1 or UTF-8 locale.
A small complication is that different elements could have
different encodings, but all that matters is that all
non-ASCII elements have known encoding.
*/
for(i = 0; i < length(text); i++)
if(!ENC_KNOWN(STRING_ELT(text, i)) &&
!IS_ASCII(STRING_ELT(text, i))) {
allKnown = FALSE;
break;
}
if(allKnown) {
known_to_be_latin1 = old_latin1;
known_to_be_utf8 = old_utf8;
}
if (num == NA_INTEGER) num = -1;
s = R_ParseVector(text, num, &status, source);
if (status != PARSE_OK) parseError(call, R_ParseError);
}
else if (ifile >= 3) {/* file != "" */
if (num == NA_INTEGER) num = -1;
try {
if(!wasopen && !con->open(con))
error(_("cannot open the connection"));
if(!con->canread) error(_("cannot read from this connection"));
s = R_ParseConn(con, num, &status, source);
if(!wasopen) con->close(con);
} catch (...) {
if (!wasopen && con->isopen)
con->close(con);
throw;
}
if (status != PARSE_OK) parseError(call, R_ParseError);
}
else {
if (num == NA_INTEGER) num = 1;
s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source);
if (status != PARSE_OK) parseError(call, R_ParseError);
}
UNPROTECT(2);
known_to_be_latin1 = old_latin1;
known_to_be_utf8 = old_utf8;
return s;
}
void test(string args)
{
args = splitArg(args, 1);
if(streql(args, "") || streql(args, "-H"))
{
print("\nThis file is in charge of testing the data types embedded in Q-OS.",black);
print("\nAccepted Arguments:\n-list\tTests the list.c file\n-set \ttests the set.c file", black);
print("\n-strb\ttests the strbuilder.c file\n-y \tshould return the current year...",black);
}
else if(streql(args, "-LIST"))//For testing lists
{
newline();
list_t test_list = list_init();
test_list.autoShrink = true;
for(uint8 i = 0; i < 4; i++)
{
list_add(&test_list, "1");
list_add(&test_list, "2");
list_add(&test_list, "3");
list_add(&test_list, "4");
list_add(&test_list, "5");
list_add(&test_list, "6");
list_add(&test_list, "7");
list_add(&test_list, "8");
list_add(&test_list, "9");
list_add(&test_list, "10");
list_add(&test_list, "11");
list_add(&test_list, "12");
list_add(&test_list, "13");
list_add(&test_list, "14");
list_add(&test_list, "15");
list_add(&test_list, "16");
}
list_add(&test_list, "Pointless");
println("Done sizing up", white);
printint(test_list.capt, white);
element_t t;
for(uint8 i = 0; i < 64; i++)
{
t = list_shift(&test_list);
}
println("\nLast item deleted should be \"16\"", white);
println(t.udata.strdata, white);
println("\nDeleting all but element \"Pointless\"", white);
for(uint8 i = 0; i < test_list.size; i++)
{
println(list_get(test_list, i), white);
}
println("Done resizing up", white);
printint(test_list.capt, white);
list_destroy(&test_list);
}
else if(streql(args,"-SET"))
{
set_t test_set = set_init();
for(uint8 i = 0; i < 4; i++)
{
set_add(&test_set, "0");
set_add(&test_set, "1");
set_add(&test_set, "2");
set_add(&test_set, "3");
set_add(&test_set, "4");
set_add(&test_set, "5");
set_add(&test_set, "6");
set_add(&test_set, "7");
set_add(&test_set, "8");
set_add(&test_set, "9");
set_add(&test_set, "10");
set_add(&test_set, "11");
set_add(&test_set, "12");
set_add(&test_set, "13");
set_add(&test_set, "14");
set_add(&test_set, "15");
set_add(&test_set, "16");
print("\nIteration: ", white);
printint(i, white);
}
println("\n\nInsertion::Output should be 17", white);
printint(test_set.size, white);
set_t tmp = set_init();
set_add(&tmp, "Union item");
set_union(&test_set, &tmp);
println("\n\nUnion::Output should be 18", white);
printint(test_set.size, white);
set_intersect(&test_set, &tmp);
println("\n\nIntersect::Output should be 1", white);
printint(test_set.size, white);
println("\n\nPreparing for diff test", white);
set_add(&test_set, "1");
set_add(&test_set, "2");
set_add(&test_set, "3");
set_add(&tmp, "2");
set_add(&tmp, "3");
set_add(&tmp, "4");
set_diff(&test_set, &tmp);
println("Diff::Output should be 2", white);
printint(test_set.size, white);
set_destroy(&tmp);
set_destroy(&test_set);
}
else if(streql(args, "-STRB"))
{
static const string bak = "Hello, world ";
static const uint32 bln = 13;
strbuilder_t test_strb = strbuilder_init();
strbuilder_append(&test_strb, bak);
strbuilder_append(&test_strb, "Hello, 2nd world");
println("\nTesting backup text. Output should 1", red);
printint(streql(bak, test_strb.prevTxt), green);
println("\nOutput should be \"Hello, world Hello, 2nd world\"", red);
println(strbuilder_tostr(test_strb), green);
println("\nRemoving greeters from first world", red);
strbuilder_delete(&test_strb, 0, bln);
println("\nOutput should be \"Hello, 2nd world\"", red);
println(strbuilder_tostr(test_strb), green);
strbuilder_flip(&test_strb);
println("\nOutput should be \"dlrow dn2 ,olleH\"", red);
println(strbuilder_tostr(test_strb), green);
list_t tmp = strbuilder_split(test_strb, " ");
println("\nOutput should be last str split by spaces", red);
for(uint8 i = 0; i < tmp.size; i++)
{
println(list_get(tmp, i), white);
}
list_destroy(&tmp);
strbuilder_destroy(&test_strb);
}
else if(streql(args,"-Y"))
{
//getTime() test
printint(getTime("year"),white);
}
}
void
parse_control_point (char **ss,
control_point *cp)
{
char *argv[MAXARGS];
int argc, i, j;
int set_cm = 0, set_image_size = 0, set_nbatches = 0, set_white_level = 0, set_cmap_inter = 0;
int set_spatial_oversample = 0;
double *slot = NULL, xf, cm, t, nbatches, white_level, spatial_oversample, cmap_inter;
double image_size[2];
for (i = 0; i < NXFORMS; i++)
{
cp->xform[i].density = 0.0;
cp->xform[i].color = (i == 0);
cp->xform[i].var[0] = 1.0;
for (j = 1; j < NVARS; j++)
cp->xform[i].var[j] = 0.0;
cp->xform[i].c[0][0] = 1.0;
cp->xform[i].c[0][1] = 0.0;
cp->xform[i].c[1][0] = 0.0;
cp->xform[i].c[1][1] = 1.0;
cp->xform[i].c[2][0] = 0.0;
cp->xform[i].c[2][1] = 0.0;
}
for (j = 0; j < 2; j++)
{
cp->pulse[j][0] = 0.0;
cp->pulse[j][1] = 60.0;
cp->wiggle[j][0] = 0.0;
cp->wiggle[j][1] = 60.0;
}
tokenize (ss, argv, &argc);
for (i = 0; i < argc; i++)
{
if (streql("xform", argv[i]))
slot = &xf;
else if (streql("time", argv[i]))
slot = &cp->time;
else if (streql("brightness", argv[i]))
slot = &cp->brightness;
else if (streql("contrast", argv[i]))
slot = &cp->contrast;
else if (streql("gamma", argv[i]))
slot = &cp->gamma;
else if (streql("zoom", argv[i]))
slot = &cp->zoom;
else if (streql("image_size", argv[i]))
{
slot = image_size;
set_image_size = 1;
}
else if (streql("center", argv[i]))
slot = cp->center;
else if (streql("pulse", argv[i]))
slot = (double *) cp->pulse;
else if (streql("wiggle", argv[i]))
slot = (double *) cp->wiggle;
else if (streql("pixels_per_unit", argv[i]))
slot = &cp->pixels_per_unit;
else if (streql("spatial_filter_radius", argv[i]))
slot = &cp->spatial_filter_radius;
else if (streql("sample_density", argv[i]))
slot = &cp->sample_density;
else if (streql("nbatches", argv[i]))
{
slot = &nbatches;
set_nbatches = 1;
}
else if (streql("white_level", argv[i]))
{
slot = &white_level;
set_white_level = 1;
}
else if (streql("spatial_oversample", argv[i]))
{
slot = &spatial_oversample;
set_spatial_oversample = 1;
}
else if (streql("cmap", argv[i]))
{
slot = &cm;
set_cm = 1;
}
else if (streql("density", argv[i]))
slot = &cp->xform[(int)xf].density;
else if (streql("color", argv[i]))
slot = &cp->xform[(int)xf].color;
else if (streql("coefs", argv[i]))
{
slot = cp->xform[(int)xf].c[0];
cp->xform[(int)xf].density = 1.0;
}
else if (streql("var", argv[i]))
slot = cp->xform[(int)xf].var;
else if (streql("cmap_inter", argv[i]))
{
slot = &cmap_inter;
set_cmap_inter = 1;
}
else
*slot++ = g_strtod(argv[i], NULL);
}
if (set_cm)
{
cp->cmap_index = (int) cm;
get_cmap(cp->cmap_index, cp->cmap, 256);
}
if (set_image_size)
{
cp->width = (int) image_size[0];
cp->height = (int) image_size[1];
}
if (set_cmap_inter)
cp->cmap_inter = (int) cmap_inter;
if (set_nbatches)
cp->nbatches = (int) nbatches;
if (set_spatial_oversample)
cp->spatial_oversample = (int) spatial_oversample;
if (set_white_level)
cp->white_level = (int) white_level;
for (i = 0; i < NXFORMS; i++)
{
t = 0.0;
for (j = 0; j < NVARS; j++)
t += cp->xform[i].var[j];
t = 1.0 / t;
for (j = 0; j < NVARS; j++)
cp->xform[i].var[j] *= t;
}
qsort ((char *) cp->xform, NXFORMS, sizeof(xform), compare_xforms);
}
int o2_clock_set(o2_time_callback callback, void *data)
{
if (!o2_ensemble_name) {
O2_DBk(printf("%s o2_clock_set cannot be called before o2_initialize.\n",
o2_debug_prefix));
return O2_FAIL;
}
int was_synchronized = o2_clock_is_synchronized;
// adjust local_start_time to ensure continuity of time:
// new_local_time - new_time_offset == old_local_time - old_time_offset
// new_time_offset = new_local_time - (old_local_time - old_time_offset)
o2_time old_local_time = o2_local_time(); // (includes -old_time_offset)
time_callback = callback;
time_callback_data = data;
time_offset = 0.0; // get the time without any offset
o2_time new_local_time = o2_local_time();
time_offset = new_local_time - old_local_time;
if (!is_master) {
o2_clock_synchronized(new_local_time, new_local_time);
o2_service_new("_cs");
o2_method_new("/_cs/get", "is", &cs_ping_handler, NULL, FALSE, FALSE);
O2_DBg(printf("%s ** master clock established, time is now %g\n",
o2_debug_prefix, o2_local_time()));
is_master = TRUE;
announce_synchronized(new_local_time);
if (!was_synchronized) {
// every service including local ones and those provided by a
// synchronized processes are now synchronized
dyn_array_ptr table = &o2_context->path_tree.children;
enumerate enumerator;
o2_enumerate_begin(&enumerator, table);
services_entry_ptr services_ptr;
o2_in_find_and_call_handlers++;
while ((services_ptr =
(services_entry_ptr) o2_enumerate_next(&enumerator))) {
if ((services_ptr->tag == SERVICES) &&
(services_ptr->services.length > 0)) {
o2_info_ptr service = GET_SERVICE(services_ptr->services, 0);
// _cs was just created above and was reported as O2_LOCAL,
// so don't do it again.
if ((service->tag == PATTERN_NODE ||
service->tag == PATTERN_HANDLER) &&
!streql(services_ptr->key, "_cs")) {
o2_send_cmd("!_o2/si", 0.0, "sis",
services_ptr->key, O2_LOCAL,
o2_context->process->proc.name);
} else if (service->tag == OSC_REMOTE_SERVICE) {
o2_send_cmd("!_o2/si", 0.0, "sis",
services_ptr->key, O2_TO_OSC,
o2_context->process->proc.name);
} else if (service->tag == TCP_SOCKET &&
((process_info_ptr) service)->proc.status ==
PROCESS_OK) {
o2_send_cmd("!_o2/si", 0.0, "sis",
services_ptr->key, O2_REMOTE,
o2_context->process->proc.name);
}
}
}
}
o2_in_find_and_call_handlers--;
}
return O2_SUCCESS;
}
#include "assert.h"
#include "stdlib.h"
#include "stdio.h"
#include "allegro.h"
#include "string.h"
#include "ctype.h"
//#include "memory.h"
#include "trace.h"
#include "strparse.h"
#ifndef EXPERIMENTAL_NOTE_TRACK
#include "allegrord.h"
#endif /* EXPERIMENTAL_NOTE_TRACK */
#define streql(s1, s2) (strcmp(s1, s2) == 0)
#define field_max 80
//Note that this is an #ifdef, not an #ifndef
#ifdef EXPERIMENTAL_NOTE_TRACK
class Alg_reader {
public:
FILE *file;
int line_no;
String_parse line_parser;
bool line_parser_flag;
char field[field_max];
bool error_flag;
Alg_seq_ptr seq;
double tsnum;
double tsden;
Alg_reader(FILE *a_file, Alg_seq_ptr new_seq);
void readline();
Alg_parameters_ptr process_attributes(Alg_parameters_ptr attributes, double time);
bool parse();
long parse_chan(char *field);
long parse_int(char *field);
int find_real_in(char *field, int n);
double parse_real(char *field);
void parse_error(char *field, long offset, char *message);
double parse_dur(char *field, double base);
double parse_after_dur(double dur, char *field, int n, double base);
double parse_loud(char *field);
long parse_key(char *field);
double parse_pitch(char *field);
long parse_after_key(int key, char *field, int n);
long find_int_in(char *field, int n);
bool parse_attribute(char *field, Alg_parameter_ptr parm);
bool parse_val(Alg_parameter_ptr param, char *s, int i);
bool check_type(char type_char, Alg_parameter_ptr param);
};
#endif /* EXPERIMENTAL_NOTE_TRACK */
void subseq(char *result, char *source, int from, int to)
{
memcpy(result, source + from, to - from);
result[to - from] = 0;
}
#ifndef EXPERIMENTAL_NOTE_TRACK
double Allegro_reader::parse_pitch(char *field)
#else /* EXPERIMENTAL_NOTE_TRACK */
double Alg_reader::parse_pitch(char *field)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
if (isdigit(field[1])) {
char real_string[80];
int last = find_real_in(field, 1);
subseq(real_string, field, 1, last);
return atof(real_string);
} else {
return (double) parse_key(field);
}
}
#ifndef EXPERIMENTAL_NOTE_TRACK
Allegro_reader::Allegro_reader(FILE *a_file)
{
file = a_file; // save the file
line_parser_flag = false;
line_no = 0;
seq = Seq();
tsnum = 4; // default time signature
tsden = 4;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
// it is the responsibility of the caller to delete
// the seq
Alg_reader::Alg_reader(FILE *a_file, Alg_seq_ptr new_seq)
{
file = a_file; // save the file
line_parser_flag = false;
line_no = 0;
tsnum = 4; // default time signature
tsden = 4;
seq = new_seq;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
//Note that this is an #ifdef, not an #ifndef
#ifdef EXPERIMENTAL_NOTE_TRACK
Alg_seq_ptr alg_read(FILE *file, Alg_seq_ptr new_seq)
// read a sequence from allegro file
{
if (!new_seq) new_seq = new Alg_seq();
Alg_reader alg_reader(file, new_seq);
alg_reader.parse();
return alg_reader.seq;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
void Allegro_reader::readline()
#else /* EXPERIMENTAL_NOTE_TRACK */
void Alg_reader::readline()
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
char line[256];
char *line_flag = fgets(line, 256, file);
line_parser_flag = false;
if (line_flag) {
line_parser.init(line);
line_parser_flag = true;
error_flag = false;
}
}
#ifndef EXPERIMENTAL_NOTE_TRACK
void Allegro_reader::process_attributes(Parameters_ptr attributes, double time)
{
// print "process_attributes:", attributes
bool ts_flag;
if (attributes) {
Parameters_ptr a;
if (a = Parameters::remove_key(&attributes, "tempor")) {
double tempo = a->parm.r;
seq.insert_tempo(tempo, seq.map.time_to_beat(time));
}
if (a = Parameters::remove_key(&attributes, "beatr")) {
double beat = a->parm.r;
seq.insert_beat(time, beat);
}
if (a = Parameters::remove_key(&attributes, "tsnumr")) {
tsnum = a->parm.r;
ts_flag = true;
}
if (a = Parameters::remove_key(&attributes, "tsdenr")) {
tsden = a->parm.r;
ts_flag = true;
}
if (ts_flag) {
seq.set_time_sig(seq.map.time_to_beat(time), tsnum, tsden);
}
}
}
#else /* EXPERIMENTAL_NOTE_TRACK */
Alg_parameters_ptr Alg_reader::process_attributes(
Alg_parameters_ptr attributes, double time)
{
// print "process_attributes:", attributes
bool ts_flag = false;
if (attributes) {
Alg_parameters_ptr a;
bool in_seconds = seq->get_units_are_seconds();
if (a = Alg_parameters::remove_key(&attributes, "tempor")) {
double tempo = a->parm.r;
seq->insert_tempo(tempo, seq->get_time_map()->time_to_beat(time));
}
if (a = Alg_parameters::remove_key(&attributes, "beatr")) {
double beat = a->parm.r;
seq->insert_beat(time, beat);
}
if (a = Alg_parameters::remove_key(&attributes, "timesig_numr")) {
tsnum = a->parm.r;
ts_flag = true;
}
if (a = Alg_parameters::remove_key(&attributes, "timesig_denr")) {
tsden = a->parm.r;
ts_flag = true;
}
if (ts_flag) {
seq->set_time_sig(seq->get_time_map()->time_to_beat(time),
tsnum, tsden);
}
if (in_seconds) seq->convert_to_seconds();
}
return attributes; // in case it was modified
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
bool Allegro_reader::parse()
{
int voice = 0;
int key = 60;
double loud = 100.0;
double pitch = 60.0;
double dur = 1.0;
double time = 0.0;
readline();
bool valid = false; // ignore blank lines
while (line_parser_flag) {
bool time_flag = false;
bool next_flag = false;
double next;
bool voice_flag = false;
bool loud_flag = false;
bool dur_flag = false;
bool new_pitch_flag = false; // "P" syntax
double new_pitch = 0.0;
bool new_key_flag = false; // "K" syntax
int new_key = 0;
bool new_note_flag = false; // "A"-"G" syntax
int new_note = 0;
Parameters_ptr attributes = NULL;
line_parser.get_nonspace_quoted(field);
char pk = line_parser.peek();
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
while (field[0]) {
// print "field", "|";field;"|", "|";line_parser.string;"|", line_parser.pos
char first = toupper(field[0]);
if (strchr("ABCDEFGKLPUSIQHW-", first)) {
valid = true; // it's a note or event
}
if (first == 'V') {
if (voice_flag) {
parse_error(field, 0, "Voice specified twice");
} else {
voice = parse_int(field);
}
voice_flag = true;
} else if (first == 'T') {
if (time_flag) {
parse_error(field, 0, "Time specified twice");
} else {
time = parse_dur(field, 0.0);
}
time_flag = true;
} else if (first == 'N') {
if (next_flag) {
parse_error(field, 0, "Next specified twice");
} else {
next = parse_dur(field, time);
}
next_flag = true;
} else if (first == 'K') {
if (new_key_flag) {
parse_error(field, 0, "Key specified twice");
} else {
new_key = parse_key(field);
new_key_flag = true;
}
} else if (first == 'L') {
if (loud_flag) {
parse_error(field, 0, "Loudness specified twice");
} else {
loud = parse_loud(field);
}
loud_flag = true;
} else if (first == 'P') {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
new_pitch = parse_pitch(field);
new_pitch_flag = true;
}
} else if (first == 'U') {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("SIQHW", first)) {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
// prepend 'U' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'U';
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("ABCDEFG", first)) {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
// prepend 'K' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'K';
new_note = parse_key(field);
new_note_flag = true;
}
} else if (first == '-') {
Parameter parm;
if (parse_attribute(field, &parm)) { // enter attribute-value pair
attributes = new Parameters(attributes);
attributes->parm = parm;
parm.s = NULL; // protect string from deletion by destructor
}
} else {
parse_error(field, 0, "Unknown field");
}
if (error_flag) {
field[0] = 0; // exit the loop
} else {
line_parser.get_nonspace_quoted(field);
pk = line_parser.peek();
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
}
}
// a case analysis:
// Key < 128 counts as both key and pitch
// A-G implies pitch AND key unless key given too
// K60 P60 -- both are specified, use 'em
// K60 P60 C4 -- overconstrained, an error
// K60 C4 -- overconstrained
// K60 -- OK, pitch is 60
// C4 P60 -- over constrained
// P60 -- OK, key is from before, pitch is 60
// C4 -- OK, key is 60, pitch is 60
// <nothing> -- OK, key and pitch from before
// K200 with P60 ok, pitch is 60
// K200 with neither P60 nor C4 uses
// pitch from before
// figure out what the key/instance is:
if (new_key_flag) { // it was directly specified
key = new_key;
if (key < 128 && new_note_flag) {
parse_error("", 0, "Pitch specified twice");
}
} else if (new_note_flag) { // "A"-"G" used
key = new_note;
}
if (new_pitch_flag) {
pitch = new_pitch;
} else if (key < 128) {
pitch = key;
}
// now we've acquired new parameters
// if (it is a note, then enter the note
if (valid) {
// change tempo or beat
process_attributes(attributes, time);
// if there's a duration or pitch, make a note:
if (new_pitch_flag || dur_flag || new_note_flag) {
new_key_flag = false;
new_pitch_flag = false;
Allegro_note_ptr note_ptr = new Allegro_note;
note_ptr->chan = voice;
note_ptr->time = time;
note_ptr->dur = dur;
note_ptr->key = key;
note_ptr->pitch = pitch;
note_ptr->loud = loud;
note_ptr->parameters = attributes;
seq.add_event(note_ptr); // sort later
} else {
int update_key = -1;
// key or pitch must appear explicitly; otherwise
// update applies to channel
if (new_key_flag || new_pitch_flag) {
update_key = key;
}
if (loud_flag) {
Allegro_update_ptr new_upd = new Allegro_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->key = update_key;
new_upd->parameter.set_attr(symbol_table.insert_string("loudr"));
new_upd->parameter.r = pitch;
seq.add_event(new_upd);
}
if (attributes) {
while (attributes) {
Allegro_update_ptr new_upd = new Allegro_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->key = update_key;
new_upd->parameter = attributes->parm;
seq.add_event(new_upd);
Parameters_ptr p = attributes;
attributes = attributes->next;
delete p;
}
}
}
if (next_flag) {
time = time + next;
} else if (dur_flag) {
time = time + dur;
}
}
readline();
}
//print "Finished reading score"
if (!error_flag) {
seq.convert_to_seconds(); // make sure format is correct
// seq.notes.sort('event_greater_than');
}
// print "parse returns error_flag", error_flag
return error_flag;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
bool Alg_reader::parse()
{
int voice = 0;
int key = 60;
double loud = 100.0;
double pitch = 60.0;
double dur = 1.0;
double time = 0.0;
int track_num = 0;
seq->convert_to_seconds();
//seq->set_real_dur(0.0); // just in case it's not initialized already
readline();
bool valid = false; // ignore blank lines
while (line_parser_flag) {
bool time_flag = false;
bool next_flag = false;
double next;
bool voice_flag = false;
bool loud_flag = false;
bool dur_flag = false;
bool new_pitch_flag = false; // "P" syntax
double new_pitch = 0.0;
bool new_key_flag = false; // "K" syntax
int new_key = 0;
bool new_note_flag = false; // "A"-"G" syntax
int new_note = 0;
Alg_parameters_ptr attributes = NULL;
if (line_parser.peek() == '#') {
// look for #track
line_parser.get_nonspace_quoted(field);
if (streql(field, "#track")) {
line_parser.get_nonspace_quoted(field); // number
track_num = parse_int(field - 1);
seq->add_track(track_num);
}
// maybe we have a comment
} else {
// we must have a track to insert into
if (seq->tracks() == 0) seq->add_track(0);
line_parser.get_nonspace_quoted(field);
char pk = line_parser.peek();
// attributes are parsed as two adjacent nonspace_quoted tokens
// so we have to conditionally call get_nonspace_quoted() again
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
while (field[0]) {
char first = toupper(field[0]);
if (strchr("ABCDEFGKLPUSIQHW-", first)) {
valid = true; // it's a note or event
}
if (first == 'V') {
if (voice_flag) {
parse_error(field, 0, "Voice specified twice");
} else {
voice = parse_chan(field);
}
voice_flag = true;
} else if (first == 'T') {
if (time_flag) {
parse_error(field, 0, "Time specified twice");
} else {
time = parse_dur(field, 0.0);
}
time_flag = true;
} else if (first == 'N') {
if (next_flag) {
parse_error(field, 0, "Next specified twice");
} else {
next = parse_dur(field, time);
}
next_flag = true;
} else if (first == 'K') {
if (new_key_flag) {
parse_error(field, 0, "Key specified twice");
} else {
new_key = parse_key(field);
new_key_flag = true;
}
} else if (first == 'L') {
if (loud_flag) {
parse_error(field, 0, "Loudness specified twice");
} else {
loud = parse_loud(field);
}
loud_flag = true;
} else if (first == 'P') {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
new_pitch = parse_pitch(field);
new_pitch_flag = true;
}
} else if (first == 'U') {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("SIQHW", first)) {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
// prepend 'U' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'U';
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("ABCDEFG", first)) {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
// prepend 'K' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'K';
new_note = parse_key(field);
new_note_flag = true;
}
} else if (first == '-') {
Alg_parameter parm;
if (parse_attribute(field, &parm)) { // enter attribute-value pair
attributes = new Alg_parameters(attributes);
attributes->parm = parm;
parm.s = NULL; // protect string from deletion by destructor
}
} else {
parse_error(field, 0, "Unknown field");
}
if (error_flag) {
field[0] = 0; // exit the loop
} else {
line_parser.get_nonspace_quoted(field);
pk = line_parser.peek();
// attributes are parsed as two adjacent nonspace_quoted
// tokens so we have to conditionally call
// get_nonspace_quoted() again
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
}
}
// a case analysis:
// Key < 128 counts as both key and pitch
// A-G implies pitch AND key unless key given too
// K60 P60 -- both are specified, use 'em
// K60 P60 C4 -- overconstrained, an error
// K60 C4 -- overconstrained
// K60 -- OK, pitch is 60
// C4 P60 -- over constrained
// P60 -- OK, key is from before, pitch is 60
// C4 -- OK, key is 60, pitch is 60
// <nothing> -- OK, key and pitch from before
// K200 with P60 ok, pitch is 60
// K200 with neither P60 nor C4 uses
// pitch from before
// figure out what the key/instance is:
if (new_key_flag) { // it was directly specified
key = new_key;
if (key < 128 && new_note_flag) {
parse_error("", 0, "Pitch specified twice");
}
} else if (new_note_flag) { // "A"-"G" used
key = new_note;
}
if (new_pitch_flag) {
pitch = new_pitch;
} else if (key < 128) {
pitch = key;
}
// now we've acquired new parameters
// if (it is a note, then enter the note
if (valid) {
// change tempo or beat
attributes = process_attributes(attributes, time);
// if there's a duration or pitch, make a note:
if (new_pitch_flag || dur_flag || new_note_flag) {
new_key_flag = false;
new_pitch_flag = false;
Alg_note_ptr note_ptr = new Alg_note;
note_ptr->chan = voice;
note_ptr->time = time;
note_ptr->dur = dur;
note_ptr->set_identifier(key);
note_ptr->pitch = pitch;
note_ptr->loud = loud;
note_ptr->parameters = attributes;
seq->add_event(note_ptr, track_num); // sort later
if (seq->get_real_dur() < (time + dur)) seq->set_real_dur(time + dur);
} else {
int update_key = -1;
// key or pitch must appear explicitly; otherwise
// update applies to channel
if (new_key_flag || new_pitch_flag) {
update_key = key;
}
if (loud_flag) {
Alg_update_ptr new_upd = new Alg_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->set_identifier(update_key);
new_upd->parameter.set_attr(symbol_table.insert_string("loudr"));
new_upd->parameter.r = pitch;
seq->add_event(new_upd, track_num);
if (seq->get_real_dur() < time) seq->set_real_dur(time);
}
if (attributes) {
while (attributes) {
Alg_update_ptr new_upd = new Alg_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->set_identifier(update_key);
new_upd->parameter = attributes->parm;
seq->add_event(new_upd, track_num);
Alg_parameters_ptr p = attributes;
attributes = attributes->next;
p->parm.s = NULL; // so we don't delete the string
delete p;
}
}
}
if (next_flag) {
time = time + next;
} else if (dur_flag) {
time = time + dur;
}
}
}
readline();
}
//print "Finished reading score"
if (!error_flag) {
seq->convert_to_seconds(); // make sure format is correct
// seq->notes.sort('event_greater_than');
}
// real_dur is valid, translate to beat_dur
seq->set_beat_dur((seq->get_time_map())->time_to_beat(seq->get_real_dur()));
// print "parse returns error_flag", error_flag
return error_flag;
}
SEXP Random2(SEXP args)
{
if (!isVectorList(CAR(args))) error("incorrect usage");
SEXP x, a, b;
R_xlen_t i, n, na, nb;
ran2 fn = NULL; /* -Wall */
const char *dn = CHAR(STRING_ELT(getListElement(CAR(args), "name"), 0));
SEXPTYPE type = REALSXP;
if (streql(dn, "rbeta")) fn = &rbeta;
else if (streql(dn, "rbinom")) {
type = INTSXP;
fn = &rbinom;
} else if (streql(dn, "rcauchy")) fn = &rcauchy;
else if (streql(dn, "rf")) fn = &rf;
else if (streql(dn, "rgamma")) fn = &rgamma;
else if (streql(dn, "rlnorm")) fn = &rlnorm;
else if (streql(dn, "rlogis")) fn = &rlogis;
else if (streql(dn, "rnbinom")) {
type = INTSXP;
fn = &rnbinom;
} else if (streql(dn, "rnorm")) fn = &rnorm;
else if (streql(dn, "runif")) fn = &runif;
else if (streql(dn, "rweibull")) fn = &rweibull;
else if (streql(dn, "rwilcox")) {
type = INTSXP;
fn = &rwilcox;
} else if (streql(dn, "rnchisq")) fn = &rnchisq;
else if (streql(dn, "rnbinom_mu")) {
fn = &rnbinom_mu;
} else error(_("invalid arguments"));
args = CDR(args);
if (!isVector(CAR(args)) ||
!isNumeric(CADR(args)) ||
!isNumeric(CADDR(args)))
error(_("invalid arguments"));
if (XLENGTH(CAR(args)) == 1) {
#ifdef LONG_VECTOR_SUPPORT
double dn = asReal(CAR(args));
if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX)
error(_("invalid arguments"));
n = (R_xlen_t) dn;
#else
n = asInteger(CAR(args));
if (n == NA_INTEGER || n < 0)
error(_("invalid arguments"));
#endif
}
else n = XLENGTH(CAR(args));
PROTECT(x = allocVector(type, n));
if (n == 0) {
UNPROTECT(1);
return(x);
}
na = XLENGTH(CADR(args));
nb = XLENGTH(CADDR(args));
if (na < 1 || nb < 1) {
if (type == INTSXP)
for (i = 0; i < n; i++) INTEGER(x)[i] = NA_INTEGER;
else
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
warning(_("NAs produced"));
}
else {
Rboolean naflag = FALSE;
PROTECT(a = coerceVector(CADR(args), REALSXP));
PROTECT(b = coerceVector(CADDR(args), REALSXP));
GetRNGstate();
double *ra = REAL(a), *rb = REAL(b);
if (type == INTSXP) {
int *ix = INTEGER(x); double rx;
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx = fn(ra[i % na], rb[i % nb]);
if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN) {
naflag = TRUE;
ix[i] = NA_INTEGER;
} else ix[i] = (int) rx;
}
} else {
double *rx = REAL(x);
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx[i] = fn(ra[i % na], rb[i % nb]);
if (ISNAN(rx[i])) naflag = TRUE;
}
}
if (naflag) warning(_("NAs produced"));
PutRNGstate();
UNPROTECT(2);
}
UNPROTECT(1);
return x;
}
SEXP Random1(SEXP args)
{
if (!isVectorList(CAR(args))) error("incorrect usage");
SEXP x, a;
R_xlen_t i, n, na;
ran1 fn = NULL; /* -Wall */
const char *dn = CHAR(STRING_ELT(getListElement(CAR(args), "name"), 0));
SEXPTYPE type = REALSXP;
if (streql(dn, "rchisq")) fn = &rchisq;
else if (streql(dn, "rexp")) fn = &rexp;
else if (streql(dn, "rgeom")) {
type = INTSXP;
fn = &rgeom;
} else if (streql(dn, "rpois")) {
type = INTSXP;
fn = &rpois;
}
else if (streql(dn, "rt")) fn = &rt;
else if (streql(dn, "rsignrank")) {
type = INTSXP;
fn = &rsignrank;
}
else error(_("invalid arguments"));
args = CDR(args);
if (!isVector(CAR(args)) || !isNumeric(CADR(args)))
error(_("invalid arguments"));
if (XLENGTH(CAR(args)) == 1) {
#ifdef LONG_VECTOR_SUPPORT
double dn = asReal(CAR(args));
if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX)
error(_("invalid arguments"));
n = (R_xlen_t) dn;
#else
n = asInteger(CAR(args));
if (n == NA_INTEGER || n < 0)
error(_("invalid arguments"));
#endif
}
else n = XLENGTH(CAR(args));
PROTECT(x = allocVector(type, n));
if (n == 0) {
UNPROTECT(1);
return(x);
}
na = XLENGTH(CADR(args));
if (na < 1) {
if (type == INTSXP)
for (i = 0; i < n; i++) INTEGER(x)[i] = NA_INTEGER;
else
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
warning(_("NAs produced"));
} else {
Rboolean naflag = FALSE;
PROTECT(a = coerceVector(CADR(args), REALSXP));
GetRNGstate();
double *ra = REAL(a);
errno = 0;
if (type == INTSXP) {
double rx;
int *ix = INTEGER(x);
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx = fn(ra[i % na]);
if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN ) {
naflag = TRUE;
ix[i] = NA_INTEGER;
}
else ix[i] = (int) rx;
}
} else {
double *rx = REAL(x);
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx[i] = fn(ra[i % na]);
if (ISNAN(rx[i])) naflag = TRUE;
}
}
if (naflag) warning(_("NAs produced"));
PutRNGstate();
UNPROTECT(1);
}
UNPROTECT(1);
return x;
}
// supercomparateur joker (tm)
// compare a et b (b=avec joker dedans), case insensitive [voir CI]
// renvoi l'adresse de la première lettre de la chaine
// (cà d *[..]toto.. renvoi adresse de toto dans la chaine)
// accepte les délires du genre www.*.*/ * / * truc*.*
// cet algo est 'un peu' récursif mais ne consomme pas trop de tm
// * = toute lettre
// --?-- : spécifique à HTTrack et aux ?
HTS_INLINE char *strjoker(char *chaine, char *joker, LLint * size,
int *size_flag) {
//int err=0;
if (strnotempty(joker) == 0) { // fin de chaine joker
if (strnotempty(chaine) == 0) // fin aussi pour la chaine: ok
return chaine;
else if (chaine[0] == '?')
return chaine; // --?-- pour les index.html?Choix=2
else
return NULL; // non trouvé
}
// on va progresser en suivant les 'mots' contenus dans le joker
// un mot peut être un * ou bien toute autre séquence de lettres
if (strcmp(joker, "*") == 0) { // ok, rien après
return chaine;
}
// 1er cas: jokers * ou jokers multiples *[..]
if (joker[0] == '*') { // comparer joker+reste (*toto/..)
int jmp; // nombre de caractères pour le prochain mot dans joker
int cut = 0; // interdire tout caractère superflu
char pass[256];
char LEFT = '[', RIGHT = ']';
int unique = 0;
switch (joker[1]) {
case '[':
LEFT = '[';
RIGHT = ']';
unique = 0;
break;
case '(':
LEFT = '(';
RIGHT = ')';
unique = 1;
break;
}
if ((joker[1] == LEFT) && (joker[2] != LEFT)) { // multijoker (tm)
int i;
for(i = 0; i < 256; i++)
pass[i] = 0;
// noms réservés
if ((strfield(joker + 2, "file")) || (strfield(joker + 2, "name"))) {
for(i = 0; i < 256; i++)
pass[i] = 1;
pass[(int) '?'] = 0;
//pass[(int) ';'] = 0;
pass[(int) '/'] = 0;
i = 2;
{
int len = (int) strlen(joker);
while((joker[i] != RIGHT) && (joker[i]) && (i < len))
i++;
}
} else if (strfield(joker + 2, "path")) {
for(i = 0; i < 256; i++)
pass[i] = 1;
pass[(int) '?'] = 0;
//pass[(int) ';'] = 0;
i = 2;
{
int len = (int) strlen(joker);
while((joker[i] != RIGHT) && (joker[i]) && (i < len))
i++;
}
} else if (strfield(joker + 2, "param")) {
if (chaine[0] == '?') { // il y a un paramètre juste lÃ
for(i = 0; i < 256; i++)
pass[i] = 1;
} // sinon synonyme de 'rien'
i = 2;
{
int len = (int) strlen(joker);
while((joker[i] != RIGHT) && (joker[i]) && (i < len))
i++;
}
} else {
// décode les directives comme *[A-Z,âêîôû,0-9]
i = 2;
if (joker[i] == RIGHT) { // *[] signifie "plus rien après"
cut = 1; // caractère supplémentaire interdit
} else {
int len = (int) strlen(joker);
while((joker[i] != RIGHT) && (joker[i]) && (i < len)) {
if ((joker[i] == '<') || (joker[i] == '>')) { // *[<10]
int lsize = 0;
int lverdict;
i++;
if (sscanf(joker + i, "%d", &lsize) == 1) {
if (size) {
if (*size >= 0) {
if (size_flag)
*size_flag = 1; /* a joué */
if (joker[i - 1] == '<')
lverdict = (*size < lsize);
else
lverdict = (*size > lsize);
if (!lverdict) {
return NULL; // ne correspond pas
} else {
*size = lsize;
return chaine; // ok
}
} else
return NULL; // ne correspond pas
} else
return NULL; // ne correspond pas (test impossible)
// jump
while(isdigit((unsigned char) joker[i]))
i++;
}
} else if (joker[i + 1] == '-') { // 2 car, ex: *[A-Z]
if ((int) (unsigned char) joker[i + 2] >
(int) (unsigned char) joker[i]) {
int j;
for(j = (int) (unsigned char) joker[i];
j <= (int) (unsigned char) joker[i + 2]; j++)
pass[j] = 1;
}
// else err=1;
i += 3;
} else { // 1 car, ex: *[ ]
if (joker[i + 2] == '\\' && joker[i + 3] != 0) { // escaped char, such as *[\[] or *[\]]
i++;
}
pass[(int) (unsigned char) joker[i]] = 1;
i++;
}
if ((joker[i] == ',') || (joker[i] == ';'))
i++;
}
}
}
// Ã sauter dans joker
jmp = i;
if (joker[i])
jmp++;
//
} else { // tout autoriser
//
int i;
for(i = 0; i < 256; i++)
pass[i] = 1; // tout autoriser
jmp = 1;
////if (joker[2]==LEFT) jmp=3; // permet de recher *<crochet ouvrant>
}
{
int i, max;
char *adr;
// la chaine doit se terminer exactement
if (cut) {
if (strnotempty(chaine))
return NULL; // perdu
else
return chaine; // ok
}
// comparaison en boucle, c'est ca qui consomme huhu..
// le tableau pass[256] indique les caractères ASCII autorisés
// tester sans le joker (pas ()+ mais ()*)
if (!unique) {
if ((adr = strjoker(chaine, joker + jmp, size, size_flag))) {
return adr;
}
}
// tester
i = 0;
if (!unique)
max = (int) strlen(chaine);
else /* *(a) only match a (not aaaaa) */
max = 1;
while(i < (int) max) {
if (pass[(int) (unsigned char) chaine[i]]) { // caractère autorisé
if ((adr = strjoker(chaine + i + 1, joker + jmp, size, size_flag))) {
return adr;
}
i++;
} else
i = max + 2; // sortir
}
// tester chaîne vide
if (i != max + 2) // avant c'est ok
if ((adr = strjoker(chaine + max, joker + jmp, size, size_flag)))
return adr;
return NULL; // perdu
}
} else { // comparer mot+reste (toto*..)
if (strnotempty(chaine)) {
int jmp = 0, ok = 1;
// comparer début de joker et début de chaine
while((joker[jmp] != '*') && (joker[jmp]) && (ok)) {
// CI : remplacer streql par une comparaison !=
if (!streql(chaine[jmp], joker[jmp])) {
ok = 0; // quitter
}
jmp++;
}
// comparaison ok?
if (ok) {
// continuer la comparaison.
if (strjoker(chaine + jmp, joker + jmp, size, size_flag))
return chaine; // retourner 1e lettre
}
} // strlen(a)
return NULL;
} // * ou mot
return NULL;
}
// créer dans s, à partir du chemin courant curr_fil, le lien vers link (absolu)
// un ident_url_relatif a déja été fait avant, pour que link ne soit pas un chemin relatif
int lienrelatif(char *s, const char *link, const char *curr_fil) {
char BIGSTK _curr[HTS_URLMAXSIZE * 2];
char BIGSTK newcurr_fil[HTS_URLMAXSIZE * 2], newlink[HTS_URLMAXSIZE * 2];
char *curr;
//int n=0;
char *a;
int slash = 0;
//
newcurr_fil[0] = '\0';
newlink[0] = '\0';
//
// patch: éliminer les ? (paramètres) sinon bug
{
const char *a;
if ((a = strchr(curr_fil, '?'))) {
strncatbuff(newcurr_fil, curr_fil, (int) (a - curr_fil));
curr_fil = newcurr_fil;
}
if ((a = strchr(link, '?'))) {
strncatbuff(newlink, link, (int) (a - link));
link = newlink;
}
}
// recopier uniquement le chemin courant
curr = _curr;
strcpybuff(curr, curr_fil);
if ((a = strchr(curr, '?')) == NULL) // couper au ? (params)
a = curr + strlen(curr) - 1; // pas de params: aller à la fin
while((*a != '/') && (a > curr))
a--; // chercher dernier / du chemin courant
if (*a == '/')
*(a + 1) = '\0'; // couper dernier /
// "effacer" s
s[0] = '\0';
// sauter ce qui est commun aux 2 chemins
{
const char *l;
if (*link == '/')
link++; // sauter slash
if (*curr == '/')
curr++;
l = link;
//c=curr;
// couper ce qui est commun
while((streql(*link, *curr)) && (*link != 0)) {
link++;
curr++;
}
// mais on veut un répertoirer entier!
// si on a /toto/.. et /toto2/.. on ne veut pas sauter /toto !
while(((*link != '/') || (*curr != '/')) && (link > l)) {
link--;
curr--;
}
//if (*link=='/') link++;
//if (*curr=='/') curr++;
}
// calculer la profondeur du répertoire courant et remonter
// LES ../ ONT ETE SIMPLIFIES
a = curr;
if (*a == '/')
a++;
while(*a)
if (*(a++) == '/')
strcatbuff(s, "../");
//if (strlen(s)==0) strcatbuff(s,"/");
if (slash)
strcatbuff(s, "/"); // garder absolu!!
// on est dans le répertoire de départ, copier
strcatbuff(s, link + ((*link == '/') ? 1 : 0));
/* Security check */
if (strlen(s) >= HTS_URLMAXSIZE)
return -1;
// on a maintenant une chaine de la forme ../../test/truc.html
return 0;
}
SEXP attribute_hidden do_filepath(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, sep, x;
int i, j, k, ln, maxlen, nx, nzero, pwidth, sepw;
const char *s, *csep, *cbuf;
char *buf;
checkArity(op, args);
/* Check the arguments */
x = CAR(args);
if (!isVectorList(x))
error(_("invalid first argument"));
nx = length(x);
if(nx == 0) return allocVector(STRSXP, 0);
sep = CADR(args);
if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
error(_("invalid separator"));
sep = STRING_ELT(sep, 0);
csep = CHAR(sep);
sepw = (int) strlen(csep); /* hopefully 1 */
/* Any zero-length argument gives zero-length result */
maxlen = 0; nzero = 0;
for (j = 0; j < nx; j++) {
if (!isString(VECTOR_ELT(x, j))) {
/* formerly in R code: moved to C for speed */
SEXP call, xj = VECTOR_ELT(x, j);
if(OBJECT(xj)) { /* method dispatch */
PROTECT(call = lang2(install("as.character"), xj));
SET_VECTOR_ELT(x, j, eval(call, env));
UNPROTECT(1);
} else if (isSymbol(xj))
SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
else
SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
if (!isString(VECTOR_ELT(x, j)))
error(_("non-string argument to Internal paste"));
}
ln = length(VECTOR_ELT(x, j));
if(ln > maxlen) maxlen = ln;
if(ln == 0) {nzero++; break;}
}
if(nzero || maxlen == 0) return allocVector(STRSXP, 0);
PROTECT(ans = allocVector(STRSXP, maxlen));
for (i = 0; i < maxlen; i++) {
pwidth = 0;
for (j = 0; j < nx; j++) {
k = length(VECTOR_ELT(x, j));
pwidth += (int) strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
}
pwidth += (nx - 1) * sepw;
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
for (j = 0; j < nx; j++) {
k = length(VECTOR_ELT(x, j));
if (k > 0) {
s = translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k));
strcpy(buf, s);
buf += strlen(s);
}
if (j != nx - 1 && sepw != 0) {
strcpy(buf, csep);
buf += sepw;
}
}
#ifdef Win32
// Trailing seps are invalid for file paths except for / and d:/
if(streql(csep, "/") || streql(csep, "\\")) {
if(buf > cbuf) {
buf--;
if(*buf == csep[0] && buf > cbuf &&
(buf != cbuf+2 || cbuf[1] != ':')) *buf = '\0';
}
}
#endif
SET_STRING_ELT(ans, i, mkChar(cbuf));
}
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return ans;
}
static void
parseArgs(int argc, char **argv)
{
while (--argc > 0)
if ((++argv)[0][0] == '-')
{
switch (argv[0][1])
{
case 'q':
BeQuiet = TRUE;
break;
case 'Q':
BeQuiet = FALSE;
break;
case 'v':
BeVerbose = TRUE;
break;
case 'V':
BeVerbose = FALSE;
break;
case 'r':
UseMsgRPC = TRUE;
break;
case 'R':
UseMsgRPC = FALSE;
break;
case 's':
if (streql(argv[0], "-server"))
{
--argc; ++argv;
if (argc == 0)
fatal("missing name for -server option");
ServerFileName = strmake(argv[0]);
}
else if (streql(argv[0], "-sheader"))
{
--argc; ++argv;
if (argc == 0)
fatal ("missing name for -sheader option");
ServerHeaderFileName = strmake(argv[0]);
}
else
GenSymTab = TRUE;
break;
case 'S':
GenSymTab = FALSE;
break;
case 'i':
if (streql(argv[0], "-iheader"))
{
--argc; ++argv;
if (argc == 0)
fatal("missing name for -iheader option");
InternalHeaderFileName = strmake(argv[0]);
}
else
{
--argc; ++argv;
if (argc == 0)
fatal("missing prefix for -i option");
UserFilePrefix = strmake(argv[0]);
}
break;
case 'u':
if (streql(argv[0], "-user"))
{
--argc; ++argv;
if (argc == 0)
fatal("missing name for -user option");
UserFileName = strmake(argv[0]);
}
else
fatal("unknown flag: '%s'", argv[0]);
break;
case 'h':
if (streql(argv[0], "-header"))
{
--argc; ++argv;
if (argc == 0)
fatal("missing name for -header option");
UserHeaderFileName = strmake(argv[0]);
}
else
fatal("unknown flag: '%s'", argv[0]);
break;
default:
fatal("unknown flag: '%s'", argv[0]);
/*NOTREACHED*/
}
}
else
fatal("bad argument: '%s'", *argv);
}
/* do the two objects compute as identical?
Also used in unique.c */
Rboolean
R_compute_identical(SEXP x, SEXP y, int flags)
{
SEXP ax, ay, atrx, atry;
if(x == y) /* same pointer */
return TRUE;
if(TYPEOF(x) != TYPEOF(y))
return FALSE;
if(OBJECT(x) != OBJECT(y))
return FALSE;
/* Skip attribute checks for CHARSXP
-- such attributes are used for the cache. */
if(TYPEOF(x) == CHARSXP)
{
/* This matches NAs */
return Seql(x, y);
}
ax = ATTRIB(x); ay = ATTRIB(y);
if (!ATTR_AS_SET) {
if(!R_compute_identical(ax, ay, flags)) return FALSE;
}
/* Attributes are special: they should be tagged pairlists. We
don't test them if they are not, and we do not test the order
if they are.
This code is not very efficient, but then neither is using
pairlists for attributes. If long attribute lists become more
common (and they are used for S4 slots) we should store them in
a hash table.
*/
else if(ax != R_NilValue || ay != R_NilValue) {
if(ax == R_NilValue || ay == R_NilValue)
return FALSE;
if(TYPEOF(ax) != LISTSXP || TYPEOF(ay) != LISTSXP) {
warning(_("ignoring non-pairlist attributes"));
} else {
SEXP elx, ely;
if(length(ax) != length(ay)) return FALSE;
/* They are the same length and should have
unique non-empty non-NA tags */
for(elx = ax; elx != R_NilValue; elx = CDR(elx)) {
const char *tx = CHAR(PRINTNAME(TAG(elx)));
for(ely = ay; ely != R_NilValue; ely = CDR(ely))
if(streql(tx, CHAR(PRINTNAME(TAG(ely))))) {
/* We need to treat row.names specially here */
if(streql(tx, "row.names")) {
PROTECT(atrx = getAttrib(x, R_RowNamesSymbol));
PROTECT(atry = getAttrib(y, R_RowNamesSymbol));
if(!R_compute_identical(atrx, atry, flags)) {
UNPROTECT(2);
return FALSE;
} else
UNPROTECT(2);
} else
if(!R_compute_identical(CAR(elx), CAR(ely), flags))
return FALSE;
break;
}
if(ely == R_NilValue) return FALSE;
}
}
}
switch (TYPEOF(x)) {
case NILSXP:
return TRUE;
case LGLSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case INTSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case REALSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
double *xp = REAL(x), *yp = REAL(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i], yp[i], ne_strict)) return FALSE;
}
return TRUE;
}
case CPLXSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
Rcomplex *xp = COMPLEX(x), *yp = COMPLEX(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i].r, yp[i].r, ne_strict) ||
neWithNaN(xp[i].i, yp[i].i, ne_strict))
return FALSE;
}
return TRUE;
}
case STRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++) {
/* This special-casing for NAs is not needed */
Rboolean na1 = (STRING_ELT(x, i) == NA_STRING),
na2 = (STRING_ELT(y, i) == NA_STRING);
if(na1 ^ na2) return FALSE;
if(na1 && na2) continue;
if (! Seql(STRING_ELT(x, i), STRING_ELT(y, i))) return FALSE;
}
return TRUE;
}
case CHARSXP: /* Probably unreachable, but better safe than sorry... */
{
/* This matches NAs */
return Seql(x, y);
}
case VECSXP:
case EXPRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++)
if(!R_compute_identical(VECTOR_ELT(x, i),VECTOR_ELT(y, i), flags))
return FALSE;
return TRUE;
}
case LANGSXP:
case LISTSXP:
{
while (x != R_NilValue) {
if(y == R_NilValue)
return FALSE;
if(!R_compute_identical(CAR(x), CAR(y), flags))
return FALSE;
if(!R_compute_identical(PRINTNAME(TAG(x)), PRINTNAME(TAG(y)), flags))
return FALSE;
x = CDR(x);
y = CDR(y);
}
return(y == R_NilValue);
}
case CLOSXP:
return(R_compute_identical(FORMALS(x), FORMALS(y), flags) &&
R_compute_identical(BODY_EXPR(x), BODY_EXPR(y), flags) &&
(CLOENV(x) == CLOENV(y) ? TRUE : FALSE) &&
(IGNORE_BYTECODE || R_compute_identical(BODY(x), BODY(y), flags))
);
case SPECIALSXP:
case BUILTINSXP:
return(PRIMOFFSET(x) == PRIMOFFSET(y) ? TRUE : FALSE);
case ENVSXP:
case SYMSXP:
case WEAKREFSXP:
case BCODESXP: /**** is this the best approach? */
return(x == y ? TRUE : FALSE);
case EXTPTRSXP:
return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
case RAWSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)RAW(x), (void *)RAW(y),
length(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;
/* case PROMSXP: args are evaluated, so will not be seen */
/* test for equality of the substituted expression -- or should
we require both expression and environment to be identical? */
/*#define PREXPR(x) ((x)->u.promsxp.expr)
#define PRENV(x) ((x)->u.promsxp.env)
return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),
flags),
subsititute(PREXPR(y), PRENV(y))));*/
case S4SXP:
/* attributes already tested, so all slots identical */
return TRUE;
default:
/* these are all supposed to be types that represent constant
entities, so no further testing required ?? */
printf("Unknown Type: %s (%x)\n", type2char(TYPEOF(x)), TYPEOF(x));
return TRUE;
}
}
mrb_value
node_to_value_with_aliases(mrb_state *mrb,
yaml_document_t *document, yaml_node_t *node, int use_scalar_aliases)
{
/* YAML will return a NULL node if the input was empty */
if (!node)
return mrb_nil_value();
switch (node->type)
{
case YAML_SCALAR_NODE:
{
const char *str = (char *) node->data.scalar.value;
char *endptr;
long long ll;
double dd;
/* if node is a YAML_PLAIN_SCALAR_STYLE */
if (node->data.scalar.style == YAML_PLAIN_SCALAR_STYLE) {
if (streql("~", str)) return mrb_nil_value();
if (use_scalar_aliases) {
/* Check if it is a null http://yaml.org/type/null.html */
if (streql("nil", str) || streql("", str)
#if MRUBY_YAML_NULL
|| streql("null", str) || streql("Null", str) || streql("NULL", str)
#endif
) {
return mrb_nil_value();
/* Check if it is a Boolean http://yaml.org/type/bool.html */
} else if (
streql("true", str) || streql("True", str) || streql("TRUE", str)
#if MRUBY_YAML_BOOLEAN_ON
|| streql("on", str) || streql("On", str) || streql("ON", str)
#endif
#if MRUBY_YAML_BOOLEAN_YES
|| streql("yes", str) || streql("Yes", str) || streql("YES", str)
#endif
#if MRUBY_YAML_BOOLEAN_SHORTHAND_YES
|| streql("y", str) || streql("Y", str)
#endif
) {
return mrb_true_value();
} else if (
streql("false", str) || streql("False", str) || streql("FALSE", str)
#if MRUBY_YAML_BOOLEAN_OFF
|| streql("off", str) || streql("Off", str) || streql("OFF", str)
#endif
#if MRUBY_YAML_BOOLEAN_NO
|| streql("no", str) || streql("No", str) || streql("NO", str)
#endif
#if MRUBY_YAML_BOOLEAN_SHORTHAND_NO
|| streql("n", str) || streql("N", str)
#endif
) {
return mrb_false_value();
}
}
/* Check if it is a Fixnum */
ll = strtoll(str, &endptr, 0);
if (str != endptr && *endptr == '\0')
return mrb_fixnum_value(ll);
/* Check if it is a Float */
dd = strtod(str, &endptr);
if (str != endptr && *endptr == '\0')
return mrb_float_value(mrb, dd);
}
/* Otherwise it is a String */
return mrb_str_new(mrb, str, node->data.scalar.length);
}
case YAML_SEQUENCE_NODE:
{
/* Sequences are arrays in Ruby */
mrb_value result = mrb_ary_new(mrb);
yaml_node_item_t *item;
int ai = mrb_gc_arena_save(mrb);
for (item = node->data.sequence.items.start;
item < node->data.sequence.items.top; item++)
{
yaml_node_t *child_node = yaml_document_get_node(document, *item);
mrb_value child = node_to_value(mrb, document, child_node);
mrb_ary_push(mrb, result, child);
mrb_gc_arena_restore(mrb, ai);
}
return result;
}
case YAML_MAPPING_NODE:
{
/* Mappings are hashes in Ruby */
mrb_value result = mrb_hash_new(mrb);
yaml_node_t *key_node;
yaml_node_t *value_node;
yaml_node_pair_t *pair;
mrb_value key, value;
int ai = mrb_gc_arena_save(mrb);
for (pair = node->data.mapping.pairs.start;
pair < node->data.mapping.pairs.top; pair++)
{
key_node = yaml_document_get_node(document, pair->key);
value_node = yaml_document_get_node(document, pair->value);
key = node_to_value_key(mrb, document, key_node);
value = node_to_value(mrb, document, value_node);
mrb_hash_set(mrb, result, key, value);
mrb_gc_arena_restore(mrb, ai);
}
return result;
}
default:
return mrb_nil_value();
}
}
#include "assert.h"
#include "stdlib.h"
#include "stdio.h"
#include "allegro.h"
#include "string.h"
#include "ctype.h"
//#include "memory.h"
#include "trace.h"
#include "strparse.h"
#ifndef EXPERIMENTAL_NOTE_TRACK
#include "allegrord.h"
#endif /* EXPERIMENTAL_NOTE_TRACK */
#define streql(s1, s2) (strcmp(s1, s2) == 0)
#define field_max 80
//Note that this is an #ifdef, not an #ifndef
#ifdef EXPERIMENTAL_NOTE_TRACK
class Alg_reader {
public:
FILE *file;
int line_no;
String_parse line_parser;
bool line_parser_flag;
char field[field_max];
bool error_flag;
Alg_seq_ptr seq;
double tsnum;
double tsden;
Alg_reader(FILE *a_file, Alg_seq_ptr new_seq);
void readline();
Alg_parameters_ptr process_attributes(Alg_parameters_ptr attributes, double time);
bool parse();
long parse_chan(char *field);
long parse_int(char *field);
int find_real_in(char *field, int n);
double parse_real(char *field);
void parse_error(char *field, long offset, char *message);
double parse_dur(char *field, double base);
double parse_after_dur(double dur, char *field, int n, double base);
double parse_loud(char *field);
long parse_key(char *field);
double parse_pitch(char *field);
long parse_after_key(int key, char *field, int n);
long find_int_in(char *field, int n);
bool parse_attribute(char *field, Alg_parameter_ptr parm);
bool parse_val(Alg_parameter_ptr param, char *s, int i);
bool check_type(char type_char, Alg_parameter_ptr param);
};
#endif /* EXPERIMENTAL_NOTE_TRACK */
void subseq(char *result, char *source, int from, int to)
{
memcpy(result, source + from, to - from);
result[to - from] = 0;
}
#ifndef EXPERIMENTAL_NOTE_TRACK
double Allegro_reader::parse_pitch(char *field)
#else /* EXPERIMENTAL_NOTE_TRACK */
double Alg_reader::parse_pitch(char *field)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
if (isdigit(field[1])) {
char real_string[80];
int last = find_real_in(field, 1);
subseq(real_string, field, 1, last);
return atof(real_string);
} else {
return (double) parse_key(field);
}
}
#ifndef EXPERIMENTAL_NOTE_TRACK
Allegro_reader::Allegro_reader(FILE *a_file)
{
file = a_file; // save the file
line_parser_flag = false;
line_no = 0;
seq = Seq();
tsnum = 4; // default time signature
tsden = 4;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
// it is the responsibility of the caller to delete
// the seq
Alg_reader::Alg_reader(FILE *a_file, Alg_seq_ptr new_seq)
{
file = a_file; // save the file
line_parser_flag = false;
line_no = 0;
tsnum = 4; // default time signature
tsden = 4;
seq = new_seq;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
//Note that this is an #ifdef, not an #ifndef
#ifdef EXPERIMENTAL_NOTE_TRACK
Alg_seq_ptr alg_read(FILE *file, Alg_seq_ptr new_seq)
// read a sequence from allegro file
{
if (!new_seq) new_seq = new Alg_seq();
Alg_reader alg_reader(file, new_seq);
alg_reader.parse();
return alg_reader.seq;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
void Allegro_reader::readline()
#else /* EXPERIMENTAL_NOTE_TRACK */
void Alg_reader::readline()
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
char line[256];
char *line_flag = fgets(line, 256, file);
line_parser_flag = false;
if (line_flag) {
line_parser.init(line);
line_parser_flag = true;
error_flag = false;
}
}
#ifndef EXPERIMENTAL_NOTE_TRACK
void Allegro_reader::process_attributes(Parameters_ptr attributes, double time)
{
// print "process_attributes:", attributes
bool ts_flag;
if (attributes) {
Parameters_ptr a;
if (a = Parameters::remove_key(&attributes, "tempor")) {
double tempo = a->parm.r;
seq.insert_tempo(tempo, seq.map.time_to_beat(time));
}
if (a = Parameters::remove_key(&attributes, "beatr")) {
double beat = a->parm.r;
seq.insert_beat(time, beat);
}
if (a = Parameters::remove_key(&attributes, "tsnumr")) {
tsnum = a->parm.r;
ts_flag = true;
}
if (a = Parameters::remove_key(&attributes, "tsdenr")) {
tsden = a->parm.r;
ts_flag = true;
}
if (ts_flag) {
seq.set_time_sig(seq.map.time_to_beat(time), tsnum, tsden);
}
}
}
#else /* EXPERIMENTAL_NOTE_TRACK */
Alg_parameters_ptr Alg_reader::process_attributes(
Alg_parameters_ptr attributes, double time)
{
// print "process_attributes:", attributes
bool ts_flag = false;
if (attributes) {
Alg_parameters_ptr a;
bool in_seconds = seq->get_units_are_seconds();
if (a = Alg_parameters::remove_key(&attributes, "tempor")) {
double tempo = a->parm.r;
seq->insert_tempo(tempo, seq->get_time_map()->time_to_beat(time));
}
if (a = Alg_parameters::remove_key(&attributes, "beatr")) {
double beat = a->parm.r;
seq->insert_beat(time, beat);
}
if (a = Alg_parameters::remove_key(&attributes, "timesig_numr")) {
tsnum = a->parm.r;
ts_flag = true;
}
if (a = Alg_parameters::remove_key(&attributes, "timesig_denr")) {
tsden = a->parm.r;
ts_flag = true;
}
if (ts_flag) {
seq->set_time_sig(seq->get_time_map()->time_to_beat(time),
tsnum, tsden);
}
if (in_seconds) seq->convert_to_seconds();
}
return attributes; // in case it was modified
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
bool Allegro_reader::parse()
{
int voice = 0;
int key = 60;
double loud = 100.0;
double pitch = 60.0;
double dur = 1.0;
double time = 0.0;
readline();
bool valid = false; // ignore blank lines
while (line_parser_flag) {
bool time_flag = false;
bool next_flag = false;
double next;
bool voice_flag = false;
bool loud_flag = false;
bool dur_flag = false;
bool new_pitch_flag = false; // "P" syntax
double new_pitch = 0.0;
bool new_key_flag = false; // "K" syntax
int new_key = 0;
bool new_note_flag = false; // "A"-"G" syntax
int new_note = 0;
Parameters_ptr attributes = NULL;
line_parser.get_nonspace_quoted(field);
char pk = line_parser.peek();
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
while (field[0]) {
// print "field", "|";field;"|", "|";line_parser.string;"|", line_parser.pos
char first = toupper(field[0]);
if (strchr("ABCDEFGKLPUSIQHW-", first)) {
valid = true; // it's a note or event
}
if (first == 'V') {
if (voice_flag) {
parse_error(field, 0, "Voice specified twice");
} else {
voice = parse_int(field);
}
voice_flag = true;
} else if (first == 'T') {
if (time_flag) {
parse_error(field, 0, "Time specified twice");
} else {
time = parse_dur(field, 0.0);
}
time_flag = true;
} else if (first == 'N') {
if (next_flag) {
parse_error(field, 0, "Next specified twice");
} else {
next = parse_dur(field, time);
}
next_flag = true;
} else if (first == 'K') {
if (new_key_flag) {
parse_error(field, 0, "Key specified twice");
} else {
new_key = parse_key(field);
new_key_flag = true;
}
} else if (first == 'L') {
if (loud_flag) {
parse_error(field, 0, "Loudness specified twice");
} else {
loud = parse_loud(field);
}
loud_flag = true;
} else if (first == 'P') {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
new_pitch = parse_pitch(field);
new_pitch_flag = true;
}
} else if (first == 'U') {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("SIQHW", first)) {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
// prepend 'U' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'U';
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("ABCDEFG", first)) {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
// prepend 'K' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'K';
new_note = parse_key(field);
new_note_flag = true;
}
} else if (first == '-') {
Parameter parm;
if (parse_attribute(field, &parm)) { // enter attribute-value pair
attributes = new Parameters(attributes);
attributes->parm = parm;
parm.s = NULL; // protect string from deletion by destructor
}
} else {
parse_error(field, 0, "Unknown field");
}
if (error_flag) {
field[0] = 0; // exit the loop
} else {
line_parser.get_nonspace_quoted(field);
pk = line_parser.peek();
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
}
}
// a case analysis:
// Key < 128 counts as both key and pitch
// A-G implies pitch AND key unless key given too
// K60 P60 -- both are specified, use 'em
// K60 P60 C4 -- overconstrained, an error
// K60 C4 -- overconstrained
// K60 -- OK, pitch is 60
// C4 P60 -- over constrained
// P60 -- OK, key is from before, pitch is 60
// C4 -- OK, key is 60, pitch is 60
// <nothing> -- OK, key and pitch from before
// K200 with P60 ok, pitch is 60
// K200 with neither P60 nor C4 uses
// pitch from before
// figure out what the key/instance is:
if (new_key_flag) { // it was directly specified
key = new_key;
if (key < 128 && new_note_flag) {
parse_error("", 0, "Pitch specified twice");
}
} else if (new_note_flag) { // "A"-"G" used
key = new_note;
}
if (new_pitch_flag) {
pitch = new_pitch;
} else if (key < 128) {
pitch = key;
}
// now we've acquired new parameters
// if (it is a note, then enter the note
if (valid) {
// change tempo or beat
process_attributes(attributes, time);
// if there's a duration or pitch, make a note:
if (new_pitch_flag || dur_flag || new_note_flag) {
new_key_flag = false;
new_pitch_flag = false;
Allegro_note_ptr note_ptr = new Allegro_note;
note_ptr->chan = voice;
note_ptr->time = time;
note_ptr->dur = dur;
note_ptr->key = key;
note_ptr->pitch = pitch;
note_ptr->loud = loud;
note_ptr->parameters = attributes;
seq.add_event(note_ptr); // sort later
} else {
int update_key = -1;
// key or pitch must appear explicitly; otherwise
// update applies to channel
if (new_key_flag || new_pitch_flag) {
update_key = key;
}
if (loud_flag) {
Allegro_update_ptr new_upd = new Allegro_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->key = update_key;
new_upd->parameter.set_attr(symbol_table.insert_string("loudr"));
new_upd->parameter.r = pitch;
seq.add_event(new_upd);
}
if (attributes) {
while (attributes) {
Allegro_update_ptr new_upd = new Allegro_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->key = update_key;
new_upd->parameter = attributes->parm;
seq.add_event(new_upd);
Parameters_ptr p = attributes;
attributes = attributes->next;
delete p;
}
}
}
if (next_flag) {
time = time + next;
} else if (dur_flag) {
time = time + dur;
}
}
readline();
}
//print "Finished reading score"
if (!error_flag) {
seq.convert_to_seconds(); // make sure format is correct
// seq.notes.sort('event_greater_than');
}
// print "parse returns error_flag", error_flag
return error_flag;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
bool Alg_reader::parse()
{
int voice = 0;
int key = 60;
double loud = 100.0;
double pitch = 60.0;
double dur = 1.0;
double time = 0.0;
int track_num = 0;
seq->convert_to_seconds();
//seq->set_real_dur(0.0); // just in case it's not initialized already
readline();
bool valid = false; // ignore blank lines
while (line_parser_flag) {
bool time_flag = false;
bool next_flag = false;
double next;
bool voice_flag = false;
bool loud_flag = false;
bool dur_flag = false;
bool new_pitch_flag = false; // "P" syntax
double new_pitch = 0.0;
bool new_key_flag = false; // "K" syntax
int new_key = 0;
bool new_note_flag = false; // "A"-"G" syntax
int new_note = 0;
Alg_parameters_ptr attributes = NULL;
if (line_parser.peek() == '#') {
// look for #track
line_parser.get_nonspace_quoted(field);
if (streql(field, "#track")) {
line_parser.get_nonspace_quoted(field); // number
track_num = parse_int(field - 1);
seq->add_track(track_num);
}
// maybe we have a comment
} else {
// we must have a track to insert into
if (seq->tracks() == 0) seq->add_track(0);
line_parser.get_nonspace_quoted(field);
char pk = line_parser.peek();
// attributes are parsed as two adjacent nonspace_quoted tokens
// so we have to conditionally call get_nonspace_quoted() again
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
while (field[0]) {
char first = toupper(field[0]);
if (strchr("ABCDEFGKLPUSIQHW-", first)) {
valid = true; // it's a note or event
}
if (first == 'V') {
if (voice_flag) {
parse_error(field, 0, "Voice specified twice");
} else {
voice = parse_chan(field);
}
voice_flag = true;
} else if (first == 'T') {
if (time_flag) {
parse_error(field, 0, "Time specified twice");
} else {
time = parse_dur(field, 0.0);
}
time_flag = true;
} else if (first == 'N') {
if (next_flag) {
parse_error(field, 0, "Next specified twice");
} else {
next = parse_dur(field, time);
}
next_flag = true;
} else if (first == 'K') {
if (new_key_flag) {
parse_error(field, 0, "Key specified twice");
} else {
new_key = parse_key(field);
new_key_flag = true;
}
} else if (first == 'L') {
if (loud_flag) {
parse_error(field, 0, "Loudness specified twice");
} else {
loud = parse_loud(field);
}
loud_flag = true;
} else if (first == 'P') {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
new_pitch = parse_pitch(field);
new_pitch_flag = true;
}
} else if (first == 'U') {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("SIQHW", first)) {
if (dur_flag) {
parse_error(field, 0, "Dur specified twice");
} else {
// prepend 'U' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'U';
dur = parse_dur(field, time);
dur_flag = true;
}
} else if (strchr("ABCDEFG", first)) {
if (new_note_flag || new_pitch_flag) {
parse_error(field, 0, "Pitch specified twice");
} else {
// prepend 'K' to field, copy EOS too
memmove(field + 1, field, strlen(field) + 1);
field[0] = 'K';
new_note = parse_key(field);
new_note_flag = true;
}
} else if (first == '-') {
Alg_parameter parm;
if (parse_attribute(field, &parm)) { // enter attribute-value pair
attributes = new Alg_parameters(attributes);
attributes->parm = parm;
parm.s = NULL; // protect string from deletion by destructor
}
} else {
parse_error(field, 0, "Unknown field");
}
if (error_flag) {
field[0] = 0; // exit the loop
} else {
line_parser.get_nonspace_quoted(field);
pk = line_parser.peek();
// attributes are parsed as two adjacent nonspace_quoted
// tokens so we have to conditionally call
// get_nonspace_quoted() again
if (pk && !isspace(pk)) {
line_parser.get_nonspace_quoted(field + strlen(field));
}
}
}
// a case analysis:
// Key < 128 counts as both key and pitch
// A-G implies pitch AND key unless key given too
// K60 P60 -- both are specified, use 'em
// K60 P60 C4 -- overconstrained, an error
// K60 C4 -- overconstrained
// K60 -- OK, pitch is 60
// C4 P60 -- over constrained
// P60 -- OK, key is from before, pitch is 60
// C4 -- OK, key is 60, pitch is 60
// <nothing> -- OK, key and pitch from before
// K200 with P60 ok, pitch is 60
// K200 with neither P60 nor C4 uses
// pitch from before
// figure out what the key/instance is:
if (new_key_flag) { // it was directly specified
key = new_key;
if (key < 128 && new_note_flag) {
parse_error("", 0, "Pitch specified twice");
}
} else if (new_note_flag) { // "A"-"G" used
key = new_note;
}
if (new_pitch_flag) {
pitch = new_pitch;
} else if (key < 128) {
pitch = key;
}
// now we've acquired new parameters
// if (it is a note, then enter the note
if (valid) {
// change tempo or beat
attributes = process_attributes(attributes, time);
// if there's a duration or pitch, make a note:
if (new_pitch_flag || dur_flag || new_note_flag) {
new_key_flag = false;
new_pitch_flag = false;
Alg_note_ptr note_ptr = new Alg_note;
note_ptr->chan = voice;
note_ptr->time = time;
note_ptr->dur = dur;
note_ptr->set_identifier(key);
note_ptr->pitch = pitch;
note_ptr->loud = loud;
note_ptr->parameters = attributes;
seq->add_event(note_ptr, track_num); // sort later
if (seq->get_real_dur() < (time + dur)) seq->set_real_dur(time + dur);
} else {
int update_key = -1;
// key or pitch must appear explicitly; otherwise
// update applies to channel
if (new_key_flag || new_pitch_flag) {
update_key = key;
}
if (loud_flag) {
Alg_update_ptr new_upd = new Alg_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->set_identifier(update_key);
new_upd->parameter.set_attr(symbol_table.insert_string("loudr"));
new_upd->parameter.r = pitch;
seq->add_event(new_upd, track_num);
if (seq->get_real_dur() < time) seq->set_real_dur(time);
}
if (attributes) {
while (attributes) {
Alg_update_ptr new_upd = new Alg_update;
new_upd->chan = voice;
new_upd->time = time;
new_upd->set_identifier(update_key);
new_upd->parameter = attributes->parm;
seq->add_event(new_upd, track_num);
Alg_parameters_ptr p = attributes;
attributes = attributes->next;
p->parm.s = NULL; // so we don't delete the string
delete p;
}
}
}
if (next_flag) {
time = time + next;
} else if (dur_flag) {
time = time + dur;
}
}
}
readline();
}
//print "Finished reading score"
if (!error_flag) {
seq->convert_to_seconds(); // make sure format is correct
// seq->notes.sort('event_greater_than');
}
// real_dur is valid, translate to beat_dur
seq->set_beat_dur((seq->get_time_map())->time_to_beat(seq->get_real_dur()));
// print "parse returns error_flag", error_flag
return error_flag;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
//Note that this is an #ifdef, not an #ifndef
#ifdef EXPERIMENTAL_NOTE_TRACK
long Alg_reader::parse_chan(char *field)
{
char *int_string = field + 1;
char *msg = "Integer or - expected";
char *p = int_string;
char c;
// check that all chars in int_string are digits or '-':
while (c = *p++) {
if (!isdigit(c) && c != '-') {
parse_error(field, p - field - 1, msg);
return 0;
}
}
p--; // p now points to end-of-string character
if (p - int_string == 0) {
// bad: string length is zero
parse_error(field, 1, msg);
return 0;
}
if (p - int_string == 1 && int_string[0] == '-') {
// special case: entire string is "-", interpret as -1
return -1;
}
return atoi(int_string);
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
long Allegro_reader::parse_int(char *field)
{
char int_string[field_max];
strcpy(int_string, field + 1);
char *msg = "Integer expected";
char *p = int_string;
char c;
while (c = *p++) {
if (!isdigit(c)) {
parse_error(field, 1, msg);
return 0;
}
}
if (strlen(int_string) < 1) {
parse_error(field, 1, msg);
return 0;
}
return atoi(int_string);
}
#else /* EXPERIMENTAL_NOTE_TRACK */
long Alg_reader::parse_int(char *field)
{
char *int_string = field + 1;
char *msg = "Integer expected";
char *p = int_string;
char c;
// check that all chars in int_string are digits:
while (c = *p++) {
if (!isdigit(c)) {
parse_error(field, p - field - 1, msg);
return 0;
}
}
p--; // p now points to end-of-string character
if (p - int_string == 0) {
// bad: string length is zero
parse_error(field, 1, msg);
return 0;
}
return atoi(int_string);
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
int Allegro_reader::find_real_in(char *field, int n)
#else /* EXPERIMENTAL_NOTE_TRACK */
int Alg_reader::find_real_in(char *field, int n)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
// scans from offset n to the end of a real constant
bool decimal = false;
int len = strlen(field);
for (int i = n; i < len; i++) {
char c = field[i];
if (!isdigit(c)) {
if (c == '.' && !decimal) {
decimal = true;
} else {
return i;
}
}
}
return strlen(field);
}
#ifndef EXPERIMENTAL_NOTE_TRACK
double Allegro_reader::parse_real(char *field)
#else /* EXPERIMENTAL_NOTE_TRACK */
double Alg_reader::parse_real(char *field)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
char real_string[80];
char *msg = "Real expected";
bool decimal = false;
int last = find_real_in(field, 1);
subseq(real_string, field, 1, last);
if (last <= 1 || last < (int) strlen(field)) {
parse_error(field, 1, msg);
return 0;
}
return atof(real_string);
}
#ifndef EXPERIMENTAL_NOTE_TRACK
void Allegro_reader::parse_error(char *field, long offset, char *message)
#else /* EXPERIMENTAL_NOTE_TRACK */
void Alg_reader::parse_error(char *field, long offset, char *message)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
int position = line_parser.pos - strlen(field) + offset;
error_flag = true;
puts(line_parser.string);
for (int i = 0; i < position; i++) {
putc(' ', stdout);
}
putc('^', stdout);
printf(" %s\n", message);
}
double duration_lookup[] = { 0.25, 0.5, 1.0, 2.0, 4.0 };
#ifndef EXPERIMENTAL_NOTE_TRACK
double Allegro_reader::parse_dur(char *field, double base)
{
char *msg = "Duration expected";
char real_string[80];
char *durs = "SIQHW";
char *p;
int last;
double dur;
if (strlen(field) < 2) {
// fall through to error message
return -1;
} else if (isdigit(field[1])) {
last = find_real_in(field, 1);
subseq(real_string, field, 1, last);
dur = atof(real_string);
// convert dur from seconds to beats
dur = seq.map.time_to_beat(base + dur) - seq.map.time_to_beat(base);
} else if (p = strchr(durs, field[1])) {
dur = duration_lookup[p - durs];
last = 2;
} else {
parse_error(field, 1, msg);
return 0;
}
dur = parse_after_dur(dur, field, last, base);
dur = seq.map.beat_to_time(seq.map.time_to_beat(base) + dur) - base;
return dur;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
double Alg_reader::parse_dur(char *field, double base)
{
char *msg = "Duration expected";
char real_string[80];
char *durs = "SIQHW";
char *p;
int last;
double dur;
if (strlen(field) < 2) {
// fall through to error message
return -1;
} else if (isdigit(field[1])) {
last = find_real_in(field, 1);
subseq(real_string, field, 1, last);
dur = atof(real_string);
// convert dur from seconds to beats
dur = seq->get_time_map()->time_to_beat(base + dur) -
seq->get_time_map()->time_to_beat(base);
} else if (p = strchr(durs, field[1])) {
dur = duration_lookup[p - durs];
last = 2;
} else {
parse_error(field, 1, msg);
return 0;
}
dur = parse_after_dur(dur, field, last, base);
dur = seq->get_time_map()->beat_to_time(
seq->get_time_map()->time_to_beat(base) + dur) - base;
return dur;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
double Allegro_reader::parse_after_dur(double dur, char *field, int n, double base)
{
char a_string[80];
if ((int) strlen(field) == n) {
return dur;
}
if (field[n] == 'T') {
return parse_after_dur(dur * 2/3, field, n + 1, base);
}
if (field[n] == '.') {
return parse_after_dur(dur * 1.5, field, n + 1, base);
}
if (isdigit(field[n])) {
int last = find_real_in(field, n);
subseq(a_string, field, n, last);
double f = atof(a_string);
return parse_after_dur(dur * f, field, last, base);
}
if (field[n] == '+') {
subseq(a_string, field, n + 1, -1);
return dur + parse_dur(a_string,
seq.map.beat_to_time(
seq.map.time_to_beat(base) + dur));
}
parse_error(field, n, "Unexpected character in duration");
return dur;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
double Alg_reader::parse_after_dur(double dur, char *field, int n, double base)
{
char a_string[80];
if ((int) strlen(field) == n) {
return dur;
}
if (field[n] == 'T') {
return parse_after_dur(dur * 2/3, field, n + 1, base);
}
if (field[n] == '.') {
return parse_after_dur(dur * 1.5, field, n + 1, base);
}
if (isdigit(field[n])) {
int last = find_real_in(field, n);
subseq(a_string, field, n, last);
double f = atof(a_string);
return parse_after_dur(dur * f, field, last, base);
}
if (field[n] == '+') {
subseq(a_string, field, n + 1, -1);
return dur + parse_dur(
a_string, seq->get_time_map()->beat_to_time(
seq->get_time_map()->time_to_beat(base) + dur));
}
parse_error(field, n, "Unexpected character in duration");
return dur;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
static struct {
#else /* EXPERIMENTAL_NOTE_TRACK */
struct loud_lookup_struct {
#endif /* EXPERIMENTAL_NOTE_TRACK */
char *str;
int val;
} loud_lookup[] = { {"FFF", 127}, {"FF", 120}, {"F", 110}, {"MF", 100},
{"MP", 90}, {"P", 80}, {"PP", 70}, {"PPP", 60},
{NULL, 0} };
#ifndef EXPERIMENTAL_NOTE_TRACK
double Allegro_reader::parse_loud(char *field)
{
char *msg = "Loudness expected";
if (isdigit(field[1])) {
return parse_int(field);
} else {
double loud = 0.0;
char dyn[field_max];
strcpy(dyn, field + 1);
char *p = dyn;
while (*p) {
if (isupper(*p)) *p = toupper(*p);
}
for (int i = 0; loud_lookup[i].str; i++) {
if (streql(loud_lookup[i].str, dyn)) {
return (double) loud_lookup[i].val;
}
}
}
parse_error(field, 1, msg);
return 100.0;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
double Alg_reader::parse_loud(char *field)
{
char *msg = "Loudness expected";
if (isdigit(field[1])) {
return parse_int(field);
} else {
double loud = 0.0;
char dyn[field_max];
strcpy(dyn, field + 1);
char *p = dyn;
while (*p) {
if (islower(*p)) *p = toupper(*p);
p++;
}
for (int i = 0; loud_lookup[i].str; i++) {
if (streql(loud_lookup[i].str, dyn)) {
return (double) loud_lookup[i].val;
}
}
}
parse_error(field, 1, msg);
return 100.0;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
int key_lookup[] = {21, 23, 12, 14, 16, 17, 19};
#ifndef EXPERIMENTAL_NOTE_TRACK
long Allegro_reader::parse_key(char *field)
#else /* EXPERIMENTAL_NOTE_TRACK */
long Alg_reader::parse_key(char *field)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
char *msg = "Pitch expected";
char *pitches = "ABCDEFG";
char *p;
if (isdigit(field[1])) {
return parse_int(field);
} else if (p = strchr(pitches, field[1])) {
long key = key_lookup[p - pitches];
key = parse_after_key(key, field, 2);
return key;
}
parse_error(field, 1, msg);
return 0;
}
#ifndef EXPERIMENTAL_NOTE_TRACK
long Allegro_reader::parse_after_key(int key, char *field, int n)
#else /* EXPERIMENTAL_NOTE_TRACK */
long Alg_reader::parse_after_key(int key, char *field, int n)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
char octave[20];
if ((int) strlen(field) == n) {
return key;
}
char c = toupper(field[n]);
if (c == 'S') {
return parse_after_key(key + 1, field, n + 1);
}
if (c == 'F') {
return parse_after_key(key - 1, field, n + 1);
}
if (isdigit(c)) {
int last = find_int_in(field, n);
subseq(octave, field, n, last);
int oct = atoi(octave);
return parse_after_key(key + oct * 12, field, last);
}
parse_error(field, n, "Unexpected character in pitch");
return key;
}
#ifndef EXPERIMENTAL_NOTE_TRACK
long Allegro_reader::find_int_in(char *field, int n)
#else /* EXPERIMENTAL_NOTE_TRACK */
long Alg_reader::find_int_in(char *field, int n)
#endif /* EXPERIMENTAL_NOTE_TRACK */
{
while ((int) strlen(field) > n && isdigit(field[n])) {
n = n + 1;
}
return n;
}
#ifndef EXPERIMENTAL_NOTE_TRACK
bool Allegro_reader::parse_attribute(char *field, Parameter_ptr param)
{
int i = 1;
while (i < (int) strlen(field)) {
if (field[i] == ':') {
char attr[80];
subseq(attr, field, 1, i);
char type_char = field[i - 1];
if (strchr("iarsl", type_char)) {
param->set_attr(symbol_table.insert_string(attr));
parse_val(param, field, i + 1);
}
return !error_flag;
}
i = i + 1;
}
return false;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
bool Alg_reader::parse_attribute(char *field, Alg_parameter_ptr param)
{
int i = 1;
while (i < (int) strlen(field)) {
if (field[i] == ':') {
char attr[80];
subseq(attr, field, 1, i);
char type_char = field[i - 1];
if (strchr("iarsl", type_char)) {
param->set_attr(symbol_table.insert_string(attr));
parse_val(param, field, i + 1);
} else {
parse_error(field, 0, "attribute needs to end with typecode: i,a,r,s, or l");
}
return !error_flag;
}
i = i + 1;
}
return false;
}
#endif /* EXPERIMENTAL_NOTE_TRACK */
#ifndef EXPERIMENTAL_NOTE_TRACK
bool Allegro_reader::parse_val(Parameter_ptr param, char *s, int i)
{
int len = (int) strlen(s);
if (i >= len) {
return false;
}
if (s[i] == '"') {
if (!check_type('s', param)) {
return false;
}
char *r = new char[len - i];
subseq(r, s, i + 1, len - 1);
param->s = r;
} else if (s[i] == '\'') {
if (!check_type('a', param)) {
return false;
}
char r[80];
subseq(r, s, i + 1, len - 1);
param->a = symbol_table.insert_string(r);
} else if (param->attr_type() == 'l') {
if (streql(s + i, "true") || streql(s + i, "t")) {
param->l = true;
} else if (streql(s + i, "false") || streql(s + i, "nil")) {
param->l = false;
} else return false;
} else if (isdigit(s[i])) {
int pos = i + 1;
bool period = false;
while (pos < len) {
if (isdigit(s[pos])) {
;
} else if (!period && s[pos] == '.') {
period = true;
} else {
parse_error(s, pos, "Unexpected char in number");
return false;
}
pos = pos + 1;
}
char r[80];
subseq(r, s, i, len);
if (period) {
if (!check_type('r', param)) {
return false;
}
param->r = atof(r);
} else {
if (param->attr_type() == 'r') {
param->r = atoi(r);
} else if (!check_type('i', param)) {
return false;
} else {
param->i = atoi(r);
}
}
}
return true;
}
#else /* EXPERIMENTAL_NOTE_TRACK */
bool Alg_reader::parse_val(Alg_parameter_ptr param, char *s, int i)
{
int len = (int) strlen(s);
if (i >= len) {
return false;
}
if (s[i] == '"') {
if (!check_type('s', param)) {
return false;
}
char *r = new char[len - i];
subseq(r, s, i + 1, len - 1);
param->s = r;
} else if (s[i] == '\'') {
if (!check_type('a', param)) {
return false;
}
char r[80];
subseq(r, s, i + 1, len - 1);
param->a = symbol_table.insert_string(r);
} else if (param->attr_type() == 'l') {
if (streql(s + i, "true") || streql(s + i, "t")) {
param->l = true;
} else if (streql(s + i, "false") || streql(s + i, "nil")) {
param->l = false;
} else return false;
} else if (isdigit(s[i]) || s[i] == '-') {
int pos = i + 1;
bool period = false;
int sign = 1;
if (s[i] == '-') {
sign = -1;
pos = i + 2;
}
while (pos < len) {
if (isdigit(s[pos])) {
;
} else if (!period && s[pos] == '.') {
period = true;
} else {
parse_error(s, pos, "Unexpected char in number");
return false;
}
pos = pos + 1;
}
char r[80];
subseq(r, s, i, len);
if (period) {
if (!check_type('r', param)) {
return false;
}
param->r = atof(r);
} else {
if (param->attr_type() == 'r') {
param->r = atoi(r);
} else if (!check_type('i', param)) {
return false;
} else {
param->i = sign * atoi(r);
}
}
} else {
parse_error(s, i, "invalid value");
return false;
}
return true;
}
