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

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

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