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

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.65    ! noro       48:  * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.64 2005/09/29 08:55:26 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},
1.65    ! noro      115:        {"flatten_quote",Pflatten_quote,-2},
1.60      noro      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;
1.65    ! noro      539:        Obj obj;
1.61      noro      540:        QUOTE q;
1.53      noro      541:        NODE r;
1.56      noro      542:        int ret;
1.53      noro      543:
1.62      noro      544: #if 0
1.61      noro      545:        g = partial_eval(BDY(((QUOTE)ARG0(arg))));
                    546:        MKQUOTE(q,g);
                    547:        ret = quote_unify((Obj)q,(Obj)ARG1(arg),&r);
1.62      noro      548: #else
1.65    ! noro      549:        obj = (Obj)ARG0(arg);
        !           550:        if ( !obj || OID(obj) != O_QUOTE) {
        !           551:                objtoquote(obj,&q); obj = (Obj)q;
        !           552:        }
        !           553:        ret = quote_unify(obj,(Obj)ARG1(arg),&r);
1.62      noro      554: #endif
1.57      noro      555:        if ( ret ) {
                    556:                do_assign(r);
                    557:                *rp = ONE;
                    558:        } else
1.56      noro      559:                *rp = 0;
                    560: }
                    561:
                    562: void do_assign(NODE arg)
                    563: {
                    564:        NODE t,pair;
                    565:        int pv;
                    566:
                    567:        QUOTE value;
                    568:
                    569:        for ( t = arg; t; t = NEXT(t) ) {
                    570:                pair = BDY((LIST)BDY(t));
                    571:                pv = (int)FA0((FNODE)BDY((QUOTE)BDY(pair)));
                    572:                value = (QUOTE)(BDY(NEXT(pair)));
                    573:                ASSPV(pv,value);
                    574:        }
1.53      noro      575: }
                    576:
                    577: /*
1.56      noro      578: /* consistency check and merge
                    579:  */
1.53      noro      580:
1.56      noro      581: int merge_matching_node(NODE n,NODE a,NODE *rp)
1.53      noro      582: {
                    583:        NODE ta,ba,tn,bn;
                    584:        QUOTE pa,va,pn,vn;
                    585:
1.56      noro      586:        if ( !n ) {
                    587:                *rp = a;
                    588:                return 1;
                    589:        }
1.53      noro      590:        for ( ta = a; ta; ta = NEXT(ta) ) {
                    591:                ba = BDY((LIST)BDY(ta));
1.55      noro      592:                if ( !ba ) continue;
1.53      noro      593:                pa = (QUOTE)BDY(ba); va = (QUOTE)BDY(NEXT(ba));
                    594:                for ( tn = n; tn; tn = NEXT(tn) ) {
                    595:                        bn = BDY((LIST)BDY(tn));
1.55      noro      596:                        if ( !bn ) continue;
1.53      noro      597:                        pn = (QUOTE)BDY(bn); vn = (QUOTE)BDY(NEXT(bn));
1.55      noro      598:                        if ( !compquote(CO,pa,pn) ) {
                    599:                                if ( !compquote(CO,va,vn) ) break;
                    600:                                else return 0;
                    601:                        }
1.53      noro      602:                }
                    603:                if ( !tn ) {
                    604:                        MKNODE(tn,(pointer)BDY(ta),n);
                    605:                        n = tn;
                    606:                }
                    607:        }
1.56      noro      608:        *rp = n;
                    609:        return 1;
1.53      noro      610: }
                    611:
1.56      noro      612: int quote_unify_node(NODE f,NODE pat,NODE *rp) {
                    613:        NODE r,a,tf,tp,r1;
                    614:        int ret;
1.53      noro      615:
                    616:        if ( length(f) != length(pat) ) return 0;
                    617:        r = 0;
                    618:        for ( tf = f, tp = pat; tf; tf = NEXT(tf), tp = NEXT(tp) ) {
1.56      noro      619:                ret = quote_unify((Obj)BDY(tf),(Obj)BDY(tp),&a);
                    620:                if ( !ret ) return 0;
                    621:                ret = merge_matching_node(r,a,&r1);
                    622:                if ( !ret ) return 0;
                    623:                else r = r1;
1.53      noro      624:        }
1.56      noro      625:        *rp = r;
                    626:        return 1;
1.53      noro      627: }
                    628:
                    629: void get_quote_id_arg(QUOTE f,int *id,NODE *r)
                    630: {
                    631:        LIST fa;
                    632:        NODE arg,fab;
                    633:
                    634:        arg = mknode(1,f); Pquote_to_funargs(arg,&fa); fab = BDY((LIST)fa);
                    635:        *id = QTOS((Q)BDY(fab)); *r = NEXT(fab);
                    636: }
                    637:
1.56      noro      638: /* *rp : [[quote(A),quote(1)],...] */
1.53      noro      639:
1.56      noro      640: int quote_unify(Obj f, Obj pat, NODE *rp)
1.53      noro      641: {
                    642:        NODE tf,tp,head,body;
                    643:        NODE parg,farg,r;
                    644:        LIST fa,l;
                    645:        int pid,id;
1.55      noro      646:        FUNC ff,pf;
1.56      noro      647:        int ret;
1.64      noro      648:        QUOTE q;
                    649:        FNODE g;
1.53      noro      650:
                    651:        if ( OID(pat) == O_LIST ) {
                    652:                if ( OID(f) == O_LIST )
1.56      noro      653:                        return quote_unify_node(BDY((LIST)f),BDY((LIST)pat),rp);
1.53      noro      654:                else
                    655:                        return 0;
                    656:        } else if ( OID(pat) == O_QUOTE ) {
                    657:                if ( OID(f) != O_QUOTE ) return 0;
                    658:                get_quote_id_arg((QUOTE)pat,&pid,&parg);
                    659:                get_quote_id_arg((QUOTE)f,&id,&farg);
                    660:                switch ( pid ) {
1.55      noro      661:                        case I_FORMULA:
                    662:                                if ( compquote(CO,f,pat) )
                    663:                                        return 0;
                    664:                                else {
1.56      noro      665:                                        *rp = 0;
                    666:                                        return 1;
1.55      noro      667:                                }
                    668:                                break;
                    669:                        case I_LIST:
1.56      noro      670:                                return quote_unify_node(BDY((LIST)BDY(farg)),
                    671:                                                        BDY((LIST)BDY(parg)),rp);
1.53      noro      672:                        case I_PVAR:
                    673:                                /* [[pat,f]] */
                    674:                                r = mknode(2,pat,f); MKLIST(l,r);
1.56      noro      675:                                *rp =  mknode(1,l);
                    676:                                return 1;
1.53      noro      677:                        case I_IFUNC:
                    678:                                /* F(X,Y,...) = ... */
                    679:                                if ( id == I_FUNC ) {
1.54      noro      680:                                        r = mknode(2,BDY(parg),BDY(farg)); MKLIST(l,r);
                    681:                                        head = mknode(1,l);
1.56      noro      682:                                        ret = quote_unify(BDY(NEXT(farg)),
                    683:                                                                BDY(NEXT(parg)),&body);
                    684:                                        if ( !ret ) return 0;
                    685:                                        else return merge_matching_node(head,body,rp);
1.53      noro      686:                                } else
                    687:                                        return 0;
1.64      noro      688:
                    689:                        case I_NARYOP:
1.53      noro      690:                        case I_BOP:
1.64      noro      691:                                /* X+Y = ... */
                    692:                                if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0;
                    693:
                    694:                                /* XXX converting to I_BOP */
                    695:                                if ( ((FNODE)BDY((QUOTE)pat))->id == I_NARYOP ) {
                    696:                                        g = quote_to_bin(BDY((QUOTE)pat),1);
                    697:                                        MKQUOTE(q,g);
                    698:                                        get_quote_id_arg((QUOTE)q,&pid,&parg);
                    699:                                }
                    700:                                if ( ((FNODE)BDY((QUOTE)f))->id == I_NARYOP ) {
                    701:                                        g = quote_to_bin(BDY((QUOTE)f),1);
                    702:                                        MKQUOTE(q,g);
                    703:                                        get_quote_id_arg((QUOTE)q,&id,&farg);
                    704:                                }
                    705:                                return quote_unify_node(NEXT(farg),NEXT(parg),rp);
                    706:                                break;
                    707:
1.55      noro      708:                        case I_FUNC:
                    709:                                /* f(...) = ... */
1.53      noro      710:                                if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0;
1.56      noro      711:                                return quote_unify_node(NEXT(farg),NEXT(parg),rp);
1.55      noro      712:                                break;
1.53      noro      713:                        default:
                    714:                                if ( pid == id )
1.56      noro      715:                                        return quote_unify_node(farg,parg,rp);
1.53      noro      716:                                else
                    717:                                        return 0;
                    718:                }
                    719:        }
1.13      noro      720: }
                    721:
1.14      noro      722: void Pquotetotex(NODE arg,STRING *rp)
1.13      noro      723: {
1.14      noro      724:        TB tb;
1.13      noro      725:
1.14      noro      726:        NEWTB(tb);
1.27      noro      727:        /* XXX for DP */
                    728:        is_lt = 1;
1.14      noro      729:        fnodetotex_tb(BDY((QUOTE)ARG0(arg)),tb);
                    730:        tb_to_string(tb,rp);
1.13      noro      731: }
                    732:
1.14      noro      733: void Pquotetotex_tb(NODE arg,Q *rp)
1.13      noro      734: {
                    735:        int i;
1.14      noro      736:        TB tb;
1.13      noro      737:
1.14      noro      738:        asir_assert(ARG1(arg),O_TB,"quotetotex_tb");
1.27      noro      739:        /* XXX for DP */
                    740:        is_lt = 1;
1.14      noro      741:        fnodetotex_tb(BDY((QUOTE)ARG0(arg)),ARG1(arg));
1.13      noro      742:        *rp = 0;
                    743: }
                    744:
1.14      noro      745: void Pstring_to_tb(NODE arg,TB *rp)
                    746: {
                    747:        TB tb;
                    748:
                    749:        asir_assert(ARG0(arg),O_STR,"string_to_tb");
                    750:        NEWTB(tb);
                    751:        tb->body[0] = BDY((STRING)ARG0(arg));
                    752:        tb->next++;
                    753:        *rp = tb;
                    754: }
                    755:
                    756: void Ptb_to_string(NODE arg,STRING *rp)
                    757: {
                    758:        TB tb;
                    759:
                    760:        asir_assert(ARG0(arg),O_TB,"tb_to_string");
                    761:        tb = (TB)ARG0(arg);
                    762:        tb_to_string(tb,rp);
                    763: }
                    764:
                    765: void tb_to_string(TB tb,STRING *rp)
1.13      noro      766: {
1.14      noro      767:        int j,len;
1.13      noro      768:        char *all,*p,*q;
                    769:
1.14      noro      770:        for ( j = 0, len = 0; j < tb->next; j++ )
                    771:                len += strlen(tb->body[j]);
                    772:        all = (char *)MALLOC_ATOMIC((len+1)*sizeof(char));
                    773:        for ( j = 0, p = all; j < tb->next; j++ )
                    774:                for ( q = tb->body[j]; *q; *p++ = *q++ );
                    775:        *p = 0;
                    776:        MKSTR(*rp,all);
                    777: }
                    778:
                    779: void Pclear_tb(NODE arg,Q *rp)
                    780: {
                    781:        TB tb;
                    782:        int j;
                    783:
                    784:        asir_assert(ARG0(arg),O_TB,"clear_tb");
                    785:        tb = (TB)ARG0(arg);
                    786:        for ( j = 0; j < tb->next; j++ )
                    787:                tb->body[j] = 0;
                    788:        tb->next = 0;
                    789:        *rp = 0;
1.13      noro      790: }
1.5       noro      791:
                    792: void Pstr_len(arg,rp)
                    793: NODE arg;
                    794: Q *rp;
                    795: {
1.16      noro      796:        Obj obj;
                    797:        TB tb;
                    798:        int r,i;
1.5       noro      799:
1.16      noro      800:        obj = (Obj)ARG0(arg);
                    801:        if ( !obj || (OID(obj) != O_STR && OID(obj) != O_TB) )
                    802:                error("str_len : invalid argument");
                    803:        if ( OID(obj) == O_STR)
                    804:                r = strlen(BDY((STRING)obj));
                    805:        else if ( OID(obj) == O_TB ) {
                    806:                tb = (TB)obj;
                    807:                for ( r = i = 0; i < tb->next; i++ )
                    808:                        r += strlen(tb->body[i]);
                    809:        }
1.5       noro      810:        STOQ(r,*rp);
                    811: }
                    812:
                    813: void Pstr_chr(arg,rp)
                    814: NODE arg;
                    815: Q *rp;
                    816: {
                    817:        STRING str,terminator;
                    818:        Q start;
                    819:        char *p,*ind;
                    820:        int chr,spos,r;
                    821:
                    822:        str = (STRING)ARG0(arg);
                    823:        start = (Q)ARG1(arg);
                    824:        terminator = (STRING)ARG2(arg);
                    825:        asir_assert(str,O_STR,"str_chr");
                    826:        asir_assert(start,O_N,"str_chr");
                    827:        asir_assert(terminator,O_STR,"str_chr");
                    828:        p = BDY(str);
                    829:        spos = QTOS(start);
                    830:        chr = BDY(terminator)[0];
1.8       noro      831:        if ( spos > (int)strlen(p) )
1.5       noro      832:                r = -1;
                    833:        else {
                    834:                ind = strchr(p+spos,chr);
                    835:                if ( ind )
                    836:                        r = ind-p;
                    837:                else
                    838:                        r = -1;
                    839:        }
                    840:        STOQ(r,*rp);
                    841: }
                    842:
                    843: void Psub_str(arg,rp)
                    844: NODE arg;
                    845: STRING *rp;
                    846: {
                    847:        STRING str;
                    848:        Q head,tail;
                    849:        char *p,*r;
                    850:        int spos,epos,len;
                    851:
                    852:        str = (STRING)ARG0(arg);
                    853:        head = (Q)ARG1(arg);
                    854:        tail = (Q)ARG2(arg);
                    855:        asir_assert(str,O_STR,"sub_str");
                    856:        asir_assert(head,O_N,"sub_str");
                    857:        asir_assert(tail,O_N,"sub_str");
                    858:        p = BDY(str);
                    859:        spos = QTOS(head);
                    860:        epos = QTOS(tail);
                    861:        len = strlen(p);
                    862:        if ( (spos >= len) || (epos < spos) ) {
                    863:                *rp = 0; return;
                    864:        }
                    865:        if ( epos >= len )
                    866:                epos = len-1;
                    867:        len = epos-spos+1;
                    868:        r = (char *)MALLOC(len+1);
                    869:        strncpy(r,p+spos,len);
                    870:        r[len] = 0;
                    871:        MKSTR(*rp,r);
                    872: }
1.3       noro      873:
                    874: void Pstrtoascii(arg,rp)
                    875: NODE arg;
                    876: LIST *rp;
                    877: {
                    878:        STRING str;
                    879:        unsigned char *p;
                    880:        int len,i;
                    881:        NODE n,n1;
                    882:        Q q;
                    883:
                    884:        str = (STRING)ARG0(arg);
                    885:        asir_assert(str,O_STR,"strtoascii");
                    886:        p = BDY(str);
                    887:        len = strlen(p);
                    888:        for ( i = len-1, n = 0; i >= 0; i-- ) {
                    889:                UTOQ((unsigned int)p[i],q);
                    890:                MKNODE(n1,q,n);
                    891:                n = n1;
                    892:        }
                    893:        MKLIST(*rp,n);
                    894: }
                    895:
                    896: void Pasciitostr(arg,rp)
                    897: NODE arg;
                    898: STRING *rp;
                    899: {
                    900:        LIST list;
                    901:        unsigned char *p;
                    902:        int len,i,j;
                    903:        NODE n;
                    904:        Q q;
                    905:
                    906:        list = (LIST)ARG0(arg);
                    907:        asir_assert(list,O_LIST,"asciitostr");
                    908:        n = BDY(list);
                    909:        len = length(n);
                    910:        p = MALLOC_ATOMIC(len+1);
                    911:        for ( i = 0; i < len; i++, n = NEXT(n) ) {
                    912:                q = (Q)BDY(n);
                    913:                asir_assert(q,O_N,"asciitostr");
                    914:                j = QTOS(q);
1.4       noro      915:                if ( j >= 256 || j <= 0 )
1.3       noro      916:                        error("asciitostr : argument out of range");
                    917:                p[i] = j;
                    918:        }
                    919:        p[i] = 0;
                    920:        MKSTR(*rp,(char *)p);
                    921: }
1.1       noro      922:
                    923: void Peval_str(arg,rp)
                    924: NODE arg;
                    925: Obj *rp;
                    926: {
                    927:        FNODE fnode;
                    928:        char *cmd;
1.10      ohara     929: #if defined(PARI)
1.8       noro      930:        void recover(int);
                    931:
1.1       noro      932:        recover(0);
1.11      saito     933: #  if !(PARI_VERSION_CODE > 131588)
1.1       noro      934:        if ( setjmp(environnement) ) {
                    935:                avma = top; recover(1);
                    936:                resetenv("");
                    937:        }
1.11      saito     938: #  endif
1.1       noro      939: #endif
                    940:        cmd = BDY((STRING)ARG0(arg));
1.9       noro      941:        exprparse_create_var(0,cmd,&fnode);
1.1       noro      942:        *rp = eval(fnode);
                    943: }
                    944:
                    945: void Prtostr(arg,rp)
                    946: NODE arg;
                    947: STRING *rp;
                    948: {
                    949:        char *b;
                    950:        int len;
                    951:
1.2       noro      952:        len = estimate_length(CO,ARG0(arg));
1.12      noro      953:        b = (char *)MALLOC_ATOMIC(len+1);
1.1       noro      954:        soutput_init(b);
                    955:        sprintexpr(CO,ARG0(arg));
                    956:        MKSTR(*rp,b);
                    957: }
                    958:
                    959: void Pstrtov(arg,rp)
                    960: NODE arg;
                    961: P *rp;
                    962: {
1.8       noro      963:        char *p;
1.1       noro      964:
                    965:        p = BDY((STRING)ARG0(arg));
                    966: #if 0
                    967:        if ( !islower(*p) )
                    968:                *rp = 0;
                    969:        else {
                    970:                for ( t = p+1; t && (isalnum(*t) || *t == '_'); t++ );
                    971:                if ( *t )
                    972:                        *rp = 0;
                    973:                else
                    974:                        makevar(p,rp);
                    975:        }
                    976: #else
                    977:        makevar(p,rp);
                    978: #endif
1.14      noro      979: }
                    980:
1.15      noro      981: static struct TeXSymbol texsymbol[] = {
                    982:  {"sin","\\sin"},
                    983:  {"cos","\\cos"},
                    984:  {"tan","\\tan"},
                    985:  {"sinh","\\sinh"},
                    986:  {"cosh","\\cosh"},
                    987:  {"tanh","\\tanh"},
                    988:  {"exp","\\exp"},
                    989:  {"log","\\log"},
                    990:
                    991: /* Greek Letters (lower case) */
                    992:  {"alpha","\\alpha"},
                    993:  {"beta","\\beta"},
                    994:  {"gamma","\\gamma"},
                    995:  {"delta","\\delta"},
                    996:  {"epsilon","\\epsilon"},
                    997:  {"varepsilon","\\varepsilon"},
                    998:  {"zeta","\\zeta"},
                    999:  {"eta","\\eta"},
                   1000:  {"theta","\\theta"},
                   1001:  {"vartheta","\\vartheta"},
                   1002:  {"iota","\\iota"},
                   1003:  {"kappa","\\kappa"},
                   1004:  {"lambda","\\lambda"},
                   1005:  {"mu","\\mu"},
                   1006:  {"nu","\\nu"},
                   1007:  {"xi","\\xi"},
                   1008:  {"pi","\\pi"},
                   1009:  {"varpi","\\varpi"},
                   1010:  {"rho","\\rho"},
                   1011:  {"sigma","\\sigma"},
                   1012:  {"varsigma","\\varsigma"},
                   1013:  {"tau","\\tau"},
                   1014:  {"upsilon","\\upsilon"},
                   1015:  {"phi","\\phi"},
                   1016:  {"varphi","\\varphi"},
                   1017:  {"chi","\\chi"},
                   1018:  {"omega","\\omega"},
                   1019:
                   1020: /* Greek Letters, (upper case) */
                   1021:  {"ggamma","\\Gamma"},
                   1022:  {"ddelta","\\Delta"},
                   1023:  {"ttheta","\\Theta"},
                   1024:  {"llambda","\\Lambda"},
                   1025:  {"xxi","\\Xi"},
                   1026:  {"ppi","\\Pi"},
                   1027:  {"ssigma","\\Sigma"},
                   1028:  {"uupsilon","\\Upsilon"},
                   1029:  {"pphi","\\Phi"},
                   1030:  {"ppsi","\\Psi"},
                   1031:  {"oomega","\\Omega"},
                   1032:
                   1033:  /* Our own mathematical functions */
                   1034:  {"algebra_tensor","\\otimes"},
                   1035:  {"base_where","{\\rm \\ where \\ }"},
                   1036:  /* Mathematical constants */
                   1037:  {"c_pi","\\pi"},
                   1038:  {"c_i","\\sqrt{-1}"},
                   1039:
                   1040:  /* Temporary  */
                   1041:  {0,0}
                   1042: };
                   1043:
1.14      noro     1044: char *symbol_name(char *name)
                   1045: {
1.15      noro     1046:        int i;
                   1047:
1.41      noro     1048:        if ( !name || strlen(name) == 0 )
                   1049:                return "";
1.38      noro     1050:        if ( !(conv_flag & CONV_TABLE) )
                   1051:                return name;
                   1052:
1.18      noro     1053:        if ( user_texsymbol )
                   1054:                for ( i = 0; user_texsymbol[i].text; i++ )
                   1055:                        if ( !strcmp(user_texsymbol[i].text,name) )
                   1056:                                return user_texsymbol[i].symbol;
1.15      noro     1057:        for ( i = 0; texsymbol[i].text; i++ )
                   1058:                if ( !strcmp(texsymbol[i].text,name) )
                   1059:                        return texsymbol[i].symbol;
1.41      noro     1060:        return 0;
1.52      noro     1061: }
                   1062:
                   1063: void Pget_function_name(NODE arg,STRING *rp)
                   1064: {
                   1065:                QUOTEARG qa;
                   1066:                ARF f;
                   1067:                char *opname;
                   1068:
                   1069:                qa = (QUOTEARG)BDY(arg);
                   1070:                if ( !qa || OID(qa) != O_QUOTEARG || qa->type != A_arf )
                   1071:                        *rp = 0;
                   1072:                else {
                   1073:                        f = (ARF)BDY(qa);
                   1074:                        opname = f->name;
                   1075:                        MKSTR(*rp,opname);
                   1076:                }
1.14      noro     1077: }
                   1078:
1.51      noro     1079: FNODE strip_paren(FNODE);
                   1080:
1.14      noro     1081: void fnodetotex_tb(FNODE f,TB tb)
                   1082: {
                   1083:        NODE n,t,t0;
1.38      noro     1084:        char vname[BUFSIZ],prefix[BUFSIZ];
                   1085:        char *opname,*vname_conv,*prefix_conv;
1.14      noro     1086:        Obj obj;
1.46      noro     1087:        int i,len,allzero,elen,elen2,si;
1.40      noro     1088:        C cplx;
                   1089:        char *r;
1.17      noro     1090:        FNODE fi,f2;
1.14      noro     1091:
                   1092:        write_tb(" ",tb);
                   1093:        if ( !f ) {
                   1094:                write_tb("0",tb);
                   1095:                return;
                   1096:        }
                   1097:        switch ( f->id ) {
                   1098:                /* unary operators */
1.23      noro     1099:                case I_NOT:
                   1100:                        write_tb("\\neg (",tb);
                   1101:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1102:                        write_tb(")",tb);
                   1103:                        break;
                   1104:                case I_PAREN:
                   1105:                        write_tb("(",tb);
                   1106:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1107:                        write_tb(")",tb);
                   1108:                        break;
                   1109:                case I_MINUS:
                   1110:                        write_tb("-",tb);
                   1111:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1112:                        break;
                   1113:
                   1114:                /* binary operators */
                   1115:                /* arg list */
                   1116:                /* I_AND, I_OR => FA0(f), FA1(f) */
                   1117:                /* otherwise   => FA1(f), FA2(f) */
                   1118:                case I_BOP:
                   1119:                        opname = ((ARF)FA0(f))->name;
                   1120:                        if ( !strcmp(opname,"+") ) {
                   1121:                                fnodetotex_tb((FNODE)FA1(f),tb);
1.35      noro     1122:                                if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
1.23      noro     1123:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1124:                        } else if ( !strcmp(opname,"-") ) {
                   1125:                                if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
                   1126:                                write_tb(opname,tb);
                   1127:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1128:                        } else if ( !strcmp(opname,"*") ) {
                   1129:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1130:                                write_tb(" ",tb);
                   1131:                                /* XXX special care for DP */
                   1132:                                f2 = (FNODE)FA2(f);
                   1133:                                if ( f2->id == I_EV ) {
                   1134:                                        n = (NODE)FA0(f2);
                   1135:                                        for ( i = 0; n; n = NEXT(n), i++ ) {
                   1136:                                                fi = (FNODE)BDY(n);
                   1137:                                                if ( fi->id != I_FORMULA || FA0(fi) )
                   1138:                                                        break;
                   1139:                                        }
                   1140:                                        if ( n )
                   1141:                                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1142:                                } else
                   1143:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1144:                        } else if ( !strcmp(opname,"/") ) {
                   1145:                                write_tb("\\frac{",tb);
                   1146:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1147:                                write_tb("} {",tb);
                   1148:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1149:                                write_tb("}",tb);
                   1150:                        } else if ( !strcmp(opname,"^") ) {
                   1151:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1152:                                write_tb("^{",tb);
1.51      noro     1153:                                fnodetotex_tb(strip_paren((FNODE)FA2(f)),tb);
1.23      noro     1154:                                write_tb("} ",tb);
                   1155:                        } else if ( !strcmp(opname,"%") ) {
                   1156:                                fnodetotex_tb((FNODE)FA1(f),tb);
                   1157:                                write_tb(" {\\rm mod}\\, ",tb);
                   1158:                                fnodetotex_tb((FNODE)FA2(f),tb);
                   1159:                        } else
                   1160:                                error("invalid binary operator");
                   1161:                        break;
                   1162:
                   1163:                case I_COP:
                   1164:                        switch( (cid)FA0(f) ) {
                   1165:                                case C_EQ:
                   1166:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1167:                                        write_tb(" = ",tb);
                   1168:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1169:                                        break;
                   1170:                                case C_NE:
                   1171:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1172:                                        write_tb(" \\neq ",tb);
                   1173:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1174:                                        break;
                   1175:                                case C_GT:
                   1176:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1177:                                        write_tb(" > ",tb);
1.23      noro     1178:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1179:                                        break;
                   1180:                                case C_LT:
                   1181:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1182:                                        write_tb(" < ",tb);
1.23      noro     1183:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1184:                                        break;
1.23      noro     1185:                                case C_GE:
                   1186:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1187:                                        write_tb(" \\geq ",tb);
                   1188:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1189:                                        break;
1.23      noro     1190:                                case C_LE:
                   1191:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1192:                                        write_tb(" \\leq ",tb);
                   1193:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1194:                                        break;
                   1195:                        }
                   1196:                        break;
                   1197:
1.23      noro     1198:                case I_LOP:
                   1199:                        switch( (lid)FA0(f) ) {
                   1200:                                case L_EQ:
                   1201:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1202:                                        write_tb(" = ",tb);
                   1203:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1204:                                        break;
                   1205:                                case L_NE:
                   1206:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1207:                                        write_tb(" \\neq ",tb);
                   1208:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1209:                                        break;
                   1210:                                case L_GT:
                   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_LT:
                   1216:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.45      noro     1217:                                        write_tb(" < ",tb);
1.23      noro     1218:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1219:                                        break;
                   1220:                                case L_GE:
                   1221:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1222:                                        write_tb(" \\geq ",tb);
                   1223:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1224:                                        break;
1.23      noro     1225:                                case L_LE:
                   1226:                                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1227:                                        write_tb(" \\leq ",tb);
                   1228:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1229:                                        break;
1.23      noro     1230:                                case L_AND:
                   1231:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.14      noro     1232:                                        write_tb(" {\\rm \\ and\\ } ",tb);
1.23      noro     1233:                                        fnodetotex_tb((FNODE)FA2(f),tb);
                   1234:                                        break;
                   1235:                                case L_OR:
1.14      noro     1236:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.23      noro     1237:                                        write_tb(" {\\rm \\ or\\ } ",tb);
                   1238:                                        fnodetotex_tb((FNODE)FA2(f),tb);
1.14      noro     1239:                                        break;
1.23      noro     1240:                                case L_NOT:
                   1241:                                        /* XXX : L_NOT is a unary operator */
                   1242:                                        write_tb("\\neg (",tb);
1.14      noro     1243:                                        fnodetotex_tb((FNODE)FA1(f),tb);
1.23      noro     1244:                                        write_tb(")",tb);
                   1245:                                        return;
1.14      noro     1246:                        }
                   1247:                        break;
                   1248:
1.23      noro     1249:                case I_AND:
                   1250:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1251:                        write_tb(" {\\rm \\ and\\ } ",tb);
                   1252:                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1253:                        break;
                   1254:
                   1255:                case I_OR:
                   1256:                        fnodetotex_tb((FNODE)FA0(f),tb);
                   1257:                        write_tb(" {\\rm \\ or\\ } ",tb);
                   1258:                        fnodetotex_tb((FNODE)FA1(f),tb);
                   1259:                        break;
                   1260:
1.14      noro     1261:                /* ternary operators */
                   1262:                case I_CE:
                   1263:                        error("fnodetotex_tb : not implemented yet");
                   1264:                        break;
                   1265:
                   1266:                /* lists */
                   1267:                case I_LIST:
                   1268:                        write_tb(" [ ",tb);
                   1269:                        n = (NODE)FA0(f);
                   1270:                        fnodenodetotex_tb(n,tb);
                   1271:                        write_tb("]",tb);
                   1272:                        break;
                   1273:
                   1274:                /* function */
1.23      noro     1275:                case I_FUNC:
1.40      noro     1276:                        if ( !strcmp(((FUNC)FA0(f))->name,"@pi") )
                   1277:                                write_tb("\\pi",tb);
                   1278:                        else if ( !strcmp(((FUNC)FA0(f))->name,"@e") )
                   1279:                                write_tb("e",tb);
                   1280:                        else {
                   1281:                                opname = conv_rule(((FUNC)FA0(f))->name);
                   1282:                                write_tb(opname,tb);
                   1283:                                write_tb("(",tb);
                   1284:                                fargstotex_tb(opname,FA1(f),tb);
                   1285:                                write_tb(")",tb);
                   1286:                        }
1.23      noro     1287:                        break;
                   1288:
                   1289:                /* XXX */
                   1290:                case I_CAR:
1.28      noro     1291:                        opname = conv_rule("car");
1.23      noro     1292:                        write_tb(opname,tb);
                   1293:                        write_tb("(",tb);
                   1294:                        fargstotex_tb(opname,FA0(f),tb);
                   1295:                        write_tb(")",tb);
                   1296:                        break;
                   1297:
                   1298:                case I_CDR:
1.28      noro     1299:                        opname = conv_rule("cdr");
1.23      noro     1300:                        write_tb(opname,tb);
                   1301:                        write_tb("(",tb);
                   1302:                        fargstotex_tb(opname,FA0(f),tb);
                   1303:                        write_tb(")",tb);
                   1304:                        break;
                   1305:
                   1306:                /* exponent vector */
                   1307:                case I_EV:
                   1308:                        n = (NODE)FA0(f);
1.31      noro     1309:                        if ( dp_vars_hweyl ) {
                   1310:                                elen = length(n);
                   1311:                                elen2 = elen>>1;
                   1312:                                elen = elen2<<1;
                   1313:                        }
1.23      noro     1314:                        allzero = 1;
1.27      noro     1315:                        if ( show_lt && is_lt )
                   1316:                                write_tb("\\underline{",tb);
1.23      noro     1317:                        for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
                   1318:                                fi = (FNODE)BDY(n);
                   1319:                                if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
                   1320:                                allzero = 0;
1.38      noro     1321:                                if ( dp_vars && i < dp_vars_len ) {
                   1322:                                        strcpy(vname,dp_vars[i]);
                   1323:                                        vname_conv = conv_rule(vname);
                   1324:                                } else {
                   1325:                                        if ( dp_vars_hweyl ) {
1.44      noro     1326:                                                if ( i < elen2 ) {
1.38      noro     1327:                                                        strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44      noro     1328:                                                        prefix_conv = conv_rule(prefix);
                   1329:                                                        vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46      noro     1330:                                                        si = i+dp_vars_origin;
                   1331:                                                        sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
                   1332:                                                                prefix_conv,si);
1.44      noro     1333:                                                } else if ( i < elen ) {
1.46      noro     1334:                                                        strcpy(prefix,
                   1335:                                                                dp_dvars_prefix?dp_dvars_prefix:"\\partial");
1.44      noro     1336:                                                        prefix_conv = conv_rule(prefix);
                   1337:                                                        vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46      noro     1338:                                                        si = i+dp_dvars_origin-elen2;
                   1339:                                                        sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
                   1340:                                                                prefix_conv,si);
1.44      noro     1341:                                                } else {
1.38      noro     1342:                                                        strcpy(prefix,"h");
1.44      noro     1343:                                                        vname_conv = conv_rule(prefix);
                   1344:                                                }
                   1345:                                        } else {
1.38      noro     1346:                                                strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44      noro     1347:                                                prefix_conv = conv_rule(prefix);
                   1348:                                                vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46      noro     1349:                                                si = i+dp_vars_origin;
                   1350:                                                sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
                   1351:                                                        prefix_conv,si);
1.44      noro     1352:                                        }
1.38      noro     1353:                                }
1.23      noro     1354:                                if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
                   1355:                                        len = strlen(vname_conv);
                   1356:                                        opname = MALLOC_ATOMIC(len+2);
                   1357:                                        sprintf(opname,"%s ",vname_conv);
1.14      noro     1358:                                        write_tb(opname,tb);
1.23      noro     1359:                                } else {
                   1360:                                        len = strlen(vname_conv);
                   1361:                                        /* 2: ^{ */
                   1362:                                        opname = MALLOC_ATOMIC(len+1+2);
                   1363:                                        sprintf(opname,"%s^{",vname_conv);
1.14      noro     1364:                                        write_tb(opname,tb);
1.23      noro     1365:                                        fnodetotex_tb((FNODE)BDY(n),tb);
                   1366:                                        write_tb("} ",tb);
                   1367:                                }
1.14      noro     1368:                        }
1.23      noro     1369:                        /* XXX */
                   1370:                        if ( allzero )
                   1371:                                write_tb(" 1 ",tb);
1.27      noro     1372:                        if ( show_lt && is_lt ) {
                   1373:                                write_tb("}",tb);
                   1374:                                is_lt = 0;
                   1375:                        }
1.14      noro     1376:                        break;
                   1377:
1.23      noro     1378:                /* string */
1.14      noro     1379:                case I_STR:
                   1380:                        write_tb((char *)FA0(f),tb);
                   1381:                        break;
                   1382:
1.23      noro     1383:                /* internal object */
1.14      noro     1384:                case I_FORMULA:
                   1385:                        obj = (Obj)FA0(f);
1.40      noro     1386:                        if ( !obj )
1.42      noro     1387:                                write_tb("0",tb);
1.40      noro     1388:                        else if ( OID(obj) == O_N && NID(obj) == N_C ) {
                   1389:                                cplx = (C)obj;
                   1390:                                write_tb("(",tb);
                   1391:                                if ( cplx->r ) {
                   1392:                                        r = objtostr((Obj)cplx->r); write_tb(r,tb);
                   1393:                                }
                   1394:                                if ( cplx->i ) {
                   1395:                                        if ( cplx->r && compnum(0,cplx->i,0) > 0 ) {
                   1396:                                                write_tb("+",tb);
                   1397:                                                if ( !UNIQ(cplx->i) ) {
                   1398:                                                        r = objtostr((Obj)cplx->i); write_tb(r,tb);
                   1399:                                                }
                   1400:                                        } else if ( MUNIQ(cplx->i) )
                   1401:                                                write_tb("-",tb);
                   1402:                                        else if ( !UNIQ(cplx->i) ) {
                   1403:                                                r = objtostr((Obj)cplx->i); write_tb(r,tb);
                   1404:                                        }
                   1405:                                        write_tb("\\sqrt{-1}",tb);
                   1406:                                }
                   1407:                                write_tb(")",tb);
                   1408:                        } else if ( OID(obj) == O_P )
                   1409:                                write_tb(conv_rule(VR((P)obj)->name),tb);
                   1410:                        else
                   1411:                                write_tb(objtostr(obj),tb);
1.14      noro     1412:                        break;
                   1413:
1.23      noro     1414:                /* program variable */
1.14      noro     1415:                case I_PVAR:
                   1416:                        if ( FA1(f) )
                   1417:                                error("fnodetotex_tb : not implemented yet");
                   1418:                        GETPVNAME(FA0(f),opname);
                   1419:                        write_tb(opname,tb);
                   1420:                        break;
                   1421:
                   1422:                default:
                   1423:                        error("fnodetotex_tb : not implemented yet");
                   1424:        }
1.40      noro     1425: }
                   1426:
                   1427: char *objtostr(Obj obj)
                   1428: {
                   1429:        int len;
                   1430:        char *r;
                   1431:
                   1432:        len = estimate_length(CO,obj);
                   1433:        r = (char *)MALLOC_ATOMIC(len+1);
                   1434:        soutput_init(r);
                   1435:        sprintexpr(CO,obj);
                   1436:        return r;
1.50      ohara    1437: }
                   1438:
                   1439: void Psprintf(NODE arg,STRING *rp)
                   1440: {
                   1441:     STRING string;
                   1442:     char *s,*t,*r;
                   1443:     int argc,n,len;
                   1444:     NODE node;
                   1445:
                   1446:     string = (STRING)ARG0(arg);
                   1447:     asir_assert(string,O_STR,"sprintf");
                   1448:     s = BDY(string);
                   1449:     for(n = 0, t = s; *t; t++) {
                   1450:         if (*t=='%' && *(t+1)=='a') {
                   1451:             n++;
                   1452:         }
                   1453:     }
                   1454:     for(node = NEXT(arg), argc = 0, len = strlen(s); node; node = NEXT(node), argc++) {
                   1455:         len += estimate_length(CO,BDY(node));
                   1456:     }
                   1457:     if (argc < n) {
                   1458:         error("sprintf: invalid argument");
                   1459:     }
                   1460:     r = (char *)MALLOC_ATOMIC(len);
                   1461:     for(node = NEXT(arg), t = r; *s; s++) {
                   1462:         if (*s=='%' && *(s+1)=='a') {
                   1463:             strcpy(t,objtostr(BDY(node)));
                   1464:             node = NEXT(node);
                   1465:             t = strchr(t,0);
                   1466:             s++;
                   1467:         }else {
                   1468:             *t++ = *s;
                   1469:         }
                   1470:     }
                   1471:     *t = 0;
                   1472:     MKSTR(*rp,r);
1.14      noro     1473: }
                   1474:
                   1475: void fnodenodetotex_tb(NODE n,TB tb)
                   1476: {
                   1477:        for ( ; n; n = NEXT(n) ) {
1.27      noro     1478:                is_lt = 1;
1.14      noro     1479:                fnodetotex_tb((FNODE)BDY(n),tb);
                   1480:                if ( NEXT(n) ) write_tb(", ",tb);
                   1481:        }
                   1482: }
                   1483:
                   1484: void fargstotex_tb(char *name,FNODE f,TB tb)
                   1485: {
                   1486:        NODE n;
                   1487:
                   1488:        if ( !strcmp(name,"matrix") ) {
                   1489:                error("fargstotex_tb : not implemented yet");
                   1490:        } else if ( !strcmp(name,"vector") ) {
                   1491:                error("fargstotex_tb : not implemented yet");
                   1492:        } else {
                   1493:                if ( f->id == I_LIST ) {
                   1494:                        n = (NODE)FA0(f);
                   1495:                        fnodenodetotex_tb(n,tb);
                   1496:                } else
                   1497:                        fnodetotex_tb(f,tb);
1.35      noro     1498:        }
                   1499: }
                   1500:
                   1501: int top_is_minus(FNODE f)
                   1502: {
                   1503:        char *opname;
                   1504:        int len;
                   1505:        Obj obj;
                   1506:
                   1507:        if ( !f )
                   1508:                return 0;
                   1509:        switch ( f->id ) {
                   1510:                case I_MINUS:
                   1511:                        return 1;
                   1512:                case I_BOP:
                   1513:                        opname = ((ARF)FA0(f))->name;
                   1514:                        switch ( opname[0] ) {
                   1515:                                case '+': case '*': case '/': case '^': case '%':
                   1516:                                        return top_is_minus((FNODE)FA1(f));
                   1517:                                case '-':
                   1518:                                        if ( FA1(f) )
                   1519:                                                return top_is_minus((FNODE)FA1(f));
                   1520:                                        else
                   1521:                                                return 1;
                   1522:                                default:
                   1523:                                        return 0;
                   1524:                        }
                   1525:                        break;
                   1526:                case I_COP:
                   1527:                        return top_is_minus((FNODE)FA1(f));
                   1528:                case I_LOP:
                   1529:                        if ( (lid)FA0(f) == L_NOT ) return 0;
                   1530:                        else return top_is_minus((FNODE)FA1(f));
                   1531:                case I_AND: case I_OR:
                   1532:                        return top_is_minus((FNODE)FA0(f));
                   1533:                case I_FORMULA:
                   1534:                        obj = (Obj)FA0(f);
1.36      noro     1535:                        if ( !obj )
                   1536:                                return 0;
                   1537:                        else {
                   1538:                                switch ( OID(obj) ) {
                   1539:                                        case O_N:
                   1540:                                                return mmono((P)obj);
                   1541:                                        case O_P:
                   1542:                                                /* must be a variable */
                   1543:                                                opname = conv_rule(VR((P)obj)->name);
                   1544:                                                return opname[0]=='-';
                   1545:                                        default:
                   1546:                                                /* ??? */
                   1547:                                                len = estimate_length(CO,obj);
                   1548:                                                opname = (char *)MALLOC_ATOMIC(len+1);
                   1549:                                                soutput_init(opname);
                   1550:                                                sprintexpr(CO,obj);
                   1551:                                                return opname[0]=='-';
                   1552:                                }
1.35      noro     1553:                        }
                   1554:                default:
                   1555:                        return 0;
1.14      noro     1556:        }
1.47      noro     1557: }
                   1558:
                   1559: FNODE flatten_fnode(FNODE,char *);
                   1560:
1.48      noro     1561: void Pflatten_quote(NODE arg,Obj *rp)
1.47      noro     1562: {
                   1563:        FNODE f;
                   1564:        QUOTE q;
                   1565:
1.48      noro     1566:        if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE )
                   1567:                *rp = (Obj)ARG0(arg);
1.65    ! noro     1568:        else if ( argc(arg) == 1 ) {
        !          1569:                f = flatten_fnode(BDY((QUOTE)ARG0(arg)),"+");
        !          1570:                f = flatten_fnode(f,"*");
        !          1571:                MKQUOTE(q,f);
        !          1572:                *rp = (Obj)q;
        !          1573:        } else {
1.48      noro     1574:                f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg)));
                   1575:                MKQUOTE(q,f);
                   1576:                *rp = (Obj)q;
                   1577:        }
1.63      noro     1578: }
                   1579:
                   1580: void Pget_quote_id(NODE arg,Q *rp)
                   1581: {
                   1582:        FNODE f;
                   1583:        QUOTE q;
                   1584:
                   1585:        q = (QUOTE)ARG0(arg);
                   1586:        if ( !q || OID(q) != O_QUOTE )
                   1587:                error("get_quote_id : invalid argument");
                   1588:        f = BDY(q);
                   1589:        STOQ((int)f->id,*rp);
1.48      noro     1590: }
                   1591:
                   1592: void Pquote_to_funargs(NODE arg,LIST *rp)
                   1593: {
                   1594:        fid_spec_p spec;
                   1595:        QUOTE q;
                   1596:        QUOTEARG qa;
                   1597:        FNODE f;
                   1598:        STRING s;
                   1599:        QUOTE r;
                   1600:        int i;
                   1601:        Q id,a;
1.49      noro     1602:        LIST l;
                   1603:        NODE t0,t,w,u,u0;
1.48      noro     1604:
                   1605:        q = (QUOTE)ARG0(arg);
                   1606:        if ( !q || OID(q) != O_QUOTE )
                   1607:                error("quote_to_funargs : invalid argument");
                   1608:        f = BDY(q);
                   1609:        if ( !f ) {
                   1610:                MKLIST(*rp,0);
                   1611:                return;
                   1612:        }
                   1613:        get_fid_spec(f->id,&spec);
                   1614:        if ( !spec )
                   1615:                error("quote_to_funargs : not supported yet");
                   1616:        t0 = 0;
                   1617:        STOQ((int)f->id,id);
                   1618:        NEXTNODE(t0,t);
                   1619:        BDY(t) = (pointer)id;
                   1620:        for ( i = 0; spec->type[i] != A_end; i++ ) {
                   1621:                NEXTNODE(t0,t);
                   1622:                switch ( spec->type[i] ) {
                   1623:                        case A_fnode:
                   1624:                                MKQUOTE(r,(FNODE)f->arg[i]);
                   1625:                                BDY(t) = (pointer)r;
                   1626:                                break;
                   1627:                        case A_int:
                   1628:                                STOQ((int)f->arg[i],a);
                   1629:                                BDY(t) = (pointer)a;
                   1630:                                break;
                   1631:                        case A_str:
                   1632:                                MKSTR(s,(char *)f->arg[i]);
                   1633:                                BDY(t) = (pointer)s;
                   1634:                                break;
                   1635:                        case A_internal:
                   1636:                                BDY(t) = (pointer)f->arg[i];
                   1637:                                break;
1.49      noro     1638:                        case A_node:
                   1639:                                w = (NODE)f->arg[i];
                   1640:                                for ( u0 = 0; w; w = NEXT(w) ){
                   1641:                                        NEXTNODE(u0,u);
                   1642:                                        MKQUOTE(r,(FNODE)BDY(w));
                   1643:                                        BDY(u) = (pointer)r;
                   1644:                                }
                   1645:                                if ( u0 ) NEXT(u) = 0;
                   1646:                                MKLIST(l,u0);
                   1647:                                BDY(t) = (pointer)l;
                   1648:                                break;
1.48      noro     1649:                        default:
                   1650:                                MKQUOTEARG(qa,spec->type[i],f->arg[i]);
                   1651:                                BDY(t) = (pointer)qa;
                   1652:                                break;
                   1653:                }
                   1654:        }
                   1655:        if ( t0 ) NEXT(t) = 0;
                   1656:        MKLIST(*rp,t0);
                   1657: }
                   1658:
                   1659: void Pfunargs_to_quote(NODE arg,QUOTE *rp)
                   1660: {
                   1661:        fid_spec_p spec;
                   1662:        QUOTE q;
                   1663:        QUOTEARG qa;
                   1664:        FNODE f;
                   1665:        STRING s;
1.49      noro     1666:        QUOTE r,b;
1.48      noro     1667:        int i;
                   1668:        LIST l;
                   1669:        fid id;
                   1670:        Obj a;
1.49      noro     1671:        NODE t0,t,u0,u,w;
1.48      noro     1672:
                   1673:        l = (LIST)ARG0(arg);
                   1674:        if ( !l || OID(l) != O_LIST || !(t=BDY(l)) )
                   1675:                error("funargs_to_quote : invalid argument");
                   1676:        t = BDY(l);
                   1677:        id = (fid)QTOS((Q)BDY(t)); t = NEXT(t);
                   1678:        get_fid_spec(id,&spec);
                   1679:        if ( !spec )
                   1680:                error("funargs_to_quote : not supported yet");
                   1681:        for ( i = 0; spec->type[i] != A_end; i++ );
                   1682:        NEWFNODE(f,i);
                   1683:        f->id = id;
                   1684:        for ( i = 0; spec->type[i] != A_end; i++, t = NEXT(t) ) {
                   1685:                if ( !t )
                   1686:                        error("funargs_to_quote : argument mismatch");
                   1687:                a = (Obj)BDY(t);
                   1688:                switch ( spec->type[i] ) {
                   1689:                        case A_fnode:
                   1690:                                if ( !a || OID(a) != O_QUOTE )
                   1691:                                        error("funargs_to_quote : invalid argument");
                   1692:                                f->arg[i] = BDY((QUOTE)a);
                   1693:                                break;
                   1694:                        case A_int:
                   1695:                                if ( !INT(a) )
                   1696:                                        error("funargs_to_quote : invalid argument");
                   1697:                                f->arg[i] = (pointer)QTOS((Q)a);
                   1698:                                break;
                   1699:                        case A_str:
                   1700:                                if ( !a || OID(a) != O_STR )
                   1701:                                        error("funargs_to_quote : invalid argument");
                   1702:                                f->arg[i] = (pointer)BDY((STRING)a);
                   1703:                                break;
                   1704:                        case A_internal:
                   1705:                                f->arg[i] = (pointer)a;
1.49      noro     1706:                                break;
                   1707:                        case A_node:
                   1708:                                if ( !a || OID(a) != O_LIST )
                   1709:                                        error("funargs_to_quote : invalid argument");
                   1710:                                u0 = 0;
                   1711:                                for ( w = BDY((LIST)a); w; w = NEXT(w) ) {
                   1712:                                        NEXTNODE(u0,u);
                   1713:                                        b = (QUOTE)BDY(w);
                   1714:                                        if ( !b || OID(b) != O_QUOTE )
                   1715:                                                error("funargs_to_quote : invalid argument");
                   1716:                                        BDY(u) = BDY(b);
                   1717:                                }
                   1718:                                if ( u0 ) NEXT(u) = 0;
                   1719:                                f->arg[i] = (pointer)u0;
1.48      noro     1720:                                break;
                   1721:                        default:
                   1722:                                if ( !a || OID(a) != O_QUOTEARG ||
                   1723:                                        ((QUOTEARG)a)->type != spec->type[i] )
                   1724:                                        error("funargs_to_quote : invalid argument");
                   1725:                                f->arg[i] = BDY((QUOTEARG)a);
                   1726:                                break;
                   1727:                }
                   1728:        }
                   1729:        MKQUOTE(*rp,f);
1.1       noro     1730: }

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