[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.64

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

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