00001
00002 #ifdef _MSC_VER
00003 #include <windows.h>
00004 #include <stdio.h>
00005 #endif
00006
00007 #ifdef _MSC_VER
00008 #define __STDC__
00009 #endif
00010
00011 #ifdef __STDC__
00012 #include <stdlib.h>
00013 #else
00014 extern char *getenv();
00015 #endif
00016
00017
00018 #include "intersci.h"
00019
00020 static char buf[1024];
00021
00022 static int icre=1;
00023 static int indent = 0;
00024 static int pass = 0 ;
00025
00026 #ifdef _MSC_VER
00027 static void SciEnv ();
00028 #define putenv _putenv
00029 #endif
00030
00031 int main(argc,argv)
00032 unsigned int argc;
00033 char **argv;
00034 {
00035 int InterFace = 0 ;
00036 #ifdef _MSC_VER
00037 SciEnv();
00038 #endif
00039 switch (argc) {
00040 case 2:
00041 InterFace = 0; break;
00042 case 3:
00043 InterFace = atoi(argv[2]);break;
00044 default:
00045 printf("usage: intersci <interface file> <interface number>\n");
00046 exit(1);
00047 break;
00048 }
00049 basfun = BasfunAlloc();
00050 if (basfun == 0) {
00051 printf("Running out of memory\n");
00052 exit(1);
00053 }
00054 forsub = ForsubAlloc();
00055 if (forsub == 0) {
00056 printf("Running out of memory\n");
00057 exit(1);
00058 }
00059 ISCIReadFile(argv[1]);
00060 GenFundef(argv[1],InterFace);
00061 return 0;
00062 }
00063
00064 void ISCIReadFile(file)
00065 char *file;
00066 {
00067 FILE *fin, *fout, *foutv;
00068 char filout[MAXNAM];
00069 char filin[MAXNAM];
00070 sprintf(filin,"%s.desc",file);
00071 fin = fopen(filin,"r");
00072 if (fin == 0) {
00073 printf("interface file \"%s\" does not exist\n",filin);
00074 exit(1);
00075 }
00076 Copyright();
00077 strcpy(filout,file);
00078 strcat(filout,".f");
00079 fout = fopen(filout,"w");
00080 strcpy(filout,file);
00081 strcat(filout,".tmp");
00082 foutv = fopen(filout,"w");
00083 InitDeclare();
00084 nFun = 0;
00085 while(ReadFunction(fin)) {
00086 nFun++;
00087 if (nFun > MAXFUN) {
00088 printf("Too many SCILAB functions. The maximum is %d\n",MAXFUN);
00089 exit(1);
00090 }
00091 ResetDeclare();
00092
00093 pass=0;
00094 WriteFunctionCode(foutv);
00095
00096 ForNameClean();
00097
00098 pass=1;
00099 WriteFunctionCode(fout);
00101 }
00102 WriteMain(fout,file);
00103 printf("FORTRAN file \"%s.f\" has been created\n",file);
00104 WriteAddInter(file) ;
00105 printf("Scilab file \"%s.sce\" has been created\n",file);
00106 fclose(fout);
00107 fclose(fin);
00108 }
00109
00110 void WriteMain(f,file)
00111 FILE *f;
00112 char* file;
00113 {
00114 int i;
00115 FCprintf(f,"\nc interface function \n");
00116 FCprintf(f,"c ********************\n");
00117 WriteMainHeader(f,file);
00118 Fprintf(f,indent,"goto (");
00119 for (i = 1; i < nFun ; i++) {
00120 Fprintf(f,indent,"%d,",i);
00121 }
00122 Fprintf(f,indent,"%d) fin\nreturn\n",nFun);
00123 for (i = 0; i < nFun; i++) {
00124 FCprintf(f,"%d call ints%s('%s')\n",i+1,funNames[i],funNames[i]);
00125 Fprintf(f,indent,"return\n");
00126 }
00127 Fprintf(f,indent,"end\n");
00128 }
00129
00130 void WriteAddInter(file)
00131 char *file;
00132 {
00133 FILE *fout;
00134 int i;
00135 char filout[MAXNAM];
00136 strcpy(filout,file);
00137 strcat(filout,".sce");
00138 fout = fopen(filout,"w");
00139 if ( fout != (FILE*) 0)
00140 {
00141 fprintf(fout,"// Addinter for file %s\n",file);
00142 fprintf(fout,"// for hppa/sun-solaris/linux/dec\n");
00143 fprintf(fout,"//--------------------------------\n");
00144 fprintf(fout,"//Scilab functions \n");
00145 fprintf(fout,"%s_funs=[...\n",file);
00146 for (i = 0; i < nFun -1; i++)
00147 fprintf(fout," '%s';\n",funNames[i]);
00148 fprintf(fout," '%s']\n",funNames[nFun-1]);
00149 fprintf(fout,"// interface file to link: ifile='%s.o' \n",file);
00150 fprintf(fout,"// user's files to link: ufiles=['file1.o','file2.o',....] \n");
00151 fprintf(fout,"// files = [ifile,ufiles] \n");
00152 fprintf(fout,"addinter(files,'%s',%s_funs);\n",file,file);
00153 fclose(fout);
00154 }
00155 else
00156 fprintf(stderr,"Can't open file %s\n",file);
00157 }
00158
00159
00160
00161
00162 void Copyright()
00163 {
00164 printf("\nINTERSCI Version %s (%s)\n",VERSION,DATE);
00165 printf(" Copyright (C) INRIA All rights reserved\n\n");
00166 }
00167
00168
00169
00170
00171
00172 int ReadFunction(f)
00173 FILE *f;
00174 {
00175 int i, j, l, type, ftype;
00176 char s[MAXLINE];
00177 char str[MAXNAM];
00178 char *words[MAXLINE];
00179 char *optwords[MAXLINE];
00180 IVAR ivar;
00181 int nwords, line1, inbas, fline1, infor, nopt, out1;
00182
00183 nVariable = 0;
00184 maxOpt = 0;
00185 line1 = 1;
00186 inbas = 0;
00187 fline1 = 0;
00188 infor = 0;
00189 out1 = 0;
00190 while (fgets(s,MAXLINE,f))
00191 {
00192
00193 if (line1 != 1) nwords = ParseLine(s,words);
00194 else nwords = ParseScilabLine(s,words);
00195
00196 if (words[0][0] == '*') return(1);
00197 if (line1 == 1)
00198 {
00199
00200 if ((int)strlen(words[0]) > 24)
00201 {
00202 printf("SCILAB function name too long: \"%s\"\n",words[0]);
00203 exit(1);
00204 }
00205 basfun->name = (char *)malloc((unsigned)(strlen(words[0])+1));
00206 strcpy(basfun->name,words[0]);
00207 printf("**************************\n");
00208 printf("processing SCILAB function \"%s\"\n",words[0]);
00209 funNames[nFun] = basfun->name;
00210 i = nwords - 1;
00211 if (i > MAXARG)
00212 {
00213 printf("too may input arguments for SCILAB function\"%s\"\n",
00214 words[0]);
00215 printf(" augment constant \"MAXARG\" and recompile intersci\n");
00216 exit(1);
00217 }
00218 basfun->nin = i;
00219 for (i = 0; i < nwords - 1; i++)
00220 {
00221 if (words[i+1][0] == '{')
00222 {
00223 maxOpt++;
00224 nopt = ParseLine(words[i+1]+1,optwords);
00225 if (nopt != 2) {
00226 printf("Bad syntax for optional argument. Two variables needed\n");
00227 exit(1);
00228 }
00229 ivar = GetVar(optwords[0],1);
00230 basfun->in[i] = ivar;
00231 variables[ivar-1]->opt_type = NAME;
00232 variables[ivar-1]->opt_name =
00233 (char *)malloc((unsigned)(strlen(optwords[1])+1));
00234 strcpy(variables[ivar-1]->opt_name,optwords[1]);
00235 }
00236 else if (words[i+1][0] == '[')
00237 {
00238 maxOpt++;
00239 nopt = ParseLine(words[i+1]+1,optwords);
00240 if (nopt != 2)
00241 {
00242 printf("Bad syntax for optional argument. Two variables needed\n");
00243 exit(1);
00244 }
00245 ivar = GetVar(optwords[0],1);
00246 basfun->in[i] = ivar;
00247 variables[ivar-1]->opt_type = VALUE;
00248 variables[ivar-1]->opt_name =
00249 (char *)malloc((unsigned)(strlen(optwords[1])+1));
00250 strcpy(variables[ivar-1]->opt_name,optwords[1]);
00251 }
00252 else basfun->in[i] = GetVar(words[i+1],1);
00253 }
00254 line1 = 0;
00255 inbas = 1;
00256 }
00257 else if (inbas == 1)
00258 {
00259 if (nwords == 0)
00260 {
00261
00262 inbas = 0;
00263 fline1 = 1;
00264 }
00265 else
00266 {
00267
00268 ivar = GetVar(words[0],1);
00269 i = ivar - 1;
00270 if (nwords == 1)
00271 {
00272 printf("type missing for variable \"%s\"\n",words[0]);
00273 exit(1);
00274 }
00275 type = GetBasType(words[1]);
00276 variables[i]->type = type;
00277 switch (type)
00278 {
00279 case SCALAR:
00280 case ANY:
00281 case SCIMPOINTER:
00282 case SCISMPOINTER:
00283 case SCILPOINTER:
00284 case SCIBPOINTER:
00285 case SCIOPOINTER:
00286 break;
00287 case COLUMN:
00288 case ROW:
00289 case STRING:
00290 case WORK:
00291 case VECTOR:
00292 if (nwords != 3)
00293 {
00294 printf("bad type specification for variable \"%s\" \n", words[0]);
00295 printf("only %d argument given and %d are expected\n", nwords,3);
00296 exit(1);
00297 }
00298 variables[i]->el[0] = GetVar(words[2],1);
00299 break;
00300 case LIST:
00301 case TLIST:
00302 if (nwords != 3)
00303 {
00304 printf("bad type specification for variable \"%s\"\n", words[0]);
00305 printf("only %d argument given and %d are expected\n", nwords,3);
00306 exit(1);
00307 }
00308 ReadListFile(words[2],words[0],i);
00309 break;
00310 case POLYNOM:
00311 case MATRIX:
00312 case BMATRIX:
00313 case STRINGMAT:
00314 if (nwords != 4)
00315 {
00316 printf("bad type specification for variable \"%s\"\n",words[0]);
00317 printf("%d argument given and %d are expected\n", nwords,4);
00318 exit(1);
00319 }
00320 variables[i]->el[0] = GetVar(words[2],1);
00321 variables[i]->el[1] = GetVar(words[3],1);
00322 break;
00323 case IMATRIX:
00324 if (nwords != 5)
00325 {
00326 printf("bad type specification for variable \"%s\"\n",words[0]);
00327 printf("%d argument given and %d are expected\n", nwords,5);
00328 exit(1);
00329 }
00330 variables[i]->el[0] = GetVar(words[2],1);
00331 variables[i]->el[1] = GetVar(words[3],1);
00332 variables[i]->el[2] = GetVar(words[4],1);
00333 break;
00334 case SPARSE:
00335 if (nwords != 6)
00336 {
00337 printf("bad type specification for variable \"%s\"\n",words[0]);
00338 printf("%d argument given and %d are expected\n", nwords,6);
00339 printf("name sparse m n nel it\n");
00340 exit(1);
00341 }
00342 variables[i]->el[0] = GetVar(words[2],1);
00343 variables[i]->el[1] = GetVar(words[3],1);
00344 variables[i]->el[2] = GetVar(words[4],1);
00345 variables[i]->el[3] = GetVar(words[5],1);
00346 break;
00347 case SEQUENCE:
00348 printf("variable \"%s\" cannot have type \"SEQUENCE\"\n",
00349 words[0]);
00350 exit(1);
00351 break;
00352 case EMPTY:
00353 printf("variable \"%s\" cannot have type \"EMPTY\"\n",
00354 words[0]);
00355 exit(1);
00356 break;
00357 }
00358 }
00359 }
00360 else if (fline1 == 1)
00361 {
00362
00363 forsub->name = (char *)malloc((unsigned)(strlen(words[0])+1));
00364 strcpy(forsub->name,words[0]);
00365 i = nwords - 1;
00366 if (i > MAXARG)
00367 {
00368 printf("too many argument for FORTRAN subroutine \"%s\"\n",
00369 words[0]);
00370 printf(" augment constant \"MAXARG\" and recompile intersci\n");
00371 exit(1);
00372 }
00373 forsub->narg = i;
00374 for (i = 0; i < nwords - 1; i++)
00375 {
00376 forsub->arg[i] = GetExistVar(words[i+1]);
00377 }
00378 fline1 = 0;
00379 infor = 1;
00380 }
00381 else if (infor == 1)
00382 {
00383 if (nwords == 0)
00384 {
00385
00386 infor = 0;
00387 out1 = 1;
00388 }
00389 else
00390 {
00391
00392 if (nwords == 1)
00393 {
00394 printf("type missing for FORTRAN argument \"%s\"\n",
00395 words[0]);
00396 exit(1);
00397 }
00398 ivar = GetExistVar(words[0]);
00399 ftype = GetForType(words[1]);
00400 variables[ivar-1]->for_type = ftype;
00401 if (ftype == EXTERNAL)
00402 {
00403 strcpy((char *)(variables[ivar-1]->fexternal),words[1]);
00404 switch (variables[ivar-1]->type)
00405 {
00406 case COLUMN:
00407 case POLYNOM:
00408 case ROW:
00409 case STRING:
00410 case VECTOR:
00411 sprintf(str,"ne%d",ivar);
00412 AddForName(variables[ivar-1]->el[0],str);
00413 break;
00414 case SPARSE:
00415 sprintf(str,"me%d",ivar);
00416 AddForName(variables[ivar-1]->el[0],str);
00417 sprintf(str,"ne%d",ivar);
00418 AddForName(variables[ivar-1]->el[1],str);
00419 sprintf(str,"nel%d",ivar);
00420 AddForName(variables[ivar-1]->el[2],str);
00421 sprintf(str,"it%d",ivar);
00422 AddForName(variables[ivar-1]->el[3],str);
00423 break;
00424 case IMATRIX:
00425 sprintf(str,"me%d",ivar);
00426 AddForName(variables[ivar-1]->el[0],str);
00427 sprintf(str,"ne%d",ivar);
00428 AddForName(variables[ivar-1]->el[1],str);
00429 sprintf(str,"it%d",ivar);
00430 AddForName(variables[ivar-1]->el[2],str);
00431 break;
00432 case MATRIX:
00433 case BMATRIX:
00434 case STRINGMAT:
00435 sprintf(str,"me%d",ivar);
00436 AddForName(variables[ivar-1]->el[0],str);
00437 sprintf(str,"ne%d",ivar);
00438 AddForName(variables[ivar-1]->el[1],str);
00439 break;
00440 default:
00441 printf("FORTRAN argument \"%s\" with external type \"%s\"\n",
00442 variables[ivar-1]->name,words[1]);
00443 printf(" cannot have a variable type of \"%s\" \n",SGetSciType(variables[ivar-1]->type));
00444 exit(1);
00445 break;
00446 }
00447 }
00448 }
00449 }
00450 else if (out1 == 1)
00451 {
00452
00453 i = ivar - 1;
00454 if (nwords == 1)
00455 {
00456 printf("type missing for output variable \"out\"\n");
00457 exit(1);
00458 }
00459 ivar = GetOutVar(words[0]);
00460 basfun->out = ivar;
00461 i = ivar - 1;
00462 type = GetBasType(words[1]);
00463 variables[i]->type = type;
00464 switch (type)
00465 {
00466 case LIST:
00467 case TLIST:
00468 case SEQUENCE:
00469 l = nwords - 2;
00470 if (l > MAXEL)
00471 {
00472 printf("list or sequence too long for output variable \"out\"\n");
00473 printf(" augment constant \"MAXEL\" and recompile intersci\n");
00474 exit(1);
00475 }
00476 for (j = 0; j < l; j++)
00477 variables[i]->el[j] = GetExistVar(words[j+2]);
00478 variables[i]->length = l;
00479 break;
00480 case EMPTY:
00481 break;
00482 default:
00483 printf("output variable \"out\" of SCILAB function\n");
00484 printf(" must have type \"LIST\", \"TLIST\", \"SEQUENCE\" or\n");
00485 printf(" \"EMPTY\"\n");
00486 exit(1);
00487 break;
00488 }
00489 out1 = 0;
00490 }
00491 else
00492 {
00493
00494 ivar = GetExistVar(words[0]);
00495 i = ivar -1 ;
00496 variables[i]->equal = GetExistVar(words[1]);
00497 }
00498 }
00499
00500 return(0);
00501 }
00502
00503
00504
00505
00506
00507
00508
00509
00510 int ParseScilabLine(s,words)
00511 char *s, *words[];
00512 {
00513 char w[MAXNAM];
00514 int nwords = 0;
00515 int inword = 1;
00516 int inopt1 = 0;
00517 int inopt2 = 0;
00518 int i = 0;
00519 if (*s == ' ' || *s == '\t') inword = 0;
00520 if (*s == '{') inopt1 = 1;
00521 if (*s == '[') inopt2 = 1;
00522 while (*s) {
00523 if (inopt1) {
00524 w[i++] = *s++;
00525 if (*s == '{' || *s == '[' || *s == ']' || *s == '\n') {
00526 printf("Bad syntax for optional argument. No matching \"}\"\n");
00527 exit(1);
00528 }
00529 else if (*s == '}') {
00530 w[i++] = '\n';
00531 w[i] = '\0';
00532 words[nwords] = (char *)malloc((unsigned)(i+1));
00533 strcpy(words[nwords],w);
00534 nwords++;
00535 inopt1 = 0;
00536 inword = 0;
00537 }
00538 }
00539 else if (inopt2) {
00540 w[i++] = *s++;
00541 if (*s == '[' || *s == '{' || *s == '}' || *s == '\n') {
00542 printf("Bad syntax for optional argument. No matching \"]\"\n");
00543 exit(1);
00544 }
00545 else if (*s == ']') {
00546 w[i++] = '\n';
00547 w[i] = '\0';
00548 words[nwords] = (char *)malloc((unsigned)(i+1));
00549 strcpy(words[nwords],w);
00550 nwords++;
00551 inopt2 = 0;
00552 inword = 0;
00553 }
00554 }
00555 else if (inword) {
00556 w[i++] = *s++;
00557 if (*s == ' ' || *s == '\t' || *s == '\n') {
00558 w[i] = '\0';
00559 words[nwords] = (char *)malloc((unsigned)(i+1));
00560 strcpy(words[nwords],w);
00561 nwords++;
00562 inword = 0;
00563 }
00564 }
00565 else {
00566 s++;
00567 if (*s != ' ' && *s != '\t') {
00568
00569 i = 0;
00570 inword = 1;
00571 if (*s == '{') inopt1 = 1;
00572 if (*s == '[') inopt2 = 1;
00573 }
00574 }
00575 }
00576 return(nwords);
00577 }
00578
00579
00580
00581 int ParseLine(s,words)
00582 char *s, *words[];
00583 {
00584 char w[MAXNAM];
00585 int nwords = 0;
00586 int inword = 1;
00587 int i = 0;
00588 if(*s == ' ' || *s == '\t') inword = 0;
00589 while (*s) {
00590 if (inword) {
00591 w[i++] = *s++;
00592 if (*s == ' ' || *s == '\t' || *s == '\n') {
00593 w[i] = '\0';
00594 words[nwords] = (char *)malloc((unsigned)(i+1));
00595 strcpy(words[nwords],w);
00596 nwords++;
00597 inword = 0;
00598 }
00599 }
00600 else {
00601 s++;
00602 if (*s != ' ' && *s != '\t') {
00603 i = 0;
00604 inword = 1;
00605 }
00606 }
00607 }
00608 return(nwords);
00609 }
00610
00611
00612
00613 void ReadListFile(listname,varlistname,ivar)
00614 char *listname;
00615 char *varlistname;
00616 IVAR ivar;
00617 {
00618 FILE *fin;
00619 char filin[MAXNAM];
00620 int nel;
00621
00622 sprintf(filin,"%s.list",listname);
00623 fin = fopen(filin,"r");
00624 if (fin == 0)
00625 {
00626 printf("description file for list or tlist \"%s\" does not exist\n",
00627 filin);
00628 exit(1);
00629 }
00630 printf("reading description file for list or tlist \"%s\"\n", listname);
00631
00632 nel = 0;
00633 while(ReadListElement(fin,varlistname,ivar,nel))
00634 {
00635 nel++;
00636 }
00637
00638 fclose(fin);
00639 }
00640
00641 int ReadListElement(f,varlistname,iivar,nel)
00642 FILE *f;
00643 char *varlistname;
00644 int nel;
00645 IVAR iivar;
00646 {
00647 char s[MAXLINE];
00648 char *words[MAXLINE];
00649 int i, nline, nwords, type;
00650 IVAR ivar;
00651 char str[MAXNAM];
00652 nline = 0;
00653 while (fgets(s,MAXLINE,f) != NULL)
00654 {
00655
00656 nline++;
00657 switch (nline)
00658 {
00659 case 1:
00660 break;
00661 case 2:
00662
00663 nwords = ParseLine(s,words);
00664 sprintf(str,"%s(%s)",words[0],varlistname);
00665 ivar = GetVar(str,0);
00666 i = ivar - 1;
00667 if (nwords == 1)
00668 {
00669 printf("type missing for variable \"%s\"\n",words[0]);
00670 exit(1);
00671 }
00672 type = GetBasType(words[1]);
00673 variables[i]->type = type;
00674 variables[i]->list_name = (char *)malloc((unsigned)(strlen(varlistname)+1));
00675 strcpy(variables[i]->list_name,varlistname);
00676 variables[i]->list_el = nel+1;
00677 sprintf(str,"stk(l%de%d)",iivar+1,nel+1);
00678 AddForName(ivar,str);
00679 switch (type)
00680 {
00681 case SCALAR:
00682 case ANY:
00683 break;
00684 case COLUMN:
00685 case ROW:
00686 case STRING:
00687 case VECTOR:
00688 if (nwords != 3)
00689 {
00690 printf("bad type for variable \"%s\"\n",
00691 words[0]);
00692 exit(1);
00693 }
00694 if (isdigit(words[2][0]))
00695 {
00696 variables[i]->el[0] = GetVar(words[2],0);
00697 }
00698 else
00699 {
00700 sprintf(str,"%s(%s)",words[2],varlistname);
00701 variables[i]->el[0] = GetVar(str,0);
00702 }
00703 break;
00704 case POLYNOM:
00705 case MATRIX:
00706 case BMATRIX:
00707 case STRINGMAT:
00708 if (nwords != 4)
00709 {
00710 printf("bad type for variable \"%s\"\n",
00711 words[0]);
00712 exit(1);
00713 }
00714 if (isdigit(words[2][0]))
00715 {
00716 variables[i]->el[0] = GetVar(words[2],0);
00717 }
00718 else
00719 {
00720 sprintf(str,"%s(%s)",words[2],varlistname);
00721 variables[i]->el[0] = GetVar(str,0);
00722 }
00723 if (isdigit(words[3][0]))
00724 {
00725 variables[i]->el[1] = GetVar(words[3],0);
00726 }
00727 else
00728 {
00729 sprintf(str,"%s(%s)",words[3],varlistname);
00730 variables[i]->el[1] = GetVar(str,0);
00731 }
00732 break;
00733 case IMATRIX:
00734 if (nwords != 6)
00735 {
00736 printf("bad type for variable \"%s\"\n",
00737 words[0]);
00738 exit(1);
00739 }
00740 if (isdigit(words[2][0]))
00741 {
00742 variables[i]->el[0] = GetVar(words[2],0);
00743 }
00744 else
00745 {
00746 sprintf(str,"%s(%s)",words[2],varlistname);
00747 variables[i]->el[0] = GetVar(str,0);
00748 }
00749 if (isdigit(words[3][0]))
00750 {
00751 variables[i]->el[1] = GetVar(words[3],0);
00752 }
00753 else
00754 {
00755 sprintf(str,"%s(%s)",words[3],varlistname);
00756 variables[i]->el[1] = GetVar(str,0);
00757 }
00758 sprintf(str,"%s(%s)",words[4],varlistname);
00759 variables[i]->el[2] = GetVar(str,0);
00760 break;
00761 case SPARSE:
00762 if (nwords != 6)
00763 {
00764 printf("bad type for variable \"%s\"\n",
00765 words[0]);
00766 exit(1);
00767 }
00768 if (isdigit(words[2][0]))
00769 {
00770 variables[i]->el[0] = GetVar(words[2],0);
00771 }
00772 else
00773 {
00774 sprintf(str,"%s(%s)",words[2],varlistname);
00775 variables[i]->el[0] = GetVar(str,0);
00776 }
00777 if (isdigit(words[3][0]))
00778 {
00779 variables[i]->el[1] = GetVar(words[3],0);
00780 }
00781 else
00782 {
00783 sprintf(str,"%s(%s)",words[3],varlistname);
00784 variables[i]->el[1] = GetVar(str,0);
00785 }
00786 if (isdigit(words[4][0]))
00787 {
00788 variables[i]->el[2] = GetVar(words[4],0);
00789 }
00790 else
00791 {
00792 sprintf(str,"%s(%s)",words[4],varlistname);
00793 variables[i]->el[2] = GetVar(str,0);
00794 }
00795 sprintf(str,"%s(%s)",words[5],varlistname);
00796 variables[i]->el[3] = GetVar(str,0);
00797 break;
00798 case WORK:
00799 case SEQUENCE:
00800 case EMPTY:
00801 case LIST:
00802 case TLIST:
00803 printf("variable \"%s\" cannot have type \"%s\"\n",
00804 words[0],SGetSciType(type));
00805 exit(1);
00806 default:
00807 printf("variable \"%s\" has unknown type \"%s\"\n",
00808 words[0],SGetSciType(type));
00809 }
00810 break;
00811 default:
00812
00813 if (s[0] == '*')
00814 {
00815 return(1);
00816 }
00817 else
00818 {
00819 printf("bad description file for list or tlist \"%s\"\n",
00820 varlistname);
00821 exit(1);
00822 }
00823 break;
00824 }
00825 }
00826 return(0);
00827 }
00828
00829
00830
00831
00832
00833
00834
00835
00836
00837
00838
00839
00840
00841 IVAR GetVar(name,p)
00842 char *name;
00843 int p;
00844 {
00845 int i;
00846 VARPTR var;
00847 if (strcmp(name,"out") == 0) {
00848 printf("the name of a variable which is not the output variable\n");
00849 printf(" of SCILAB function cannot be \"out\"\n");
00850 exit(1);
00851 }
00852 for (i = 0; i < nVariable; i++) {
00853 var = variables[i];
00854 if (strcmp(var->name,name) == 0) {
00855 var->present = var->present || p;
00856 return(i+1);
00857 }
00858 }
00859 if (nVariable == MAXVAR) {
00860 printf("too many variables\n");
00861 printf(" augment constant \"MAXVAR\" and recompile intersci\n");
00862 exit(1);
00863 }
00864 var = VarAlloc();
00865 if (var == 0) {
00866 printf("Running out of memory\n");
00867 exit(1);
00868 }
00869 var->name = (char *)malloc((unsigned)(strlen(name) + 1));
00870 strcpy(var->name,name);
00871 var->type = 0;
00872 var->length = 0;
00873 var->for_type = 0;
00874 var->equal = 0;
00875 var->nfor_name = 0;
00876 var->kp_state = -1;
00877 var->list_el = 0;
00878 var->opt_type = 0;
00879 var->present = p;
00880 variables[nVariable++] = var;
00881 return(nVariable);
00882 }
00883
00884
00885
00886 IVAR GetExistVar(name)
00887 char *name;
00888 {
00889 int i;
00890 VARPTR var;
00891 if (strcmp(name,"out") == 0) {
00892 printf("the name of a variable which is not the output variable\n");
00893 printf(" of SCILAB function cannot be \"out\"\n");
00894 exit(1);
00895 }
00896 for (i = 0; i < nVariable; i++) {
00897 var = variables[i];
00898 if (strcmp(var->name,name) == 0) {
00899
00900 var->present = 1;
00901 return(i+1);
00902 }
00903 }
00904 i=CreatePredefVar(name);
00905 if ( i != -1) return(i);
00906 printf("variable \"%s\" must exist\n",name);
00907 exit(1);
00908 }
00909
00910
00911
00912
00913
00914
00915 int CreatePredefVar(name)
00916 char *name;
00917 {
00918 VARPTR var;
00919 if (strcmp(name,"err") == 0
00920 || strcmp(name,"rhs") == 0
00921 || strcmp(name,"lhs") == 0
00922 || strcmp(name,"fname") == 0)
00923 {
00924 int num ;
00925 num=GetVar(name,1);
00926 var = variables[num-1];
00927 var->for_type = PREDEF;
00928 return(num);
00929 }
00930 return(-1);
00931 }
00932
00933
00934
00935
00936 IVAR GetOutVar(name)
00937 char *name;
00938 {
00939 VARPTR var;
00940 if (strcmp(name,"out") != 0) {
00941 printf("the name of output variable of SCILAB function\n");
00942 printf(" must be \"out\"\n");
00943 exit(1);
00944 }
00945 if (nVariable == MAXVAR) {
00946 printf("too many variables\n");
00947 printf(" augmente constant \"MAXVAR\" and recompile intersci\n");
00948 exit(1);
00949 }
00950 var = VarAlloc();
00951 if (var == 0) {
00952 printf("Running out of memory\n");
00953 exit(1);
00954 }
00955 var->name = (char *)malloc((unsigned)(strlen(name) + 1));
00956 strcpy(var->name,name);
00957 var->type = 0;
00958 var->length = 0;
00959 var->for_type = 0;
00960 var->equal = 0;
00961 var->nfor_name = 0;
00962 var->kp_state = -1;
00963 var->list_el = 0;
00964 var->opt_type = 0;
00965 var->present = 0;
00966 variables[nVariable++] = var;
00967 return(nVariable);
00968 }
00969
00970
00971
00972
00973 IVAR GetExistOutVar()
00974 {
00975 int i;
00976 char str[4];
00977 strcpy(str,"out");
00978 for (i = 0; i < nVariable; i++) {
00979 if (strcmp(variables[i]->name,str) == 0)
00980 return(i+1);
00981 }
00982 printf("variable \"out\" must exist\n");
00983 exit(1);
00984 }
00985
00986
00987
00988
00989
00990
00991 void AddForName(ivar,name)
00992 IVAR ivar;
00993 char* name;
00994 {
00995 VARPTR var;
00996 int l;
00997 var = variables[ivar-1];
00998 l = var->nfor_name;
00999 if (l == MAXARG) {
01000 printf("too many \"for_name\" for variable \"%s\"\n",var->name);
01001 printf(" augment constant \"MAXARG\" and recompile intersci\n");
01002 exit(1);
01003 }
01004 var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1));
01005 strcpy(var->for_name[l],name);
01006 var->nfor_name = l + 1;
01007 }
01008
01009 void AddForName1(ivar,name)
01010 IVAR ivar;
01011 char* name;
01012 {
01013 VARPTR var;
01014 int l;
01015 var = variables[ivar-1];
01016 l = var->nfor_name;
01017 if ( pass == 0 && var->kp_state == -1 )
01018 {
01019 var->kp_state = var->nfor_name ;
01020 }
01021 if (l == MAXARG) {
01022 printf("too many \"for_name\" for variable \"%s\"\n",var->name);
01023 printf(" augment constant \"MAXARG\" and recompile intersci\n");
01024 exit(1);
01025 }
01026 var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1));
01027 strcpy(var->for_name[l],name);
01028 var->nfor_name = l + 1;
01029 }
01030
01031 void ForNameClean()
01032 {
01033 VARPTR var;
01034 int i;
01035 for (i = 0; i < nVariable; i++) {
01036 var = variables[i];
01037 if ( var->kp_state != -1 )
01038 {
01039 var->nfor_name = var->kp_state ;
01040 }
01041 }
01042 }
01043
01044 void ChangeForName(ivar,name)
01045 IVAR ivar;
01046 char* name;
01047 {
01048 VARPTR var;
01049 int l;
01050 var = variables[ivar-1];
01051 l = var->nfor_name;
01052 var->for_name[0] = (char *)malloc((unsigned)(strlen(name) + 1));
01053 strcpy(var->for_name[0],name);
01054
01055 if (l == 0) var->nfor_name = 1;
01056 }
01057
01058
01059
01060
01061
01062
01063
01064
01065
01066 static struct btype { char *sname ;
01067 int code ;}
01068 SType[] = {
01069 {"any", ANY},
01070 {"bmatrix", BMATRIX},
01071 {"bpointer", SCIBPOINTER},
01072 {"column", COLUMN},
01073 {"empty", EMPTY},
01074 {"imatrix", IMATRIX},
01075 {"list", LIST},
01076 {"lpointer", SCILPOINTER},
01077 {"matrix", MATRIX},
01078 {"mpointer", SCIMPOINTER},
01079 {"opointer", SCIOPOINTER},
01080 {"polynom", POLYNOM},
01081 {"row", ROW},
01082 {"scalar", SCALAR},
01083 {"sequence", SEQUENCE},
01084 {"smpointer", SCISMPOINTER},
01085 {"sparse", SPARSE},
01086 {"string", STRING},
01087 {"stringmat", STRINGMAT},
01088 {"tlist", TLIST},
01089 {"vector", VECTOR},
01090 {"work", WORK},
01091 {(char *) 0 , -1}
01092 };
01093
01094
01095
01096 int GetBasType(sname)
01097 char *sname;
01098 {
01099 int i=0;
01100 while ( SType[i].sname != (char *) NULL)
01101 {
01102 int j ;
01103 j = strcmp(sname,SType[i].sname);
01104 if ( j == 0 )
01105 {
01106 return(SType[i].code);
01107 }
01108 else
01109 {
01110 if ( j <= 0)
01111 break;
01112 else i++;
01113 }
01114 }
01115 printf("the type of variable \"%s\" is unknown\n",sname);
01116 exit(1);
01117 }
01118
01119
01120
01121 char *SGetSciType(type)
01122 int type;
01123 {
01124 int i=0;
01125 while ( SType[i].code != -1 )
01126 {
01127 if ( SType[i].code == type )
01128 return(SType[i].sname);
01129 else
01130 i++;
01131 }
01132 return("unknown");
01133 }
01134
01135
01136
01137 static struct ftype { char *fname ;
01138 int code ;}
01139 FType[] = {
01140 {"Cstringv",CSTRINGV},
01141 {"bpointer",BPOINTER},
01142 {"char",CHAR},
01143 {"double", DOUBLE},
01144 {"int",INT},
01145 {"integer",INT},
01146 {"lpointer",LPOINTER},
01147 {"mpointer",MPOINTER},
01148 {"opointer",OPOINTER},
01149 {"predef",PREDEF},
01150 {"real",REAL},
01151 {"smpointer",SMPOINTER},
01152 {(char *) 0 , -1}
01153 };
01154
01155
01156
01157
01158 int GetForType(type)
01159 char *type;
01160 {
01161 int i=0;
01162 while ( FType[i].fname != (char *) NULL)
01163 {
01164 int j;
01165 j = strcmp(type,FType[i].fname);
01166 if ( j == 0 )
01167 {
01168 return(FType[i].code);
01169 }
01170 else
01171 {
01172 if ( j <= 0)
01173 break;
01174 else i++;
01175 }
01176 }
01177 return(EXTERNAL);
01178 }
01179
01180
01181
01182 char *SGetForType(type)
01183 int type;
01184 {
01185 int i=0;
01186 while ( FType[i].code != -1 )
01187 {
01188 if ( FType[i].code == type )
01189 return(FType[i].fname);
01190 else
01191 i++;
01192 }
01193 return("External");
01194 }
01195
01196
01197
01198
01199
01200
01201 void WriteMainHeader(f,fname)
01202 FILE *f;
01203 char* fname;
01204 {
01205 char *scidir;
01206 Fprintf(f,indent,"subroutine %s\n",fname);
01207 scidir = getenv("SCI");
01208 if ( scidir != NULL)
01209 Fprintf(f,indent,"include '%s/routines/stack.h'\n",scidir);
01210 else
01211 Fprintf(f,indent,"include 'SCIDIR/routines/stack.h'\n");
01212 Fprintf(f,indent,"rhs = max(0,rhs)\n");
01213 FCprintf(f,"c\n");
01214 }
01215
01216
01217 void WriteHeader(f,fname0,fname)
01218 FILE *f;
01219 char* fname,*fname0;
01220 {
01221 char *scidir;
01222 Fprintf(f,indent,"subroutine %s%s(fname)\n",fname0,fname);
01223 FCprintf(f,"c\n");
01224 Fprintf(f,indent,"character*(*) fname\n");
01225 scidir = getenv("SCI");
01226 if ( scidir != NULL)
01227 Fprintf(f,indent,"include '%s/routines/stack.h'\n",scidir);
01228 else
01229 Fprintf(f,indent,"include 'SCIDIR/routines/stack.h'\n");
01230 FCprintf(f,"c\n");
01231 Fprintf(f,indent,"integer iadr, sadr\n");
01232 WriteDeclaration(f);
01233 Fprintf(f,indent,"iadr(l)=l+l-1\n");
01234 Fprintf(f,indent,"sadr(l)=(l/2)+1\n");
01235 Fprintf(f,indent,"rhs = max(0,rhs)\n");
01236 FCprintf(f,"c\n");
01237 }
01238
01239 void WriteFunctionCode(f)
01240 FILE* f;
01241 {
01242 int i;
01243 IVAR ivar;
01244 icre=1;
01245 if ( pass == 1)
01246 {
01247 printf(" generating code for SCILAB function\"%s\"\n",
01248 basfun->name);
01249 printf(" and FORTRAN subroutine\"%s\"\n",forsub->name);
01250 }
01251 FCprintf(f,"c SCILAB function : %s, fin = %d\n",basfun->name,nFun);
01252 WriteHeader(f,"ints",basfun->name);
01253
01254
01255 for (i = 0; i < forsub->narg; i++)
01256 {
01257 if (variables[forsub->arg[i]-1]->for_type == CHAR)
01258 {
01259 Fprintf(f,indent,"lbuf = 1\n");
01260 break;
01261 }
01262 }
01263
01264
01265
01266 AddDeclare(DEC_INT,"topk");
01267 AddDeclare(DEC_INT,"rhsk");
01268 Fprintf(f,indent,"topk = top \n");
01269 Fprintf(f,indent,"rhsk = rhs \n");
01270
01271
01272 AddDeclare(DEC_LOGICAL,"checkrhs");
01273 Fprintf(f,indent,"if(.not.checkrhs(fname,%d,%d)) return\n",basfun->nin - maxOpt,basfun->nin);
01274
01275
01276 ivar = basfun->out;
01277 if ((variables[ivar-1]->length == 0) || (variables[ivar-1]->type == LIST)
01278 || (variables[ivar-1]->type == TLIST))
01279 {
01280 AddDeclare(DEC_LOGICAL,"checklhs");
01281 Fprintf(f,indent,"if(.not.checklhs(fname,1,1)) return\n");
01282 }
01283 else
01284 {
01285 AddDeclare(DEC_LOGICAL,"checklhs");
01286 Fprintf(f,indent,"if(.not.checklhs(fname,1,%d)) return\n",variables[ivar-1]->length);
01287 }
01288
01289
01290 for (i = 0; i < basfun->nin; i++)
01291 {
01292 switch ( variables[i]->type )
01293 {
01294 case LIST :
01295 case TLIST:
01296 WriteListAnalysis(f,i);
01297 break;
01298 default:
01299 WriteArgCheck(f,i);
01300 break;
01301 }
01302 }
01303
01304
01305
01306 WriteCrossCheck(f);
01307
01308
01309 WriteEqualCheck(f);
01310
01311
01312 WriteFortranCall(f);
01313
01314
01315 WriteOutput(f);
01316 }
01317
01318
01319 void WriteInfoCode(f)
01320 FILE* f;
01321 {
01322 int i,iout;
01323 IVAR ivar;
01324 VARPTR var,vout;
01325
01326 iout = GetExistOutVar();
01327 vout = variables[iout -1];
01328
01329 switch (vout->type) {
01330 case LIST:
01331 case TLIST:
01332
01333 printf("list(");
01334 for (i = 0; i < vout->length; i++)
01335 {
01336 ivar = vout->el[i];
01337 var = variables[ivar-1];
01338 printf("%s",var->name);
01339 if ( i != vout->length -1 )
01340 printf(",");
01341 else
01342 printf(")");
01343 }
01344 break ;
01345 case SEQUENCE:
01346
01347 printf("[");
01348 for (i = 0; i < vout->length; i++)
01349 {
01350 ivar = vout->el[i];
01351 var = variables[ivar-1];
01352 printf("%s",var->name);
01353 if ( i != vout->length -1 )
01354 printf(",");
01355 else
01356 printf("]");
01357 }
01358 break;
01359 case EMPTY:
01360 printf("[]\n");
01361 break;
01362 }
01363
01364 printf("=%s(",basfun->name);
01365 for (i = 0; i < basfun->nin; i++)
01366 {
01367 printf("%s(%s)",variables[i]->name,SGetSciType(variables[i]->type));
01368 if ( i != basfun->nin -1 )
01369 printf(",");
01370 }
01371 printf(")\n");
01372
01373 }
01374
01375
01376
01377
01378
01379 void WriteArgCheck(f,i)
01380 FILE *f;
01381 int i;
01382 {
01383 int i1;
01384 char str[MAXNAM];
01385 char str1[MAXNAM];
01386 char size[MAXNAM];
01387 char data[MAXNAM];
01388
01389 VARPTR var = variables[basfun->in[i]-1];
01390 i1 = i + 1;
01391
01392 FCprintf(f,"c checking variable %s (number %d)\n",var->name,i1);
01393 FCprintf(f,"c \n");
01394
01395
01396 if (var->opt_type != 0)
01397 {
01403 Fprintf(f,indent++,"if(rhs .le. %d) then\n", i1-1 );
01404 switch (var->opt_type) {
01405 case NAME:
01406 AddDeclare(DEC_LOGICAL,"optvarget");
01407 Fprintf(f,indent,"if (.not.optvarget(fname,topk,%d,'%s ')) return\n",i1,var->opt_name);
01408 break;
01409 case VALUE:
01410 switch (var->type) {
01411 case SCALAR:
01412 AddDeclare(DEC_LOGICAL,"cremat");
01413 Fprintf(f,indent,"top = top+1\n");
01414 Fprintf(f,indent,"rhs = rhs+1\n");
01415 Fprintf(f,indent,"if(.not.cremat(fname,top,0,1,1,lr%d,lc%d)) return\n",i1,i1);
01416 Fprintf(f,indent,"stk(lr%d)= %s\n",i1,var->opt_name);
01417 break;
01418 case SCISMPOINTER:
01419 case SCILPOINTER:
01420 case SCIBPOINTER:
01421 case SCIOPOINTER:
01422 case SCIMPOINTER:
01423 sprintf(buf,"cre%s", SGetSciType(var->type));
01424 AddDeclare(DEC_LOGICAL,buf);
01425 Fprintf(f,indent,"top = top+1\n");
01426 Fprintf(f,indent,"rhs = rhs+1\n");
01427 Fprintf(f,indent,"if(.not.cre%s(fname,top,lwv)) return\n", SGetSciType(var->type));
01428 break;
01429 case MATRIX:
01430 OptvarGetSize(var->opt_name,size,data);
01431 AddDeclare(DEC_LOGICAL,"cremat");
01432 Fprintf(f,indent,"top = top+1\n");
01433 Fprintf(f,indent,"rhs = rhs+1\n");
01434 sprintf(str,"dat%d %s",i1,data);
01435 AddDeclare(DEC_DATA,str);
01436 sprintf(str,"dat%d(%s)",i1,size);
01437 AddDeclare(DEC_DOUBLE,str);
01438 Fprintf(f,indent,"m%d = 1\n",i1);
01439 Fprintf(f,indent,"n%d = %s\n",i1,size);
01440 Fprintf(f,indent,"if(.not.cremat(fname,top,0,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1);
01441 Fprintf(f,indent,"call dcopy(%s,dat%d,1,stk(lr%d),1)\n",size,i1,i1);
01442 break;
01443 case STRING:
01444 AddDeclare(DEC_LOGICAL,"cresmat2");
01445 Fprintf(f,indent,"top = top+1\n");
01446 Fprintf(f,indent,"rhs = rhs+1\n");
01447 Fprintf(f,indent,"nlr%d = %d\n",i1,strlen(var->opt_name));
01448 Fprintf(f,indent,"if(.not.cresmat2(fname,top,nlr%d,lr%d)) return\n",i1,i1,i1);
01449 Fprintf(f,indent,"call cvstr(nlr%d,istk(lr%d),'%s',0)\n",i1,i1,var->opt_name);
01450 break;
01451 default:
01452 printf("Optional variable with value must be \"SCALAR\" or \"STRING\"\n");
01453 exit(1);
01454 break;
01455 }
01456 break;
01457 }
01458 Fprintf(f,--indent,"endif\n");
01459 }
01460
01461
01462 switch(var->type)
01463 {
01464 case BMATRIX:
01465 AddDeclare(DEC_LOGICAL,"getbmat");
01466 Fprintf(f,indent,"if(.not.getbmat(fname,top,top-rhs+%d,m%d,n%d,lr%d)) return\n",i1,i1,i1,i1);
01467
01468 if (var->el[0] == var->el[1]) {
01469
01470 AddDeclare(DEC_LOGICAL,"checkval");
01471 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
01472 }
01473 sprintf(str,"m%d",i1);
01474 Check(f,str,var,i1,0);
01475 sprintf(str,"n%d",i1);
01476 Check(f,str,var,i1,1);
01477 break;
01478 case MATRIX:
01479 case IMATRIX:
01480 AddDeclare(DEC_LOGICAL,"getmat");
01481 Fprintf(f,indent,"if(.not.getmat(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
01482
01483 if (var->el[0] == var->el[1]) {
01484
01485 AddDeclare(DEC_LOGICAL,"checkval");
01486 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
01487 }
01488 sprintf(str,"m%d",i1);
01489 Check(f,str,var,i1,0);
01490 sprintf(str,"n%d",i1);
01491 Check(f,str,var,i1,1);
01492 sprintf(str,"it%d",i1);
01493 if (var->type == IMATRIX ) AddForName1(var->el[2],str);
01494 break;
01495 case SPARSE:
01496 AddDeclare(DEC_LOGICAL,"getsparse");
01497 Fprintf(f,indent,"if(.not.getsparse(fname,top,top-rhs+%d,it%d,m%d,n%d,nel%d,mnel%d,icol%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1,i1,i1,i1);
01498
01499 if (var->el[0] == var->el[1]) {
01500
01501 AddDeclare(DEC_LOGICAL,"checkval");
01502 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
01503 }
01504 sprintf(str,"m%d",i1);
01505 Check(f,str,var,i1,0);
01506 sprintf(str,"n%d",i1);
01507 Check(f,str,var,i1,1);
01508 sprintf(str,"nel%d",i1);
01509 AddForName1(var->el[2],str);
01510 sprintf(str,"it%d",i1);
01511 AddForName1(var->el[3],str);
01512 break;
01513 case STRINGMAT:
01514 AddDeclare(DEC_LOGICAL,"getsmat");
01515 Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n",
01516 i1,i1,i1,i1,i1);
01517
01518 if (var->el[0] == var->el[1]) {
01519
01520 AddDeclare(DEC_LOGICAL,"checkval");
01521 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
01522 }
01523 sprintf(str,"m%d",i1);
01524 Check(f,str,var,i1,0);
01525 strcpy(str1,variables[var->el[0]-1]->name);
01526 sprintf(str,"n%d",i1);
01527 Check(f,str,var,i1,1);
01528 break;
01529 case ROW:
01530 AddDeclare(DEC_LOGICAL,"getvectrow");
01531 Fprintf(f,indent,"if(.not.getvectrow(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
01532 sprintf(str,"n%d",i1);
01533 Check(f,str,var,i1,0);
01534 break;
01535 case COLUMN:
01536 AddDeclare(DEC_LOGICAL,"getvectcol");
01537 Fprintf(f,indent,"if(.not.getvectcol(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
01538 sprintf(str,"m%d",i1);
01539 Check(f,str,var,i1,0);
01540 break;
01541 case VECTOR:
01542 AddDeclare(DEC_LOGICAL,"getvect");
01543 Fprintf(f,indent,"if(.not.getvect(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
01544 sprintf(str,"n%d*m%d",i1,i1);
01545 Check(f,str,var,i1,0);
01546 AddForName1(var->el[0],str);
01547 break;
01548 case POLYNOM:
01549 AddDeclare(DEC_LOGICAL,"getonepoly");
01550 sprintf(str,"namelr%d*4",i1);
01551 AddDeclare(DEC_CHAR,str);
01552 Fprintf(f,indent,"if(.not.getonepoly(fname,top,top-rhs+%d,it%d,m%d,namelr%d,namellr%d,lr%d,lc%d)\n",i1,i1,i1,i1,i1,i1,i1);
01553 AddDeclare(DEC_LOGICAL,"checkval");
01554 sprintf(str,"m%d",i1);
01555 Check(f,str,var,i1,0);
01556 AddForName(var->el[0],str);
01557 break;
01558 case SCALAR:
01559 AddDeclare(DEC_LOGICAL,"getscalar");
01560 Fprintf(f,indent,"if(.not.getscalar(fname,top,top-rhs+%d,lr%d)) return\n",i1,i1);
01561 break;
01562 case SCIMPOINTER:
01563 case SCISMPOINTER:
01564 case SCILPOINTER:
01565 case SCIBPOINTER:
01566 case SCIOPOINTER:
01567 sprintf(buf,"get%s", SGetSciType(var->type));
01568 AddDeclare(DEC_LOGICAL,buf);
01569 Fprintf(f,indent,"if(.not.get%s(fname,top,top-rhs+%d,lr%d)) return\n", SGetSciType(var->type),i1,i1);
01570 break;
01571 case STRING:
01572 AddDeclare(DEC_LOGICAL,"getsmat");
01573 Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n",i1,i1,i1,i1,i1,i1,11);
01574 AddDeclare(DEC_LOGICAL,"checkval");
01575 Fprintf(f,indent,"if(.not.checkval(fname,m%d*n%d,1)) return\n",i1,i1);
01576 sprintf(str,"nlr%d",i1);
01577 Check(f,str,var,i1,0);
01578 break;
01579 case ANY:
01580 case LIST:
01581 case TLIST:
01582 break;
01583 default:
01584 printf("unknown variable type %d\n",var->type);
01585 }
01586 }
01587
01588 void OptvarGetSize(optvar,size,data)
01589 char *optvar,*size,*data;
01590 {
01591 int i,j=0,ok=0;
01592 for ( i = 0 ; i < (int) strlen(optvar) ; i++ )
01593 {
01594 if ( optvar[i] == ')' )
01595 {
01596 size[j++] = '\0'; break;
01597 }
01598 if ( ok ==1 ) size[j++]= optvar[i];
01599 if ( optvar[i] == '(' ) ok =1 ;
01600 }
01601 if ( i < (int) strlen(optvar)) strcpy(data,optvar+i+1);
01602 }
01603
01604
01605
01606
01607
01608
01609 void Check(f,str,var,i1,nel)
01610 FILE *f;
01611 char *str;
01612 int i1, nel;
01613 VARPTR var;
01614 {
01615 char str1[MAXNAM];
01616 strcpy(str1,variables[var->el[nel]-1]->name);
01617 if (isdigit(str1[0]) != 0)
01618 {
01619
01620 if ( strcmp(str,str1) != 0)
01621 {
01622 AddDeclare(DEC_LOGICAL,"checkval");
01623 Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",str,str1);
01624 }
01625 }
01626 AddForName1(var->el[nel],str);
01627 }
01628
01629
01630 void WriteCrossCheck(f)
01631 FILE *f;
01632 {
01633 int i, j;
01634 char *n1, *n2;
01635 VARPTR var;
01636 FCprintf(f,"c \n");
01637 FCprintf(f,"c cross variable size checking\n");
01638 FCprintf(f,"c \n");
01639 for (i = 0; i < nVariable; i++) {
01640 var = variables[i];
01641
01642 if (var->nfor_name != 0 && var->list_el == 0) {
01643 if (strncmp(var->for_name[0],"ne",2) != 0 &&
01644 strncmp(var->for_name[0],"me",2) != 0) {
01645 n1 = Forname2Int(var->for_name[0]);
01646 for (j = 1; j < var->nfor_name; j++) {
01647 n2 = Forname2Int(var->for_name[j]);
01648 if ( strcmp(n1,n2) != 0)
01649 {
01650 AddDeclare(DEC_LOGICAL,"checkval");
01651 Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",n1,n2);
01652 }
01653 }
01654 }
01655 }
01656 }
01657
01658
01659
01660 }
01661
01662 void WriteEqualCheck(f)
01663 FILE *f;
01664 {
01665
01666
01667
01668 }
01669
01670 void WriteFortranCall(f)
01671 FILE *f;
01672 {
01673 int i, j, ind;
01674 IVAR ivar, iivar;
01675 char call[MAXCALL];
01676 char str1[8],str2[8];
01677 sprintf(call,"call %s(",forsub->name);
01678
01679 for (i = 0; i < forsub->narg; i++)
01680 {
01681 ivar = forsub->arg[i];
01682 ind = 0;
01683 if (variables[ivar-1]->list_el != 0)
01684 {
01685
01686 iivar = GetExistVar(variables[ivar-1]->list_name);
01687 for (j = 0; j < basfun->nin; j++)
01688 {
01689 if (iivar == basfun->in[j])
01690 {
01691
01692 sprintf(str1,"%de%d",iivar,variables[ivar-1]->list_el);
01693 sprintf(str2,"%de%d",iivar,variables[ivar-1]->list_el);
01694 WriteCallConvertion(f,ivar,str2,str1,call);
01695 ind = 1;
01696 break;
01697 }
01698 }
01699 if (ind == 0)
01700 {
01701 printf("list or tlist \"%s\" must be an argument of SCILAB function\n",
01702 variables[ivar-1]->list_name);
01703 exit(1);
01704 }
01705 }
01706 else
01707 {
01708 for (j = 0; j < basfun->nin; j++)
01709 {
01710 if (ivar == basfun->in[j])
01711 {
01712
01713 sprintf(str1,"%d",j+1);
01714 sprintf(str2,"%d",i+1);
01715 WriteCallConvertion(f,ivar,str2,str1,call);
01716 ind = 1;
01717 break;
01718 }
01719 }
01720 }
01721 if (ind == 0)
01722 {
01723
01724 WriteCallRest(f,ivar,i+1,call);
01725 }
01726 }
01727 if (forsub->narg == 0)
01728 strcat(call,")");
01729 else
01730 call[strlen(call)-1] = ')';
01731 Fprintf(f,indent,call);
01732 Fprintf(f,indent,"\n");
01733
01734
01735
01736
01737
01738
01739
01740 Fprintf(f,indent,"if(err .gt. 0 .or. err1 .gt. 0) return \n");
01741
01742 FCprintf(f,"c\n");
01743 }
01744
01745
01746
01747
01748
01749
01750
01751 void WriteCallConvertion(f,ivar,farg,barg,call)
01752 FILE *f;
01753 IVAR ivar;
01754 char *farg;
01755 char *barg;
01756 char *call;
01757 {
01758 VARPTR var = variables[ivar-1];
01759 char str[MAXNAM];
01760 char str1[MAXNAM];
01761 switch (var->type)
01762 {
01763 case POLYNOM:
01764 case ROW:
01765 case VECTOR:
01766 case SCALAR:
01767 case COLUMN:
01768 case IMATRIX:
01769 case MATRIX:
01770 case SPARSE:
01771 switch ( var->type )
01772 {
01773 case POLYNOM: sprintf(str1,"n%s",barg); break;
01774 case COLUMN: sprintf(str1,"m%s",barg); break ;
01775 case VECTOR: sprintf(str1,"m%s*n%s",barg,barg); break ;
01776 case SCALAR: sprintf(str1,"1"); break ;
01777 case ROW: sprintf(str1,"n%s",barg); break;
01778 case SPARSE: sprintf(str1,"nel%s",barg);break;
01779 case IMATRIX:
01780 case MATRIX: sprintf(str1,"n%s*m%s",barg,barg); break;
01781 }
01782 switch (var->for_type)
01783 {
01784 case CHAR:
01785 case CSTRINGV:
01786 printf("incompatibility between the variable type and the FORTRAN type for variable \"%s\"\n",var->name);
01787 exit(1);
01788 case INT:
01789 Fprintf(f,indent,"call entier(%s,stk(lr%s),istk(iadr(lr%s)))\n",str1,barg,barg);
01790 if (var->type == IMATRIX || var->type == SPARSE)
01791 {
01792 Fprintf(f,indent++,"if (it%s.eq.1) then \n",barg);
01793 Fprintf(f,indent,"call entier(%s,stk(lc%s),istk(iadr(lc%s)))\n",str1,barg,barg);
01794 Fprintf(f,--indent,"endif\n");
01795 if ( var->type == SPARSE)
01796 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),istk(iadr(lr%s)),istk(iadr(lc%s))"
01797 ,barg,barg,barg,barg,barg,barg,barg,barg);
01798 else
01799 sprintf(str,"istk(iadr(lr%s)),istk(iadr(lc%s)),it%s",barg,barg,barg);
01800 ChangeForName(ivar,str);
01801 strcat(call,str);
01802 strcat(call,",");
01803 }
01804 else
01805 {
01806 sprintf(str,"istk(iadr(lr%s))",barg);
01807 ChangeForName(ivar,str);
01808 strcat(call,str);
01809 strcat(call,",");
01810 }
01811 break;
01812 case REAL:
01813 Fprintf(f,indent,"call simple(%s,stk(lr%s),stk(lr%s))\n",str1,barg,barg,barg);
01814 if (var->type == IMATRIX || var->type == SPARSE)
01815 {
01816 Fprintf(f,indent++,"if (it%s.eq.1) then \n",barg);
01817 Fprintf(f,indent,"call simple(%s,stk(lc%s),stk(lc%s))\n",str1,barg,barg);
01818 Fprintf(f,--indent,"endif\n");
01819 if ( var->type == SPARSE)
01820 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s),"
01821 ,barg,barg,barg,barg,barg,barg,barg,barg);
01822 else
01823 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg);
01824 strcat(call,str);
01825 }
01826 else
01827 {
01828 sprintf(str,"stk(lr%s),",barg);
01829 strcat(call,str);
01830 }
01831 break;
01832 case DOUBLE:
01833 if (var->type == IMATRIX)
01834 {
01835 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg);
01836 strcat(call,str);
01837 }
01838 else if (var->type == SPARSE)
01839 {
01840 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s),"
01841 ,barg,barg,barg,barg,barg,barg,barg,barg);
01842 strcat(call,str);
01843 }
01844 else
01845 {
01846 sprintf(str,"stk(lr%s),",barg);
01847 strcat(call,str);
01848 }
01849 break;
01850 }
01851 break;
01852 case BMATRIX:
01853 sprintf(str1,"n%s*m%s",barg,barg);
01854 if (var->for_type != INT)
01855 {
01856 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01857 SGetSciType(var->type),SGetForType(var->for_type),var->name);
01858 exit(1);
01859 }
01860 sprintf(str,"istk(lr%s)",barg);
01861 ChangeForName(ivar,str);
01862 strcat(call,str);
01863 strcat(call,",");
01864 break;
01865 case SCIMPOINTER:
01866 if (var->for_type != MPOINTER)
01867 {
01868 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01869 SGetSciType(var->type),SGetForType(var->for_type),var->name);
01870 exit(1);
01871 }
01872 sprintf(str,"stk(lr%s),",barg);
01873 strcat(call,str);
01874 break;
01875 case SCISMPOINTER:
01876 if (var->for_type != SMPOINTER)
01877 {
01878 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01879 SGetSciType(var->type),SGetForType(var->for_type),var->name);
01880 exit(1);
01881 }
01882 sprintf(str,"stk(lr%s),",barg);
01883 strcat(call,str);
01884 break;
01885 case SCILPOINTER:
01886 if (var->for_type != LPOINTER)
01887 {
01888 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01889 SGetSciType(var->type),SGetForType(var->for_type),var->name);
01890 exit(1);
01891 }
01892 sprintf(str,"stk(lr%s),",barg);
01893 strcat(call,str);
01894 break;
01895 case SCIBPOINTER:
01896 if (var->for_type != BPOINTER)
01897 {
01898 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01899 SGetSciType(var->type),SGetForType(var->for_type),var->name);
01900 exit(1);
01901 }
01902 sprintf(str,"stk(lr%s),",barg);
01903 strcat(call,str);
01904 break;
01905 case SCIOPOINTER:
01906 if (var->for_type != OPOINTER)
01907 {
01908 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01909 SGetSciType(var->type),SGetForType(var->for_type),var->name);
01910 exit(1);
01911 }
01912 sprintf(str,"stk(lr%s),",barg);
01913 strcat(call,str);
01914 break;
01915 case STRINGMAT:
01916 if (var->for_type != CSTRINGV)
01917 {
01918 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01919 SGetSciType(STRINGMAT),SGetForType(var->for_type),var->name);
01920 exit(1);
01921 }
01922 AddDeclare(DEC_LOGICAL,"crestringv");
01923 Fprintf(f,indent,"if(.not.crestringv(fname,top+%d,lr%s-5-m%s*n%s,lw%s)) return\n",icre++,barg,barg,barg,farg);
01924 sprintf(str,"stk(lw%s),",farg);
01925 strcat(call,str);
01926 break;
01927 case LIST:
01928 case TLIST:
01929 case SEQUENCE:
01930 printf("a FORTRAN argument cannot have a variable type of \"LIST\"\n");
01931 printf(" \"TLIST\" or \"SEQUENCE\"\n");
01932 exit(1);
01933 break;
01934 case STRING:
01935 if (var->for_type != CHAR)
01936 {
01937 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
01938 SGetSciType(STRING),SGetForType(var->for_type),var->name);
01939 exit(1);
01940 }
01941 AddDeclare(DEC_LOGICAL,"bufstore");
01942 Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%s,lbuff%s,lr%s,nlr%s)) return\n",farg,farg,barg,barg);
01943 sprintf(str,"buf(lbufi%s:lbuff%s),",farg,farg);
01944 strcat(call,str);
01945 break;
01946 case ANY:
01947 sprintf(str,"istk(il%s),",barg);
01948 strcat(call,str);
01949 break;
01950 }
01951 }
01952
01953
01954
01955
01956
01957
01958
01959 void WriteCallRest(f,ivar,farg,call)
01960 FILE *f;
01961 IVAR ivar;
01962 int farg;
01963 char *call;
01964 {
01965 VARPTR var = variables[ivar-1];
01966 char str[MAXNAM];
01967 char str1[MAXNAM];
01968 char str2[MAXNAM];
01969 char str3[MAXNAM];
01970 char str4[MAXNAM];
01971 switch (var->type)
01972 {
01973 case 0:
01974
01975 if (var->nfor_name == 0 && var->for_type != PREDEF)
01976 {
01977 printf("dimension variable \"%s\" is not defined\n",var->name);
01978 exit(1);
01979 }
01980 switch (var->for_type)
01981 {
01982 case PREDEF:
01983 if ( strcmp(var->name,"rhs") == 0)
01984 sprintf(str,"rhsk");
01985 else
01986 sprintf(str,"%s",var->name);
01987 strcat(call,str);
01988 strcat(call,",");
01989 break;
01990 case 0:
01991 case INT:
01992 sprintf(str,"%s",var->for_name[0]);
01993 if ( ~isdigit(str[0]))
01994 {
01995 strcat(call,str);
01996 strcat(call,",");
01997 }
01998 else
01999 {
02000 Fprintf(f,indent,"locd%d= int(%s)\n",farg,var->for_name[0]);
02001 sprintf(str,"locd%d,",farg);
02002 strcat(call,str);
02003 sprintf(str,"locd%d",farg);
02004 AddDeclare(DEC_INT,str);
02005 }
02006 break;
02007 case DOUBLE:
02008 Fprintf(f,indent,"locd%d= dble(%s)\n",farg,var->for_name[0]);
02009 sprintf(str,"locd%d,",farg);
02010 strcat(call,str);
02011 sprintf(str,"locd%d",farg);
02012 AddDeclare(DEC_DOUBLE,str);
02013 break;
02014 case REAL:
02015 Fprintf(f,indent,"locr%d=real(%s)\n",farg,var->for_name[0]);
02016 sprintf(str,"locr%d,",farg);
02017 strcat(call,str);
02018 sprintf(str,"locr%d",farg);
02019 AddDeclare(DEC_REAL,str);
02020 break;
02021 case CHAR:
02022 case CSTRINGV:
02023 printf("a dimension variable cannot have FORTRAN type \"%s\"\n",SGetForType(var->for_type));
02024 exit(1);
02025 break;
02026 }
02027 break;
02028
02029 case COLUMN:
02030 case ROW:
02031 case WORK:
02032 case POLYNOM:
02033 case VECTOR:
02034 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
02035 if (var->for_type == EXTERNAL)
02036 strcpy(str1,"1");
02037 else
02038 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02039 AddDeclare(DEC_LOGICAL,"cremat");
02040 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,1,lw%d,loc%d)) return\n",icre++,str1,farg,farg);
02041 sprintf(str,"stk(lw%d),",farg);
02042 strcat(call,str);
02043 break;
02044 case SPARSE :
02045 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
02046 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
02047 if (var->for_type == EXTERNAL)
02048 {
02049 strcpy(str1,"1");
02050 strcpy(str2,"1");
02051 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg);
02052 AddDeclare(DEC_LOGICAL,"cremat");
02053 sprintf(str,"stk(lw%d),",farg);
02054 strcat(call,str);
02055 }
02056 else
02057 {
02058 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
02059 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
02060 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
02061 sprintf(str4,"%s",Forname2Int(variables[var->el[3]-1]->for_name[0]));
02062 AddDeclare(DEC_LOGICAL,"cresparse");
02063 Fprintf(f,indent,"if(.not.cresparse(fname,top+%d,%s,%s,%s,%s,mnel%d,icol%d,lw%d,lwc%d)) return\n",icre++,str4,str1,str2,str3,farg,farg,farg,farg);
02064 sprintf(str,"%s,%s,%s,%s,istk(mnel%d),istk(icol%d),stk(lw%d),stk(lwc%d),",
02065 str4,str1,str2,str3,farg,farg,farg,farg);
02066 strcat(call,str);
02067 }
02068 break;
02069 case IMATRIX:
02070 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
02071 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
02072 if (var->for_type == EXTERNAL)
02073 {
02074 strcpy(str1,"1");
02075 strcpy(str2,"1");
02076 strcpy(str3,"1");
02077 }
02078 else
02079 {
02080 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
02081 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
02082 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
02083 };
02084 AddDeclare(DEC_LOGICAL,"cremat");
02085 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,%s,%s,%s,lw%d,lwc%d)) return\n",icre++,str3,str1,str2,farg,farg);
02086 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
02087 sprintf(str,"stk(lw%d),stk(lwc%d),%s,",farg,farg,str3);
02088 strcat(call,str);
02089 break;
02090 case MATRIX:
02091 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
02092 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
02093 if (var->for_type == EXTERNAL)
02094 {
02095 strcpy(str1,"1");
02096 strcpy(str2,"1");
02097 }
02098 else
02099 {
02100 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
02101 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
02102 };
02103 AddDeclare(DEC_LOGICAL,"cremat");
02104 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg);
02105 sprintf(str,"stk(lw%d),",farg);
02106 strcat(call,str);
02107 break;
02108 case BMATRIX:
02109 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
02110 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
02111 if (var->for_type == EXTERNAL)
02112 {
02113 strcpy(str1,"1");
02114 strcpy(str2,"1");
02115 }
02116 else
02117 {
02118 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
02119 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
02120 };
02121 AddDeclare(DEC_LOGICAL,"crebmat");
02122 Fprintf(f,indent,"if(.not.crebmat(fname,top+%d,%s,%s,lw%d)) return\n",icre++,str1,str2,farg);
02123 sprintf(str,"istk(lw%d),",farg);
02124 strcat(call,str);
02125 break;
02126 case SCIMPOINTER:
02127 case SCISMPOINTER:
02128 case SCILPOINTER:
02129 case SCIBPOINTER:
02130 case SCIOPOINTER:
02131 sprintf(buf,"cre%s", SGetSciType(var->type));
02132 AddDeclare(DEC_LOGICAL,buf);
02133 Fprintf(f,indent,"if(.not.cre%s(fname,top+%d,lw%d)) return\n", SGetSciType(var->type),icre++,farg);
02134 sprintf(str,"stk(lw%d),",farg);
02135 strcat(call,str);
02136 break;
02137 case STRINGMAT:
02138 if (var->for_type == EXTERNAL || var->for_type == CSTRINGV )
02139 {
02140
02141
02142 WriteCallRestCheck(f,var,farg,"mm",0,1) ;
02143 WriteCallRestCheck(f,var,farg,"nn",1,1) ;
02144 sprintf(str,"mm%d",farg);
02145 AddForName1(var->el[0],str);
02146 sprintf(str,"nn%d",farg);
02147 AddForName1(var->el[1],str);
02148 AddDeclare(DEC_LOGICAL,"crepointer");
02149 Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg);
02150 sprintf(str,"stk(lw%d),",farg);
02151 strcat(call,str);
02152 }
02153 else
02154 {
02156 fprintf(stderr,"WARNING : your code contains a specification \n");
02157 fprintf(stderr," not fully implemented in intersci \n");
02158 WriteCallRestCheck(f,var,farg,"mm",0,0) ;
02159 WriteCallRestCheck(f,var,farg,"nn",1,0) ;
02160 AddDeclare(DEC_LOGICAL,"cresmatafaire");
02161 Fprintf(f,indent,"if(.not.cresmatafaire(fname,top+%d,lw%d)) return\n",icre++,farg);
02162 sprintf(str,"stk(lw%d),",farg);
02163 strcat(call,str);
02164 }
02165 break;
02166 case SCALAR:
02167 AddDeclare(DEC_LOGICAL,"cremat");
02168 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,1,1,lw%d,loc%d)) return\n",icre++,farg,farg);
02169 sprintf(str,"stk(lw%d),",farg);
02170 strcat(call,str);
02171 break;
02172 case STRING:
02173 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
02174 if (var->for_type == EXTERNAL)
02175 {
02176 AddDeclare(DEC_LOGICAL,"crepointer");
02177 Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg);
02178 sprintf(str,"stk(lw%d),",farg);
02179 strcat(call,str);
02180 }
02181 else
02182 {
02183 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02184 AddDeclare(DEC_LOGICAL,"cresmat2");
02185 Fprintf(f,indent,"if(.not.cresmat2(fname,top+%d,%s,lr%d)) return\n",icre++,str1,farg);
02186 AddDeclare(DEC_LOGICAL,"bufstore");
02187 Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%d,lbuff%d,lr%d,%s)) return\n",farg,farg,farg,str1);
02188 sprintf(str,"buf(lbufi%d:lbuff%d),",farg,farg);
02189 strcat(call,str);
02190 }
02191 break;
02192 case LIST:
02193 case TLIST:
02194 case SEQUENCE:
02195 case ANY:
02196 printf("work or output FORTRAN argument cannot have\n");
02197 printf(" type \"ANY\", \"LIST\", \"TLIST\" or \"SEQUENCE\"\n");
02198 exit(1);
02199 break;
02200 }
02201 }
02202
02203
02204
02205
02206
02207
02208
02209
02210 void WriteCallRestCheck(f,var,farg,name,iel,flag)
02211 VARPTR var ;
02212 FILE *f;
02213 char *name;
02214 int iel,farg,flag;
02215 {
02216 char sdim[MAXNAM];
02217 char str[MAXNAM];
02218 int ind,j;
02219 if (variables[var->el[iel]-1]->nfor_name == 0)
02220 {
02221 strcpy(str,variables[var->el[iel]-1]->name);
02222 if (isdigit(str[0]) == 0)
02223 {
02224 ind = 0;
02225 for (j = 0; j < basfun->nin; j++)
02226 {
02227 if (strcmp(variables[var->el[iel]-1]->name,
02228 variables[basfun->in[j]-1]->name) == 0)
02229 {
02230
02231 sprintf(sdim,"%s%d",name,farg);
02232 Fprintf(f,indent,"%s= int(stk(lr%d))\n",sdim,j+1);
02233 AddForName1(var->el[iel],sdim);
02234 ind = 1;
02235 break;
02236 }
02237 }
02238 if (ind == 0 && flag != 1 )
02239 {
02245 }
02246 }
02247 else
02248 {
02249 sprintf(sdim,"%s%d",name,farg);
02250 Fprintf(f,indent,"%s=%s\n",sdim,str);
02251 AddForName1(var->el[iel],sdim);
02252 }
02253 }
02254 }
02255
02256 void WriteOutput(f)
02257 FILE *f;
02258 {
02259 IVAR iout,ivar;
02260 VARPTR var,vout;
02261 int i;
02262
02263 Fprintf(f,indent,"topk=top-rhs\n");
02264 AddDeclare(DEC_INT,"topl");
02265 Fprintf(f,indent,"topl=top+%d\n",icre-1);
02266
02267 iout = GetExistOutVar();
02268 vout = variables[iout -1];
02269
02270 switch (vout->type) {
02271 case LIST:
02272 case TLIST:
02273 FCprintf(f,"c Creation of output %s\n",SGetSciType(vout->type));
02274 Fprintf(f,indent,"top=topl+1\n");
02275 Fprintf(f,indent,"call cre%s(top,%d,lw)\n",SGetSciType(vout->type),vout->length);
02276
02277 for (i = 0; i < vout->length; i++)
02278 {
02279 ivar = vout->el[i];
02280 var = variables[ivar-1];
02281 FCprintf(f,"c \n");
02282 FCprintf(f,"c Element %d: %s\n",i+1,var->name);
02283 WriteVariable(f,var,ivar,1,i+1);
02284 }
02285 FCprintf(f,"c \n");
02286 FCprintf(f,"c Putting in order the stack\n");
02287 Fprintf(f,indent,"call copyobj(fname,topl+1,topk+1)\n");
02288 Fprintf(f,indent,"top=topk+1\n");
02289 Fprintf(f,indent,"return\n");
02290 break;
02291 case SEQUENCE:
02292
02293 for (i = 0; i < vout->length; i++)
02294 {
02295 ivar = vout->el[i];
02296 var = variables[ivar-1];
02297 FCprintf(f,"c \n");
02298 Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1);
02299 FCprintf(f,"c --------------output variable: %s\n",var->name);
02300 Fprintf(f,indent,"top=topl+%d\n",i+1);
02301 WriteVariable(f,var,ivar,0,0);
02302 Fprintf(f,--indent,"endif\n");
02303 }
02304 FCprintf(f,"c Putting in order the stack\n");
02305 for (i = 0; i < vout->length; i++)
02306 {
02307 Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1);
02308 Fprintf(f,indent,"call copyobj(fname,topl+%d,topk+%d)\n",i+1,i+1);
02309 Fprintf(f,--indent,"endif\n");
02310 }
02311 Fprintf(f,indent,"top=topk+lhs\n");
02312 Fprintf(f,indent,"return\n");
02313 break;
02314 case EMPTY:
02315 FCprintf(f,"c no output variable\n");
02316 Fprintf(f,indent,"top=topk+1\n");
02317 Fprintf(f,indent,"call objvide(fname,top)\n");
02318 Fprintf(f,indent,"return\n");
02319 break;
02320 }
02321 Fprintf(f,indent,"end\n");
02322 FCprintf(f,"c\n");
02323 }
02324
02325 void WriteVariableOutput(f,var,barg,farg,convert,insidelist,nel)
02326 FILE *f;
02327 VARPTR var;
02328 int barg, farg, insidelist,convert,nel;
02329 {
02330 char strR[MAXNAM];
02331 char str[MAXNAM];
02332 char strc[MAXNAM];
02333 char strit[MAXNAM];
02334 char str1[MAXNAM];
02335 char str2[MAXNAM];
02336 char str3[MAXNAM];
02337 char str4[MAXNAM];
02338 if (convert == 1) {
02339
02340
02341
02342 }
02343
02344
02345
02346
02347
02348 if ( var->list_name != (char *) 0 )
02349 {
02350 int ivart,fargt,bargt,nel1;
02351 ivart=GetExistVar(var->list_name);
02352 bargt=GetNumberInScilabCall(ivart);
02353 fargt=GetNumberInFortranCall(ivart);
02354 nel1= var->list_el;
02355 if (convert == 1)
02356 {
02357
02358 bargt = 0;
02359 }
02360 if (bargt == 0)
02361 {
02362 sprintf(strR,"%de%d",fargt,nel1);
02363 sprintf(str,"lw%de%d",fargt,nel1);
02364 sprintf(strc,"lwc%de%d",fargt,nel1);
02365 sprintf(strit,"itr%de%d",fargt,nel1);
02366 }
02367 else
02368 {
02369 sprintf(strR,"%de%d",bargt,nel1);
02370 sprintf(str,"lr%de%d",bargt,nel1);
02371 sprintf(strc,"lc%de%d",bargt,nel1);
02372 sprintf(strit,"it%de%d",bargt,nel1);
02373 }
02374 }
02375 else
02376 {
02377 if (barg == 0)
02378 {
02379 sprintf(strR,"%d",farg);
02380 sprintf(str,"lw%d",farg);
02381 sprintf(strc,"lwc%d",farg);
02382 sprintf(strit,"itr%d",farg);
02383 }
02384 else
02385 {
02386 sprintf(strR,"%d",barg);
02387 sprintf(str,"lr%d",barg);
02388 sprintf(strc,"lc%d",barg);
02389 sprintf(strit,"it%d",farg);
02390 }
02391 }
02392 switch (var->type)
02393 {
02394 case COLUMN:
02395 case ROW:
02396 case VECTOR:
02397 case MATRIX:
02398 case SCALAR:
02399 switch ( var->type )
02400 {
02401 case COLUMN:
02402 strcpy(str2,"1");
02403 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02404 break;
02405 case ROW:
02406 case VECTOR:
02407 strcpy(str1,"1");
02408 strcpy(str2,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02409 break;
02410 case MATRIX:
02411 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02412 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02413 break;
02414 case SCALAR:
02415 strcpy(str1,"1");
02416 strcpy(str2,"1");
02417 break;
02418 }
02419 if ( insidelist != 0)
02420 {
02421 AddDeclare(DEC_LOGICAL,"listcremat");
02422 Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,0,%s,%s,lrs,lcs)) return\n",nel,str1,str2);
02423 }
02424 else
02425 {
02426 AddDeclare(DEC_LOGICAL,"cremat");
02427 Fprintf(f,indent,"if(.not.cremat(fname,top,0,%s,%s,lrs,lcs)) return\n",str1,str2);
02428 }
02429 if (barg != 0 && var->type != SCALAR)
02430 {
02431 sprintf(str1,"n%d",barg);
02432 sprintf(str2,"m%d",barg);
02433 }
02434 switch (var->for_type)
02435 {
02436 case INT:
02437 Fprintf(f,indent,"call int2db(%s*%s,istk(iadr(%s)),-1,stk(lrs),-1)\n", str1,str2,str);
02438 break;
02439 case DOUBLE:
02440 Fprintf(f,indent,"call dcopy(%s*%s,stk(%s),1,stk(lrs),1)\n", str1,str2,str);
02441 break;
02442 case REAL:
02443 Fprintf(f,indent,"call rea2db(%s*%s,stk(%s),-1,stk(lrs),-1)\n", str1,str2,str);
02444 break;
02445 }
02446 break;
02447 case BMATRIX:
02448 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02449 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02450 if ( insidelist != 0)
02451 {
02452 AddDeclare(DEC_LOGICAL,"listcrebmat");
02453 Fprintf(f,indent,"if(.not.listcrebmat(fname,top,%d,lw,%s,%s,lrs)) return\n",nel,str1,str2);
02454 }
02455 else
02456 {
02457 AddDeclare(DEC_LOGICAL,"crebmat");
02458 Fprintf(f,indent,"if(.not.crebmat(fname,top,%s,%s,lrs)) return\n",str1,str2);
02459 }
02460 if (barg != 0 && var->type != SCALAR)
02461 {
02462 sprintf(str1,"n%d",barg);
02463 sprintf(str2,"m%d",barg);
02464 }
02465 Fprintf(f,indent,"call icopy(%s*%s,istk(%s),1,istk(lrs),1)\n", str1,str2,str);
02466 break;
02467 case SPARSE:
02468
02469 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02470 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02471 strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
02472 strcpy(str4,Forname2Int(variables[var->el[3]-1]->for_name[0]));
02473 if ( insidelist != 0)
02474 {
02475 AddDeclare(DEC_LOGICAL,"listcresparse");
02476 Fprintf(f,indent,"if(.not.listcresparse(fname,top,%d,lw,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
02477 ,nel,str4,str1,str2,str3);
02478 }
02479 else
02480 {
02481 AddDeclare(DEC_LOGICAL,"cresparse");
02482 Fprintf(f,indent,"if(.not.cresparse(fname,top,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
02483 ,str4,str1,str2,str3);
02484 }
02485 if (barg != 0 && var->type != SCALAR)
02486 {
02487 sprintf(str1,"m%d",barg);
02488 sprintf(str2,"n%d",barg);
02489 sprintf(str3,"nel%d",barg);
02490 sprintf(str4,"it%d",barg);
02491 }
02492
02493 Fprintf(f,indent,"call icopy(%s,istk(mnel%s),1,istk(mnels),1)\n",
02494 str1,strR);
02495 Fprintf(f,indent,"call icopy(%s,istk(icol%s),1,istk(icols),1)\n",
02496 str3,strR);
02497 switch (var->for_type)
02498 {
02499 case INT:
02500 Fprintf(f,indent,"call int2db(%s,istk(iadr(%s)),-1,stk(lrs),-1)\n", str3,str);
02501 Fprintf(f,indent++,"if (%s.eq.1) then\n",str4);
02502 Fprintf(f,indent,"call int2db(%s,istk(iadr(%s)),-1,stk(lcs),-1)\n", str3,strc);
02503 Fprintf(f,indent--,"endif\n");
02504 break;
02505 case DOUBLE:
02506 Fprintf(f,indent,"call dcopy(%s,stk(%s),1,stk(lrs),1)\n", str3,str);
02507 Fprintf(f,indent++,"if (%s.eq.1) then\n",str4);
02508 Fprintf(f,indent,"call dcopy(%s,stk(%s),1,stk(lcs),1)\n", str3,strc);
02509 Fprintf(f,indent--,"endif\n");
02510 break;
02511 case REAL:
02512 Fprintf(f,indent,"call rea2db(%s,stk(%s),-1,stk(lrs),-1)\n", str3,str);
02513 Fprintf(f,indent++,"if (%s.eq.1) then\n",str4);
02514 Fprintf(f,indent,"call rea2db(%s,stk(%s),-1,stk(lcs),-1)\n", str3,strc);
02515 Fprintf(f,indent--,"endif\n");
02516 break;
02517 }
02518 break ;
02519 case IMATRIX:
02520
02521 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02522 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02523 strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
02524 if ( insidelist != 0)
02525 {
02526 AddDeclare(DEC_LOGICAL,"listcremat");
02527 Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,%s,%s,%s,lrs,lcs)) return\n"
02528 ,nel,str3,str1,str2);
02529 }
02530 else
02531 {
02532 AddDeclare(DEC_LOGICAL,"cremat");
02533 Fprintf(f,indent,"if(.not.cremat(fname,top,%s,%s,%s,lrs,lcs)) return\n",
02534 str3,str1,str2);
02535 }
02536 if (barg != 0 && var->type != SCALAR)
02537 {
02538 sprintf(str1,"m%d",barg);
02539 sprintf(str2,"n%d",barg);
02540 sprintf(str3,"it%d",barg);
02541 }
02542 switch (var->for_type)
02543 {
02544 case INT:
02545 Fprintf(f,indent,"call int2db(%s*%s,istk(iadr(%s)),-1,stk(lrs),-1)\n", str1,str2,str);
02546 Fprintf(f,indent++,"if (%s.eq.1) then\n",str3);
02547 Fprintf(f,indent,"call int2db(%s*%s,istk(iadr(%s)),-1,stk(lcs),-1)\n", str1,str2,strc);
02548 Fprintf(f,indent--,"endif\n");
02549 break;
02550 case DOUBLE:
02551 Fprintf(f,indent,"call dcopy(%s*%s,stk(%s),1,stk(lrs),1)\n", str1,str2,str);
02552 Fprintf(f,indent++,"if (%s.eq.1) then\n",str3);
02553 Fprintf(f,indent,"call dcopy(%s*%s,stk(%s),1,stk(lcs),1)\n", str1,str2,strc);
02554 Fprintf(f,indent--,"endif\n");
02555 break;
02556 case REAL:
02557 Fprintf(f,indent,"call rea2db(%s*%s,stk(%s),-1,stk(lrs),-1)\n", str1,str2,str);
02558 Fprintf(f,indent++,"if (%s.eq.1) then\n",str3);
02559 Fprintf(f,indent,"call rea2db(%s*%s,stk(%s),-1,stk(lcs),-1)\n", str1,str2,strc);
02560 Fprintf(f,indent--,"endif\n");
02561 break;
02562 }
02563 break ;
02564 case POLYNOM:
02565 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02566 if ( insidelist != 0)
02567 {
02568 AddDeclare(DEC_LOGICAL,"listcreopoly");
02569 Fprintf(f,indent,"if(.not.listcreopoly(fname,top,%d,lw,0,%s,name%s,namel%s,lrs,lcs)) return\n",nel,str1,str,str);
02570 }
02571 else
02572 {
02573 AddDeclare(DEC_LOGICAL,"creonepoly");
02574 Fprintf(f,indent,"if(.not.creonepoly(fname,top,0,%s,name%s,namel%s,lrs,lcs)) return\n",str1,str,str);
02575 }
02576 switch (var->for_type) {
02577 case INT:
02578 Fprintf(f,indent,"call int2db(%s,stk(%s),-1,stk(lrs),-1)\n",
02579 str1,str);
02580 break;
02581 case DOUBLE:
02582 Fprintf(f,indent,"call dcopy(%s,stk(%s),1,stk(lrs),1)\n",
02583 str1,str);
02584 break;
02585 case REAL:
02586 Fprintf(f,indent,"call rea2db(%s,stk(%s),-1,stk(lrs),-1)\n",
02587 str1,str);
02588 break;
02589 }
02590 break;
02591 case STRING:
02592 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02593 if (barg != 0)
02594 {
02595 sprintf(str1,"nlr%d",barg);
02596 }
02597
02598 if ( insidelist != 0)
02599 {
02600 AddDeclare(DEC_LOGICAL,"listcrestring");
02601 Fprintf(f,indent,"if(.not.listcrestring(fname,top,%d,lw,%s,ilrs)) return\n",
02602 nel,str1);
02603 }
02604 else
02605 {
02606 AddDeclare(DEC_LOGICAL,"cresmat2");
02607 Fprintf(f,indent,"if(.not.cresmat2(fname,top,%s,ilrs)) return\n",str1);
02608 }
02609 Fprintf(f,indent,"call cvstr(%s,istk(ilrs),buf(lbufi%d:lbuff%d),0)\n",
02610 str1,farg,farg);
02611 break;
02612 case SCISMPOINTER:
02613 case SCIMPOINTER:
02614 case SCILPOINTER:
02615 case SCIBPOINTER:
02616 case SCIOPOINTER:
02617 if ( insidelist != 0)
02618 {
02619 printf(" %s in output list : not implemented ;",SGetSciType(var->type));
02620 }
02621 else
02622 {
02623 sprintf(buf,"cre%s", SGetSciType(var->type));
02624 AddDeclare(DEC_LOGICAL,buf);
02625 Fprintf(f,indent,"if(.not.cre%s(fname,top,lrs)) return\n", SGetSciType(var->type));
02626 Fprintf(f,indent,"stk(lrs)=stk(%s)\n",str);
02627 }
02628 break;
02629 case STRINGMAT:
02630 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02631 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02632 sprintf(str,"lw%d",farg);
02633 if ( insidelist != 0)
02634 {
02635 AddDeclare(DEC_LOGICAL,"lcrestringmatfromC");
02636 Fprintf(f,indent,"if(.not.lcrestringmatfromC(fname,top,%d,lw,%s,%s,%s)) return\n",
02637 nel,str,str1,str2);
02638 }
02639 else
02640 {
02641 AddDeclare(DEC_LOGICAL,"crestringmatfromC");
02642 Fprintf(f,indent,"if(.not.crestringmatfromC(fname,top,%s,%s,%s)) return\n",
02643 str,str1,str2);
02644 }
02645 break;
02646 case WORK:
02647 case LIST:
02648 case TLIST:
02649 case SEQUENCE:
02650 case ANY:
02651 printf("output variable \"%s\" cannot have type\n",
02652 var->name);
02653 printf(" \"WORK\", \"LIST\", \"TLIST\", \"SEQUENCE\" or \"ANY\"\n");
02654 exit(1);
02655 break;
02656 }
02657 }
02658
02659 void WriteExternalVariableOutput(f,var,farg,insidelist,nel)
02660 FILE *f;
02661 VARPTR var;
02662 int farg;
02663 int insidelist,nel;
02664 {
02665 char str[MAXNAM];
02666 char str1[MAXNAM];
02667 char str2[MAXNAM];
02668 char str3[MAXNAM];
02669 char str4[MAXNAM];
02670 switch (var->type) {
02671 case COLUMN:
02672 case ROW:
02673 case VECTOR:
02674 case MATRIX:
02675 case SCALAR:
02676 switch ( var->type )
02677 {
02678 case COLUMN:
02679 strcpy(str2,"1");
02680 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02681 break;
02682 case ROW:
02683 case VECTOR:
02684 strcpy(str1,"1");
02685 strcpy(str2,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02686 break;
02687 case MATRIX:
02688 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02689 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02690 break;
02691 case SCALAR:
02692 strcpy(str1,"1");
02693 strcpy(str2,"1");
02694 break;
02695 }
02696 if ( insidelist != 0)
02697 {
02698 AddDeclare(DEC_LOGICAL,"listcremat");
02699 Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,0,%s,%s,lrs,lcs)) return\n",nel,
02700 str1,str2);
02701 }
02702 else
02703 {
02704 AddDeclare(DEC_LOGICAL,"cremat");
02705 Fprintf(f,indent,"if(.not.cremat(fname,top,0,%s,%s,lrs,lcs)) return\n",str1,str2);
02706 }
02707 sprintf(str,"lw%d",farg);
02708 Fprintf(f,indent,"call %s(%s*%s,stk(%s),stk(lrs))\n", var->fexternal,str1,str2,str);
02709 break;
02710 case IMATRIX:
02711 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02712 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02713 strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
02714 if ( insidelist != 0)
02715 {
02716 AddDeclare(DEC_LOGICAL,"listcremat");
02717 Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,%s,%s,%s,lrs,lcs)) return\n",
02718 nel,str3,str1,str2);
02719 }
02720 else
02721 {
02722 AddDeclare(DEC_LOGICAL,"cremat");
02723 Fprintf(f,indent,"if(.not.cremat(fname,top,%s,%s,%s,lrs,lcs)) return\n",str3,str1,str2);
02724 }
02725 sprintf(str,"lw%d",farg);
02726 Fprintf(f,indent,"call %s(%s*%s,stk(%s),stk(lrs))\n", var->fexternal,str1,str2,str);
02727 sprintf(str,"lwc%d",farg);
02728 Fprintf(f,indent++,"if (%s.eq.1) then \n",str3);
02729 Fprintf(f,indent,"call %s(%s*%s,stk(%s),stk(lcs))\n", var->fexternal,str1,str2,str);
02730 Fprintf(f,--indent,"endif\n");
02731 break;
02732 case SPARSE:
02733 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02734 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02735 strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
02736 strcpy(str4,Forname2Int(variables[var->el[3]-1]->for_name[0]));
02737 if ( insidelist != 0)
02738 {
02739 AddDeclare(DEC_LOGICAL,"listcresparse");
02740 Fprintf(f,indent,"if(.not.listcresparse(fname,top,%d,lw,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
02741 ,nel,str4,str1,str2,str3);
02742 }
02743 else
02744 {
02745 AddDeclare(DEC_LOGICAL,"cresparse");
02746 Fprintf(f,indent,"if(.not.cresparse(fname,top,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
02747 ,str4,str1,str2,str3);
02748 }
02749 sprintf(str,"lw%d",farg);
02750 Fprintf(f,indent,"call %s(stk(%s),istk(mnels),istk(icols),stk(lrs),stk(lcs))\n",var->fexternal,str);
02751 break;
02752 case BMATRIX:
02753 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02754 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02755 if ( insidelist != 0)
02756 {
02757 AddDeclare(DEC_LOGICAL,"listcrebmat");
02758 Fprintf(f,indent,"if(.not.listcrebmat(fname,top,%d,lw,%s,%s,lrs)) return\n",
02759 nel,str1,str2);
02760 }
02761 else
02762 {
02763 AddDeclare(DEC_LOGICAL,"crebmat");
02764 Fprintf(f,indent,"if(.not.crebmat(fname,top,%s,%s,lrs)) return\n",str1,str2);
02765 }
02766 sprintf(str,"lw%d",farg);
02767 Fprintf(f,indent,"call %s(%s*%s,istk(%s),istk(lrs))\n",var->fexternal,str1,str2,str);
02768 break;
02769 case POLYNOM:
02770 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02771 strcpy(str2,variables[var->el[1]-1]->name);
02772 Fprintf(f,indent,"err=sadr(ilw+10)+%s-lstk(bot)\n",str1);
02773 Fprintf(f,indent,"if(err .gt. 0) then\n");
02774 Fprintf(f,indent,"call error(17)\n");
02775 Fprintf(f,indent,"return\n");
02776 Fprintf(f,indent,"endif\n");
02777 Fprintf(f,indent,"istk(ilw)=1\n");
02778 Fprintf(f,indent,"istk(ilw+1)=1\n");
02779 Fprintf(f,indent,"istk(ilw+2)=1\n");
02780 Fprintf(f,indent,"istk(ilw+3)=0\n");
02781 Fprintf(f,indent,"call cvstr(4,'%s ',istk(ilw+4),0)\n",str2);
02782
02783 Fprintf(f,indent,"istk(ilw+8)=1\n");
02784 Fprintf(f,indent,"istk(ilw+9)=1+%s\n",str1);
02785 sprintf(str,"lw%d",farg);
02786 Fprintf(f,indent,"lw=sadr(ilw+10)\n");
02787 Fprintf(f,indent,"call %s(%s,stk(%s),stk(lw))\n",
02788 var->fexternal,str1,str);
02789 Fprintf(f,indent,"lw=lw+%s\n",str1);
02790 break;
02791 case STRING:
02792 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02793 if ( insidelist != 0)
02794 {
02795 AddDeclare(DEC_LOGICAL,"listcrestring");
02796 Fprintf(f,indent,"if(.not.listcrestring(fname,top,%d,lw,%s,ilrs)) return\n",nel,str1,str2);
02797 }
02798 else
02799 {
02800 AddDeclare(DEC_LOGICAL,"crestring");
02801 Fprintf(f,indent,"if(.not.crestring(fname,top,%s,ilrs)) return\n",str1);
02802 }
02803 sprintf(str,"lw%d",farg);
02804 Fprintf(f,indent,"call %s(%s,stk(%s),istk(ilrs))\n", var->fexternal,str1,str);
02805 break;
02806 case STRINGMAT:
02807 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
02808 strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
02809 sprintf(str,"lw%d",farg);
02810 Fprintf(f,indent,"call %s(stk(%s),istk(ilw),%s,%s,lstk(bot)-sadr(ilw),ierr)\n",
02811 var->fexternal,str,str1,str2);
02812 Fprintf(f,indent,"if(ierr .gt. 0) then\n");
02813 Fprintf(f,indent,"buf='not enough memory'\n");
02814 Fprintf(f,indent,"call error(1000)\n");
02815 Fprintf(f,indent,"return\n");
02816 Fprintf(f,indent,"endif\n");
02817 sprintf(str,"istk(ilw+4+%s*%s)-1",str1,str2);
02818 Fprintf(f,indent,"lw=sadr(ilw+5+%s*%s+%s)\n",str1,str2,str);
02819 break;
02820 }
02821 }
02822
02823 void WriteListAnalysis(f,i)
02824
02825 FILE *f;
02826 int i;
02827 {
02828 int k,i1,iel;
02829 char str1[MAXNAM],str[MAXNAM];
02830 VARPTR var;
02831 i1=i+1;
02832 AddDeclare(DEC_LOGICAL,"getilist");
02833 Fprintf(f,indent,"if(.not.getilist(fname,topk,top-rhs+%d,n%d,1,il%d)) return\n",i1,i1,i1);
02834 for (k = 0; k < nVariable ; k++)
02835 {
02836 var = variables[k];
02837 if ((var->list_el != 0) &&
02838 (strcmp(var->list_name,variables[i]->name) == 0) &&
02839 var->present)
02840 {
02841 iel=var->list_el;
02842 FCprintf(f,"c \n");
02843 FCprintf(f,"c -- list element number %d %s --\n",iel,var->name);
02844 sprintf(str1,"%de%d",i1,iel);
02845 AddDeclare(DEC_LOGICAL,"getilist");
02846 switch (var->type)
02847 {
02848 case SPARSE:
02849 AddDeclare(DEC_LOGICAL,"getlistsparse");
02850 Fprintf(f,indent,"if(.not.getlistsparse(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,nel%s,mnel%s,icol%s,lr%s,lc%s)) return\n",
02851 i1,iel,str1,str1,str1,str1,str1,str1,str1,str1);
02852 if (var->el[0] == var->el[1]) {
02853
02854 AddDeclare(DEC_LOGICAL,"checkval");
02855 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
02856 }
02857 sprintf(str,"m%s",str1);
02858 AddForName1(var->el[0],str);
02859 sprintf(str,"n%s",str1);
02860 AddForName1(var->el[1],str);
02861 sprintf(str,"nel%s",str1);
02862 AddForName1(var->el[2],str);
02863 sprintf(str,"it%s",str1);
02864 AddForName1(var->el[3],str);
02865 break;
02866 case IMATRIX:
02867 AddDeclare(DEC_LOGICAL,"getlistmat");
02868 Fprintf(f,indent,"if(.not.getlistmat(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
02869 i1,iel,str1,str1,str1,str1,str1);
02870 if (var->el[0] == var->el[1]) {
02871
02872 AddDeclare(DEC_LOGICAL,"checkval");
02873 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
02874 }
02875 sprintf(str,"m%s",str1);
02876 AddForName1(var->el[0],str);
02877 sprintf(str,"n%s",str1);
02878 AddForName1(var->el[1],str);
02879 sprintf(str,"it%s",str1);
02880 AddForName1(var->el[2],str);
02881 break;
02882 case MATRIX:
02883 AddDeclare(DEC_LOGICAL,"getlistmat");
02884 Fprintf(f,indent,"if(.not.getlistmat(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
02885 i1,iel,str1,str1,str1,str1,str1);
02886 if (var->el[0] == var->el[1]) {
02887
02888 AddDeclare(DEC_LOGICAL,"checkval");
02889 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
02890 }
02891 sprintf(str,"m%s",str1);
02892 AddForName1(var->el[0],str);
02893 sprintf(str,"n%s",str1);
02894 AddForName1(var->el[1],str);
02895 break;
02896 case BMATRIX:
02897 AddDeclare(DEC_LOGICAL,"getlistbmat");
02898 Fprintf(f,indent,"if(.not.getlistbmat(fname,topk,top-rhs+%d,%d,m%s,n%s,lr%s)) return\n",
02899 i1,iel,str1,str1,str1,str1,str1);
02900 if (var->el[0] == var->el[1]) {
02901
02902 AddDeclare(DEC_LOGICAL,"checkval");
02903 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
02904 }
02905 sprintf(str,"m%s",str1);
02906 AddForName1(var->el[0],str);
02907 sprintf(str,"n%s",str1);
02908 AddForName1(var->el[1],str);
02909 break;
02910 case STRINGMAT:
02911 AddDeclare(DEC_LOGICAL,"getlistsimat");
02912 Fprintf(f,indent,"if(.not.getlistsimat(fname,topk,top-rhs+%d,%d,m%s,n%s,1,1,lr%s,nlr%s)) return\n",
02913 i1,iel,str1,str1,str1,str1);
02914
02915 if (var->el[0] == var->el[1]) {
02916
02917 AddDeclare(DEC_LOGICAL,"checkval");
02918 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
02919 }
02920 sprintf(str,"m%s",str1);
02921 AddForName1(var->el[0],str);
02922 sprintf(str,"n%s",str1);
02923 AddForName1(var->el[1],str);
02924 break;
02925 case ROW:
02926 AddDeclare(DEC_LOGICAL,"getlistvectrow");
02927 Fprintf(f,indent,"if(.not.getlistvectrow(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
02928 i1,iel,str1,str1,str1,str1,str1);
02929 sprintf(str,"n%s",str1);
02930 AddForName1(var->el[0],str);
02931 break;
02932 case COLUMN :
02933 AddDeclare(DEC_LOGICAL,"getlistvectcol");
02934 Fprintf(f,indent,"if(.not.getlistvectcol(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
02935 i1,iel,str1,str1,str1,str1,str1);
02936 sprintf(str,"n%s",str1);
02937 AddForName1(var->el[0],str);
02938 break;
02939 case VECTOR:
02940 AddDeclare(DEC_LOGICAL,"getlistvect");
02941 Fprintf(f,indent,"if(.not.getlistvect(fname,top,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
02942 i1,iel,str1,str1,str1,str1,str1);
02943 sprintf(str,"n%s*m%s",str1,str1);
02944 AddForName1(var->el[0],str);
02945 break;
02946 case POLYNOM:
02947 AddDeclare(DEC_LOGICAL,"getlistpoly");
02948 Fprintf(f,indent,"if(.not.getlistpoly(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,name%s,\n",
02949 i1,iel,str1,str1,str1,str1);
02950 Fprintf(f,indent,"$ namel%s,ilp%s,lr%s,lc%s)\n",str1,str1,str1,str1);
02951 AddDeclare(DEC_LOGICAL,"checkval");
02952 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
02953 break;
02954 case SCALAR:
02955 AddDeclare(DEC_LOGICAL,"getlistscalar");
02956 Fprintf(f,indent,"if(.not.getlistscalar(fname,topk,top-rhs+%d,%d,lr%s)) return\n",i1,iel,str1);
02957 break;
02958 case STRING:
02959 AddDeclare(DEC_LOGICAL,"getlistsmat");
02960 Fprintf(f,indent,"if(.not.getlistsmat(fname,topk,top-rhs+%d,%d,m%s,n%s,1,1,lr%s,nlr%s)) return\n",
02961 i1,iel,str1,str1,str1,str1);
02962 AddDeclare(DEC_LOGICAL,"checkval");
02963 Fprintf(f,indent,"if(.not.checkval(fname,m%s*n%s,1)) return\n",str1,str1);
02964 sprintf(str,"n%s",str1);
02965 strcpy(str1,variables[var->el[0]-1]->name);
02966 AddForName1(var->el[0],str);
02967 break;
02968 case ANY:
02969 break;
02970 }
02971 }
02972 }
02973 }
02974
02975
02976
02977
02978
02979
02980
02981
02982 void WriteVariable(f,var,ivar,insidelist,nel)
02983 FILE *f;
02984 VARPTR var;
02985 IVAR ivar;
02986 int insidelist;
02987 {
02988 IVAR ivar2, barg, farg;
02989 VARPTR var2;
02990 int j;
02991
02992
02993
02994 barg = GetNumberInScilabCall(ivar);
02995
02996
02997
02998 farg = GetNumberInFortranCall(ivar);
02999
03000 if (var->for_type == EXTERNAL)
03001 {
03002
03003 if (barg != 0)
03004 {
03005 printf("output variable with external type \"%s\" \n",var->name);
03006 printf(" cannot be an input argument of SCILAB function\n");
03007 exit(1);
03008 }
03009 if (var->equal != 0)
03010 {
03011 printf("output variable with external type \"%s\"\n", var->name);
03012 printf(" cannot have a convertion\n");
03013 exit(1);
03014 }
03015 if (farg == 0)
03016 {
03017 printf("output variable with external type \"%s\" must be\n", var->name);
03018 printf(" an argument of FORTRAN subroutine");
03019 exit(1);
03020 }
03021 WriteExternalVariableOutput(f,var,farg,insidelist,nel);
03022 }
03023 else
03024 {
03025 if (var->equal != 0)
03026 {
03027
03028 if (barg !=0 || farg!= 0)
03029 {
03030 printf("output variable with convertion \"%s\" must not be\n",var->name);
03031 printf(" an input variable of SCILAB function or an argument\n");
03032 printf(" of FORTRAN subroutine\n");
03033 exit(1);
03034 }
03035 ivar2 = var->equal;
03036 var2 = variables[ivar2-1];
03037
03038 barg = 0;
03039 for (j = 0; j < basfun->nin; j++)
03040 {
03041 if (ivar2 == basfun->in[j])
03042 {
03043 barg = j + 1;
03044 break;
03045 }
03046 }
03047 if (barg == 0)
03048 {
03049 printf("output variable with convertion \"%s\" must be\n",
03050 var->name);
03051 printf(" an input variable of SCILAB function\n");
03052 exit(1);
03053 }
03054
03055 farg = 0;
03056 for (j = 0; j < forsub->narg; j++) {
03057 if (ivar2 == forsub->arg[j]) {
03058 farg = j + 1;
03059 break;
03060 }
03061 }
03062 if (farg == 0)
03063 {
03064 printf("output variable with convertion \"%s\" must be\n",
03065 var->name);
03066 printf(" an argument FORTRAN subroutine");
03067 exit(1);
03068 }
03069 var->for_type = var2->for_type;
03070 WriteVariableOutput(f,var,barg,farg,1,insidelist,nel);
03071 }
03072 else
03073 {
03074
03075 if (farg == 0) {
03076 printf("variable without convertion \"%s\" must be an argument\n",
03077 var->name);
03078 printf(" of FORTRAN subroutine\n");
03079 exit(1);
03080 }
03081 WriteVariableOutput(f,var,barg,farg,0,insidelist,nel);
03082 }
03083 }
03084 }
03085
03086
03087 int GetNumberInScilabCall(ivar)
03088 int ivar;
03089 {
03090 int j;
03091 for (j = 0; j < basfun->nin; j++)
03092 {
03093 if (ivar == basfun->in[j]) {
03094 return(j+1);
03095 break;
03096 }
03097 }
03098 return(0);
03099 }
03100
03101 int GetNumberInFortranCall(ivar)
03102 int ivar;
03103 {
03104 int j;
03105 for (j = 0; j < forsub->narg; j++)
03106 {
03107 if (ivar == forsub->arg[j])
03108 {
03109 return( j + 1);
03110 break;
03111 }
03112 }
03113 return(0);
03114 }
03115
03116 char unknown[]="ukn";
03117
03118 char *Forname2Int(str)
03119 char *str;
03120 {
03121 int l;
03122 char *p;
03123 if (str == (char *) 0)
03124 {
03125 printf("Error in Forname2Int \n");
03126 printf("Maybe an internal variable has a dimension\n");
03127 printf("which can't be evaluated\n");
03128 abort();
03129 return(unknown);
03130 }
03131 if (strncmp(str,"stk",3) == 0) {
03132 l = strlen(str);
03133 p = (char *)malloc((unsigned)(l + 6));
03134 sprintf(p,"int(%s)",str);
03135 return p;
03136 }
03137 else return str;
03138 }
03139
03140
03141
03142 void GenFundef(file,interf)
03143 char *file;
03144 int interf;
03145 {
03146 FILE *fout;
03147 char filout[MAXNAM];
03148 int i,j;
03149 if (interf != 0 )
03150 {
03151 strcpy(filout,file);
03152 strcat(filout,".fundef");
03153 fout = fopen(filout,"w");
03154 fprintf(fout,"#define IN_%s %.2d\n",file,interf);
03155 for (i = 0; i < nFun; i++) {
03156 fprintf(fout,"{\"%s\",",funNames[i]);
03157 for (j = 0; j < 25 - (int)strlen(funNames[i]); j++) fprintf(fout," ");
03158 fprintf(fout,"\t\tIN_%s,\t%d,\t3},\n",file,i+1);
03159 }
03160 printf("\nfile \"%s\" has been created\n",filout);
03161 fclose(fout);
03162 }
03163 }
03164
03165
03166
03167
03168
03169
03170
03171 static struct Declare {
03172 int type;
03173 char *name;
03174 char **decls ;
03175 int ndecls;
03176 } Init[] = {
03177 { DEC_CHAR,"char",(char **) 0,0},
03178 { DEC_INT ,"integer",(char **) 0,0},
03179 { DEC_DOUBLE,"double precision",(char **) 0,0},
03180 { DEC_REAL,"real",(char **) 0,0},
03181 { DEC_LOGICAL,"logical",(char **) 0,0},
03182 { DEC_DATA,"data",(char **) 0,0},
03183 { -1 ,"void",(char **) 0,0}
03184 };
03185
03186 void InitDeclare()
03187 {
03188 int i = 0;
03189 while ( Init[i].type != -1)
03190 {
03191 Init[i].decls = (char **) 0;
03192 Init[i].ndecls =0 ;
03193 i++;
03194 }
03195 }
03196
03197 void ResetDeclare()
03198 {
03199 int j = 0;
03200 while ( Init[j].type != -1)
03201 {
03202 if ( Init[j].decls != (char **) 0)
03203 {
03204 int i;
03205 for ( i = 0 ; i < Init[j].ndecls ; i++ )
03206 free((char *) Init[j].decls[i]);
03207 free (( char *) Init[j].decls );
03208 }
03209 Init[j].decls=(char **) 0;
03210 Init[j].ndecls=0;
03211 j++;
03212 }
03213 }
03214
03215 int CheckDeclare(type,declaration)
03216 int type;
03217 char *declaration;
03218 {
03219 int j = 0;
03220 while ( Init[j].type != -1)
03221 {
03222 if ( Init[j].type == type )
03223 {
03224 int i;
03225 for ( i = 0 ; i < Init[j].ndecls ; i++ )
03226 {
03227 if ( strcmp(declaration,Init[j].decls[i])==0)
03228 return(1);
03229 }
03230 return(0);
03231 }
03232 j++;
03233 }
03234 return(0);
03235 }
03236
03237 void AddDeclare(type,declaration)
03238 int type;
03239 char *declaration;
03240 {
03241 int j = 0;
03242 if ( CheckDeclare(type,declaration)== 1) return ;
03243 while ( Init[j].type != -1)
03244 {
03245 if ( Init[j].type == type )
03246 {
03247 if ( Init[j].decls != (char **) 0)
03248 {
03249 (Init[j].ndecls)++;
03250 Init[j].decls = (char **) realloc((char *) Init[j].decls, (unsigned) (Init[j].ndecls ) *sizeof(char *));
03251 }
03252 else
03253 {
03254 (Init[j].ndecls)++;
03255 Init[j].decls = (char **) malloc ( (unsigned) (Init[j].ndecls ) *sizeof(char *));
03256 }
03257 if ( Init[j].decls == ( char **) 0)
03258 {
03259 fprintf(stderr,"No more space\n");
03260 exit(1);
03261 }
03262 Init[j].decls[Init[j].ndecls-1]=(char*) malloc((unsigned) (strlen(declaration)+1)*sizeof(char));
03263 if ( Init[j].decls[Init[j].ndecls-1] == ( char *) 0)
03264 {
03265 fprintf(stderr,"No more space\n");
03266 exit(1);
03267 }
03268 strcpy( Init[j].decls[Init[j].ndecls-1], declaration );
03269 }
03270 j++;
03271 }
03272 }
03273
03274 void WriteDeclaration(f)
03275 FILE *f;
03276 {
03277 int j = 0;
03278 int i;
03279 while ( Init[j].type != -1)
03280 {
03281 if ( Init[j].ndecls != 0)
03282 Fprintf(f,indent,"%s ",Init[j].name);
03283 for (i= 0 ; i < Init[j].ndecls ; i++)
03284 {
03285 Fprintf(f,indent,"%s",Init[j].decls[i]);
03286 if ( i != Init[j].ndecls -1 ) Fprintf(f,indent,",");
03287 else Fprintf(f,indent,"\n");
03288 }
03289 j++;
03290 }
03291 }
03292
03293
03294
03295
03296
03297 #ifdef __STDC__
03298 #include <stdarg.h>
03299 #else
03300 #include <varargs.h>
03301 #endif
03302
03303 #define MAXBUF 4096
03304 char sbuf[MAXBUF];
03305
03306 #ifdef __STDC__
03307 void Fprintf(FILE *f,int indent,char *format,...)
03308 #else
03309
03310 void Fprintf(va_alist) va_dcl
03311 #endif
03312 {
03313 int i;
03314 static int count=0;
03315 va_list ap;
03316 #ifdef __STDC__
03317 va_start(ap,format);
03318 #else
03319 FILE *f;
03320 int indent;
03321 char *format;
03322 va_start(ap);
03323 f = va_arg(ap, FILE *);
03324 indent= va_arg(ap, int );
03325 format = va_arg(ap, char *);
03326 #endif
03327 vsprintf(sbuf,format,ap);
03328 for ( i = 0 ; i < (int) strlen(sbuf); i++)
03329 {
03330 if ( count == 0)
03331 {
03332 white(f,7+indent);
03333 count = 7+indent;
03334 }
03335 if ( count == 72 && sbuf[i] != '\n' ) { fprintf(f,"\n $ ");count=7;}
03336 if ( sbuf[i] == '\n') count = -1 ;
03337 fprintf(f,"%c",sbuf[i]);
03338 count++;
03339 }
03340 va_end(ap);
03341 }
03342
03343 void white(f,ind)
03344 FILE *f;
03345 int ind;
03346 {
03347 int i ;
03348 for (i =0 ; i < ind ; i++) fprintf(f," ");
03349 }
03350
03351
03352
03353 #ifdef __STDC__
03354 void FCprintf(FILE *f,char *format,...)
03355 #else
03356
03357 void FCprintf(va_alist) va_dcl
03358 #endif
03359 {
03360 va_list ap;
03361 #ifdef __STDC__
03362 va_start(ap,format);
03363 #else
03364 FILE *f;
03365 char *format;
03366 va_start(ap);
03367 f = va_arg(ap, FILE *);
03368 format = va_arg(ap, char *);
03369 #endif
03370 vfprintf(f,format,ap);
03371 va_end(ap);
03372 }
03373
03374
03375
03376
03377
03378
03379
03380
03381 #ifdef _MSC_VER
03382 static void SciEnv ()
03383 {
03384 char *p,*p1;
03385 char modname[MAX_PATH+1];
03386 char env[MAX_PATH+1+10];
03387 if (!GetModuleFileName (NULL, modname+1, MAX_PATH))
03388 return;
03389 if ((p = strrchr (modname+1, '\\')) == NULL)
03390 return;
03391 *p = 0;
03392
03393
03394 if ((p = strrchr (modname+1, '\\')))
03395 {
03396 *p = 0;
03397 for (p = modname+1; *p; p++)
03398 {
03399 if (*p == '\\') *p = '/';
03400 }
03401 p = modname + 1;
03402
03403 if ( ( p1 = getenv("SCI")) == (char *) 0 )
03404 {
03405 sprintf(env,"SCI=%s",p);
03406 putenv(env);
03407 }
03408 }
03409 }
03410 #endif
