static int
parse_headword(chasen_cell_t *cell, int default_weight, lexicon_t *lex)
{
chasen_cell_t *headword;
if (atomp(cell)) {
headword = cell;
lex->weight = (unsigned short)default_weight;
} else if (atomp(cha_car(cell))) {
headword = cha_car(cell);
if (nullp(cha_cdr(cell)))
lex->weight = (unsigned short)default_weight;
else if (!atomp(cha_car(cha_cdr(cell))))
return err_msg("has invalid form", cell);
else {
int weight;
weight = (int)(atof(s_atom_val(cha_car(cha_cdr(cell))))
* MRPH_DEFAULT_WEIGHT);
if (weight < 0) {
weight = 0;
return err_msg(": weight must be between 0 and 6553.5", cell);
} else if (weight > MRPH_WEIGHT_MAX) {
weight = MRPH_WEIGHT_MAX;
return err_msg(": weight must be between 0 and 6553.5", cell);
}
lex->weight = (unsigned short)weight;
}
} else {
return err_msg("has invalid form", cell);
}
if (get_string(headword, lex->headword, MIDASI_LEN) < 0)
return -1;
return lex->weight;
}
int equalp(int x1, int x2){
int start1,start2,len1,len2,elt;
if(nullp(x1) && nullp(x2))
return(1);
if((nullp(x1) && !nullp(x2)) || (!nullp(x1) && nullp(x2)))
return(0);
if(numberp(x1) && numberp(x2) && numeqp(x1,x2))
return(1);
if(vectorp(x1) && vectorp(x2)){
start1 = car(x1); start2 = car(x2);
len1 = cdr(x1); len2 = cdr(x2);
if(len1 == len2){
if(len1 == 0)
return(1);
else{
elt = 0;
while(elt < len1){
if(!equalp(car(start1+elt),car(start2+elt)))
return(0);
elt++;
}
}
return(1);
}
else
return(0);
}
if(atomp(x1) && atomp(x2))
return(eqvp(x1,x2));
if(equalp(car(x1),car(x2)))
return(equalp(cdr(x1),cdr(x2)));
else
return(0);
}
/* GSoC12: Tobenna Peter, Igwe */
Rat parseRat(char* srat, const char* info, int j)
{
char snum[MAXSTR], sden[MAXSTR];
mp num, den;
atoaa(srat, snum, sden);
atomp(snum, num);
if (sden[0]=='\0')
itomp(1, den);
else
{
atomp(sden, den);
if (negative(den) || zero(den))
{
char str[MAXSTR];
mptoa(den, str);
fprintf(stderr, "Warning: Denominator ");
fprintf(stderr, "%s of %s[%d] set to 1 since not positive\n",
str, info, j+1);
itomp(1, den);
}
}
Rat r = mptorat(num, den);
return r;
}
long
readrat ( lrs_mp Na, lrs_mp Da )
/* read a rational or integer and convert to lrs_mp with base BASE */
/* returns true if denominator is not one */
/* returns 999 if premature end of file */
{
char in[MAXINPUT], num[MAXINPUT], den[MAXINPUT];
if ( fscanf ( lrs_ifp, "%s", in ) == EOF ) {
fprintf ( lrs_ofp, "\nInvalid rational input" );
exit ( 1 );
}
if ( !strcmp ( in, "end" ) ) { /*premature end of input file */
return ( 999L );
}
atoaa ( in, num, den ); /*convert rational to num/dem strings */
atomp ( num, Na );
if ( den[0] == '\0' ) {
itomp ( 1L, Da );
return ( FALSE );
}
atomp ( den, Da );
return ( TRUE );
}
/* returns 999 if premature end of file */
long plrs_readrat (lrs_mp Na, lrs_mp Da, const char* rat)
{
char in[MAXINPUT], num[MAXINPUT], den[MAXINPUT];
strcpy(in, rat);
atoaa (in, num, den); /*convert rational to num/dem strings */
atomp (num, Na);
if (den[0] == '\0')
{
itomp (1L, Da);
return (FALSE);
}
atomp (den, Da);
return (TRUE);
}
//--------eval---------------
int eval(int addr){
int res;
if(atomp(addr)){
if(numberp(addr))
return(addr);
if(symbolp(addr)){
res = findsym(addr);
if(res == -1)
error(CANT_FIND_ERR, "eval", addr);
else
return(res);
}
}
else
if(listp(addr)){
if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))
return(cadr(addr));
if(numberp(car(addr)))
error(ARG_SYM_ERR, "eval", addr);
if(subrp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(car(addr),cdr(addr)));
if(functionp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
}
error(CANT_FIND_ERR, "eval", addr);
return(0);
}
/* xatom - is this an atom? */
LVAL xatom(void)
{
LVAL arg;
arg = xlgetarg();
xllastarg();
return (atomp(arg) ? s_true : NIL);
}
/* pplist - pretty print a list */
LOCAL void pplist(LVAL expr)
{
int n;
/* if the expression will fit on one line, print it on one */
if ((n = flatsize(expr)) < ppmaxlen) {
xlprint(ppfile,expr,TRUE);
pplevel += n;
}
/* otherwise print it on several lines */
else {
n = ppmargin;
ppputc('(');
if (atomp(car(expr))) {
ppexpr(car(expr));
ppputc(' ');
ppmargin = pplevel;
expr = cdr(expr);
}
else
ppmargin = pplevel;
for (; consp(expr); expr = cdr(expr)) {
pp(car(expr));
if (consp(cdr(expr)))
ppterpri();
}
if (expr != NIL) {
ppputc(' '); ppputc('.'); ppputc(' ');
ppexpr(expr);
}
ppputc(')');
ppmargin = n;
}
}
int eval(int addr){
int res;
if(atomp(addr)){
if(IS_NUMBER(addr))
return(addr);
if(IS_SYMBOL(addr)){
res = findsym(GET_NAME(addr));
switch(GET_TAG(res)){
case NUM: return(makenum(GET_NUMBER(res)));
case SYM: return(GET_BIND(res));
case LIS: return(GET_BIND(res));
}
}
}
else{
if(HAS_NAME(car(addr),"quote"))
return(cadr(addr));
if(subrp(car(addr)))
return(apply(symname(car(addr)),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(symname(car(addr)),cdr(addr)));
if(lambdap(car(addr)))
return(apply(symname(car(addr)),evlis(cdr(addr))));
}
return(NIL);
}
int improperp(int x){
while(!(nullp(x))){
if(atomp(cdr(x)))
return(1);
x = cdr(x);
}
return(0);
}
int f_atomp(int arglist){
int arg;
checkarg(LEN1_TEST, "atom" ,arglist);
arg = car(arglist);
if(atomp(arg))
return(T);
else
return(NIL);
}
static int
parse_dic(FILE *input, FILE *output[], da_build_t *builder)
{
chasen_cell_t *cell;
lexicon_t lexicons[256]; /* XXX */
int pos = -1;
int weight = MRPH_WEIGHT_MAX;
int stat = 0;
while (!cha_s_feof(input)) {
cell = cha_s_read(input);
if (atomp(cell))
return err_msg("is not list", cell);
if (atomp(cha_car(cell))) {
char *s = s_atom_val(cha_car(cell));
if (cha_litmatch(s, 1, STR_POS))
pos = cha_get_nhinsi_id(cha_car(cha_cdr(cell)));
else if (cha_litmatch(s, 1, STR_DEF_POS_COST))
weight = atoi(s_atom_val(cha_car(cha_cdr(cell))));
else
stat = err_msg("is not defined", cell);
} else {
if (pos < 0)
stat = err_msg("POS is not specified", NULL);
else if (parse_lexicon(cell, lexicons, pos, weight) < 0)
stat = -1;
else {
if (lexicons[0].inf_type > 0 &&
lexicons[0].inf_form > 0) {
lexicons[0].con_tbl += lexicons[0].inf_form - 1;
}
stat = dump_dic(lexicons, output, builder);
}
}
cha_s_free(cell);
}
return stat;
}
void
readmp ( lrs_mp a )
/* read an integer and convert to lrs_mp with base BASE */
{
char in[MAXINPUT];
if ( fscanf ( lrs_ifp, "%s", in ) == EOF ) {
fprintf ( lrs_ofp, "\nInvalid integer input" );
exit ( 1 );
}
atomp ( in, a );
}
/* GSoC12: Tobenna Peter, Igwe */
Rat parseDecimal(char* srat, const char* info, int j)
{
double x;
int count;
char* sub;
sscanf(srat, "%lf", &x);
sub = strchr(srat, '.');
if(strchr(sub+1, '.') != NULL)
{
fprintf(stderr, "Error: Decimal ");
fprintf(stderr, "%s of %s[%d] has more than one decimal point\n", srat, info, j);
exit(1);
}
count = strlen(sub+1);
char* str = strtok(srat, ".");
strcat(str, strtok(NULL, "."));
/*int num = floor(x * pow(10, count));*/
mp num;
atomp(str, num);
/*int den = pow(10, count);*/
int i;
strcpy(str, "10");
for(i = 1; i < count; ++i)
{
strcat(str, "0");
}
mp den;
atomp(str, den);
Rat rat = mptorat(num, den);
return rat;
}
//--------eval---------------
int eval(int addr){
int res;
//ctrl+cによる割り込みがあった場合
if(exit_flag == 1){
exit_flag = 0;
P = addr; //後で調べられるように退避
printf("exit eval by CTRL_C_EVENT\n"); fflush(stdout);
longjmp(buf,1);
}
if(atomp(addr)){
if(numberp(addr))
return(addr);
if(symbolp(addr)){
res = findsym(addr);
if(res == 0)
error(CANT_FIND_ERR, "eval", addr);
else
switch(GET_TAG(res)){
case NUM: return(res);
case SYM: return(res);
case LIS: return(res);
case SUBR: return(res);
case FSUBR: return(res);
case LAMBDA:return(GET_BIND(res));
}
}
}
else
if(listp(addr)){
if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))
return(cadr(addr));
if(numberp(car(addr)))
error(ARG_SYM_ERR, "eval", addr);
if(subrp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
if(fsubrp(car(addr)))
return(apply(car(addr),cdr(addr)));
if(lambdap(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
}
error(CANT_FIND_ERR, "eval", addr);
}
int readlist(void){
int car,cdr;
gettoken();
if(stok.type == RPAREN)
return(NIL);
else
if(stok.type == DOT){
cdr = read();
if(atomp(cdr))
gettoken();
return(cdr);
}
else{
stok.flag = BACK;
car = read();
cdr = readlist();
return(cons(car,cdr));
}
}
std::string sprint(const cons_t* p, std::string& s, bool escape)
{
switch ( type_of(p) ) {
case NIL: return s;
case BOOLEAN: return s + to_s(p->boolean);
case CHAR: return s + to_s(p->character, escape);
case REAL: return s + to_s(p->number.real);
case INTEGER: return s + to_s(p->number.integer);
case RATIONAL: return s + to_s(p->number.rational);
case CLOSURE: return s + (escape? to_s(p->closure) : "");
case SYMBOL: return s + *p->symbol;
case STRING: return s + (escape? "\"" + encode_str(p->string) + "\"" : p->string);
case VECTOR: return s + sprint(p->vector, s, escape);
case BYTEVECTOR: return s + sprint(p->bytevector, s, escape);
case CONTINUATION: return s + (escape? to_s(p->continuation) : "");
case SYNTAX: return s + sprint(p->syntax->transformer, s, escape);
case PORT: return s + sprint(p->port, s, escape);
case ENVIRONMENT: return s + sprint(p->environment, s, escape);
case POINTER: return s + sprint(p->pointer, s, escape);
case PAIR: {
std::string head = sprint(car(p), s, escape);
std::string tail = sprint(cdr(p), s, escape);
bool paren = type_of(car(p))==PAIR;
bool dotted = atomp(cdr(p)) && !nullp(cdr(p)) && !emptylistp(cadr(p));
return s
+ (paren? "(" : "")
+ head
+ (paren? ")" : "")
+ (!tail.empty() ? " " : "")
+ (dotted? ". " : "")
+ tail;
}}
return s;
}
/* evform - evaluate a form */
LOCAL LVAL evform(LVAL form)
{
LVAL fun,args,val,type;
LVAL tracing=NIL;
LVAL *argv;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
LVAL funname;
int argc;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
(*profile_count_ptr)++; /* increment profile counter */
/* get the function and the argument list */
fun = car(form);
args = cdr(form);
funname = fun;
/* get the functional value of symbols */
if (symbolp(fun)) {
if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
tracing = fun;
fun = xlgetfunction(fun);
}
/* check for nil */
if (null(fun))
xlerror("bad function",NIL);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
argv = xlargv;
argc = xlargc;
xlargc = evpushargs(fun,args);
xlargv = xlfp + 3;
trenter(tracing,xlargc,xlargv);
val = (*getsubr(fun))();
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case FSUBR:
argv = xlargv;
argc = xlargc;
xlargc = pushargs(fun,args);
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if ((type = car(fun)) == s_lambda)
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
/* do profiling */
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
if (gettype(fun) == s_lambda) {
argc = evpushargs(fun,args);
argv = xlfp + 3;
trenter(tracing,argc,argv);
val = evfun(fun,argc,argv);
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
}
else {
macroexpand(fun,args,&fun);
val = xleval(fun);
}
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
break;
default:
xlerror("bad function",fun);
}
/* restore the stack */
xlpopn(2);
/* return the result value */
return (val);
}
/* xlapply - apply a function to arguments (already on the stack) */
LVAL xlapply(int argc)
{
LVAL *oldargv,fun,val;
LVAL funname;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
int oldargc;
/* get the function */
fun = xlfp[1];
/* get the functional value of symbols */
if (symbolp(fun)) {
funname = fun; /* save it */
while ((val = getfunction(fun)) == s_unbound)
xlfunbound(fun);
fun = xlfp[1] = val;
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
}
/* check for nil */
if (null(fun))
xlerror("bad function",fun);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
oldargc = xlargc;
oldargv = xlargv;
xlargc = argc;
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlargc = oldargc;
xlargv = oldargv;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if (car(fun) == s_lambda) {
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
} else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
if (gettype(fun) != s_lambda)
xlerror("bad function",fun);
val = evfun(fun,argc,xlfp+3);
break;
default:
xlerror("bad function",fun);
}
/* restore original profile counting state */
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
/* remove the call frame */
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
/* return the function value */
return (val);
}
static int
parse_lexicon(chasen_cell_t *entry, lexicon_t *lexies, int pos, int weight)
{
chasen_cell_t *cell, *cdr;
int stat = 0;
memset(lexies, 0, sizeof(lexicon_t));
lexies[1].pos = 0;
lexies[0].pos = pos;
lexies[0].weight = weight;
lexies[0].base = lexies[0].info = "";
lexies[0].reading_len = lexies[0].pron_len = -1;
if (atomp(entry))
return err_msg("is not list", entry);
for (cell = cha_car(entry), cdr = cha_cdr(entry); !nullp(cell);
cell = cha_car(cdr), cdr = cha_cdr(cdr)) {
char *pred;
chasen_cell_t *val;
if (atomp(cell))
return err_msg("is not list", entry);
pred = s_atom_val(cha_car(cell));
val = cha_car(cha_cdr(cell));
if (cha_litmatch(pred, 1, STR_POS)) {
lexies[0].pos = cha_get_nhinsi_id(val);
} else if (cha_litmatch(pred, 1, STR_WORD)) {
stat = parse_headword(val, weight, lexies);
} else if (cha_litmatch(pred, 1, STR_READING)) {
stat = get_string(val, lexies[0].reading, MIDASI_LEN * 2);
lexies[0].reading_len = strlen(lexies[0].reading);
} else if (cha_litmatch(pred, 1, STR_PRON)) {
stat = get_string(val, lexies[0].pron, MIDASI_LEN * 2);
lexies[0].pron_len = strlen(lexies[0].pron);
} else if (cha_litmatch(pred, 1, STR_BASE)) {
lexies[0].base = s_atom_val(val);
} else if (cha_litmatch(pred, 1, STR_CTYPE)) {
lexies[0].inf_type = cha_get_type_id(s_atom_val(val));
} else if (cha_litmatch(pred, 1, STR_CFORM)) {
lexies[0].inf_form = cha_get_form_id(s_atom_val(val),
lexies[0].inf_type);
} else if (cha_litmatch(pred, 2, STR_INFO1, STR_INFO2)) {
lexies[0].info = s_atom_val(val);
} else if (cha_litmatch(pred, 1, STR_COMPOUND)) {
chasen_cell_t *head, *tail;
lexicon_t *lex = lexies + 1;
for (head = val, tail = cha_cdr(cha_cdr(cell));
!nullp(head);
head = cha_car(tail), tail = cha_cdr(tail))
stat = parse_lexicon(head, lex++, pos, 0);
if (lexies[0].inf_type > 0 && lexies[0].inf_form == 0 &&
lexies[0].inf_type != lex[-1].inf_type)
stat = err_msg(": conjugation type is different from that of the compound word", entry);
} else {
stat = err_msg("is not defined", cha_car(cell));
}
if (stat < 0)
return -1;
}
if (cha_check_table(lexies) <= 0)
return err_msg("is invalid connection", cell);
if (lexies[0].inf_type > 0) {
if (lexies[0].inf_form == 0) {
kform_t *basic_form;
basic_form = &Cha_form[lexies[0].inf_type]
[Cha_type[lexies[0].inf_type].basic];
stat = stem(lexies[0].headword, basic_form->gobi);
if (lexies[0].reading_len >= 0) {
stat = stem(lexies[0].reading, basic_form->ygobi);
lexies[0].reading_len = strlen(lexies[0].reading);
}
if (lexies[0].pron_len >= 0) {
stat = stem(lexies[0].pron, basic_form->pgobi);
lexies[0].pron_len = strlen(lexies[0].pron);
}
lexies[0].stem_len = strlen(lexies[0].headword);
} else {
kform_t *form;
form = &Cha_form[lexies[0].inf_type][lexies[0].inf_form];
lexies[0].stem_len = -1;
if (!lexies[0].base[0])
return err_msg("needs base form",
cha_tmp_atom(lexies[0].headword));
}
} else {
lexies[0].inf_type = 0;
lexies[0].inf_form = 0;
lexies[0].stem_len = strlen(lexies[0].headword);
}
return stat;
}
