127 lines
4.0 KiB
Mathematica
127 lines
4.0 KiB
Mathematica
|
DIM2 ;SFISC/XAK,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;06:48 PM 1 Jul 1998
|
||
|
|
;;22.0;VA FileMan;;Mar 30, 1999
|
||
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
||
|
|
;12277;4186487;4104;
|
||
|
|
;
|
||
|
|
SUB ; "(": open paren situations (GG^DIM1)
|
||
|
|
F %J=%I-1:-1 S %C1=$E(%,%J) Q:%C1'?1(1UN,1"%")
|
||
|
|
S %C1=$E(%,%J+1,%I-1)
|
||
|
|
I %C1]"",%C1'?1(1U,1"%").UN G ERR
|
||
|
|
I %C1]"",%[("."_%C1) G ERR
|
||
|
|
S %(%N,0)=$S(%C1]""!($E(%,%J)="^"):"V^",$E(%,%J)="@":"@^",1:"0^")
|
||
|
|
S %(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%N=%N+1 G 1
|
||
|
|
;
|
||
|
|
UP ; ")": close paren situations (GG^DIM1)
|
||
|
|
I %N=0 G ERR
|
||
|
|
I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR
|
||
|
|
I $E(%,%I+1)]"","<>_[]:/\?'+-=!&#*),"""'[$E(%,%I+1) G ERR
|
||
|
|
S %N=%N-1,%(%N,1)=%(%N,1)+1,%F=$P(%(%N,0),"^") I %F D G ERR:%ERR
|
||
|
|
. S %F=$P(%(%N,0),"^",2),%F1=%(%N,1)
|
||
|
|
. I %F1<+%F S %ERR=1 Q ; not enough commas for this function
|
||
|
|
. I %F1>$P(%F,";",2) S %ERR=1 Q ; too many commas for this function
|
||
|
|
. I %(%N,2),'%(%N,3) S %ERR=1 ; we're in $S and haven't yet hit a :
|
||
|
|
K %(%N+1)
|
||
|
|
I '%F,%F'["V",%F'["@",%F'["P",%(%N,1)>1 G ERR
|
||
|
|
G 1
|
||
|
|
;
|
||
|
|
AR ; ",": comma situations -- "P" below means "parameters" (GG^DIM1)
|
||
|
|
I %N<1 G ERR
|
||
|
|
I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR
|
||
|
|
I '%(%N-1,3),%(%N-1,2) G ERR
|
||
|
|
I "@("[$E(%,1,2) G ERR
|
||
|
|
S %(%N-1,1)=%(%N-1,1)+1,%(%N-1,3)=0 G 1
|
||
|
|
;
|
||
|
|
SEL ; ":": $SELECT delimiter (GG^DIM1)
|
||
|
|
S %(%N-1,3)=%(%N-1,3)+1 G ERR:'%(%N-1,2)!(%(%N-1,3)>1),1
|
||
|
|
;
|
||
|
|
GLO ; "^": global reference (GG^DIM1)
|
||
|
|
D %INC G ERR:$E(%,%I,999)'?1U.UN.P.E&("%("'[%C)
|
||
|
|
G ERR:"=+-\/<>(,#!&*':@[]_"'[$E(%,%I-2)
|
||
|
|
S %I=%I-1 G 1
|
||
|
|
;
|
||
|
|
PAT ; "?": pattern match (GG^DIM1)
|
||
|
|
G ERR:%I=1,1:$E(%,%I+1)="@" D %INC,PATTERN G ERR:%ERR S %I=%I-1 G 1
|
||
|
|
;
|
||
|
|
PATTERN F D PATATOM Q:%C'?1N&(%C'=".")!%ERR
|
||
|
|
Q
|
||
|
|
PATATOM D REPCOUNT Q:%ERR
|
||
|
|
I %C="""" D STRLIT,%INC:'%ERR Q
|
||
|
|
I %C="(" D ALTRN8 Q
|
||
|
|
D PATCODE
|
||
|
|
Q
|
||
|
|
REPCOUNT ;
|
||
|
|
I %C'?1N,%C'="." S %ERR=1 Q
|
||
|
|
N FROM S FROM=+$E(%,%I,999) I %C?1N D INTLIT Q:%ERR
|
||
|
|
I %C="." D %INC
|
||
|
|
Q:%C'?1N I +$E(%,%I,999)<FROM S %ERR=1 Q
|
||
|
|
D INTLIT Q
|
||
|
|
INTLIT I %C'?1N S %ERR=1 Q
|
||
|
|
F D %INC Q:%C'?1N
|
||
|
|
Q
|
||
|
|
STRLIT F D %INC Q:%C="" I %C="""" Q:$E(%,%I+1)'="""" S %I=%I+1
|
||
|
|
I %C="" S %ERR=1
|
||
|
|
Q
|
||
|
|
PATCODE I "ACELNPU"'[%C!(%C="") S %ERR=1 Q
|
||
|
|
F D %INC Q:%C="" Q:"ACELNPU"'[%C
|
||
|
|
Q
|
||
|
|
ALTRN8 I %C'="(" S %ERR=1 Q
|
||
|
|
D %INC,PATATOM Q:%ERR
|
||
|
|
F Q:","'[%C D %INC,PATATOM Q:%ERR
|
||
|
|
I %C'=")" S %ERR=1 Q
|
||
|
|
D %INC
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
BINOP ; binary operator (GG^DIM1)
|
||
|
|
S %Z1=""")%'",%Z2="""($+-^%@'." G OPCHK
|
||
|
|
;
|
||
|
|
MTHOP ; math or relational operator (GG^DIM1)
|
||
|
|
S %Z1=""")%",%Z2="""($+-^%@'." G OPCHK
|
||
|
|
;
|
||
|
|
UNOP ; unary operator (GG^DIM1)
|
||
|
|
S %Z1=""":<>+-'\/()%@#&!*=_][,"
|
||
|
|
S %Z2="""($+-=&!^%.@'" I %C="'" S %Z2=%Z2_"<>?[]"
|
||
|
|
G OPCHK
|
||
|
|
;
|
||
|
|
IND ; "@": indirection (GG^DIM1)
|
||
|
|
I $E(%COM)="F" G ERR
|
||
|
|
S %Z1="^?@(%+-=\/#*!&'_<>[]:,.",%Z2="""(+^-'$@%" G OPCHK
|
||
|
|
;
|
||
|
|
OPCHK ; ensure that the characters before and after the operator are OK
|
||
|
|
S %L1=$E(%,%I-1),%L2=$E(%,%I+1) I %L1="'","[]&!<>="[%C S %L1=$E(%,%I-2)
|
||
|
|
I %L1="","+-'@"'[%C G ERR ; binary: require before
|
||
|
|
I %L1'?1UN,%Z1'[%L1 G ERR ; all: screen before
|
||
|
|
F %F="*","]" I %C=%F,%L2=%F S %I=%I+1,%L2=$E(%,%I+1) Q
|
||
|
|
I %L2="" G ERR ; all: require after
|
||
|
|
I %L2'?1UN,%Z2'[%L2 G ERR ; all: screen after
|
||
|
|
I %C="'","!&[]?=<>"'[%L2,%L1?1UN G ERR ; unary ': not binary
|
||
|
|
G 1
|
||
|
|
;
|
||
|
|
1 ; common exit point for all of ^DIM2
|
||
|
|
G GG^DIM1
|
||
|
|
;
|
||
|
|
DATA ; glvn arguments of $D,$G,$NA,$O, & $Q functions (FUNC^DIM1)
|
||
|
|
D %INC G ERR:%C="",ERR:%C=")",DATA:"^@"[%C D VAR
|
||
|
|
G ERR:"@(,)"'[%C!%ERR,GG1^DIM1
|
||
|
|
;
|
||
|
|
VAR ; variables encountered while parsing exprs (DATA, GG^DIM1)
|
||
|
|
N %START S %START=%I-1 I $E(%,%START)="^" S %START=%START-1
|
||
|
|
I %C="%" D %INC
|
||
|
|
N OUT S OUT=0 F %J=%I:1 S %C=$E(%,%J) D Q:OUT
|
||
|
|
. I ",<>?/\[]+-=_()*&#!':"[%C S OUT=1 Q
|
||
|
|
. I %C="@",$E(%,%J+1)="(",$E(%,%START)="@" S OUT=1 Q
|
||
|
|
. I %C'?1UN S %ERR=1
|
||
|
|
. I %C="^",$D(%(%N-1,"F")),%(%N-1,"F")["TEXT" S %ERR=0,OUT=1
|
||
|
|
Q:%ERR
|
||
|
|
I %C="@" S %I=%J Q
|
||
|
|
S %F=$E(%,%I,%J-1)
|
||
|
|
I %F="^",$E(%,%J)'="(" S %ERR=1
|
||
|
|
I %F]"",%F'?1U.UN,$E(%,%I-1,%J-1)'?1"%".UN S %ERR=1
|
||
|
|
S %I=%J Q
|
||
|
|
;
|
||
|
|
%INC S %I=%I+1,%C=$E(%,%I)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
ERR S %ERR=1,%N=0
|
||
|
|
FINISH G ERR:%N'=0 K %C,%,%F,%F1,%I,%J,%L1,%L2,%N,%T,%Z1,%Z2,%FN,%FZ
|
||
|
|
Q Q
|