1 /****************************************************************
2 Copyright (C) 1997-2001 Lucent Technologies
3 All Rights Reserved
4
5 Permission to use, copy, modify, and distribute this software and
6 its documentation for any purpose and without fee is hereby
7 granted, provided that the above copyright notice appear in all
8 copies and that both that the copyright notice and this
9 permission notice and warranty disclaimer appear in supporting
10 documentation, and that the name of Lucent or any of its entities
11 not be used in advertising or publicity pertaining to
12 distribution of the software without specific, written prior
13 permission.
14
15 LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
16 INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
17 IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
18 SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
19 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
20 IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
21 ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
22 THIS SOFTWARE.
23 ****************************************************************/
24
25 /* include vararg/stdarg stuff first to avoid trouble with C++ */
26 #ifdef KR_headers
27 #include "varargs.h"
28 #else
29 #include "stddef.h"
30 #include "stdarg.h"
31 #endif
32
33 #include "asl.h"
34
35 #ifdef __cplusplus
36 extern "C" {
37 #endif
38
39 real edagread_one = 1.;
40 char *progname;
41 ASL *cur_ASL;
42 ASLhead ASLhead_ASL = {&ASLhead_ASL, &ASLhead_ASL};
43
44 static char anyedag[] = "fg_read (or one of its variants)";
45 static char psedag[] = "pfg_read, pfgh_read, or jacpdim";
46
47 ASL *
48 #ifdef KR_headers
set_cur_ASL(a)49 set_cur_ASL(a) ASL *a;
50 #else
51 set_cur_ASL(ASL *a)
52 #endif
53 {
54 ASL *rv = cur_ASL;
55 cur_ASL = a;
56 return rv;
57 }
58
59 ASL *
get_cur_ASL(VOID)60 get_cur_ASL(VOID)
61 { return cur_ASL; }
62
63 void
64 #ifdef KR_headers
exit_ASL(R,n)65 exit_ASL(R, n) EdRead *R; int n;
66 #else
67 exit_ASL(EdRead *R, int n)
68 #endif
69 {
70 Jmp_buf *J;
71 if ((J = R->asl->i.err_jmp_) && n > 0)
72 longjmp(J->jb, n);
73 exit(n);
74 }
75
76 void
scream(va_alist)77 scream
78 #ifdef KR_headers
79 (va_alist)
80 va_dcl
81 {
82 EdRead *R;
83 char *fmt;
84 int n;
85 va_list ap;
86 va_start(ap);
87 R = va_arg(ap, EdRead*);
88 n = va_arg(ap, int);
89 fmt = va_arg(ap, char*);
90 #else
91 (EdRead *R, int n, const char *fmt, ...)
92 {
93 va_list ap;
94 va_start(ap, fmt);
95 #endif
96 vfprintf(Stderr, fmt, ap);
97 exit_ASL(R, n);
98 } /*}*/
99
100 static real
101 #ifdef KR_headers
102 notread(what, pred) char *what, *pred;
103 #else
104 notread(char *what, char *pred)
105 #endif
106 {
107 fprintf(Stderr, "\n*** %s called before %s.\n", what, pred);
108 exit(1);
109 /* not reached */
110 return 0;
111 }
112
113 static real
114 #ifdef KR_headers
115 obj0val(a, nobj, X, nerror) ASL *a; real *X; int nobj; fint *nerror;
116 #else
117 obj0val(ASL *a, int nobj, real *X, fint *nerror)
118 #endif
119 {
120 Not_Used(a);
121 Not_Used(nobj);
122 Not_Used(X);
123 Not_Used(nerror);
124 return notread("objval", anyedag);
125 }
126
127 static void
128 #ifdef KR_headers
129 obj0grd(a, nobj, X, G, nerror) ASL *a; int nobj; fint *nerror; real *X, *G;
130 #else
131 obj0grd(ASL *a, int nobj, real *X, real *G, fint *nerror)
132 #endif
133 {
134 Not_Used(a);
135 Not_Used(nobj);
136 Not_Used(X);
137 Not_Used(G);
138 Not_Used(nerror);
139 notread("objgrd", anyedag);
140 }
141
142 static void
143 #ifdef KR_headers
144 con0val(a, X, R, nerror) ASL *a; real *X, *R; fint *nerror;
145 #else
146 con0val(ASL *a, real *X, real *R, fint *nerror)
147 #endif
148 {
149 Not_Used(a);
150 Not_Used(X);
151 Not_Used(R);
152 Not_Used(nerror);
153 notread("conval", anyedag);
154 }
155
156 static void
157 #ifdef KR_headers
158 jac0val(a, X, J, nerror) ASL *a; real *X, *J; fint *nerror;
159 #else
160 jac0val(ASL *a, real *X, real *J, fint *nerror)
161 #endif
162 {
163 Not_Used(a);
164 Not_Used(X);
165 Not_Used(J);
166 Not_Used(nerror);
167 notread("jacval", anyedag);
168 }
169
170 static real
171 #ifdef KR_headers
172 con0ival(a, i, X, nerror) ASL *a; int i; real *X; fint *nerror;
173 #else
174 con0ival(ASL *a, int i, real *X, fint *nerror)
175 #endif
176 {
177 Not_Used(a);
178 Not_Used(i);
179 Not_Used(X);
180 Not_Used(nerror);
181 notread("conival", anyedag);
182 return 0.;
183 }
184
185 static int
186 #ifdef KR_headers
187 lcon0val(a, i, X, nerror) ASL *a; int i; real *X; fint *nerror;
188 #else
189 lcon0val(ASL *a, int i, real *X, fint *nerror)
190 #endif
191 {
192 Not_Used(a);
193 Not_Used(i);
194 Not_Used(X);
195 Not_Used(nerror);
196 notread("conival", anyedag);
197 return 0;
198 }
199
200 static void
201 #ifdef KR_headers
202 con0grd(a, i, X, G, nerror) ASL *a; int i; real *X, *G; fint *nerror;
203 #else
204 con0grd(ASL *a, int i, real *X, real *G, fint *nerror)
205 #endif
206 {
207 Not_Used(a);
208 Not_Used(i);
209 Not_Used(X);
210 Not_Used(G);
211 Not_Used(nerror);
212 notread("congrd", anyedag);
213 }
214
215 static void
216 #ifdef KR_headers
217 hv0comp(a, hv, p, nobj, ow, y) ASL *a; real *hv, *p, *ow, *y; int nobj;
218 #else
219 hv0comp(ASL *a, real *hv, real *p, int nobj, real *ow, real *y)
220 #endif
221 {
222 Not_Used(a);
223 Not_Used(hv);
224 Not_Used(p);
225 Not_Used(nobj);
226 Not_Used(ow);
227 Not_Used(y);
228 notread("hvcomp", "pfgh_read or fgh_read");
229 }
230
231 static void
232 #ifdef KR_headers
233 hv0init(a, n, no, ow, y) ASL *a; int n, no; real *ow, *y;
234 #else
235 hv0init(ASL *a, int n, int no, real *ow, real *y)
236 #endif
237 {
238 Not_Used(a);
239 Not_Used(n);
240 Not_Used(no);
241 Not_Used(ow);
242 Not_Used(y);
243 notread("hvinit", "pfgh_read");
244 }
245
246 static void
247 #ifdef KR_headers
248 hes0set(a, flags, obj, nobj, con, ncon) ASL *a; int flags; int obj;
249 int nobj; int con; int ncon;
250 #else
251 hes0set(ASL *a, int flags, int obj, int nobj, int con, int ncon)
252 #endif
253 {
254 Not_Used(a);
255 Not_Used(flags);
256 Not_Used(obj);
257 Not_Used(nobj);
258 Not_Used(con);
259 Not_Used(ncon);
260 notread("duthes, fullhes, or sputhes", "pfgh_read or jacpdim");
261 }
262
263 static void
264 #ifdef KR_headers
265 x0known(a, x, nerror) ASL *a; real *x; fint *nerror;
266 #else
267 x0known(ASL *a, real *x, fint *nerror)
268 #endif
269 {
270 Not_Used(a);
271 Not_Used(x);
272 Not_Used(nerror);
273 notread("xknown", psedag);
274 }
275
276 static void
277 #ifdef KR_headers
278 dut0hes(a, H, nobj, ow, y) ASL *a; real *H; int nobj; real *ow, *y;
279 #else
280 dut0hes(ASL *a, real *H, int nobj, real *ow, real *y)
281 #endif
282 {
283 Not_Used(a);
284 Not_Used(H);
285 Not_Used(nobj);
286 Not_Used(ow);
287 Not_Used(y);
288 notread("duthes", "pfgh_read or jacpdim");
289 }
290
291 static void
292 #ifdef KR_headers
293 ful0hes(a, H, LH, nobj, ow, y) ASL *a; real *H, *ow, *y; fint LH; int nobj;
294 #else
295 ful0hes(ASL *a, real *H, fint LH, int nobj, real *ow, real *y)
296 #endif
297 {
298 Not_Used(a);
299 Not_Used(H);
300 Not_Used(LH);
301 Not_Used(nobj);
302 Not_Used(ow);
303 Not_Used(y);
304 notread("fullhes", "pfgh_read or jacpdim");
305 }
306
307 static void
308 #ifdef KR_headers
309 sut0hes(a, p, H, nobj, ow, y) ASL *a; SputInfo **p; real *H; int nobj; real *ow, *y;
310 #else
311 sut0hes(ASL *a, SputInfo **p, real *H, int nobj, real *ow, real *y)
312 #endif
313 {
314 Not_Used(a);
315 Not_Used(p);
316 Not_Used(H);
317 Not_Used(nobj);
318 Not_Used(ow);
319 Not_Used(y);
320 notread("sputhes", "pfgh_read or jacpdim");
321 }
322
323 static fint
324 #ifdef KR_headers
325 sut0set(a, p, nobj, have_ow, have_y, both)
326 ASL *a; SputInfo **p; int nobj, have_ow, have_y, both;
327 #else
328 sut0set(ASL *a, SputInfo **p, int nobj, int have_ow, int have_y, int both)
329 #endif
330 {
331 Not_Used(a);
332 Not_Used(p);
333 Not_Used(nobj);
334 Not_Used(have_ow);
335 Not_Used(have_y);
336 Not_Used(both);
337 notread("sputset", "pfgh_read or jacpdim");
338 return 0;
339 }
340
341 Edagpars edagpars_ASL = {
342 {0,0}, /* h */
343 1., /* hffactor */
344 5, /* FUNNEL_MIN */
345 5, /* maxfwd */
346 1, /* need_funcadd */
347 100, /* vrefGulp */
348 1, /* want_derivs */
349 12, /* ihd_limit */
350 -1, /* solve_code */
351 obj0val,
352 obj0grd,
353 con0val,
354 jac0val,
355 con0ival,
356 con0grd,
357 hv0comp,
358 hv0init,
359 hes0set,
360 lcon0val,
361 x0known,
362 dut0hes,
363 ful0hes,
364 sut0hes,
365 sut0set
366 };
367
368 int
369 #ifdef KR_headers
370 edag_peek(R) EdRead *R;
371 #else
372 edag_peek(EdRead *R)
373 #endif
374 {
375 int c;
376 R->Line++;
377 R->lineinc = 0;
378 R->rl_buf[0] = c = getc(R->nl);
379 return c;
380 }
381
382 static void
383 #ifdef KR_headers
384 eatcr(nl) FILE *nl;
385 #else
386 eatcr(FILE *nl)
387 #endif
388 {
389 int c;
390
391 while((c = getc(nl)) == '\r');
392 if (c >= 0 && c != '\n')
393 ungetc(c, nl);
394 }
395
396 char *
397 #ifdef KR_headers
398 read_line(R) EdRead *R;
399 #else
400 read_line(EdRead *R)
401 #endif
402 {
403 char *s, *se;
404 int x;
405 char *rv;
406 FILE *nl = R->nl;
407
408 s = R->rl_buf;
409 se = s + sizeof(R->rl_buf) - 1;
410 if (R->lineinc)
411 R->Line++;
412 else {
413 s++;
414 R->lineinc = 1;
415 }
416 rv = s;
417 for(;;) {
418 x = getc(nl);
419 if (x < ' ') {
420 if (x < 0) {
421 eof:
422 if (R->can_end)
423 return 0;
424 fprintf(Stderr,
425 "Premature end of file, line %ld of %s\n",
426 R->Line, R->asl->i.filename_);
427 exit_ASL(R,1);
428 }
429 if (x == '\n')
430 break;
431 if (x == '\r') {
432 eatcr(nl);
433 break;
434 }
435 }
436 *s++ = x;
437 if (s >= se) {
438 for(;;) {
439 x = getc(nl);
440 if (x == '\r') {
441 eatcr(nl);
442 goto eol;
443 }
444 if (x == '\n')
445 goto eol;
446 if (x < 0)
447 goto eof;
448 }
449 }
450 }
451 eol:
452 *s = 0;
453 return rv;
454 }
455
456 static void
457 #ifdef KR_headers
458 memfailure(who, what, len) char *who, *what; size_t len;
459 #else
460 memfailure(char *who, char *what, size_t len)
461 #endif
462 {
463 fprintf(Stderr, "%s(%lu) failure: %s.\n", who, (long)len, what);
464 exit(1);
465 }
466
467 static char ran_out[] = "ran out of memory";
468
469 #ifdef KR_headers
470 Char *
471 mymalloc(len) size_t len;
472 #else
473 void *
474 mymalloc(size_t len)
475 #endif
476 {
477 #ifdef KR_headers
478 char *rv;
479 #else
480 void *rv;
481 #endif
482 static char who[] = "malloc";
483 rv = malloc(len);
484 if (!rv) {
485 /* Defend against stupid systems: malloc(0) */
486 /* should return a nonzero value. Routines in */
487 /* amplsolver.a should never call malloc(0), but */
488 /* solvers may do so. */
489 if (!len)
490 rv = malloc(sizeof(real));
491 if (!rv)
492 memfailure(who, ran_out, len);
493 }
494 return rv;
495 }
496
497 #ifdef KR_headers
498 Char *
499 myralloc(rv, len) char *rv; size_t len;
500 #else
501 void *
502 myralloc(void *rv, size_t len)
503 #endif
504 {
505 static char who[] = "realloc";
506 rv = realloc(rv, len);
507 if (!rv) {
508 if (!len)
509 rv = malloc(sizeof(real));
510 if (!rv)
511 memfailure(who, ran_out, len);
512 }
513 return rv;
514 }
515
516 void
517 what_prog(VOID)
518 {
519 if (progname)
520 fprintf(Stderr, "%s: ", progname);
521 }
522
523 void
524 #ifdef KR_headers
525 badread(R) EdRead *R;
526 #else
527 badread(EdRead *R)
528 #endif
529 {
530 what_prog();
531 fprintf(Stderr, "error reading line %ld of %s:\n\t", R->Line, R->asl->i.filename_);
532 }
533
534 void
535 #ifdef KR_headers
536 badline(R) EdRead *R;
537 #else
538 badline(EdRead *R)
539 #endif
540 {
541 ASL *asl = R->asl;
542 FILE *nl;
543 char *s, *se;
544 int x;
545
546 fprintf(Stderr, "bad line %ld of %s", R->Line, filename);
547 if (xscanf == ascanf) {
548 if (!R->lineinc) {
549 nl = R->nl;
550 s = R->rl_buf;
551 se = s + sizeof(R->rl_buf) - 1;
552 while(s < se && (x = getc(nl)) >= ' ')
553 *++s = x;
554 *s = 0;
555 }
556 fprintf(Stderr, ": %s\n", R->rl_buf);
557 }
558 else
559 fprintf(Stderr, "\n");
560 exit_ASL(R,1);
561 }
562
563 #undef asl
564
565 #define Mb_gulp 31
566 typedef struct Mblock {
567 struct Mblock *next;
568 Char *m[Mb_gulp];
569 } Mblock;
570
571 Char **
572 #ifdef KR_headers
573 M1record_ASL(I, x) Edaginfo *I; Char *x;
574 #else
575 M1record_ASL(Edaginfo *I, Char *x)
576 #endif
577 {
578 Mblock *mb;
579 Char **rv;
580
581 if (I->Mbnext >= I->Mblast) {
582 mb = (Mblock *)Malloc(sizeof(Mblock));
583 mb->next = (Mblock*)I->Mb;
584 I->Mb = (Char*)mb;
585 I->Mbnext = mb->m;
586 I->Mblast = mb->m + Mb_gulp;
587 }
588 rv = I->Mbnext++;
589 *rv = x;
590 return rv;
591 }
592
593 Char *
594 #ifdef KR_headers
595 M1alloc_ASL(I, n) Edaginfo *I; size_t n;
596 #else
597 M1alloc_ASL(Edaginfo *I, size_t n)
598 #endif
599 {
600 Mblock *mb;
601
602 if (I->Mbnext >= I->Mblast) {
603 mb = (Mblock *)Malloc(sizeof(Mblock));
604 mb->next = (Mblock*)I->Mb;
605 I->Mb = (Char*)mb;
606 I->Mbnext = mb->m;
607 I->Mblast = mb->m + Mb_gulp;
608 }
609 return *I->Mbnext++ = Malloc(n);
610 }
611
612 Char *
613 #ifdef KR_headers
614 M1zapalloc_ASL(I, n) Edaginfo *I; size_t n;
615 #else
616 M1zapalloc_ASL(Edaginfo *I, size_t n)
617 #endif
618 {
619 Char *rv;
620
621 memset(rv = M1alloc_ASL(I, n), 0, n);
622 return rv;
623 }
624
625 void
626 #ifdef KR_headers
627 M1free_ASL(I, mnext, mlast) Edaginfo *I; Char **mnext, **mlast;
628 #else
629 M1free_ASL(Edaginfo *I, Char **mnext, Char **mlast)
630 #endif
631 {
632 Char **x, **x0;
633 Mblock *Mb, *mb;
634 Char **Mblast;
635
636 if (!(Mb = (Mblock *)I->Mb))
637 return;
638 x = (Char **)I->Mbnext;
639 Mblast = I->Mblast;
640 I->Mbnext = mnext;
641 I->Mblast = mlast;
642 x0 = Mb->m;
643 for(;;) {
644 if (mlast == Mblast)
645 x0 = mnext;
646 while(x > x0)
647 if (*--x)
648 free(*x);
649 if (mlast == Mblast) {
650 I->Mb = (Char*)Mb;
651 return;
652 }
653 mb = Mb->next;
654 free(Mb);
655 if (!(Mb = mb))
656 break;
657 x0 = Mb->m;
658 Mblast = x = x0 + Mb_gulp;
659 }
660 I->Mb = 0;
661 }
662
663 void
664 #ifdef KR_headers
665 xknown_(x) real *x;
666 #else
667 xknown_(real *x)
668 #endif
669 {
670 ASL *asl;
671 if (!(asl = cur_ASL))
672 badasl_ASL(asl,0,"xknown");
673 xknowne(x, (fint*)0);
674 }
675
676 void
677 #ifdef KR_headers
678 xknowe_(x, nerror) real *x; fint *nerror;
679 #else
680 xknowe_(real *x, fint *nerror)
681 #endif
682 {
683 ASL *asl;
684 if (!(asl = cur_ASL))
685 badasl_ASL(asl,0,"xknown");
686 xknowne(x, nerror);
687 }
688
689
690 void
691 xunkno_(VOID)
692 {
693 ASL *asl;
694 if (!(asl = cur_ASL))
695 badasl_ASL(asl,0,"xunkno");
696 asl->i.x_known = 0;
697 }
698
699 void
700 #ifdef KR_headers
701 mnnzchk_ASL(asl, M, N, NZ, who1) ASL*asl; fint *M,*N,*NZ; char*who1;
702 #else
703 mnnzchk_ASL(ASL *asl, fint *M, fint *N, fint *NZ, char *who1)
704 #endif
705 {
706 int n;
707 if (!asl || (n = asl->i.ASLtype) < ASL_read_fg || n > ASL_read_pfgh)
708 badasl_ASL(asl, ASL_read_fg, who1);
709 ASL_CHECK(asl, n, who1);
710 if (*M != n_con || *N != c_vars || *NZ != nzjac) {
711 what_prog();
712 fprintf(Stderr,
713 "%s: got M = %ld, N = %ld, NZ = %ld\nexpected M = %d, N = %d, NZ = %d\n",
714 who1, (long)*M, (long)*N, *NZ, n_con, c_vars, nzjac);
715 exit(1);
716 }
717 }
718
719 void
720 #ifdef KR_headers
721 LUcopy_ASL(nv, L, U, LU) int nv; real *L, *U, *LU;
722 #else
723 LUcopy_ASL(int nv, real *L, real *U, real *LU)
724 #endif
725 {
726 real *LUe;
727 for(LUe = LU + 2*nv; LU < LUe; LU += 2) {
728 *L++ = LU[0];
729 *U++ = LU[1];
730 }
731 }
732
733 int
734 #ifdef KR_headers
735 already_ASL(who) char *who;
736 #else
737 already_ASL(char *who)
738 #endif
739 {
740 fprintf(Stderr, "%s called after ASL_alloc().\n", who);
741 return 1;
742 }
743
744 void
745 #ifdef KR_headers
746 ASL_free(aslp) ASL **aslp;
747 #else
748 ASL_free(ASL **aslp)
749 #endif
750 {
751 ASL *a;
752 ASLhead *h;
753 extern void at_end_ASL ANSI((Exitcall*));
754
755 if (!(a = *aslp))
756 return;
757 if (a == cur_ASL)
758 cur_ASL = 0;
759 h = a->p.h.prev;
760 (h->next = a->p.h.next)->prev = h;
761 if (a->i.arprev)
762 at_end_ASL(a->i.arprev);
763 M1free(&a->i, (Char**)0, (Char**)0);
764 free((Char*)a);
765 *aslp = 0;
766 }
767
768 void
769 #ifdef KR_headers
770 badasl_ASL(a, n, who) ASL *a; int n; char *who;
771 #else
772 badasl_ASL(ASL *a, int n, char *who)
773 #endif
774 {
775 if (!Stderr)
776 Stderr_init_ASL(); /* set Stderr if necessary */
777 if (a)
778 fprintf(Stderr,
779 "\n*** %s needs ASL_alloc(%d), not ASL_alloc(%d)\n",
780 who, n, a->i.ASLtype);
781 else if (n)
782 fprintf(Stderr, "\n*** %s called before ASL_alloc(%d)\n",
783 who, n);
784 else
785 fprintf(Stderr,
786 "\n*** %s called before ASL_alloc, jacdim, jac2dim, or jacpdim\n", who);
787 exit(1);
788 }
789
790 #define SKIP_NL2_DEFINES
791 #include "nlp.h"
792 #include "nlp2.h"
793 #include "asl_pfg.h"
794 #include "asl_pfgh.h"
795
796 ASL *
797 #ifdef KR_headers
798 ASL_alloc(k) int k;
799 #else
800 ASL_alloc(int k)
801 #endif
802 {
803 static int msize[5] = {
804 sizeof(ASL_fg),
805 sizeof(ASL_fg),
806 sizeof(ASL_fgh),
807 sizeof(ASL_pfg),
808 sizeof(ASL_pfgh)
809 };
810 ASL *a;
811 ASLhead *h;
812 int n;
813
814 if (!Stderr)
815 Stderr_init_ASL(); /* set Stderr if necessary */
816 Mach_ASL();
817 if (k < 1 || k > 5)
818 return 0;
819 a = (ASL*) mymalloc(n = msize[k-1]);
820 memcpy(a, &edagpars_ASL, sizeof(Edagpars));
821 memset(&a->i, 0, n - sizeof(Edagpars));
822 a->i.ASLtype = k;
823 a->i.n_prob = 1;
824 switch(k) {
825 case ASL_read_pfg: ((ASL_pfg*)a)->P.merge = 1; break;
826 case ASL_read_pfgh: ((ASL_pfgh*)a)->P.merge = 1;
827 }
828 h = a->p.h.next = ASLhead_ASL.next;
829 a->p.h.prev = h->prev;
830 h->prev = ASLhead_ASL.next = &a->p.h;
831 return cur_ASL = a;
832 }
833
834 #define Egulp 400
835
836 Char *
837 #ifdef KR_headers
838 mem_ASL(asl, len) ASL *asl; unsigned int len;
839 #else
840 mem_ASL(ASL *asl, unsigned int len)
841 #endif
842 {
843 fint k;
844 char *memNext;
845
846 if (len >= 256)
847 return M1alloc(len);
848 #ifdef Double_Align
849 len = (len + (sizeof(real)-1)) & ~(sizeof(real)-1);
850 #else
851 len = (len + (sizeof(int)-1)) & ~(sizeof(int)-1);
852 #endif
853 ACQUIRE_DTOA_LOCK(MEM_LOCK);
854 memNext = asl->i.memNext;
855 if (memNext + len >= asl->i.memLast) {
856 memNext = (char *)M1alloc(k = Egulp*Sizeof(expr) + len);
857 asl->i.memLast = memNext + k;
858 }
859 asl->i.memNext = memNext + len;
860 FREE_DTOA_LOCK(MEM_LOCK);
861 return memNext;
862 }
863
864 EdRead *
865 #ifdef KR_headers
866 EdReadInit_ASL(R, asl, nl, S) EdRead *R; ASL *asl; FILE *nl; void *S;
867 #else
868 EdReadInit_ASL(EdRead *R, ASL *asl, FILE *nl, void *S)
869 #endif
870 {
871 R->asl = asl;
872 R->nl = nl;
873 R->S = S;
874 R->Line = 10;
875 R->lineinc = 1;
876 R->can_end = 0;
877 R->dadjfcn = asl->i.dadjfcn;
878 R->iadjfcn = asl->i.iadjfcn;
879 return R;
880 }
881
882 void
883 #ifdef KR_headers
884 Suf_read_ASL(R, readall) EdRead *R; int readall;
885 #else
886 Suf_read_ASL(EdRead *R, int readall)
887 #endif
888 {
889 int *d, isreal, i, k, n, nx, nx1;
890 real *r, t;
891 SufDesc *D;
892 char *fmt;
893 ASL *asl = R->asl;
894 char sufname[128];
895
896 if (xscanf(R, "%d %d %127s", &k, &n, sufname) != 3)
897 badline(R);
898 if (k < 0 || k > 7 || n <= 0)
899 badline(R);
900 isreal = k & ASL_Sufkind_real;
901 k &= ASL_Sufkind_mask;
902 nx = (&asl->i.n_var_)[k];
903 if (k == 1)
904 nx += n_lcon;
905 if (n > nx)
906 badline(R);
907 if (readall & 1) {
908 new_D:
909 D = (SufDesc*)M1zapalloc(sizeof(SufDesc) + strlen(sufname) + 1);
910 D->next = asl->i.suffixes[k];
911 asl->i.suffixes[k] = D;
912 asl->i.nsuff[k]++;
913 asl->i.nsuffixes++;
914 strcpy(D->sufname = (char*)(D+1), sufname);
915 D->kind = k;
916 if (isreal)
917 D->kind |= ASL_Sufkind_real;
918 }
919 else for(D = asl->i.suffixes[k]; ; D = D->next) {
920 if (!D) {
921 if (readall)
922 goto new_D;
923 skip:
924 /* Skip this suffix table */
925 fmt = (char*)(isreal ? "%d %lf" : "%d %d");
926 do if (xscanf(R,fmt,&k,&t) != 2)
927 badline(R);
928 while(--n);
929 return;
930 }
931 if (k == (D->kind & ASL_Sufkind_mask)
932 && !strcmp(sufname,D->sufname))
933 break;
934 }
935 if ((D->kind & ASL_Sufkind_outonly) == ASL_Sufkind_outonly)
936 goto skip;
937 nx1 = nx + D->nextra;
938 if (D->kind & ASL_Sufkind_real) {
939 D->u.i = 0;
940 if (!(r = D->u.r))
941 D->u.r = r = (real*)mem(nx1*sizeof(real));
942 if (n < nx)
943 memset(r,0,nx*sizeof(real));
944 if (nx < nx1)
945 memset(r+nx, 0, (nx1-nx)*sizeof(real));
946 if (isreal)
947 do {
948 if (xscanf(R,"%d %lf",&i,&t) != 2
949 || i < 0 || i >= nx)
950 badline(R);
951 r[i] = t;
952 }
953 while(--n);
954 else
955 do {
956 if (xscanf(R,"%d %d",&i,&k) != 2
957 || i < 0 || i >= nx)
958 badline(R);
959 r[i] = k;
960 }
961 while(--n);
962 }
963 else {
964 D->u.r = 0;
965 if (!(d = D->u.i))
966 D->u.i = d = (int*)mem(nx1*sizeof(int));
967 if (n < nx)
968 memset(d,0,nx*sizeof(int));
969 if (nx < nx1)
970 memset(d+nx, 0, (nx1-nx)*sizeof(int));
971 if (isreal)
972 do {
973 if (xscanf(R,"%d %lf",&i,&t) != 2
974 || i < 0 || i >= nx)
975 badline(R);
976 d[i] = (int)(t + 0.5);
977 } while(--n);
978 else
979 do {
980 if (xscanf(R,"%d %d",&i,&k) != 2
981 || i < 0 || i >= nx)
982 badline(R);
983 d[i] = k;
984 }
985 while(--n);
986 }
987 D->kind |= ASL_Sufkind_input;
988 }
989
990 real
991 #ifdef KR_headers
992 f_OPNUM_ASL(e) expr_n *e;
993 #else
994 f_OPNUM_ASL(expr_n *e)
995 #endif
996 {
997 #ifdef _WIN32 /* Work around a Microsoft linker bug... */
998 /* Without the following test, f_OPNUM gets confused */
999 /* with f_OPVARVAL. Both get mapped to the same address */
1000 /* in the r_ops_ASL array defined in fg_read.c. */
1001 if (!e) {
1002 printf("f_OPNUM(e) has e = 0\n");
1003 return 0.;
1004 }
1005 #endif
1006 return e->v;
1007 }
1008
1009 void
1010 #ifdef KR_headers
1011 No_derivs_ASL(who) char *who;
1012 #else
1013 No_derivs_ASL(const char *who)
1014 #endif
1015 {
1016 fprintf(Stderr, "\nBUG: %s called with want_derivs == 0.\n", who);
1017 exit(1);
1018 }
1019
1020 void
1021 #ifdef KR_headers
1022 suf_declare_ASL(asl, sd, n) ASL *asl; SufDecl *sd; int n;
1023 #else
1024 suf_declare_ASL(ASL *asl, SufDecl *sd, int n)
1025 #endif
1026 {
1027 SufDesc *d, *dnext[4];
1028 SufDecl *sde;
1029 int i, j;
1030
1031 if (!asl)
1032 badasl_ASL(asl, 0, "suf_declare");
1033 asl->i.nsuffixes = 0;
1034 if (n > 0) {
1035 asl->i.nsuffixes = n;
1036 d = (SufDesc*)M1alloc(n*sizeof(SufDesc));
1037 memset(asl->i.nsuff, 0, 4*sizeof(int));
1038 for(i = 0; i < n; i++)
1039 asl->i.nsuff[sd[i].kind & ASL_Sufkind_mask]++;
1040 for(i = 0; i < 4; i++)
1041 if (j = asl->i.nsuff[i])
1042 asl->i.suffixes[i] = d += j;
1043 memset(dnext, 0, 4*sizeof(SufDesc*));
1044 for(sde = sd + n; sd < sde; sd++) {
1045 d = --asl->i.suffixes[i = sd->kind & ASL_Sufkind_mask];
1046 d->next = dnext[i];
1047 dnext[i] = d;
1048 d->sufname = sd->name;
1049 d->table = sd->table;
1050 d->kind = sd->kind & ~ASL_Sufkind_input;
1051 d->nextra = sd->nextra;
1052 d->u.i = 0;
1053 d->u.r = 0;
1054 }
1055 }
1056 }
1057
1058 SufDesc *
1059 #ifdef KR_headers
1060 suf_get_ASL(asl, name, kind) ASL *asl; char *name; int kind;
1061 #else
1062 suf_get_ASL(ASL *asl, const char *name, int kind)
1063 #endif
1064 {
1065 SufDesc *d, *de;
1066 int ifread;
1067
1068 if (!asl)
1069 badasl_ASL(asl, 0, "suf_get");
1070 ifread = kind & ASL_Sufkind_input;
1071 d = asl->i.suffixes[kind &= ASL_Sufkind_mask];
1072 de = d + asl->i.nsuff[kind];
1073 for(;; d++) {
1074 if (d >= de) {
1075 fprintf(Stderr, "suf_get(\"%s\") fails!\n", name);
1076 exit(1);
1077 }
1078 if (!strcmp(name, d->sufname))
1079 break;
1080 }
1081 if (ifread && !(d->kind & ASL_Sufkind_input))
1082 d = 0;
1083 return d;
1084 }
1085
1086 SufDesc *
1087 #ifdef KR_headers
1088 suf_iput_ASL(asl, name, kind, I) ASL *asl; char *name; int kind, *I;
1089 #else
1090 suf_iput_ASL(ASL *asl, const char *name, int kind, int *I)
1091 #endif
1092 {
1093 SufDesc *d = suf_get_ASL(asl, name, kind);
1094 d->u.i = I;
1095 d->kind &= ~ASL_Sufkind_real;
1096 d->kind |= ASL_Sufkind_output;
1097 return d;
1098 }
1099
1100 SufDesc *
1101 #ifdef KR_headers
1102 suf_rput_ASL(asl, name, kind, R) ASL *asl; char *name; int kind; real *R;
1103 #else
1104 suf_rput_ASL(ASL *asl, const char *name, int kind, real *R)
1105 #endif
1106 {
1107 SufDesc *d = suf_get_ASL(asl, name, kind);
1108 d->u.r = R;
1109 d->kind |= ASL_Sufkind_output | ASL_Sufkind_real;
1110 return d;
1111 }
1112
1113 #ifdef __cplusplus
1114 }
1115 #endif
1116