restore keywords

[unix-history] / usr / src / old / dbx / fortran.c

diff --git a/usr/src/old/dbx/fortran.c b/usr/src/old/dbx/fortran.c
index 0e286f6..9ef270b 100644 (file)
--- a/usr/src/old/dbx/fortran.c
+++ b/usr/src/old/dbx/fortran.c
@@ -1,6 +1,14 @@
-/* Copyright (c) 1982 Regents of the University of California */
+/*
+ * Copyright (c) 1983 Regents of the University of California.
+ * All rights reserved.  The Berkeley software License Agreement
+ * specifies the terms and conditions for redistribution.
+ */
+
+#ifndef lint
+static char sccsid[] = "@(#)fortran.c  5.3 (Berkeley) %G%";
+#endif not lint

 
 

-static char sccsid[] = "@(#)fortran.c  1.5 (Berkeley) %G%";
+static char rcsid[] = "$Header: fortran.c,v 1.5 84/12/26 10:39:37 linton Exp $";

 
 /*
  * FORTRAN dependent symbol routines.
 
 /*
  * FORTRAN dependent symbol routines.


@@ -19,7 +27,7 @@ static        char sccsid[] = "@(#)fortran.c  1.5 (Berkeley) %G%";
 #include "runtime.h"
 #include "machine.h"
 
 #include "runtime.h"
 #include "machine.h"
 

-#define isfloat(range) ( \
+#define isspecial(range) ( \

     range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \
 )
 
     range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \
 )
 


@@ -172,6 +180,7 @@ Symbol eltype;
        case CONST:
            
            printf("parameter %s = ", symname(s));
        case CONST:
            
            printf("parameter %s = ", symname(s));

+           eval(s->symvalue.constval);

             printval(s);
            break;
 
             printval(s);
            break;
 


@@ -258,8 +267,8 @@ Symbol s;
     register Symbol t;
     register Address a;
     register int i, len;
     register Symbol t;
     register Address a;
     register int i, len;

+    double d1, d2;

 
 

-    /* printf("fortran_printval with class %s \n",classname(s)); OUT*/

     switch (s->class) {
        case CONST:
        case TYPE:
     switch (s->class) {
        case CONST:
        case TYPE:


@@ -282,26 +291,49 @@ Symbol s;
            break;
 
        case RANGE:
            break;
 
        case RANGE:

-            if (isfloat(s)) {
+           if (isspecial(s)) {

                switch (s->symvalue.rangev.lower) {
                switch (s->symvalue.rangev.lower) {

+                   case sizeof(short):
+                       if (istypename(s->type, "logical*2")) {
+                           printlogical(pop(short));
+                       }
+                       break;
+

                    case sizeof(float):
                    case sizeof(float):

-                       prtreal(pop(float));
+                       if (istypename(s->type, "logical")) {
+                           printlogical(pop(long));
+                       } else {
+                           prtreal(pop(float));
+                       }

                        break;
 
                    case sizeof(double):
                        break;
 
                    case sizeof(double):

-                       if(istypename(s->type,"complex")) {
-                          printf("(");
-                       prtreal(pop(float));
-                          printf(",");
-                       prtreal(pop(float));
-                          printf(")");
+                       if (istypename(s->type, "complex")) {
+                           d2 = pop(float);
+                           d1 = pop(float);
+                           printf("(");
+                           prtreal(d1);
+                           printf(",");
+                           prtreal(d2);
+                           printf(")");
+                       } else {
+                           prtreal(pop(double));

                        }
                        }

-                       else prtreal(pop(double));

                        break;
 
                        break;
 

+                   case 2*sizeof(double):
+                       d2 = pop(double);
+                       d1 = pop(double);
+                       printf("(");
+                       prtreal(d1);
+                       printf(",");
+                       prtreal(d2);
+                       printf(")");
+                       break;
+               

                    default:
                    default:

-                       panic("bad size \"%d\" for real",
-                                  t->symvalue.rangev.lower);
+                       panic("bad size \"%d\" for special",
+                                  s->symvalue.rangev.lower);

                        break;
                }
            } else {
                        break;
                }
            } else {


@@ -318,6 +350,20 @@ Symbol s;
     }
 }
 
     }
 }
 

+/*
+ * Print out a logical
+ */
+
+private printlogical(i)
+Integer i;
+{
+    if (i == 0) {
+       printf(".false.");
+    } else {
+       printf(".true.");
+    }
+}
+

 /*
  * Print out an int 
  */
 /*
  * Print out an int 
  */


@@ -326,14 +372,13 @@ private printint(i, t)
 Integer i;
 register Symbol t;
 {
 Integer i;
 register Symbol t;
 {

-    if (istypename(t->type, "logical")) {
-       printf(((Boolean) i) == true ? "true" : "false");
-    }
-    else if ( (t->type == t_int) or istypename(t->type, "integer") or
+    if ( (t->type == t_int) or istypename(t->type, "integer") or

                   istypename(t->type,"integer*2") ) {
        printf("%ld", i);
                   istypename(t->type,"integer*2") ) {
        printf("%ld", i);

+    } else if (istypename(t->type, "addr")) {
+       printf("0x%lx", i);

     } else {
     } else {

-      error("unkown type in fortran printint");
+       error("unknown type in fortran printint");

     }
 }
 
     }
 }
 


@@ -465,34 +510,45 @@ Node a, slist;
  * Evaluate a subscript index.
  */
 
  * Evaluate a subscript index.
  */
 

-public int fortran_evalaref(s, i)
+public fortran_evalaref(s, base, i)

 Symbol s;
 Symbol s;

+Address base;

 long i;
 {
 long i;
 {

-    Symbol r;
+    Symbol r, t;

     long lb, ub;
 
     long lb, ub;
 

-    r = rtype(s)->chain;
-    if(r->symvalue.rangev.lowertype == R_ARG or
-       r->symvalue.rangev.lowertype == R_TEMP  ) {
-       if(! getbound(s,r->symvalue.rangev.lower,
-                       r->symvalue.rangev.lowertype,&lb))
+    t = rtype(s);
+    r = t->chain;
+    if (
+       r->symvalue.rangev.lowertype == R_ARG or
+        r->symvalue.rangev.lowertype == R_TEMP
+    ) {
+       if (not getbound(
+           s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb
+       )) {

           error("dynamic bounds not currently available");
           error("dynamic bounds not currently available");

+       }
+    } else {
+       lb = r->symvalue.rangev.lower;

     }
     }

-    else lb = r->symvalue.rangev.lower;
-
-    if(r->symvalue.rangev.uppertype == R_ARG or
-       r->symvalue.rangev.uppertype == R_TEMP  ) {
-       if(! getbound(s,r->symvalue.rangev.upper,
-                       r->symvalue.rangev.uppertype,&ub))
+    if (
+       r->symvalue.rangev.uppertype == R_ARG or
+        r->symvalue.rangev.uppertype == R_TEMP
+    ) {
+       if (not getbound(
+           s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub
+       )) {

           error("dynamic bounds not currently available");
           error("dynamic bounds not currently available");

+       }
+    } else {
+       ub = r->symvalue.rangev.upper;

     }
     }

-    else ub = r->symvalue.rangev.upper;

 
     if (i < lb or i > ub) {
        error("subscript out of range");
     }
 
     if (i < lb or i > ub) {
        error("subscript out of range");
     }

-    return (i - lb);
+    push(long, base + (i - lb) * size(t->type));

 }
 
 private fortran_printarray(a)
 }
 
 private fortran_printarray(a)