/* regex.f -- translated by f2c (version of 17 January 1992 0:17:58). You must link the resulting object file with the libraries: -lF77 -lI77 -lm -lc (in that order) */ /* Signature: 7628c6a0 08-Apr-2002 */ /* #include "f2c.h" */ typedef long int integer; typedef long int logical; typedef long ftnlen; #define TRUE_ (1) #define FALSE_ (0) #define max(a,b) ((a) >= (b) ? (a) : (b)) #ifdef BSD #include <strings.h> #else #include <string.h> #endif #include <ctype.h> #include <stdarg.h> #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" /* Added by Mike Dewar to provide Lisp Interface */ #include <stdio.h> void remark_(char *s,int length) { fprintf(stderr,"error: %s\n",s); } void zlowc_(char *retval, int retlen,char *ch, int chlen) { if (retlen!=1 || chlen!=1) remark_("zlowc: Calling sequence error",0); *retval = isupper(*ch) ? tolower(*ch) : *ch; } void error_(char *s,int length) { fprintf(stderr,"error: %s\n",s); my_exit(42); } /* Common Block Declarations */ struct { integer smode, mode2; } xcsmod_; #define xcsmod_1 xcsmod_ struct { logical isanum[256]; } xcscas_; #define xcscas_1 xcscas_ /* opyright 1991 Numerical Algorithms Group */ /* Match any single character */ /* $pp$ANYCHR='.' */ /* $pp$ANYAPO='?' */ /* Begin character class */ /* $pp$BCLCHR='[' */ /* Beginning of line (string) */ /* $pp$BOLAPO='%' */ /* $pp$BOLCHR='^' */ /* Closure */ /* $pp$CL0CHR='*' */ /* Positive Closure */ /* $pp$CL1CHR='+' */ /* Close tag field (group) */ /* $pp$CTGAPO='}' */ /* $pp$CTGTP1='>' */ /* End character class */ /* $pp$ECLCHR=']' */ /* End of line (string) */ /* $pp$EOLCHR='$' */ /* APOLLO and TPACK1: Escape a character anywhere, @n & @t are special */ /* $pp$ESCAPO='@' */ /* EMACS and EGREP: Escape a character inside a character class, plus */ /* various special functions outside. */ /* $pp$ESCCHR='\\' */ /* Invert character class */ /* $pp$NOTAPO='~' */ /* $pp$NOTCHR='^' */ /* EMACS and EGREP: Optional item (i.e. 0 or 1 repeats) */ /* $pp$OPTCHR='?' */ /* Open tag field (group) */ /* $pp$OTGAPO='{' */ /* $pp$OTGTP1='<' */ /* Recall tag field (group) */ /* $pp$TAGAPO='@' */ /* $pp$TAGTP1='&' */ /* $pp$TAGCHR='\\' */ /* Transition between alphanumerics and non-alphanumerics */ /* $pp$TRNTP1=':' */ /* Modes of operation */ /* $pp$EMACS=0 */ /* $pp$APOLLO=1 */ /* $pp$EGREP=2 */ /* $pp$TPACK1=3 */ /* Internal Pattern Symbols */ /* $pp$TAGSYM=-101 */ /* $pp$CL1SYM=-102 */ /* $pp$TRNSYM=-103 */ /* $pp$EOLSYM=-104 */ /* $pp$CTGSYM=-105 */ /* $pp$CCESYM=-106 */ /* $pp$CL0SYM=-107 */ /* $pp$ANYSYM=-108 */ /* $pp$BOLSYM=-109 */ /* $pp$OTGSYM=-110 */ /* $pp$CCLSYM=-111 */ /* -112 now unused */ /* $pp$EOSSYM=-113 */ /* $pp$DASSYM=-114 */ /* $pp$ERRSYM=-115 */ /* $pp$OPTSYM=-116 */ /* PATTERN MATCHING AND REPLACEMENT ROUTINES */ /* CHARACTER STRING BASED */ /* RMJI - FRIDAY 13 JANUARY 1989 */ /* Substantially revised and enhanced by Malcolm Cohen, October 1989. */ /* ---------------------------------------------------------------------- */ /* Z S I N I T - Initialise String module (regular expressions) */ /* Subroutine */ void zsinit_(mode) /* used to have return type int */ integer *mode; { /* Initialized data */ static char digits[10+1] = "0123456789"; static char lolett[26+1] = "abcdefghijklmnopqrstuvwxyz"; static char uplett[26+1] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; static integer i; if (*mode == 3) { xcsmod_1.smode = 1; xcsmod_1.mode2 = 3; } else { xcsmod_1.smode = *mode; xcsmod_1.mode2 = *mode; } for (i = 0; i <= 255; ++i) { xcscas_1.isanum[i] = FALSE_; /* L100: */ } for (i = 1; i <= 26; ++i) { xcscas_1.isanum[uplett[i - 1]] = TRUE_; xcscas_1.isanum[lolett[i - 1]] = TRUE_; /* L200: */ } for (i = 1; i <= 10; ++i) { xcscas_1.isanum[digits[i - 1]] = TRUE_; /* L300: */ } } /* zsinit_ */ /* ---------------------------------------------------------------------- */ /* Z S C P A T - Compile pattern specification from STRING to */ /* PATSTR, FLAG indicates case sensitivity (.TRUE. */ /* means case sensitive)... */ /* Subroutine */ void zscpat_(string, flag_, patstr, maxpsz, ifail, string_len) char *string; logical *flag_; integer *patstr, *maxpsz, *ifail; ftnlen string_len; { /* System generated locals */ integer i__1; /* Builtin functions */ integer i_len(); /* Local variables */ static integer i, j, lastj, limit, itemp, lj, lastcl; extern logical xlssgc_(); extern integer xissex_(), xisspr_(), xissnx_(); /* Parameter adjustments */ --patstr; /* Function Body */ limit = (integer) string_len; if (*maxpsz <= max(limit,13)) { *ifail = 1; return; } *ifail = 2; /* Save case flag */ if (*flag_) { patstr[1] = 0; } else { patstr[1] = 1; } /* Clear the tag fields and set the pointer to miss it */ for (i = 2; i <= 11; ++i) { patstr[i] = 0; /* L10: */ } patstr[12] = 1; j = 13; lastj = j; lastcl = 0; i = 1; L20: lj = j; if (j + 1 > *maxpsz) { goto L666; } if (string[i - 1] == '.' && xcsmod_1.smode != 1 || string[i - 1] == '?' && xcsmod_1.smode == 1) { patstr[j] = -108; ++j; } else if (string[i - 1] == ':' && xcsmod_1.mode2 == 3) { patstr[j] = -103; ++j; } else if (xcsmod_1.smode != 1 && string[i - 1] == '^' && i == 1 || xcsmod_1.smode == 1 && string[i - 1] == '%' && i == 1) { patstr[j] = -109; ++j; } else if (string[i - 1] == '$' && i == limit) { patstr[j] = -104; ++j; } else if (string[i - 1] == '[') { if (! xlssgc_(string, &i, &patstr[1], &j, maxpsz, string_len)) { return; } } else if ((string[i - 1] == '*' || string[i - 1] == '+' || string[i - 1] == '?' && xcsmod_1.smode != 1) && i > 1) { lj = lastj; if (patstr[lj] == -109 || patstr[lj] == -107 || patstr[lj] == -102) { goto L50; } if (string[i - 1] == '+') { lastj = j; L30: if (lj < lastj) { if (j + 1 > *maxpsz) { goto L666; } patstr[j] = patstr[lj]; ++j; ++lj; goto L30; } } if (j + 4 > *maxpsz) { goto L666; } i__1 = lastj; for (itemp = j - 1; itemp >= i__1; --itemp) { patstr[itemp + 4] = patstr[itemp]; /* L31: */ } j += 4; if (string[i - 1] == '?') { patstr[lastj] = -116; } else { patstr[lastj] = -107; } patstr[lastj + 1] = 0; patstr[lastj + 2] = lastcl; patstr[lastj + 3] = 0; lastcl = lastj; lastj += 4; } else if (string[i - 1] == '{' && xcsmod_1.mode2 == 1 || string[i - 1] == '<' && xcsmod_1.mode2 == 3) { itemp = xissnx_(&patstr[1]); if (itemp <= 0) { *ifail = 4; goto L666; } if (j + 2 > *maxpsz) { goto L666; } patstr[j] = -110; patstr[j + 1] = itemp; j += 2; } else if (string[i - 1] == '}' && xcsmod_1.mode2 == 1 || string[i - 1] == '>' && xcsmod_1.mode2 == 3) { if (j + 2 > *maxpsz) { goto L666; } patstr[j] = -105; patstr[j + 1] = xisspr_(&patstr[1]); if (patstr[j + 1] <= 0) { *ifail = 4; return; } j += 2; } else if (string[i - 1] == '\\' && xcsmod_1.smode != 1 && i < limit) { ++i; if (j + 2 > *maxpsz) { goto L666; } if (string[i - 1] == '(') { if (string[i] == '+' || string[i] == '*' || string[i] == '?') { /* Report error if open tag field followed by +*? */ *ifail = 4; goto L666; } patstr[j] = -110; patstr[j + 1] = xissnx_(&patstr[1]); } else if (string[i - 1] == ')') { patstr[j] = -105; patstr[j + 1] = xisspr_(&patstr[1]); } else if (string[i - 1] == 'b') { patstr[j] = -103; --j; } else { integer tmp=i-1; patstr[j] = xissex_(string, &tmp, string_len); --j; } if (patstr[j + 1] <= 0 && patstr[j + 1] != -103) { *ifail = 4; goto L666; } j += 2; } else { patstr[j] = xissex_(string, &i, string_len); ++j; } lastj = lj; ++i; if (i <= limit) { goto L20; } L50: if (j <= *maxpsz) { patstr[j] = -113; for (i = 2; i <= 11; ++i) { patstr[i] = 0; /* L60: */ } patstr[12] = 1; j = 13; *ifail = 0; return; } /* Some sort of error found - mark the pattern as invalid */ L666: remark_("Invalid pattern",15L); patstr[13] = -115; } /* zscpat_ */ /* ---------------------------------------------------------------------- */ /* Z S F I N D - Match the string against the compiled pattern */ logical zsfind_(string, start, finish, patstr, string_len) char *string; integer *start, *finish, *patstr; ftnlen string_len; { /* System generated locals */ integer i__1; logical ret_val; /* Builtin functions */ integer i_len(); /* Local variables */ static integer i, n; extern integer xissam_(); /* Parameter adjustments */ --patstr; /* Function Body */ if (patstr[13] == -115) { remark_("Pattern is in error", 19L); } else { /* Loop along the line until a match is found */ i__1 = (integer) string_len; for (i = 1; i <= i__1; ++i) { n = xissam_(string, &i, &patstr[1], string_len); if (n > 0) { ret_val = TRUE_; *start = i; *finish = n - 1; return ret_val; } /* L10: */ } } ret_val = FALSE_; return ret_val; } /* zsfind_ */ /* ---------------------------------------------------------------------- */ /* X I S S A M - Function to look for a pattern match */ integer xissam_(lin, from, patstr, lin_len) char *lin; integer *from, *patstr; ftnlen lin_len; { /* System generated locals */ integer ret_val; /* Builtin functions */ integer i_len(); /* Local variables */ static integer i, j, stack, offset; extern logical xlssom_(); extern integer xissps_(); /* Parameter adjustments */ --patstr; /* Function Body */ stack = 0; offset = *from; j = 13; L10: if (patstr[j] != -113) { if (patstr[j] == -107 || patstr[j] == -116) { stack = j; j += 4; i = offset; L20: if (i <= (integer) lin_len) { if (xlssom_(lin, &i, &j, &patstr[1], lin_len)) { if (patstr[stack] != -116) { goto L20; } } } patstr[stack + 1] = i - offset; patstr[stack + 3] = offset; offset = i; } else if (! xlssom_(lin, &offset, &j, &patstr[1], lin_len)) { L40: if (stack > 0) { if (patstr[stack + 1] <= 0) { stack = patstr[stack + 2]; goto L40; } } if (stack <= 0) { ret_val = 0; return ret_val; } --patstr[stack + 1]; j = stack + 4; offset = patstr[stack + 3] + patstr[stack + 1]; } j += xissps_(&j, &patstr[1]); goto L10; } /* Match found, return pointer to end of match */ ret_val = offset; return ret_val; } /* xissam_ */ /* ---------------------------------------------------------------------- */ /* X S S S C T - Function to close a tag field and save the */ /* current pointer value. */ /* Subroutine */ void xsssct_(point, n, string) integer *point, *n, *string; { static integer temp; /* Parameter adjustments */ --string; /* Function Body */ if (*n >= 1 && *n <= 9) { temp = string[*n + 2] / 256; string[*n + 2] = *point + (temp << 8); } } /* xsssct_ */ /* ---------------------------------------------------------------------- */ /* X I S S N X - Function to return an index to the next free tag */ /* field identifier. */ integer xissnx_(string) integer *string; { /* System generated locals */ integer ret_val; /* Parameter adjustments */ --string; /* Function Body */ if (string[12] > 9) { ret_val = -1; } else { ret_val = string[12]; ++string[12]; } return ret_val; } /* xissnx_ */ /* ---------------------------------------------------------------------- */ /* X S S S O P - Function to open a tag field and save the start */ /* position. */ /* Subroutine */ void xsssop_(point, n, string) integer *point, *n, *string; { /* Parameter adjustments */ --string; /* Function Body */ if (*n >= 1 && *n <= 9) { /* Save current pointer in tag field array */ string[*n + 2] = *point << 8; } } /* xsssop_ */ /* ---------------------------------------------------------------------- */ /* X I S S P R - Function to return the value of the current tag */ /* field to be closed. The storage location in */ /* PATSTR is used to hold markers to indicate which */ /* tag fields have been closed already, these */ /* markers are cleared on exit from ZCOMPP. */ integer xisspr_(patstr) integer *patstr; { /* System generated locals */ integer ret_val; /* Parameter adjustments */ --patstr; /* Function Body */ ret_val = patstr[12] - 1; L10: if (ret_val > 0) { if (patstr[ret_val + 2] != 0) { --ret_val; goto L10; } else { patstr[ret_val + 2] = 1; } } return ret_val; } /* xisspr_ */ /* ---------------------------------------------------------------------- */ /* X S S S D O - Expand pattern class range */ logical xsssdo_(valid, array, i, set, j, maxset, valid_len, array_len) char *valid, *array; integer *i, *set, *j, *maxset; ftnlen valid_len; ftnlen array_len; { /* System generated locals */ integer i__1; logical ret_val; char ch__1[1]; /* Builtin functions */ integer i_indx(); /* Local variables */ static integer k, limit; extern integer xissex_(); /* Added by ICH */ char *valid_null_term; /* Parameter adjustments */ --set; /* Function Body */ ++(*i); --(*j); ch__1[0] = xissex_(array, i, array_len); /* limit = i_indx(valid, ch__1, valid_len, 1L); */ valid_null_term = (char *) malloc(valid_len+1); strncpy(valid_null_term,valid,(int) valid_len); valid_null_term[valid_len]='\0'; limit = (integer) ((strchr(valid_null_term,ch__1[0]) - valid_null_term) + 1); if (limit<0) limit=0; ch__1[0] = set[*j]; if (*j + limit - (integer) (strchr(valid_null_term,ch__1[0]) - valid_null_term + 1) + 1 <= *maxset) { ch__1[0] = set[*j]; i__1 = limit; for (k = (integer) (strchr(valid_null_term,ch__1[0]) - valid_null_term + 1); k <= i__1; ++k) { set[*j] = valid[k - 1]; ++(*j); /* L10: */ } ret_val = TRUE_; } else { ret_val = FALSE_; } free((void *)valid_null_term); return ret_val; } /* xsssdo_ */ /* ---------------------------------------------------------------------- */ /* X I S S E X - Un-escape a single character */ integer xissex_(array, i, array_len) char *array; integer *i; ftnlen array_len; { /* System generated locals */ integer ret_val; if (array[*i - 1] == '@' && xcsmod_1.smode == 1 || array[*i - 1] == '\\' && xcsmod_1.smode != 1) { ++(*i); if (array[*i - 1] == 'n') { ret_val = 10; } else if (array[*i - 1] == 't') { ret_val = 9; } else { ret_val = array[*i - 1]; } } else { ret_val = array[*i - 1]; } return ret_val; } /* xissex_ */ /* ---------------------------------------------------------------------- */ /* X S S S F I - Fill a character class set for pattern matching */ /* Subroutine */ void xsssfi_(array, i, set, j, maxset, array_len) char *array; integer *i, *set, *j, *maxset; ftnlen array_len; { /* System generated locals */ char ch__1[1]; /* Builtin functions */ integer i_len(), i_indx(); /* Local variables */ static logical ok; extern integer xissex_(); extern logical xsssdo_(); /* Parameter adjustments */ --set; /* Function Body */ L10: ok = *j + 1 < *maxset; if (ok && array[*i - 1] != ']') { if (array[*i - 1] == '\\' && xcsmod_1.smode != 1 || array[*i - 1] == '@' && xcsmod_1.smode == 1) { /* Character has been escaped */ set[*j] = xissex_(array, i, array_len); ++(*j); } else if (array[*i - 1] != '-') { set[*j] = array[*i - 1]; ++(*j); } else if (*j <= 1 || *i == (integer) array_len) { set[*j] = -114; ++(*j); } else /* if(complicated condition) */ { ch__1[0] = set[*j - 1]; if (*ch__1>='0' && *ch__1<='9') { ok = xsssdo_("0123456789", array, i, &set[1], j, maxset, 10L, array_len); } else /* if(complicated condition) */ { ch__1[0] = set[*j - 1]; if (*ch__1>='a' && *ch__1<='z' ) { ok = xsssdo_("abcdefghijklmnopqrstuvwxyz", array, i, &set[ 1], j, maxset, 26L, array_len); } else /* if(complicated condition) */ { ch__1[0] = set[*j - 1]; if ( *ch__1>='A' && *ch__1<='Z') { ok = xsssdo_("ABCDEFGHIJKLMNOPQRSTUVWXYZ", array, i, & set[1], j, maxset, 26L, array_len); } else { set[*j] = -114; ++(*j); } } } } ++(*i); if (*i <= (integer) array_len) { goto L10; } } } /* xsssfi_ */ /* ---------------------------------------------------------------------- */ /* X L S S G C - Get character class */ logical xlssgc_(arg, i, pat, j, maxpsz, arg_len) char *arg; integer *i, *pat, *j, *maxpsz; ftnlen arg_len; { /* System generated locals */ logical ret_val; /* Local variables */ static integer jstart; extern /* Subroutine */ void xsssfi_(); static integer sym; /* Parameter adjustments */ --pat; /* Function Body */ ++(*i); /* Check if an inclusive or exclusive set is being requested */ if (arg[*i - 1] == '^' && xcsmod_1.smode != 1 || arg[*i - 1] == '~' && xcsmod_1.smode == 1) { ++(*i); sym = -106; } else { sym = -111; } if (*j + 2 <= *maxpsz) { pat[*j] = sym; pat[*j + 1] = 0; jstart = *j + 1; *j += 2; xsssfi_(arg, i, &pat[1], j, maxpsz, arg_len); pat[jstart] = *j - jstart - 1; /* Check to see if pattern filled in ok */ ret_val = arg[*i - 1] == ']'; } else { ret_val = FALSE_; } return ret_val; } /* xlssgc_ */ /* ---------------------------------------------------------------------- */ /* X L S S L O - Match a single character against a char set */ logical xlsslo_(c, pat, offset, c_len) char *c; integer *pat, *offset; ftnlen c_len; { /* System generated locals */ logical ret_val; /* Local variables */ static integer i; /* Parameter adjustments */ --pat; /* Function Body */ i = *offset + pat[*offset]; L10: if (i > *offset) { if (*c == pat[i]) { ret_val = TRUE_; return ret_val; } --i; goto L10; } ret_val = FALSE_; return ret_val; } /* xlsslo_ */ /* ---------------------------------------------------------------------- */ /* X L S S O M - Match a single pattern */ logical xlssom_(lin, i, j, patstr, lin_len) char *lin; integer *i, *j, *patstr; ftnlen lin_len; { /* System generated locals */ integer i__1; logical ret_val; char ch__1[1], ch__2[1], ch__3[1]; /* Builtin functions */ integer i_len(); /* Local variables */ static integer bump; extern logical xlsslo_(); extern /* Subroutine */ void xsssct_(), xsssop_(); /* Set initial (invalid) value for pointer update */ /* Parameter adjustments */ --patstr; /* Function Body */ bump = -1; /* Open tag field */ if (patstr[*j] == -110) { bump = 0; xsssop_(i, &patstr[*j + 1], &patstr[1]); /* Close tag field */ } else if (patstr[*j] == -105) { bump = 0; xsssct_(i, &patstr[*j + 1], &patstr[1]); /* Transition (or end or line or beginning of line) */ } else if (patstr[*j] == -103) { if (*i > (integer) lin_len || *i == 1) { bump = 0; } else { i__1 = *i - 2; if (xcscas_1.isanum[lin[*i - 1]] != xcscas_1.isanum[lin[i__1]]) { bump = 0; /* ELSE IF (I.GT.1) THEN */ /* IF (ICHAR(LIN(I:I)).EQ.10) BUMP = 0 */ } } /* End of the line */ } else if (*i > (integer) lin_len) { if (patstr[*j] == -104) { bump = 0; } } else if (patstr[*j] == -104) { if (lin[*i - 1] == 10) { bump = 0; } /* Ordinary character */ } else if (patstr[*j] > 0) { if (patstr[1] == 1) { zlowc_(ch__1, 1L, lin + (*i - 1), 1L); ch__3[0] = patstr[*j]; zlowc_(ch__2, 1L, ch__3, 1L); if (ch__1[0] == ch__2[0]) { bump = 1; } } else { if (lin[*i - 1] == patstr[*j]) { bump = 1; } } /* Beginning of the line */ } else if (patstr[*j] == -109) { if (*i == 1) { bump = 0; } /* Free match (any character) */ } else if (patstr[*j] == -108) { if (lin[*i - 1] != 10 && *i <= (integer) lin_len) { bump = 1; } /* Character class */ } else if (patstr[*j] == -111) { i__1 = *j + 1; if (xlsslo_(lin + (*i - 1), &patstr[1], &i__1, 1L)) { bump = 1; } /* Negated character class */ } else if (patstr[*j] == -106) { i__1 = *j + 1; if (lin[*i - 1] != 10 && *i <= (integer) lin_len && ! xlsslo_(lin + (*i - 1), &patstr[1], &i__1, 1L)) { bump = 1; } /* Otherwise */ } else { error_("Invalid compiled pattern", 24L); } /* If bump is no longer -1 then a match has been found */ if (bump >= 0) { *i += bump; } ret_val = bump >= 0; return ret_val; } /* xlssom_ */ /* ---------------------------------------------------------------------- */ /* X I S S P S - Return size of pattern entry */ integer xissps_(n, patstr) integer *n, *patstr; { /* System generated locals */ integer ret_val; /* Parameter adjustments */ --patstr; /* Function Body */ if (patstr[*n] > 0) { ret_val = 1; } else if (patstr[*n] == -109 || patstr[*n] == -104 || patstr[*n] == -108 || patstr[*n] == -103) { ret_val = 1; } else if (patstr[*n] == -111 || patstr[*n] == -106) { ret_val = patstr[*n + 1] + 2; } else if (patstr[*n] == -107) { ret_val = 4; } else if (patstr[*n] == -110 || patstr[*n] == -105) { ret_val = 2; } else { error_("XISSPS: Invalid pattern entry found", 35L); } return ret_val; } /* xissps_ */