| 1 | DIM2 ;SFISC/XAK,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;06:48 PM 1 Jul 1998
|
|---|
| 2 | ;;22.0;VA FileMan;;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;12277;4186487;4104;
|
|---|
| 5 | ;
|
|---|
| 6 | SUB ; "(": open paren situations (GG^DIM1)
|
|---|
| 7 | F %J=%I-1:-1 S %C1=$E(%,%J) Q:%C1'?1(1UN,1"%")
|
|---|
| 8 | S %C1=$E(%,%J+1,%I-1)
|
|---|
| 9 | I %C1]"",%C1'?1(1U,1"%").UN G ERR
|
|---|
| 10 | I %C1]"",%[("."_%C1) G ERR
|
|---|
| 11 | S %(%N,0)=$S(%C1]""!($E(%,%J)="^"):"V^",$E(%,%J)="@":"@^",1:"0^")
|
|---|
| 12 | S %(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%N=%N+1 G 1
|
|---|
| 13 | ;
|
|---|
| 14 | UP ; ")": close paren situations (GG^DIM1)
|
|---|
| 15 | I %N=0 G ERR
|
|---|
| 16 | I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR
|
|---|
| 17 | I $E(%,%I+1)]"","<>_[]:/\?'+-=!&#*),"""'[$E(%,%I+1) G ERR
|
|---|
| 18 | S %N=%N-1,%(%N,1)=%(%N,1)+1,%F=$P(%(%N,0),"^") I %F D G ERR:%ERR
|
|---|
| 19 | . S %F=$P(%(%N,0),"^",2),%F1=%(%N,1)
|
|---|
| 20 | . I %F1<+%F S %ERR=1 Q ; not enough commas for this function
|
|---|
| 21 | . I %F1>$P(%F,";",2) S %ERR=1 Q ; too many commas for this function
|
|---|
| 22 | . I %(%N,2),'%(%N,3) S %ERR=1 ; we're in $S and haven't yet hit a :
|
|---|
| 23 | K %(%N+1)
|
|---|
| 24 | I '%F,%F'["V",%F'["@",%F'["P",%(%N,1)>1 G ERR
|
|---|
| 25 | G 1
|
|---|
| 26 | ;
|
|---|
| 27 | AR ; ",": comma situations -- "P" below means "parameters" (GG^DIM1)
|
|---|
| 28 | I %N<1 G ERR
|
|---|
| 29 | I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR
|
|---|
| 30 | I '%(%N-1,3),%(%N-1,2) G ERR
|
|---|
| 31 | I "@("[$E(%,1,2) G ERR
|
|---|
| 32 | S %(%N-1,1)=%(%N-1,1)+1,%(%N-1,3)=0 G 1
|
|---|
| 33 | ;
|
|---|
| 34 | SEL ; ":": $SELECT delimiter (GG^DIM1)
|
|---|
| 35 | S %(%N-1,3)=%(%N-1,3)+1 G ERR:'%(%N-1,2)!(%(%N-1,3)>1),1
|
|---|
| 36 | ;
|
|---|
| 37 | GLO ; "^": global reference (GG^DIM1)
|
|---|
| 38 | D %INC G ERR:$E(%,%I,999)'?1U.UN.P.E&("%("'[%C)
|
|---|
| 39 | G ERR:"=+-\/<>(,#!&*':@[]_"'[$E(%,%I-2)
|
|---|
| 40 | S %I=%I-1 G 1
|
|---|
| 41 | ;
|
|---|
| 42 | PAT ; "?": pattern match (GG^DIM1)
|
|---|
| 43 | G ERR:%I=1,1:$E(%,%I+1)="@" D %INC,PATTERN G ERR:%ERR S %I=%I-1 G 1
|
|---|
| 44 | ;
|
|---|
| 45 | PATTERN F D PATATOM Q:%C'?1N&(%C'=".")!%ERR
|
|---|
| 46 | Q
|
|---|
| 47 | PATATOM D REPCOUNT Q:%ERR
|
|---|
| 48 | I %C="""" D STRLIT,%INC:'%ERR Q
|
|---|
| 49 | I %C="(" D ALTRN8 Q
|
|---|
| 50 | D PATCODE
|
|---|
| 51 | Q
|
|---|
| 52 | REPCOUNT ;
|
|---|
| 53 | I %C'?1N,%C'="." S %ERR=1 Q
|
|---|
| 54 | N FROM S FROM=+$E(%,%I,999) I %C?1N D INTLIT Q:%ERR
|
|---|
| 55 | I %C="." D %INC
|
|---|
| 56 | Q:%C'?1N I +$E(%,%I,999)<FROM S %ERR=1 Q
|
|---|
| 57 | D INTLIT Q
|
|---|
| 58 | INTLIT I %C'?1N S %ERR=1 Q
|
|---|
| 59 | F D %INC Q:%C'?1N
|
|---|
| 60 | Q
|
|---|
| 61 | STRLIT F D %INC Q:%C="" I %C="""" Q:$E(%,%I+1)'="""" S %I=%I+1
|
|---|
| 62 | I %C="" S %ERR=1
|
|---|
| 63 | Q
|
|---|
| 64 | PATCODE I "ACELNPU"'[%C!(%C="") S %ERR=1 Q
|
|---|
| 65 | F D %INC Q:%C="" Q:"ACELNPU"'[%C
|
|---|
| 66 | Q
|
|---|
| 67 | ALTRN8 I %C'="(" S %ERR=1 Q
|
|---|
| 68 | D %INC,PATATOM Q:%ERR
|
|---|
| 69 | F Q:","'[%C D %INC,PATATOM Q:%ERR
|
|---|
| 70 | I %C'=")" S %ERR=1 Q
|
|---|
| 71 | D %INC
|
|---|
| 72 | Q
|
|---|
| 73 | ;
|
|---|
| 74 | BINOP ; binary operator (GG^DIM1)
|
|---|
| 75 | S %Z1=""")%'",%Z2="""($+-^%@'." G OPCHK
|
|---|
| 76 | ;
|
|---|
| 77 | MTHOP ; math or relational operator (GG^DIM1)
|
|---|
| 78 | S %Z1=""")%",%Z2="""($+-^%@'." G OPCHK
|
|---|
| 79 | ;
|
|---|
| 80 | UNOP ; unary operator (GG^DIM1)
|
|---|
| 81 | S %Z1=""":<>+-'\/()%@#&!*=_][,"
|
|---|
| 82 | S %Z2="""($+-=&!^%.@'" I %C="'" S %Z2=%Z2_"<>?[]"
|
|---|
| 83 | G OPCHK
|
|---|
| 84 | ;
|
|---|
| 85 | IND ; "@": indirection (GG^DIM1)
|
|---|
| 86 | I $E(%COM)="F" G ERR
|
|---|
| 87 | S %Z1="^?@(%+-=\/#*!&'_<>[]:,.",%Z2="""(+^-'$@%" G OPCHK
|
|---|
| 88 | ;
|
|---|
| 89 | OPCHK ; ensure that the characters before and after the operator are OK
|
|---|
| 90 | S %L1=$E(%,%I-1),%L2=$E(%,%I+1) I %L1="'","[]&!<>="[%C S %L1=$E(%,%I-2)
|
|---|
| 91 | I %L1="","+-'@"'[%C G ERR ; binary: require before
|
|---|
| 92 | I %L1'?1UN,%Z1'[%L1 G ERR ; all: screen before
|
|---|
| 93 | F %F="*","]" I %C=%F,%L2=%F S %I=%I+1,%L2=$E(%,%I+1) Q
|
|---|
| 94 | I %L2="" G ERR ; all: require after
|
|---|
| 95 | I %L2'?1UN,%Z2'[%L2 G ERR ; all: screen after
|
|---|
| 96 | I %C="'","!&[]?=<>"'[%L2,%L1?1UN G ERR ; unary ': not binary
|
|---|
| 97 | G 1
|
|---|
| 98 | ;
|
|---|
| 99 | 1 ; common exit point for all of ^DIM2
|
|---|
| 100 | G GG^DIM1
|
|---|
| 101 | ;
|
|---|
| 102 | DATA ; glvn arguments of $D,$G,$NA,$O, & $Q functions (FUNC^DIM1)
|
|---|
| 103 | D %INC G ERR:%C="",ERR:%C=")",DATA:"^@"[%C D VAR
|
|---|
| 104 | G ERR:"@(,)"'[%C!%ERR,GG1^DIM1
|
|---|
| 105 | ;
|
|---|
| 106 | VAR ; variables encountered while parsing exprs (DATA, GG^DIM1)
|
|---|
| 107 | N %START S %START=%I-1 I $E(%,%START)="^" S %START=%START-1
|
|---|
| 108 | I %C="%" D %INC
|
|---|
| 109 | N OUT S OUT=0 F %J=%I:1 S %C=$E(%,%J) D Q:OUT
|
|---|
| 110 | . I ",<>?/\[]+-=_()*&#!':"[%C S OUT=1 Q
|
|---|
| 111 | . I %C="@",$E(%,%J+1)="(",$E(%,%START)="@" S OUT=1 Q
|
|---|
| 112 | . I %C'?1UN S %ERR=1
|
|---|
| 113 | . I %C="^",$D(%(%N-1,"F")),%(%N-1,"F")["TEXT" S %ERR=0,OUT=1
|
|---|
| 114 | Q:%ERR
|
|---|
| 115 | I %C="@" S %I=%J Q
|
|---|
| 116 | S %F=$E(%,%I,%J-1)
|
|---|
| 117 | I %F="^",$E(%,%J)'="(" S %ERR=1
|
|---|
| 118 | I %F]"",%F'?1U.UN,$E(%,%I-1,%J-1)'?1"%".UN S %ERR=1
|
|---|
| 119 | S %I=%J Q
|
|---|
| 120 | ;
|
|---|
| 121 | %INC S %I=%I+1,%C=$E(%,%I)
|
|---|
| 122 | Q
|
|---|
| 123 | ;
|
|---|
| 124 | ERR S %ERR=1,%N=0
|
|---|
| 125 | FINISH G ERR:%N'=0 K %C,%,%F,%F1,%I,%J,%L1,%L2,%N,%T,%Z1,%Z2,%FN,%FZ
|
|---|
| 126 | Q Q
|
|---|
