date and time created 87/03/16 17:57:33 by bostic

SCCS-vsn: usr.bin/ctags/fortran.c 5.1

diff --git a/usr/src/usr.bin/ctags/fortran.c b/usr/src/usr.bin/ctags/fortran.c
new file mode 100644 (file)
index 0000000..568fc16
--- /dev/null
+++ b/usr/src/usr.bin/ctags/fortran.c
@@ -0,0 +1,125 @@
+/*
+ * Copyright (c) 1987 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.1 (Berkeley) %G%";
+#endif not lint
+
+#include <ctags.h>
+#include <strings.h>
+
+char   *lbp;                           /* line buffer pointer */
+
+PF_funcs()
+{
+       register bool   pfcnt;          /* pascal/fortran functions found */
+       register char   *cp;
+       char    tok[MAXTOKEN],
+               *gettoken();
+
+       for (pfcnt = NO;;) {
+               lineftell = ftell(inf);
+               if (!fgets(lbuf,sizeof(lbuf),inf))
+                       return(pfcnt);
+               ++lineno;
+               lbp = lbuf;
+               if (*lbp == '%')        /* Ratfor escape to fortran */
+                       ++lbp;
+               for (;isspace(*lbp);++lbp);
+               if (!*lbp)
+                       continue;
+               switch (*lbp | ' ') {   /* convert to lower-case */
+               case 'c':
+                       if (cicmp("complex") || cicmp("character"))
+                               takeprec();
+                       break;
+               case 'd':
+                       if (cicmp("double")) {
+                               for (;isspace(*lbp);++lbp);
+                               if (!*lbp)
+                                       continue;
+                               if (cicmp("precision"))
+                                       break;
+                               continue;
+                       }
+                       break;
+               case 'i':
+                       if (cicmp("integer"))
+                               takeprec();
+                       break;
+               case 'l':
+                       if (cicmp("logical"))
+                               takeprec();
+                       break;
+               case 'r':
+                       if (cicmp("real"))
+                               takeprec();
+                       break;
+               }
+               for (;isspace(*lbp);++lbp);
+               if (!*lbp)
+                       continue;
+               switch (*lbp | ' ') {
+               case 'f':
+                       if (cicmp("function"))
+                               break;
+                       continue;
+               case 'p':
+                       if (cicmp("program") || cicmp("procedure"))
+                               break;
+                       continue;
+               case 's':
+                       if (cicmp("subroutine"))
+                               break;
+               default:
+                       continue;
+               }
+               for (;isspace(*lbp);++lbp);
+               if (!*lbp)
+                       continue;
+               for (cp = lbp + 1;*cp && intoken(*cp);++cp);
+               if (cp = lbp + 1)
+                       continue;
+               *cp = EOS;
+               (void)strcpy(tok,lbp);
+               getline();                      /* process line for ex(1) */
+               pfnote(tok,lineno);
+               pfcnt = YES;
+       }
+       /*NOTREACHED*/
+}
+
+/*
+ * cicmp --
+ *     do case-independent strcmp
+ */
+cicmp(cp)
+       register char   *cp;
+{
+       register int    len;
+       register char   *bp;
+
+       for (len = 0,bp = lbp;*cp && (*cp &~ ' ') == (*bp++ &~ ' ');
+           ++cp,++len);
+       if (!*cp) {
+               lbp += len;
+               return(YES);
+       }
+       return(NO);
+}
+
+static
+takeprec()
+{
+       for (;isspace(*lbp);++lbp);
+       if (*lbp == '*') {
+               for (++lbp;isspace(*lbp);++lbp);
+               if (!isdigit(*lbp))
+                       --lbp;                  /* force failure */
+               else
+                       while (isdigit(*++lbp));
+       }
+}