[BACK]Return to strobj.c CVS log [TXT][DIR] Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Annotation of OpenXM_contrib2/asir2000/builtin/strobj.c, Revision 1.60

1.6       noro        1: /*
                      2:  * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
                      3:  * All rights reserved.
                      4:  *
                      5:  * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
                      6:  * non-exclusive and royalty-free license to use, copy, modify and
                      7:  * redistribute, solely for non-commercial and non-profit purposes, the
                      8:  * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
                      9:  * conditions of this Agreement. For the avoidance of doubt, you acquire
                     10:  * only a limited right to use the SOFTWARE hereunder, and FLL or any
                     11:  * third party developer retains all rights, including but not limited to
                     12:  * copyrights, in and to the SOFTWARE.
                     13:  *
                     14:  * (1) FLL does not grant you a license in any way for commercial
                     15:  * purposes. You may use the SOFTWARE only for non-commercial and
                     16:  * non-profit purposes only, such as academic, research and internal
                     17:  * business use.
                     18:  * (2) The SOFTWARE is protected by the Copyright Law of Japan and
                     19:  * international copyright treaties. If you make copies of the SOFTWARE,
                     20:  * with or without modification, as permitted hereunder, you shall affix
                     21:  * to all such copies of the SOFTWARE the above copyright notice.
                     22:  * (3) An explicit reference to this SOFTWARE and its copyright owner
                     23:  * shall be made on your publication or presentation in any form of the
                     24:  * results obtained by use of the SOFTWARE.
                     25:  * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.7       noro       26:  * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.6       noro       27:  * for such modification or the source code of the modified part of the
                     28:  * SOFTWARE.
                     29:  *
                     30:  * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
                     31:  * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
                     32:  * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
                     33:  * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
                     34:  * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
                     35:  * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
                     36:  * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
                     37:  * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
                     38:  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
                     39:  * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
                     40:  * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
                     41:  * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
                     42:  * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
                     43:  * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
                     44:  * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
                     45:  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
                     46:  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
                     47:  *
1.60    ! noro       48:  * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.59 2005/09/21 23:39:32 noro Exp $
1.6       noro       49: */
1.1       noro       50: #include "ca.h"
                     51: #include "parse.h"
                     52: #include "ctype.h"
1.10      ohara      53: #if defined(PARI)
1.1       noro       54: #include "genpari.h"
1.11      saito      55: #  if !(PARI_VERSION_CODE > 131588)
1.1       noro       56: extern jmp_buf environnement;
1.11      saito      57: #  endif
1.1       noro       58: #endif
1.5       noro       59: #include <string.h>
                     60:
1.18      noro       61: struct TeXSymbol {
                     62:        char *text;
                     63:        char *symbol;
                     64: };
                     65:
1.1       noro       66: extern char *parse_strp;
                     67:
1.50      ohara      68: void Psprintf();
1.1       noro       69: void Prtostr(), Pstrtov(), Peval_str();
1.3       noro       70: void Pstrtoascii(), Pasciitostr();
1.5       noro       71: void Pstr_len(), Pstr_chr(), Psub_str();
1.14      noro       72: void Pwrite_to_tb();
                     73: void Ptb_to_string();
                     74: void Pclear_tb();
                     75: void Pstring_to_tb();
                     76: void Pquotetotex_tb();
                     77: void Pquotetotex();
1.24      noro       78: void Pquotetotex_env();
1.47      noro       79: void Pflatten_quote();
1.52      noro       80: void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name();
1.53      noro       81: void Pquote_unify();
1.58      ohara      82: void do_assign(NODE arg);
1.14      noro       83: void fnodetotex_tb(FNODE f,TB tb);
                     84: char *symbol_name(char *name);
1.28      noro       85: char *conv_rule(char *name);
1.38      noro       86: char *conv_subs(char *name);
1.28      noro       87: char *call_convfunc(char *name);
1.14      noro       88: void tb_to_string(TB tb,STRING *rp);
                     89: void fnodenodetotex_tb(NODE n,TB tb);
                     90: void fargstotex_tb(char *opname,FNODE f,TB tb);
1.35      noro       91: int top_is_minus(FNODE f);
1.56      noro       92: int quote_unify(Obj f,Obj pat,NODE *rp);
1.1       noro       93:
                     94: struct ftab str_tab[] = {
1.50      ohara      95:        {"sprintf",Psprintf,-99999999},
1.1       noro       96:        {"rtostr",Prtostr,1},
                     97:        {"strtov",Pstrtov,1},
                     98:        {"eval_str",Peval_str,1},
1.3       noro       99:        {"strtoascii",Pstrtoascii,1},
                    100:        {"asciitostr",Pasciitostr,1},
1.5       noro      101:        {"str_len",Pstr_len,1},
                    102:        {"str_chr",Pstr_chr,3},
                    103:        {"sub_str",Psub_str,3},
1.14      noro      104:        {"write_to_tb",Pwrite_to_tb,2},
                    105:        {"clear_tb",Pclear_tb,1},
                    106:        {"tb_to_string",Ptb_to_string,1},
                    107:        {"string_to_tb",Pstring_to_tb,1},
1.60    ! noro      108:        {"quotetotex_tb",Pquotetotex_tb,2},
        !           109:        {"quotetotex",Pquotetotex,1},
        !           110:        {"quotetotex_env",Pquotetotex_env,-99999999},
        !           111:        {"flatten_quote",Pflatten_quote,2},
        !           112:        {"quote_to_funargs",Pquote_to_funargs,1},
        !           113:        {"quote_unify",Pquote_unify,2,0x2},
1.48      noro      114:        {"funargs_to_quote",Pfunargs_to_quote,1},
1.52      noro      115:        {"get_function_name",Pget_function_name,1},
1.1       noro      116:        {0,0,0},
                    117: };
1.13      noro      118:
1.14      noro      119: void write_tb(char *s,TB tb)
                    120: {
                    121:        if ( tb->next == tb->size ) {
                    122:                tb->size *= 2;
                    123:                tb->body = (char **)REALLOC(tb->body,tb->size*sizeof(char *));
                    124:        }
                    125:        tb->body[tb->next] = s;
                    126:        tb->next++;
                    127: }
1.13      noro      128:
1.18      noro      129: int register_symbol_table(Obj arg);
                    130: int register_conv_rule(Obj arg);
1.38      noro      131: int register_conv_func(Obj arg);
1.23      noro      132: int register_dp_vars(Obj arg);
1.46      noro      133: int register_dp_vars_origin(Obj arg);
                    134: int register_dp_dvars_origin(Obj arg);
                    135: int register_dp_dvars_prefix(Obj arg);
1.25      noro      136: int register_dp_vars_prefix(Obj arg);
1.31      noro      137: int register_dp_vars_hweyl(Obj arg);
1.27      noro      138: int register_show_lt(Obj arg);
1.40      noro      139: char *objtostr(Obj obj);
1.18      noro      140: static struct TeXSymbol *user_texsymbol;
1.23      noro      141: static char **dp_vars;
1.25      noro      142: static int dp_vars_len;
                    143: static char *dp_vars_prefix;
1.46      noro      144: static char *dp_dvars_prefix;
                    145: static int dp_vars_origin;
                    146: static int dp_dvars_origin;
1.27      noro      147: static int show_lt;
1.26      noro      148: static FUNC convfunc;
1.27      noro      149: static int is_lt;
1.28      noro      150: static int conv_flag;
1.31      noro      151: static int dp_vars_hweyl;
1.28      noro      152:
1.38      noro      153: #define CONV_TABLE (1U<<0)
                    154: #define CONV_SUBS (1U<<1)
                    155: #define CONV_DMODE (1U<<2)
1.18      noro      156:
                    157: static struct {
                    158:        char *name;
                    159:        Obj value;
                    160:        int (*reg)();
                    161: } qtot_env[] = {
                    162:        {"symbol_table",0,register_symbol_table},
                    163:        {"conv_rule",0,register_conv_rule},
1.38      noro      164:        {"conv_func",0,register_conv_func},
1.23      noro      165:        {"dp_vars",0,register_dp_vars},
1.25      noro      166:        {"dp_vars_prefix",0,register_dp_vars_prefix},
1.46      noro      167:        {"dp_dvars_prefix",0,register_dp_dvars_prefix},
                    168:        {"dp_vars_origin",0,register_dp_vars_origin},
                    169:        {"dp_dvars_origin",0,register_dp_dvars_origin},
1.31      noro      170:        {"dp_vars_hweyl",0,register_dp_vars_hweyl},
1.27      noro      171:        {"show_lt",0,register_show_lt},
1.18      noro      172:        {0,0,0},
                    173: };
                    174:
1.20      noro      175: #define PARTIAL "\\partial"
1.28      noro      176:
                    177: char *conv_rule(char *name)
                    178: {
                    179:        char *body,*r;
1.41      noro      180:        int len;
1.28      noro      181:
1.38      noro      182:        if ( convfunc )
                    183:                name = call_convfunc(name);
1.41      noro      184:        if ( conv_flag & CONV_TABLE ) {
                    185:                r = symbol_name(name);
                    186:                if ( r ) return r;
                    187:        }
                    188:        if ( (conv_flag & CONV_DMODE) && *name == 'd' ) {
                    189:                body = conv_rule(name+1);
                    190:                r = MALLOC_ATOMIC((strlen(PARTIAL)+strlen(body)+5)*sizeof(char));
                    191:                if ( !body || !(len=strlen(body)) )
                    192:                        strcpy(r,PARTIAL);
                    193:                else if ( len == 1 )
                    194:                        sprintf(r,"%s_%s",PARTIAL,body);
                    195:                else
                    196:                        sprintf(r,"%s_{%s}",PARTIAL,body);
                    197:                return r;
                    198:        } else
                    199:                return conv_subs(name);
1.28      noro      200: }
                    201:
1.40      noro      202: int _is_delimiter(char c)
                    203: {
                    204:        if ( (c == ' ' || c == '_' || c == ',') ) return 1;
                    205:        else return 0;
                    206: }
                    207:
                    208: int _is_alpha(char c)
                    209: {
                    210:        if ( isdigit(c) || c == '{' || _is_delimiter(c) ) return 0;
                    211:        else return 1;
                    212: }
                    213:
1.38      noro      214: char *conv_subs(char *name)
1.19      noro      215: {
1.29      noro      216:        int i,j,k,len,clen,slen,start,level;
1.41      noro      217:        char *buf,*head,*r,*h,*brace,*buf_conv;
1.28      noro      218:        char **subs;
                    219:
1.41      noro      220:        if ( !name || !(len=strlen(name)) ) return "";
                    221:        if ( !(conv_flag&CONV_SUBS) ) return name;
1.28      noro      222:        subs = (char **)ALLOCA(len*sizeof(char* ));
1.32      noro      223:        for ( i = 0, j = 0, start = i; ; j++ ) {
1.40      noro      224:                while ( (i < len) && _is_delimiter(name[i]) ) i++;
1.32      noro      225:                start = i;
1.28      noro      226:                if ( i == len ) break;
1.29      noro      227:                if ( name[i] == '{' ) {
                    228:                        for ( level = 1, i++; i < len && level; i++ ) {
                    229:                                if ( name[i] == '{' ) level++;
                    230:                                else if ( name[i] == '}' ) level--;
                    231:                        }
1.32      noro      232:                        slen = i-start;
1.37      noro      233:                        if ( slen >= 3 ) {
                    234:                                brace = (char *)ALLOCA((slen+1)*sizeof(char));
                    235:                                strncpy(brace,name+start+1,slen-2);
                    236:                                brace[slen-2] = 0;
1.38      noro      237:                                buf = conv_subs(brace);
1.37      noro      238:                                subs[j] = (char *)ALLOCA((strlen(buf)+3)*sizeof(char));
1.38      noro      239:                                if ( strlen(buf) == 1 )
                    240:                                        strcpy(subs[j],buf);
                    241:                                else
                    242:                                        sprintf(subs[j],"{%s}",buf);
1.37      noro      243:                        } else
                    244:                                subs[j] = "{}";
1.32      noro      245:                } else {
                    246:                        if ( isdigit(name[i]) )
                    247:                                while ( i < len && isdigit(name[i]) ) i++;
                    248:                        else
1.40      noro      249:                                while ( i < len && _is_alpha(name[i]) ) i++;
1.32      noro      250:                        slen = i-start;
                    251:                        buf = (char *)ALLOCA((slen+1)*sizeof(char));
                    252:                        strncpy(buf,name+start,slen); buf[slen] = 0;
1.41      noro      253:                        buf_conv = symbol_name(buf);
                    254:                        subs[j] = buf_conv?buf_conv:buf;
1.32      noro      255:                }
1.28      noro      256:        }
1.32      noro      257:        for ( k = 0, clen = 0; k < j; k++ ) clen += strlen(subs[k]);
                    258:        /* {subs(0)}_{{subs(1)},...,{subs(j-1)}} => {}:j+1 _:1 ,:j-2 */
                    259:        h = r = MALLOC_ATOMIC((clen+(j+1)*2+1+(j-2)+1)*sizeof(char));
                    260:        if ( j == 1 )
                    261:                sprintf(h,"{%s}",subs[0]);
1.28      noro      262:        else {
1.38      noro      263:                sprintf(h,"{%s}_{%s",subs[0],subs[1]);
1.28      noro      264:                h += strlen(h);
1.32      noro      265:                for ( k = 2; k < j; k++ ) {
1.38      noro      266:                        sprintf(h,",%s",subs[k]);
1.28      noro      267:                        h += strlen(h);
1.19      noro      268:                }
1.28      noro      269:                strcpy(h,"}");
1.20      noro      270:        }
                    271:        return r;
1.19      noro      272: }
                    273:
1.26      noro      274: char *call_convfunc(char *name)
                    275: {
                    276:        STRING str,r;
                    277:        NODE arg;
                    278:
                    279:        MKSTR(str,name);
                    280:        arg = mknode(1,str);
                    281:        r = (STRING)bevalf(convfunc,arg);
                    282:        if ( !r || OID(r) != O_STR )
                    283:                error("call_convfunc : invalid result");
                    284:        return BDY(r);
                    285: }
                    286:
1.18      noro      287: int register_symbol_table(Obj arg)
                    288: {
                    289:        NODE n,t;
                    290:        Obj b;
                    291:        STRING a0,a1;
                    292:        struct TeXSymbol *uts;
                    293:        int i,len;
                    294:
                    295:        /* check */
                    296:        if ( !arg ) {
                    297:                user_texsymbol = 0;
                    298:                return 1;
                    299:        }
                    300:        if ( OID(arg) != O_LIST ) return 0;
                    301:
                    302:        n = BDY((LIST)arg);
                    303:        len = length(n);
                    304:        uts = (struct TeXSymbol *)MALLOC((len+1)*sizeof(struct TeXSymbol));
                    305:        for ( i = 0; n; n = NEXT(n), i++ ) {
                    306:                b = (Obj)BDY(n);
                    307:                if ( !b || OID(b) != O_LIST ) return 0;
                    308:                t = BDY((LIST)b);
                    309:                if ( !t || !NEXT(t) ) return 0;
                    310:                a0 = (STRING)BDY(t);
                    311:                a1 = (STRING)BDY(NEXT(t));
1.23      noro      312:                if ( !a0 ) return 0;
                    313:                if ( OID(a0) == O_STR )
                    314:                        uts[i].text = BDY(a0);
                    315:                else if ( OID(a0) == O_P )
                    316:                        uts[i].text = NAME(VR((P)a0));
                    317:                else
                    318:                        return 0;
                    319:                if ( !a1 ) return 0;
                    320:                if ( OID(a1) == O_STR )
                    321:                        uts[i].symbol = BDY(a1);
                    322:                else if ( OID(a1) == O_P )
                    323:                        uts[i].symbol = NAME(VR((P)a1));
                    324:                else
                    325:                        return 0;
1.18      noro      326:        }
                    327:        uts[i].text = 0;
                    328:        uts[i].symbol = 0;
                    329:        user_texsymbol = uts;
                    330:        return 1;
                    331: }
                    332:
1.46      noro      333: int register_dp_vars_origin(Obj arg)
                    334: {
                    335:        if ( INT(arg) ) {
                    336:                dp_vars_origin = QTOS((Q)arg);
                    337:                return 1;
                    338:        } else return 0;
                    339: }
                    340:
                    341: int register_dp_dvars_origin(Obj arg)
                    342: {
                    343:        if ( INT(arg) ) {
                    344:                dp_dvars_origin = QTOS((Q)arg);
                    345:                return 1;
                    346:        } else return 0;
                    347: }
                    348:
1.31      noro      349: int register_dp_vars_hweyl(Obj arg)
                    350: {
                    351:        if ( INT(arg) ) {
                    352:                dp_vars_hweyl = QTOS((Q)arg);
                    353:                return 1;
                    354:        } else return 0;
                    355: }
                    356:
1.27      noro      357: int register_show_lt(Obj arg)
                    358: {
                    359:        if ( INT(arg) ) {
                    360:                show_lt = QTOS((Q)arg);
                    361:                return 1;
                    362:        } else return 0;
                    363: }
1.26      noro      364:
1.18      noro      365: int register_conv_rule(Obj arg)
                    366: {
1.19      noro      367:        if ( INT(arg) ) {
1.28      noro      368:                conv_flag = QTOS((Q)arg);
                    369:                convfunc = 0;
                    370:                return 1;
1.38      noro      371:        } else return 0;
                    372: }
                    373:
                    374: int register_conv_func(Obj arg)
                    375: {
1.43      noro      376:        if ( !arg ) {
                    377:                convfunc = 0;
                    378:                return 1;
                    379:        } else if ( OID(arg) == O_P && (int)(VR((P)arg))->attr == V_SR ) {
1.26      noro      380:                convfunc = (FUNC)(VR((P)arg)->priv);
                    381:                /* f must be a function which takes single argument */
                    382:                return 1;
1.19      noro      383:        } else return 0;
1.18      noro      384: }
                    385:
1.23      noro      386: int register_dp_vars(Obj arg)
                    387: {
                    388:        int l,i;
                    389:        char **r;
                    390:        NODE n;
                    391:        STRING a;
                    392:
                    393:        if ( !arg ) {
                    394:                dp_vars = 0;
                    395:                dp_vars_len = 0;
1.25      noro      396:                return 1;
1.23      noro      397:        } else if ( OID(arg) != O_LIST )
                    398:                return 0;
                    399:        else {
                    400:                n = BDY((LIST)arg);
                    401:                l = length(n);
                    402:                r = (char **)MALLOC_ATOMIC(l*sizeof(char *));
                    403:                for ( i = 0; i < l; i++, n = NEXT(n) ) {
                    404:                        a = (STRING)BDY(n);
                    405:                        if ( !a ) return 0;
                    406:                        if ( OID(a) == O_STR )
                    407:                                r[i] = BDY(a);
                    408:                        else if ( OID(a) == O_P )
                    409:                                r[i] = NAME(VR((P)a));
                    410:                        else
                    411:                                return 0;
                    412:                }
                    413:                dp_vars = r;
                    414:                dp_vars_len = l;
                    415:                return 1;
                    416:        }
                    417: }
                    418:
1.25      noro      419: int register_dp_vars_prefix(Obj arg)
                    420: {
                    421:        if ( !arg ) {
                    422:                dp_vars_prefix = 0;
                    423:                return 1;
                    424:        } else if ( OID(arg) == O_STR ) {
                    425:                dp_vars_prefix = BDY((STRING)arg);
                    426:                return 1;
                    427:        } else if ( OID(arg) == O_P ) {
                    428:                dp_vars_prefix = NAME(VR((P)arg));
                    429:                return 1;
                    430:        } else return 0;
                    431: }
                    432:
1.46      noro      433: int register_dp_dvars_prefix(Obj arg)
                    434: {
                    435:        if ( !arg ) {
                    436:                dp_dvars_prefix = 0;
                    437:                return 1;
                    438:        } else if ( OID(arg) == O_STR ) {
                    439:                dp_dvars_prefix = BDY((STRING)arg);
                    440:                return 1;
                    441:        } else if ( OID(arg) == O_P ) {
                    442:                dp_dvars_prefix = NAME(VR((P)arg));
                    443:                return 1;
                    444:        } else return 0;
                    445: }
                    446:
1.24      noro      447: void Pquotetotex_env(NODE arg,Obj *rp)
1.18      noro      448: {
                    449:        int ac,i;
                    450:        char *name;
                    451:        NODE n,n0;
                    452:        STRING s;
                    453:        LIST l;
                    454:
                    455:        ac = argc(arg);
                    456:        if ( !ac ) {
                    457:                n0 = 0;
                    458:                for ( i = 0; qtot_env[i].name; i++ ) {
                    459:                        NEXTNODE(n0,n); MKSTR(s,qtot_env[i].name); BDY(n) = (pointer)s;
                    460:                        NEXTNODE(n0,n); BDY(n) = (Q)qtot_env[i].value;
                    461:                }
                    462:                NEXT(n) = 0;
                    463:                MKLIST(l,n0);
                    464:                *rp = (Obj)l;
1.34      noro      465:        } else if ( ac == 1 && !ARG0(arg) ) {
                    466:                /* set to default */
1.43      noro      467:                for ( i = 0; qtot_env[i].name; i++ ) {
                    468:                        (qtot_env[i].reg)(0);
1.34      noro      469:                        qtot_env[i].value = 0;
1.43      noro      470:                }
1.34      noro      471:                *rp = 0;
1.18      noro      472:        } else if ( ac == 1 || ac == 2 ) {
1.24      noro      473:                asir_assert(ARG0(arg),O_STR,"quotetotex_env");
1.18      noro      474:                name = BDY((STRING)ARG0(arg));
                    475:                for ( i = 0; qtot_env[i].name; i++ )
                    476:                        if ( !strcmp(qtot_env[i].name,name) ) {
                    477:                                if ( ac == 2 ) {
                    478:                                        if ( (qtot_env[i].reg)((Obj)ARG1(arg)) )
                    479:                                                qtot_env[i].value = (Obj)ARG1(arg);
                    480:                                        else
1.24      noro      481:                                                error("quotetotex_env : invalid argument");
1.18      noro      482:                                }
                    483:                                *rp = qtot_env[i].value;
                    484:                                return;
                    485:                        }
                    486:                *rp = 0;
                    487:        } else
                    488:                *rp = 0;
                    489: }
                    490:
1.14      noro      491: void Pwrite_to_tb(NODE arg,Q *rp)
1.13      noro      492: {
                    493:        int i;
1.16      noro      494:        Obj obj;
                    495:        TB tb;
1.13      noro      496:
1.14      noro      497:        asir_assert(ARG1(arg),O_TB,"write_to_tb");
1.16      noro      498:        obj = ARG0(arg);
                    499:        if ( !obj )
                    500:                write_tb("",ARG1(arg));
                    501:        else if ( OID(obj) == O_STR )
                    502:                write_tb(BDY((STRING)obj),ARG1(arg));
                    503:        else if ( OID(obj) == O_TB ) {
                    504:                tb = (TB)obj;
                    505:                for ( i = 0; i < tb->next; i++ )
                    506:                        write_tb(tb->body[i],ARG1(arg));
                    507:        }
1.14      noro      508:        *rp = 0;
1.53      noro      509: }
                    510:
1.57      noro      511: void Pquote_unify(NODE arg,Q *rp)
1.53      noro      512: {
                    513:        NODE r;
1.56      noro      514:        int ret;
1.53      noro      515:
1.56      noro      516:        ret = quote_unify((Obj)ARG0(arg),(Obj)ARG1(arg),&r);
1.57      noro      517:        if ( ret ) {
                    518:                do_assign(r);
                    519:                *rp = ONE;
                    520:        } else
1.56      noro      521:                *rp = 0;
                    522: }
                    523:
                    524: void do_assign(NODE arg)
                    525: {
                    526:        NODE t,pair;
                    527:        int pv;
                    528:
                    529:        QUOTE value;
                    530:
                    531:        for ( t = arg; t; t = NEXT(t) ) {
                    532:                pair = BDY((LIST)BDY(t));
                    533:                pv = (int)FA0((FNODE)BDY((QUOTE)BDY(pair)));
                    534:                value = (QUOTE)(BDY(NEXT(pair)));
                    535:                ASSPV(pv,value);
                    536:        }
1.53      noro      537: }
                    538:
                    539: /*
1.56      noro      540: /* consistency check and merge
                    541:  */
1.53      noro      542:
1.56      noro      543: int merge_matching_node(NODE n,NODE a,NODE *rp)
1.53      noro      544: {
                    545:        NODE ta,ba,tn,bn;
                    546:        QUOTE pa,va,pn,vn;
                    547:
1.56      noro      548:        if ( !n ) {
                    549:                *rp = a;
                    550:                return 1;
                    551:        }
1.53      noro      552:        for ( ta = a; ta; ta = NEXT(ta) ) {
                    553:                ba = BDY((LIST)BDY(ta));
1.55      noro      554:                if ( !ba ) continue;
1.53      noro      555:                pa = (QUOTE)BDY(ba); va = (QUOTE)BDY(NEXT(ba));
                    556:                for ( tn = n; tn; tn = NEXT(tn) ) {
                    557:                        bn = BDY((LIST)BDY(tn));
1.55      noro      558:                        if ( !bn ) continue;
1.53      noro      559:                        pn = (QUOTE)BDY(bn); vn = (QUOTE)BDY(NEXT(bn));
1.55      noro      560:                        if ( !compquote(CO,pa,pn) ) {
                    561:                                if ( !compquote(CO,va,vn) ) break;
                    562:                                else return 0;
                    563:                        }
1.53      noro      564:                }
                    565:                if ( !tn ) {
                    566:                        MKNODE(tn,(pointer)BDY(ta),n);
                    567:                        n = tn;
                    568:                }
                    569:        }
1.56      noro      570:        *rp = n;
                    571:        return 1;
1.53      noro      572: }
                    573:
1.56      noro      574: int quote_unify_node(NODE f,NODE pat,NODE *rp) {
                    575:        NODE r,a,tf,tp,r1;
                    576:        int ret;
1.53      noro      577:
                    578:        if ( length(f) != length(pat) ) return 0;
                    579:        r = 0;
                    580:        for ( tf = f, tp = pat; tf; tf = NEXT(tf), tp = NEXT(tp) ) {
1.56      noro      581:                ret = quote_unify((Obj)BDY(tf),(Obj)BDY(tp),&a);
                    582:                if ( !ret ) return 0;
                    583:                ret = merge_matching_node(r,a,&r1);
                    584:                if ( !ret ) return 0;
                    585:                else r = r1;
1.53      noro      586:        }
1.56      noro      587:        *rp = r;
                    588:        return 1;
1.53      noro      589: }
                    590:
                    591: void get_quote_id_arg(QUOTE f,int *id,NODE *r)
                    592: {
                    593:        LIST fa;
                    594:        NODE arg,fab;
                    595:
                    596:        arg = mknode(1,f); Pquote_to_funargs(arg,&fa); fab = BDY((LIST)fa);
                    597:        *id = QTOS((Q)BDY(fab)); *r = NEXT(fab);
                    598: }
                    599:
1.56      noro      600: /* *rp : [[quote(A),quote(1)],...] */
1.53      noro      601:
1.56      noro      602: int quote_unify(Obj f, Obj pat, NODE *rp)
1.53      noro      603: {
                    604:        NODE tf,tp,head,body;
                    605:        NODE parg,farg,r;
                    606:        LIST fa,l;
                    607:        int pid,id;
1.55      noro      608:        FUNC ff,pf;
1.56      noro      609:        int ret;
1.53      noro      610:
                    611:        if ( OID(pat) == O_LIST ) {
                    612:                if ( OID(f) == O_LIST )
1.56      noro      613:                        return quote_unify_node(BDY((LIST)f),BDY((LIST)pat),rp);
1.53      noro      614:                else
                    615:                        return 0;
                    616:        } else if ( OID(pat) == O_QUOTE ) {
                    617:                if ( OID(f) != O_QUOTE ) return 0;
                    618:                get_quote_id_arg((QUOTE)pat,&pid,&parg);
                    619:                get_quote_id_arg((QUOTE)f,&id,&farg);
                    620:                switch ( pid ) {
1.55      noro      621:                        case I_FORMULA:
                    622:                                if ( compquote(CO,f,pat) )
                    623:                                        return 0;
                    624:                                else {
1.56      noro      625:                                        *rp = 0;
                    626:                                        return 1;
1.55      noro      627:                                }
                    628:                                break;
                    629:                        case I_LIST:
1.56      noro      630:                                return quote_unify_node(BDY((LIST)BDY(farg)),
                    631:                                                        BDY((LIST)BDY(parg)),rp);
1.53      noro      632:                        case I_PVAR:
                    633:                                /* [[pat,f]] */
                    634:                                r = mknode(2,pat,f); MKLIST(l,r);
1.56      noro      635:                                *rp =  mknode(1,l);
                    636:                                return 1;
1.53      noro      637:                        case I_IFUNC:
                    638:                                /* F(X,Y,...) = ... */
                    639:                                if ( id == I_FUNC ) {
1.54      noro      640:                                        r = mknode(2,BDY(parg),BDY(farg)); MKLIST(l,r);
                    641:                                        head = mknode(1,l);
1.56      noro      642:                                        ret = quote_unify(BDY(NEXT(farg)),
                    643:                                                                BDY(NEXT(parg)),&body);
                    644:                                        if ( !ret ) return 0;
                    645:                                        else return merge_matching_node(head,body,rp);
1.53      noro      646:                                } else
                    647:                                        return 0;
                    648:                        case I_BOP:
1.55      noro      649:                        case I_FUNC:
1.53      noro      650:                                /* X+Y = ... */
1.55      noro      651:                                /* f(...) = ... */
1.53      noro      652:                                if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0;
1.56      noro      653:                                return quote_unify_node(NEXT(farg),NEXT(parg),rp);
1.55      noro      654:                                break;
1.53      noro      655:                        default:
                    656:                                if ( pid == id )
1.56      noro      657:                                        return quote_unify_node(farg,parg,rp);
1.53      noro      658:                                else
                    659:                                        return 0;
                    660:                }
                    661:        }
1.13      noro      662: }
                    663:
1.14      noro      664: void Pquotetotex(NODE arg,STRING *rp)
1.13      noro      665: {
1.14      noro      666:        TB tb;
1.13      noro      667:
1.14      noro      668:        NEWTB(tb);
1.27      noro      669:        /* XXX for DP */
                    670:        is_lt = 1;
1.14      noro      671:        fnodetotex_tb(BDY((QUOTE)ARG0(arg)),tb);
                    672:        tb_to_string(tb,rp);
1.13      noro      673: }
                    674:
1.14      noro      675: void Pquotetotex_tb(NODE arg,Q *rp)
1.13      noro      676: {
                    677:        int i;
1.14      noro      678:        TB tb;
1.13      noro      679:
1.14      noro      680:        asir_assert(ARG1(arg),O_TB,"quotetotex_tb");
1.27      noro      681:        /* XXX for DP */
                    682:        is_lt = 1;
1.14      noro      683:        fnodetotex_tb(BDY((QUOTE)ARG0(arg)),ARG1(arg));
1.13      noro      684:        *rp = 0;
                    685: }
                    686:
1.14      noro      687: void Pstring_to_tb(NODE arg,TB *rp)
                    688: {
                    689:        TB tb;
                    690:
                    691:        asir_assert(ARG0(arg),O_STR,"string_to_tb");
                    692:        NEWTB(tb);
                    693:        tb->body[0] = BDY((STRING)ARG0(arg));
                    694:        tb->next++;
                    695:        *rp = tb;
                    696: }
                    697:
                    698: void Ptb_to_string(NODE arg,STRING *rp)
                    699: {
                    700:        TB tb;
                    701:
                    702:        asir_assert(ARG0(arg),O_TB,"tb_to_string");
                    703:        tb = (TB)ARG0(arg);
                    704:        tb_to_string(tb,rp);
                    705: }
                    706:
                    707: void tb_to_string(TB tb,STRING *rp)
1.13      noro      708: {
1.14      noro      709:        int j,len;
1.13      noro      710:        char *all,*p,*q;
                    711:
1.14      noro      712:        for ( j = 0, len = 0; j < tb->next; j++ )
                    713:                len += strlen(tb->body[j]);
                    714:        all = (char *)MALLOC_ATOMIC((len+1)*sizeof(char));
                    715:        for ( j = 0, p = all; j < tb->next; j++ )
                    716:                for ( q = tb->body[j]; *q; *p++ = *q++ );
                    717:        *p = 0;
                    718:        MKSTR(*rp,all);
                    719: }
                    720:
                    721: void Pclear_tb(NODE arg,Q *rp)
                    722: {
                    723:        TB tb;
                    724:        int j;
                    725:
                    726:        asir_assert(ARG0(arg),O_TB,"clear_tb");
                    727:        tb = (TB)ARG0(arg);
                    728:        for ( j = 0; j < tb->next; j++ )
                    729:                tb->body[j] = 0;
                    730:        tb->next = 0;
                    731:        *rp = 0;
1.13      noro      732: }
1.5       noro      733:
                    734: void Pstr_len(arg,rp)
                    735: NODE arg;
                    736: Q *rp;
                    737: {
1.16      noro      738:        Obj obj;
                    739:        TB tb;
                    740:        int r,i;
1.5       noro      741:
1.16      noro      742:        obj = (Obj)ARG0(arg);
                    743:        if ( !obj || (OID(obj) != O_STR && OID(obj) != O_TB) )
                    744:                error("str_len : invalid argument");
                    745:        if ( OID(obj) == O_STR)
                    746:                r = strlen(BDY((STRING)obj));
                    747:        else if ( OID(obj) == O_TB ) {
                    748:                tb = (TB)obj;
                    749:                for ( r = i = 0; i < tb->next; i++ )
                    750:                        r += strlen(tb->body[i]);
                    751:        }
1.5       noro      752:        STOQ(r,*rp);
                    753: }
                    754:
                    755: void Pstr_chr(arg,rp)
                    756: NODE arg;
                    757: Q *rp;
                    758: {
                    759:        STRING str,terminator;
                    760:        Q start;
                    761:        char *p,*ind;
                    762:        int chr,spos,r;
                    763:
                    764:        str = (STRING)ARG0(arg);
                    765:        start = (Q)ARG1(arg);
                    766:        terminator = (STRING)ARG2(arg);
                    767:        asir_assert(str,O_STR,"str_chr");
                    768:        asir_assert(start,O_N,"str_chr");
                    769:        asir_assert(terminator,O_STR,"str_chr");
                    770:        p = BDY(str);
                    771:        spos = QTOS(start);
                    772:        chr = BDY(terminator)[0];
1.8       noro      773:        if ( spos > (int)strlen(p) )
1.5       noro      774:                r = -1;
                    775:        else {
                    776:                ind = strchr(p+spos,chr);
                    777:                if ( ind )
                    778:                        r = ind-p;
                    779:                else
                    780:                        r = -1;
                    781:        }
                    782:        STOQ(r,*rp);
                    783: }
                    784:
                    785: void Psub_str(arg,rp)
                    786: NODE arg;
                    787: STRING *rp;
                    788: {
                    789:        STRING str;
                    790:        Q head,tail;
                    791:        char *p,*r;
                    792:        int spos,epos,len;
                    793:
                    794:        str = (STRING)ARG0(arg);
                    795:        head = (Q)ARG1(arg);
                    796:        tail = (Q)ARG2(arg);
                    797:        asir_assert(str,O_STR,"sub_str");
                    798:        asir_assert(head,O_N,"sub_str");
                    799:        asir_assert(tail,O_N,"sub_str");
                    800:        p = BDY(str);
                    801:        spos = QTOS(head);
                    802:        epos = QTOS(tail);
                    803:        len = strlen(p);
                    804:        if ( (spos >= len) || (epos < spos) ) {
                    805:                *rp = 0; return;
                    806:        }
                    807:        if ( epos >= len )
                    808:                epos = len-1;
                    809:        len = epos-spos+1;
                    810:        r = (char *)MALLOC(len+1);
                    811:        strncpy(r,p+spos,len);
                    812:        r[len] = 0;
                    813:        MKSTR(*rp,r);
                    814: }
1.3       noro      815:
                    816: void Pstrtoascii(arg,rp)
                    817: NODE arg;
                    818: LIST *rp;
                    819: {
                    820:        STRING str;
                    821:        unsigned char *p;
                    822:        int len,i;
                    823:        NODE n,n1;
                    824:        Q q;
                    825:
                    826:        str = (STRING)ARG0(arg);
                    827:        asir_assert(str,O_STR,"strtoascii");
                    828:        p = BDY(str);
                    829:        len = strlen(p);
                    830:        for ( i = len-1, n = 0; i >= 0; i-- ) {
                    831:                UTOQ((unsigned int)p[i],q);
                    832:                MKNODE(n1,q,n);
                    833:                n = n1;
                    834:        }
                    835:        MKLIST(*rp,n);
                    836: }
                    837:
                    838: void Pasciitostr(arg,rp)
                    839: NODE arg;
                    840: STRING *rp;
                    841: {
                    842:        LIST list;
                    843:        unsigned char *p;
                    844:        int len,i,j;
                    845:        NODE n;
                    846:        Q q;
                    847:
                    848:        list = (LIST)ARG0(arg);
                    849:        asir_assert(list,O_LIST,"asciitostr");
                    850:        n = BDY(list);
                    851:        len = length(n);
                    852:        p = MALLOC_ATOMIC(len+1);
                    853:        for ( i = 0; i < len; i++, n = NEXT(n) ) {
                    854:                q = (Q)BDY(n);
                    855:                asir_assert(q,O_N,"asciitostr");
                    856:                j = QTOS(q);
1.4       noro      857:                if ( j >= 256 || j <= 0 )
1.3       noro      858:                        error("asciitostr : argument out of range");
                    859:                p[i] = j;
                    860:        }
                    861:        p[i] = 0;
                    862:        MKSTR(*rp,(char *)p);
                    863: }
1.1       noro      864:
                    865: void Peval_str(arg,rp)
                    866: NODE arg;
                    867: Obj *rp;
                    868: {
                    869:        FNODE fnode;
                    870:        char *cmd;
1.10      ohara     871: #if defined(PARI)
1.8       noro      872:        void recover(int);
                    873:
1.1       noro      874:        recover(0);
1.11      saito     875: #  if !(PARI_VERSION_CODE > 131588)
1.1       noro      876:        if ( setjmp(environnement) ) {
                    877:                avma = top; recover(1);
                    878:                resetenv("");
                    879:        }
1.11      saito     880: #  endif
1.1       noro      881: #endif
                    882:        cmd = BDY((STRING)ARG0(arg));
1.9       noro      883:        exprparse_create_var(0,cmd,&fnode);
1.1       noro      884:        *rp = eval(fnode);
                    885: }
                    886:
                    887: void Prtostr(arg,rp)
                    888: NODE arg;
                    889: STRING *rp;
                    890: {
                    891:        char *b;
                    892:        int len;
                    893:
1.2       noro      894:        len = estimate_length(CO,ARG0(arg));
1.12      noro      895:        b = (char *)MALLOC_ATOMIC(len+1);
1.1       noro      896:        soutput_init(b);
                    897:        sprintexpr(CO,ARG0(arg));
                    898:        MKSTR(*rp,b);
                    899: }
                    900:
                    901: void Pstrtov(arg,rp)
                    902: NODE arg;
                    903: P *rp;
                    904: {
1.8       noro      905:        char *p;
1.1       noro      906:
                    907:        p = BDY((STRING)ARG0(arg));
                    908: #if 0
                    909:        if ( !islower(*p) )
                    910:                *rp = 0;
                    911:        else {
                    912:                for ( t = p+1; t && (isalnum(*t) || *t == '_'); t++ );
                    913:                if ( *t )
                    914:                        *rp = 0;
                    915:                else
                    916:                        makevar(p,rp);
                    917:        }
                    918: #else
                    919:        makevar(p,rp);
                    920: #endif
1.14      noro      921: }
                    922:
1.15      noro      923: static struct TeXSymbol texsymbol[] = {
                    924:  {"sin","\\sin"},
                    925:  {"cos","\\cos"},
                    926:  {"tan","\\tan"},
                    927:  {"sinh","\\sinh"},
                    928:  {"cosh","\\cosh"},
                    929:  {"tanh","\\tanh"},
                    930:  {"exp","\\exp"},
                    931:  {"log","\\log"},
                    932:
                    933: /* Greek Letters (lower case) */
                    934:  {"alpha","\\alpha"},
                    935:  {"beta","\\beta"},
                    936:  {"gamma","\\gamma"},
                    937:  {"delta","\\delta"},
                    938:  {"epsilon","\\epsilon"},
                    939:  {"varepsilon","\\varepsilon"},
                    940:  {"zeta","\\zeta"},
                    941:  {"eta","\\eta"},
                    942:  {"theta","\\theta"},
                    943:  {"vartheta","\\vartheta"},
                    944:  {"iota","\\iota"},
                    945:  {"kappa","\\kappa"},
                    946:  {"lambda","\\lambda"},
                    947:  {"mu","\\mu"},
                    948:  {"nu","\\nu"},
                    949:  {"xi","\\xi"},
                    950:  {"pi","\\pi"},
                    951:  {"varpi","\\varpi"},
                    952:  {"rho","\\rho"},
                    953:  {"sigma","\\sigma"},
                    954:  {"varsigma","\\varsigma"},
                    955:  {"tau","\\tau"},
                    956:  {"upsilon","\\upsilon"},
                    957:  {"phi","\\phi"},
                    958:  {"varphi","\\varphi"},
                    959:  {"chi","\\chi"},
                    960:  {"omega","\\omega"},
                    961:
                    962: /* Greek Letters, (upper case) */
                    963:  {"ggamma","\\Gamma"},
                    964:  {"ddelta","\\Delta"},
                    965:  {"ttheta","\\Theta"},
                    966:  {"llambda","\\Lambda"},
                    967:  {"xxi","\\Xi"},
                    968:  {"ppi","\\Pi"},
                    969:  {"ssigma","\\Sigma"},
                    970:  {"uupsilon","\\Upsilon"},
                    971:  {"pphi","\\Phi"},
                    972:  {"ppsi","\\Psi"},
                    973:  {"oomega","\\Omega"},
                    974:
                    975:  /* Our own mathematical functions */
                    976:  {"algebra_tensor","\\otimes"},
                    977:  {"base_where","{\\rm \\ where \\ }"},
                    978:  /* Mathematical constants */
                    979:  {"c_pi","\\pi"},
                    980:  {"c_i","\\sqrt{-1}"},
                    981:
                    982:  /* Temporary  */
                    983:  {0,0}
                    984: };
                    985:
1.14      noro      986: char *symbol_name(char *name)
                    987: {
1.15      noro      988:        int i;
                    989:
1.41      noro      990:        if ( !name || strlen(name) == 0 )
                    991:                return "";
1.38      noro      992:        if ( !(conv_flag & CONV_TABLE) )
                    993:                return name;
                    994:
1.18      noro      995:        if ( user_texsymbol )
                    996:                for ( i = 0; user_texsymbol[i].text; i++ )
                    997:                        if ( !strcmp(user_texsymbol[i].text,name) )
                    998:                                return user_texsymbol[i].symbol;
1.15      noro      999:        for ( i = 0; texsymbol[i].text; i++ )
                   1000:                if ( !strcmp(texsymbol[i].text,name) )
                   1001:                        return texsymbol[i].symbol;
1.41      noro     1002:        return 0;
1.52      noro     1003: }
                   1004:
                   1005: void Pget_function_name(NODE arg,STRING *rp)
                   1006: {
                   1007:                QUOTEARG qa;
                   1008:                ARF f;
                   1009:                char *opname;
                   1010:
                   1011:                qa = (QUOTEARG)BDY(arg);
                   1012:                if ( !qa || OID(qa) != O_QUOTEARG || qa->type != A_arf )
                   1013:                        *rp = 0;
                   1014:                else {
                   1015:                        f = (ARF)BDY(qa);
                   1016:                        opname = f->name;
                   1017:                        MKSTR(*rp,opname);
                   1018:                }
1.14      noro     1019: }
                   1020:
1.51      noro     1021: FNODE strip_paren(FNODE);
                   1022:
1.14      noro     1023: void fnodetotex_tb(FNODE f,TB tb)
                   1024: {
                   1025:        NODE n,t,t0;
1.38      noro     1026:        char vname[BUFSIZ],prefix[BUFSIZ];
                   1027:        char *opname,*vname_conv,*prefix_conv;
1.14      noro     1028:        Obj obj;
1.46      noro     1029:        int i,len,allzero,elen,elen2,si;
1.40      noro     1030:        C cplx;
                   1031:        char *r;
1.17      noro     1032:        FNODE fi,f2;
1.14      noro     1033:
                   1034:        write_tb(" ",tb);
                   1035:        if ( !f ) {
                   1036:                write_tb("0",tb);
                   1037:                return;
                   1038:        }
                   1039:        switch ( f->id ) {
                   1040:                /* unary operators */
1.23      noro     1041:                case I_NOT:
                   1042:                        write_tb("\\neg (",tb);
                   1043:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1044:                        write_tb(")",tb);
                   1045:                        break;
                   1046:                case I_PAREN:
                   1047:                        write_tb("(",tb);
                   1048:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1049:                        write_tb(")",tb);
                   1050:                        break;
                   1051:                case I_MINUS:
                   1052:                        write_tb("-",tb);
                   1053:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1054:                        break;
                   1055:
                   1056:                /* binary operators */
                   1057:                /* arg list */
                   1058:                /* I_AND, I_OR => FA0(f), FA1(f) */
                   1059:                /* otherwise   => FA1(f), FA2(f) */
                   1060:                case I_BOP:
                   1061:                        opname = ((ARF)FA0(f))->name;
                   1062:                        if ( !strcmp(opname,"+") ) {
                   1063:                                fnodetotex_tb((FNODE)FA1(f),tb);
1.35      noro     1064:                                if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
1.23      noro     1065:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1066:                        } else if ( !strcmp(opname,"-") ) {
                   1067:                                if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
                   1068:                                write_tb(opname,tb);
                   1069:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1070:                        } else if ( !strcmp(opname,"*") ) {
                   1071:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1072:                                write_tb(" ",tb);
                   1073:                                /* XXX special care for DP */
                   1074:                                f2 = (FNODE)FA2(f);
                   1075:                                if ( f2->id == I_EV ) {
                   1076:                                        n = (NODE)FA0(f2);
                   1077:                                        for ( i = 0; n; n = NEXT(n), i++ ) {
                   1078:                                                fi = (FNODE)BDY(n);
                   1079:                                                if ( fi->id != I_FORMULA || FA0(fi) )
                   1080:                                                        break;
                   1081:                                        }
                   1082:                                        if ( n )
                   1083:                                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1084:                                } else
                   1085:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1086:                        } else if ( !strcmp(opname,"/") ) {
                   1087:                                write_tb("\\frac{",tb);
                   1088:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1089:                                write_tb("} {",tb);
                   1090:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1091:                                write_tb("}",tb);
                   1092:                        } else if ( !strcmp(opname,"^") ) {
                   1093:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1094:                                write_tb("^{",tb);
1.51      noro     1095:                                fnodetotex_tb(strip_paren((FNODE)FA2(f)),tb);
1.23      noro     1096:                                write_tb("} ",tb);
                   1097:                        } else if ( !strcmp(opname,"%") ) {
                   1098:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1099:                                write_tb(" {\\rm mod}\\, ",tb);
                   1100:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1101:                        } else
                   1102:                                error("invalid binary operator");
                   1103:                        break;
                   1104:
                   1105:                case I_COP:
                   1106:                        switch( (cid)FA0(f) ) {
                   1107:                                case C_EQ:
                   1108:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1109:                                        write_tb(" = ",tb);
                   1110:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1111:                                        break;
                   1112:                                case C_NE:
                   1113:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1114:                                        write_tb(" \\neq ",tb);
                   1115:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1116:                                        break;
                   1117:                                case C_GT:
                   1118:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1119:                                        write_tb(" > ",tb);
1.23      noro     1120:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1121:                                        break;
                   1122:                                case C_LT:
                   1123:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1124:                                        write_tb(" < ",tb);
1.23      noro     1125:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1126:                                        break;
1.23      noro     1127:                                case C_GE:
                   1128:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1129:                                        write_tb(" \\geq ",tb);
                   1130:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1131:                                        break;
1.23      noro     1132:                                case C_LE:
                   1133:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1134:                                        write_tb(" \\leq ",tb);
                   1135:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1136:                                        break;
                   1137:                        }
                   1138:                        break;
                   1139:
1.23      noro     1140:                case I_LOP:
                   1141:                        switch( (lid)FA0(f) ) {
                   1142:                                case L_EQ:
                   1143:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1144:                                        write_tb(" = ",tb);
                   1145:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1146:                                        break;
                   1147:                                case L_NE:
                   1148:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1149:                                        write_tb(" \\neq ",tb);
                   1150:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1151:                                        break;
                   1152:                                case L_GT:
                   1153:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1154:                                        write_tb(" > ",tb);
1.23      noro     1155:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1156:                                        break;
                   1157:                                case L_LT:
                   1158:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1159:                                        write_tb(" < ",tb);
1.23      noro     1160:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1161:                                        break;
                   1162:                                case L_GE:
                   1163:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1164:                                        write_tb(" \\geq ",tb);
                   1165:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1166:                                        break;
1.23      noro     1167:                                case L_LE:
                   1168:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1169:                                        write_tb(" \\leq ",tb);
                   1170:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1171:                                        break;
1.23      noro     1172:                                case L_AND:
                   1173:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.14      noro     1174:                                        write_tb(" {\\rm \\ and\\ } ",tb);
1.23      noro     1175:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1176:                                        break;
                   1177:                                case L_OR:
1.14      noro     1178:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.23      noro     1179:                                        write_tb(" {\\rm \\ or\\ } ",tb);
                   1180:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1181:                                        break;
1.23      noro     1182:                                case L_NOT:
                   1183:                                        /* XXX : L_NOT is a unary operator */
                   1184:                                        write_tb("\\neg (",tb);
1.14      noro     1185:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.23      noro     1186:                                        write_tb(")",tb);
                   1187:                                        return;
1.14      noro     1188:                        }
                   1189:                        break;
                   1190:
1.23      noro     1191:                case I_AND:
                   1192:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1193:                        write_tb(" {\\rm \\ and\\ } ",tb);
                   1194:                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1195:                        break;
                   1196:
                   1197:                case I_OR:
                   1198:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1199:                        write_tb(" {\\rm \\ or\\ } ",tb);
                   1200:                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1201:                        break;
                   1202:
1.14      noro     1203:                /* ternary operators */
                   1204:                case I_CE:
                   1205:                        error("fnodetotex_tb : not implemented yet");
                   1206:                        break;
                   1207:
                   1208:                /* lists */
                   1209:                case I_LIST:
                   1210:                        write_tb(" [ ",tb);
                   1211:                        n = (NODE)FA0(f);
                   1212:                        fnodenodetotex_tb(n,tb);
                   1213:                        write_tb("]",tb);
                   1214:                        break;
                   1215:
                   1216:                /* function */
1.23      noro     1217:                case I_FUNC:
1.40      noro     1218:                        if ( !strcmp(((FUNC)FA0(f))->name,"@pi") )
                   1219:                                write_tb("\\pi",tb);
                   1220:                        else if ( !strcmp(((FUNC)FA0(f))->name,"@e") )
                   1221:                                write_tb("e",tb);
                   1222:                        else {
                   1223:                                opname = conv_rule(((FUNC)FA0(f))->name);
                   1224:                                write_tb(opname,tb);
                   1225:                                write_tb("(",tb);
                   1226:                                fargstotex_tb(opname,FA1(f),tb);
                   1227:                                write_tb(")",tb);
                   1228:                        }
1.23      noro     1229:                        break;
                   1230:
                   1231:                /* XXX */
                   1232:                case I_CAR:
1.28      noro     1233:                        opname = conv_rule("car");
1.23      noro     1234:                        write_tb(opname,tb);
                   1235:                        write_tb("(",tb);
                   1236:                        fargstotex_tb(opname,FA0(f),tb);
                   1237:                        write_tb(")",tb);
                   1238:                        break;
                   1239:
                   1240:                case I_CDR:
1.28      noro     1241:                        opname = conv_rule("cdr");
1.23      noro     1242:                        write_tb(opname,tb);
                   1243:                        write_tb("(",tb);
                   1244:                        fargstotex_tb(opname,FA0(f),tb);
                   1245:                        write_tb(")",tb);
                   1246:                        break;
                   1247:
                   1248:                /* exponent vector */
                   1249:                case I_EV:
                   1250:                        n = (NODE)FA0(f);
1.31      noro     1251:                        if ( dp_vars_hweyl ) {
                   1252:                                elen = length(n);
                   1253:                                elen2 = elen>>1;
                   1254:                                elen = elen2<<1;
                   1255:                        }
1.23      noro     1256:                        allzero = 1;
1.27      noro     1257:                        if ( show_lt && is_lt )
                   1258:                                write_tb("\\underline{",tb);
1.23      noro     1259:                        for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
                   1260:                                fi = (FNODE)BDY(n);
                   1261:                                if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
                   1262:                                allzero = 0;
1.38      noro     1263:                                if ( dp_vars && i < dp_vars_len ) {
                   1264:                                        strcpy(vname,dp_vars[i]);
                   1265:                                        vname_conv = conv_rule(vname);
                   1266:                                } else {
                   1267:                                        if ( dp_vars_hweyl ) {
1.44      noro     1268:                                                if ( i < elen2 ) {
1.38      noro     1269:                                                        strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44      noro     1270:                                                        prefix_conv = conv_rule(prefix);
                   1271:                                                        vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46      noro     1272:                                                        si = i+dp_vars_origin;
                   1273:                                                        sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
                   1274:                                                                prefix_conv,si);
1.44      noro     1275:                                                } else if ( i < elen ) {
1.46      noro     1276:                                                        strcpy(prefix,
                   1277:                                                                dp_dvars_prefix?dp_dvars_prefix:"\\partial");
1.44      noro     1278:                                                        prefix_conv = conv_rule(prefix);
                   1279:                                                        vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46      noro     1280:                                                        si = i+dp_dvars_origin-elen2;
                   1281:                                                        sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
                   1282:                                                                prefix_conv,si);
1.44      noro     1283:                                                } else {
1.38      noro     1284:                                                        strcpy(prefix,"h");
1.44      noro     1285:                                                        vname_conv = conv_rule(prefix);
                   1286:                                                }
                   1287:                                        } else {
1.38      noro     1288:                                                strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44      noro     1289:                                                prefix_conv = conv_rule(prefix);
                   1290:                                                vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46      noro     1291:                                                si = i+dp_vars_origin;
                   1292:                                                sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
                   1293:                                                        prefix_conv,si);
1.44      noro     1294:                                        }
1.38      noro     1295:                                }
1.23      noro     1296:                                if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
                   1297:                                        len = strlen(vname_conv);
                   1298:                                        opname = MALLOC_ATOMIC(len+2);
                   1299:                                        sprintf(opname,"%s ",vname_conv);
1.14      noro     1300:                                        write_tb(opname,tb);
1.23      noro     1301:                                } else {
                   1302:                                        len = strlen(vname_conv);
                   1303:                                        /* 2: ^{ */
                   1304:                                        opname = MALLOC_ATOMIC(len+1+2);
                   1305:                                        sprintf(opname,"%s^{",vname_conv);
1.14      noro     1306:                                        write_tb(opname,tb);
1.23      noro     1307:                                        fnodetotex_tb((FNODE)BDY(n),tb);
                   1308:                                        write_tb("} ",tb);
                   1309:                                }
1.14      noro     1310:                        }
1.23      noro     1311:                        /* XXX */
                   1312:                        if ( allzero )
                   1313:                                write_tb(" 1 ",tb);
1.27      noro     1314:                        if ( show_lt && is_lt ) {
                   1315:                                write_tb("}",tb);
                   1316:                                is_lt = 0;
                   1317:                        }
1.14      noro     1318:                        break;
                   1319:
1.23      noro     1320:                /* string */
1.14      noro     1321:                case I_STR:
                   1322:                        write_tb((char *)FA0(f),tb);
                   1323:                        break;
                   1324:
1.23      noro     1325:                /* internal object */
1.14      noro     1326:                case I_FORMULA:
                   1327:                        obj = (Obj)FA0(f);
1.40      noro     1328:                        if ( !obj )
1.42      noro     1329:                                write_tb("0",tb);
1.40      noro     1330:                        else if ( OID(obj) == O_N && NID(obj) == N_C ) {
                   1331:                                cplx = (C)obj;
                   1332:                                write_tb("(",tb);
                   1333:                                if ( cplx->r ) {
                   1334:                                        r = objtostr((Obj)cplx->r); write_tb(r,tb);
                   1335:                                }
                   1336:                                if ( cplx->i ) {
                   1337:                                        if ( cplx->r && compnum(0,cplx->i,0) > 0 ) {
                   1338:                                                write_tb("+",tb);
                   1339:                                                if ( !UNIQ(cplx->i) ) {
                   1340:                                                        r = objtostr((Obj)cplx->i); write_tb(r,tb);
                   1341:                                                }
                   1342:                                        } else if ( MUNIQ(cplx->i) )
                   1343:                                                write_tb("-",tb);
                   1344:                                        else if ( !UNIQ(cplx->i) ) {
                   1345:                                                r = objtostr((Obj)cplx->i); write_tb(r,tb);
                   1346:                                        }
                   1347:                                        write_tb("\\sqrt{-1}",tb);
                   1348:                                }
                   1349:                                write_tb(")",tb);
                   1350:                        } else if ( OID(obj) == O_P )
                   1351:                                write_tb(conv_rule(VR((P)obj)->name),tb);
                   1352:                        else
                   1353:                                write_tb(objtostr(obj),tb);
1.14      noro     1354:                        break;
                   1355:
1.23      noro     1356:                /* program variable */
1.14      noro     1357:                case I_PVAR:
                   1358:                        if ( FA1(f) )
                   1359:                                error("fnodetotex_tb : not implemented yet");
                   1360:                        GETPVNAME(FA0(f),opname);
                   1361:                        write_tb(opname,tb);
                   1362:                        break;
                   1363:
                   1364:                default:
                   1365:                        error("fnodetotex_tb : not implemented yet");
                   1366:        }
1.40      noro     1367: }
                   1368:
                   1369: char *objtostr(Obj obj)
                   1370: {
                   1371:        int len;
                   1372:        char *r;
                   1373:
                   1374:        len = estimate_length(CO,obj);
                   1375:        r = (char *)MALLOC_ATOMIC(len+1);
                   1376:        soutput_init(r);
                   1377:        sprintexpr(CO,obj);
                   1378:        return r;
1.50      ohara    1379: }
                   1380:
                   1381: void Psprintf(NODE arg,STRING *rp)
                   1382: {
                   1383:     STRING string;
                   1384:     char *s,*t,*r;
                   1385:     int argc,n,len;
                   1386:     NODE node;
                   1387:
                   1388:     string = (STRING)ARG0(arg);
                   1389:     asir_assert(string,O_STR,"sprintf");
                   1390:     s = BDY(string);
                   1391:     for(n = 0, t = s; *t; t++) {
                   1392:         if (*t=='%' && *(t+1)=='a') {
                   1393:             n++;
                   1394:         }
                   1395:     }
                   1396:     for(node = NEXT(arg), argc = 0, len = strlen(s); node; node = NEXT(node), argc++) {
                   1397:         len += estimate_length(CO,BDY(node));
                   1398:     }
                   1399:     if (argc < n) {
                   1400:         error("sprintf: invalid argument");
                   1401:     }
                   1402:     r = (char *)MALLOC_ATOMIC(len);
                   1403:     for(node = NEXT(arg), t = r; *s; s++) {
                   1404:         if (*s=='%' && *(s+1)=='a') {
                   1405:             strcpy(t,objtostr(BDY(node)));
                   1406:             node = NEXT(node);
                   1407:             t = strchr(t,0);
                   1408:             s++;
                   1409:         }else {
                   1410:             *t++ = *s;
                   1411:         }
                   1412:     }
                   1413:     *t = 0;
                   1414:     MKSTR(*rp,r);
1.14      noro     1415: }
                   1416:
                   1417: void fnodenodetotex_tb(NODE n,TB tb)
                   1418: {
                   1419:        for ( ; n; n = NEXT(n) ) {
1.27      noro     1420:                is_lt = 1;
1.14      noro     1421:                fnodetotex_tb((FNODE)BDY(n),tb);
                   1422:                if ( NEXT(n) ) write_tb(", ",tb);
                   1423:        }
                   1424: }
                   1425:
                   1426: void fargstotex_tb(char *name,FNODE f,TB tb)
                   1427: {
                   1428:        NODE n;
                   1429:
                   1430:        if ( !strcmp(name,"matrix") ) {
                   1431:                error("fargstotex_tb : not implemented yet");
                   1432:        } else if ( !strcmp(name,"vector") ) {
                   1433:                error("fargstotex_tb : not implemented yet");
                   1434:        } else {
                   1435:                if ( f->id == I_LIST ) {
                   1436:                        n = (NODE)FA0(f);
                   1437:                        fnodenodetotex_tb(n,tb);
                   1438:                } else
                   1439:                        fnodetotex_tb(f,tb);
1.35      noro     1440:        }
                   1441: }
                   1442:
                   1443: int top_is_minus(FNODE f)
                   1444: {
                   1445:        char *opname;
                   1446:        int len;
                   1447:        Obj obj;
                   1448:
                   1449:        if ( !f )
                   1450:                return 0;
                   1451:        switch ( f->id ) {
                   1452:                case I_MINUS:
                   1453:                        return 1;
                   1454:                case I_BOP:
                   1455:                        opname = ((ARF)FA0(f))->name;
                   1456:                        switch ( opname[0] ) {
                   1457:                                case '+': case '*': case '/': case '^': case '%':
                   1458:                                        return top_is_minus((FNODE)FA1(f));
                   1459:                                case '-':
                   1460:                                        if ( FA1(f) )
                   1461:                                                return top_is_minus((FNODE)FA1(f));
                   1462:                                        else
                   1463:                                                return 1;
                   1464:                                default:
                   1465:                                        return 0;
                   1466:                        }
                   1467:                        break;
                   1468:                case I_COP:
                   1469:                        return top_is_minus((FNODE)FA1(f));
                   1470:                case I_LOP:
                   1471:                        if ( (lid)FA0(f) == L_NOT ) return 0;
                   1472:                        else return top_is_minus((FNODE)FA1(f));
                   1473:                case I_AND: case I_OR:
                   1474:                        return top_is_minus((FNODE)FA0(f));
                   1475:                case I_FORMULA:
                   1476:                        obj = (Obj)FA0(f);
1.36      noro     1477:                        if ( !obj )
                   1478:                                return 0;
                   1479:                        else {
                   1480:                                switch ( OID(obj) ) {
                   1481:                                        case O_N:
                   1482:                                                return mmono((P)obj);
                   1483:                                        case O_P:
                   1484:                                                /* must be a variable */
                   1485:                                                opname = conv_rule(VR((P)obj)->name);
                   1486:                                                return opname[0]=='-';
                   1487:                                        default:
                   1488:                                                /* ??? */
                   1489:                                                len = estimate_length(CO,obj);
                   1490:                                                opname = (char *)MALLOC_ATOMIC(len+1);
                   1491:                                                soutput_init(opname);
                   1492:                                                sprintexpr(CO,obj);
                   1493:                                                return opname[0]=='-';
                   1494:                                }
1.35      noro     1495:                        }
                   1496:                default:
                   1497:                        return 0;
1.14      noro     1498:        }
1.47      noro     1499: }
                   1500:
                   1501: FNODE flatten_fnode(FNODE,char *);
                   1502:
1.48      noro     1503: void Pflatten_quote(NODE arg,Obj *rp)
1.47      noro     1504: {
                   1505:        FNODE f;
                   1506:        QUOTE q;
                   1507:
1.48      noro     1508:        if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE )
                   1509:                *rp = (Obj)ARG0(arg);
                   1510:        else {
                   1511:                f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg)));
                   1512:                MKQUOTE(q,f);
                   1513:                *rp = (Obj)q;
                   1514:        }
                   1515: }
                   1516:
                   1517: void Pquote_to_funargs(NODE arg,LIST *rp)
                   1518: {
                   1519:        fid_spec_p spec;
                   1520:        QUOTE q;
                   1521:        QUOTEARG qa;
                   1522:        FNODE f;
                   1523:        STRING s;
                   1524:        QUOTE r;
                   1525:        int i;
                   1526:        Q id,a;
1.49      noro     1527:        LIST l;
                   1528:        NODE t0,t,w,u,u0;
1.48      noro     1529:
                   1530:        q = (QUOTE)ARG0(arg);
                   1531:        if ( !q || OID(q) != O_QUOTE )
                   1532:                error("quote_to_funargs : invalid argument");
                   1533:        f = BDY(q);
                   1534:        if ( !f ) {
                   1535:                MKLIST(*rp,0);
                   1536:                return;
                   1537:        }
                   1538:        get_fid_spec(f->id,&spec);
                   1539:        if ( !spec )
                   1540:                error("quote_to_funargs : not supported yet");
                   1541:        t0 = 0;
                   1542:        STOQ((int)f->id,id);
                   1543:        NEXTNODE(t0,t);
                   1544:        BDY(t) = (pointer)id;
                   1545:        for ( i = 0; spec->type[i] != A_end; i++ ) {
                   1546:                NEXTNODE(t0,t);
                   1547:                switch ( spec->type[i] ) {
                   1548:                        case A_fnode:
                   1549:                                MKQUOTE(r,(FNODE)f->arg[i]);
                   1550:                                BDY(t) = (pointer)r;
                   1551:                                break;
                   1552:                        case A_int:
                   1553:                                STOQ((int)f->arg[i],a);
                   1554:                                BDY(t) = (pointer)a;
                   1555:                                break;
                   1556:                        case A_str:
                   1557:                                MKSTR(s,(char *)f->arg[i]);
                   1558:                                BDY(t) = (pointer)s;
                   1559:                                break;
                   1560:                        case A_internal:
                   1561:                                BDY(t) = (pointer)f->arg[i];
                   1562:                                break;
1.49      noro     1563:                        case A_node:
                   1564:                                w = (NODE)f->arg[i];
                   1565:                                for ( u0 = 0; w; w = NEXT(w) ){
                   1566:                                        NEXTNODE(u0,u);
                   1567:                                        MKQUOTE(r,(FNODE)BDY(w));
                   1568:                                        BDY(u) = (pointer)r;
                   1569:                                }
                   1570:                                if ( u0 ) NEXT(u) = 0;
                   1571:                                MKLIST(l,u0);
                   1572:                                BDY(t) = (pointer)l;
                   1573:                                break;
1.48      noro     1574:                        default:
                   1575:                                MKQUOTEARG(qa,spec->type[i],f->arg[i]);
                   1576:                                BDY(t) = (pointer)qa;
                   1577:                                break;
                   1578:                }
                   1579:        }
                   1580:        if ( t0 ) NEXT(t) = 0;
                   1581:        MKLIST(*rp,t0);
                   1582: }
                   1583:
                   1584: void Pfunargs_to_quote(NODE arg,QUOTE *rp)
                   1585: {
                   1586:        fid_spec_p spec;
                   1587:        QUOTE q;
                   1588:        QUOTEARG qa;
                   1589:        FNODE f;
                   1590:        STRING s;
1.49      noro     1591:        QUOTE r,b;
1.48      noro     1592:        int i;
                   1593:        LIST l;
                   1594:        fid id;
                   1595:        Obj a;
1.49      noro     1596:        NODE t0,t,u0,u,w;
1.48      noro     1597:
                   1598:        l = (LIST)ARG0(arg);
                   1599:        if ( !l || OID(l) != O_LIST || !(t=BDY(l)) )
                   1600:                error("funargs_to_quote : invalid argument");
                   1601:        t = BDY(l);
                   1602:        id = (fid)QTOS((Q)BDY(t)); t = NEXT(t);
                   1603:        get_fid_spec(id,&spec);
                   1604:        if ( !spec )
                   1605:                error("funargs_to_quote : not supported yet");
                   1606:        for ( i = 0; spec->type[i] != A_end; i++ );
                   1607:        NEWFNODE(f,i);
                   1608:        f->id = id;
                   1609:        for ( i = 0; spec->type[i] != A_end; i++, t = NEXT(t) ) {
                   1610:                if ( !t )
                   1611:                        error("funargs_to_quote : argument mismatch");
                   1612:                a = (Obj)BDY(t);
                   1613:                switch ( spec->type[i] ) {
                   1614:                        case A_fnode:
                   1615:                                if ( !a || OID(a) != O_QUOTE )
                   1616:                                        error("funargs_to_quote : invalid argument");
                   1617:                                f->arg[i] = BDY((QUOTE)a);
                   1618:                                break;
                   1619:                        case A_int:
                   1620:                                if ( !INT(a) )
                   1621:                                        error("funargs_to_quote : invalid argument");
                   1622:                                f->arg[i] = (pointer)QTOS((Q)a);
                   1623:                                break;
                   1624:                        case A_str:
                   1625:                                if ( !a || OID(a) != O_STR )
                   1626:                                        error("funargs_to_quote : invalid argument");
                   1627:                                f->arg[i] = (pointer)BDY((STRING)a);
                   1628:                                break;
                   1629:                        case A_internal:
                   1630:                                f->arg[i] = (pointer)a;
1.49      noro     1631:                                break;
                   1632:                        case A_node:
                   1633:                                if ( !a || OID(a) != O_LIST )
                   1634:                                        error("funargs_to_quote : invalid argument");
                   1635:                                u0 = 0;
                   1636:                                for ( w = BDY((LIST)a); w; w = NEXT(w) ) {
                   1637:                                        NEXTNODE(u0,u);
                   1638:                                        b = (QUOTE)BDY(w);
                   1639:                                        if ( !b || OID(b) != O_QUOTE )
                   1640:                                                error("funargs_to_quote : invalid argument");
                   1641:                                        BDY(u) = BDY(b);
                   1642:                                }
                   1643:                                if ( u0 ) NEXT(u) = 0;
                   1644:                                f->arg[i] = (pointer)u0;
1.48      noro     1645:                                break;
                   1646:                        default:
                   1647:                                if ( !a || OID(a) != O_QUOTEARG ||
                   1648:                                        ((QUOTEARG)a)->type != spec->type[i] )
                   1649:                                        error("funargs_to_quote : invalid argument");
                   1650:                                f->arg[i] = BDY((QUOTEARG)a);
                   1651:                                break;
                   1652:                }
                   1653:        }
                   1654:        MKQUOTE(*rp,f);
1.1       noro     1655: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>