| 1 | ARJTDIM1 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;5/26/2004 23:44
|
|---|
| 2 | ;;3.0T1;OPENVISTA;;Jun 20, 2004
|
|---|
| 3 | ;
|
|---|
| 4 | ; Change History:
|
|---|
| 5 | ; 2004 05 26 WV/TOAD: add comments to GG to help document code
|
|---|
| 6 | ; leading to extended global refs
|
|---|
| 7 | ;
|
|---|
| 8 | Q:%ERR N %A,%A1 S (%I,%N,%ERR,%(-1,2),%(-1,3))=0
|
|---|
| 9 | ;
|
|---|
| 10 | GG ; expr, expratom, expritem, subscript, parameter (called everywhere)
|
|---|
| 11 | D %INC ; advance cursor to next character in expr
|
|---|
| 12 | I %C="" G FINISH^ARJTDIM2 ; no next character? then done
|
|---|
| 13 | I %C=";"!($A(%C)>95)!($A(%C)<33) G E ; semicolons or control chars are errors
|
|---|
| 14 | I %C="""" G QUOTE ; strings
|
|---|
| 15 | I %C="$" G FUNC ; functions, vars, and extrinsics
|
|---|
| 16 | I %C="(" G SUB^ARJTDIM2 ; start of nested parens (subs or args)
|
|---|
| 17 | I %C=")" G UP^ARJTDIM2 ; end of nested parens
|
|---|
| 18 | I %C="," G AR^ARJTDIM2 ; commas (e.g., subscripts)
|
|---|
| 19 | I %C=":" G SEL^ARJTDIM2 ; colons (e.g., $SELECT)
|
|---|
| 20 | I %C="^" G GLO^ARJTDIM2 ; gvn
|
|---|
| 21 | EXP I %C="E",$E(%,%I-1)?1N D G E:%ERR S %I=%I-1 G GG
|
|---|
| 22 | . S %L1=$E(%,%I+1)
|
|---|
| 23 | . I %L1'="-",%L1'="+",%L1'?1N S %ERR=1 Q
|
|---|
| 24 | . N %OUT S %OUT=0 F %I=%I+2:1 D Q:%ERR!%OUT
|
|---|
| 25 | . . S %C=$E(%,%I)
|
|---|
| 26 | . . I "<>=!&'[]+-*/\#_?,:)"[%C S %OUT=1 Q
|
|---|
| 27 | . . I %C'?1N S %ERR=1 Q
|
|---|
| 28 | I %C?1U!(%C="%") D VAR^ARJTDIM2 ; lvn
|
|---|
| 29 | I %ERR G E ; errors
|
|---|
| 30 | I %C="" G GG ; if done, get next character of expr
|
|---|
| 31 | I %C="?" G PAT^ARJTDIM2 ; pattern match
|
|---|
| 32 | I "=[]<>&!"[%C G BINOP^ARJTDIM2 ; string & logic operators
|
|---|
| 33 | I "/\*#_"[%C G MTHOP^ARJTDIM2 ; math operators
|
|---|
| 34 | I "'+-"[%C G UNOP^ARJTDIM2 ; unary operators
|
|---|
| 35 | I %C="@" G IND^ARJTDIM2 ; indirection
|
|---|
| 36 | PERIOD I %C="." D G E:%ERR ; periods
|
|---|
| 37 | . I $P($G(%(%N-1,0)),"^")="P" D Q
|
|---|
| 38 | . . N %C S %C=$E(%,%I+1) I %C?1N Q ; decimal pass by value
|
|---|
| 39 | . . I %C'="@",%C'?1U,%C'="%" S %ERR=1 ; bad pass by reference
|
|---|
| 40 | . D %INC N %L1,%P S %L1=$E(%,%I-2),%P="':=+-\/<>[](,*&!_#"
|
|---|
| 41 | . I %L1?1N,%C?1N Q ; 4.2
|
|---|
| 42 | . I %P[%L1,%C?1N Q ; +.2
|
|---|
| 43 | . S %ERR=1 ; illegal period
|
|---|
| 44 | I %C?1N,$E(%,%I+1)]"",$E(%,%I+1)'?1NP,$E(%,%I+1)'="E" G E ; bad numbers
|
|---|
| 45 | GG1 ;
|
|---|
| 46 | I %C]"","$(),:"""[%C S %I=%I-1 ; if at start of next expr, back up 1 char
|
|---|
| 47 | G GG ; process next expr
|
|---|
| 48 | ;
|
|---|
| 49 | QUOTE ; strlit (GG)
|
|---|
| 50 | F %J=0:0 D %INC Q:%C=""!(%C="""")
|
|---|
| 51 | G E:%C=""!("[]()><\/+-=&!_#*,;:'"""'[$E(%,%I+1)) D:$D(%(%N-1,"F")) FN:%(%N-1,"F")["FN" G E:%ERR,GG
|
|---|
| 52 | ;
|
|---|
| 53 | ;
|
|---|
| 54 | FUNC ; intrinsics & extrinsics, mainly intrinsic functions (GG)
|
|---|
| 55 | D %INC ; check next character
|
|---|
| 56 | G EXT:%C="$" ; $$ = extrinsic function
|
|---|
| 57 | I %C="&" D ; external function, not valid but capture
|
|---|
| 58 | . N REF S REF=$E(%,1,$F(%,"(",%I)-2) ; e.g., "$&ZLIB.%SPAWN(...)"
|
|---|
| 59 | . I REF="" S REF=$E(%,1,$F(%,",",%I)-2) ; e.g., "$&%UCI"
|
|---|
| 60 | . I REF[".",$P(REF,".",2)'="" S REF=$P(REF,".",2) ; e.g., return %SPAWN
|
|---|
| 61 | . D DSM(,REF,FIND,.FOUND)
|
|---|
| 62 | G E:%C'?1U ; otherwise, MUST be an uppercase character next
|
|---|
| 63 | G SPV:$E(%,%I,999)'?.U1"(".E ; if no (, then it's a special variable
|
|---|
| 64 | G FUNC1:%C="Z"!($E(%,%I+1)="(") ; Z-functions & 1-character abbrevs
|
|---|
| 65 | ;
|
|---|
| 66 | ; 2-character-abreviated functions
|
|---|
| 67 | S %T=$E(%,%I,$F(%,"(",%I)-2) ; full abbrev
|
|---|
| 68 | I %T="ST"!(%T="STACK") G E ; SAC
|
|---|
| 69 | F %F1="FNUMBER^2;3","TRANSLATE^2;3","NAME^1;2","QLENGTH^1;1","QSUBSCRIPT^2;2","REVERSE^1;1" G FUNC2:$E(%F1,1,2)=%T,FUNC2:$P(%F1,"^")=%T
|
|---|
| 70 | ;
|
|---|
| 71 | ; can a function ever pass this line?
|
|---|
| 72 | G E:$T(FNC)'[(","_%T_"^")
|
|---|
| 73 | ;
|
|---|
| 74 | ; this list of functions is used by FUNC1
|
|---|
| 75 | FNC ;;,ASCII^1;2,CHAR^1;999,DATA^1;1,EXTRACT^1;3,FIND^2;3,GET^1;2,JUSTIFY^2;3,LENGTH^1;2,ORDER^1;2,PIECE^2;4,QUERY^1;1,RANDOM^1;1,SELECT^1;999,TEXT^1;1,VIEW^1;999,ZFUNC^1;999
|
|---|
| 76 | ;
|
|---|
| 77 | FUNC1 ; this line not only validates 1-char-abbrev functions, it also allows
|
|---|
| 78 | ; Z-functions
|
|---|
| 79 | S %F1=$P($T(FNC),",",$F("ACDEFGJLOPQRSTVZ",%C)) G E:%F1=""
|
|---|
| 80 | S %F1("CODE")=$E(%,%I,$F(%,"(",%I)-2) ; capture form in code
|
|---|
| 81 | ;
|
|---|
| 82 | FUNC2 ; I think this remembers function context in prep for arg eval
|
|---|
| 83 | S %I=$F(%,"(",%I)-1 ; advance to (
|
|---|
| 84 | S %(%N,0)="1^"_$P(%F1,"^",2) ; min;max # of args to expect
|
|---|
| 85 | S %(%N,1)=0
|
|---|
| 86 | S %(%N,2)=0
|
|---|
| 87 | S %(%N,3)=0
|
|---|
| 88 | S %(%N,"F")=%F1 ; function name
|
|---|
| 89 | S %N=%N+1 ; expression nesting depth?
|
|---|
| 90 | S:$E(%F1)="S" %(%N-1,2)=1 ; $SELECT
|
|---|
| 91 | ;
|
|---|
| 92 | ; these operate on namevalues
|
|---|
| 93 | I ",DATA,NAME,ORDER,QUERY,GET,"[(","_$P(%F1,"^")_",") G DATA^ARJTDIM2
|
|---|
| 94 | ;
|
|---|
| 95 | ; validation of $TEXT
|
|---|
| 96 | I $E(%F1)="T",$E(%F1,2)'="R" D I %ERR G ERR^ARJTDIM2
|
|---|
| 97 | . S %A=%I,%I=$F(%,")",%A)-1,%N=%N-1,%A=$P($E(%,%A,%I-1),"(",2,99)
|
|---|
| 98 | . I %A?1"+"1N.E S %A=$E(%A,2,999)
|
|---|
| 99 | . N %,%I,%N S %=%A D LABEL^ARJTDIM3(1)
|
|---|
| 100 | ;
|
|---|
| 101 | ; capture of $VIEW
|
|---|
| 102 | I $P($G(%F1),U)="VIEW" D
|
|---|
| 103 | . D DSM("$V","$VIEW",FIND,.FOUND)
|
|---|
| 104 | ;
|
|---|
| 105 | ; capture of $ZCALL
|
|---|
| 106 | ; W !?40,%F1," ",%F1("CODE")," ",%,!
|
|---|
| 107 | I $P($G(%F1),U)="ZFUNC",%F1("CODE")="ZC"!(%F1("CODE")="ZCALL") D
|
|---|
| 108 | . N ARG S ARG=$E(%,%I+1,$F(%,")",%I)-2) I ARG["," S ARG=$P(ARG,",")
|
|---|
| 109 | . D DSM(,ARG,FIND,.FOUND)
|
|---|
| 110 | ;
|
|---|
| 111 | ; capture other $Z functions
|
|---|
| 112 | E I $P($G(%F1),U)="ZFUNC" D
|
|---|
| 113 | . D DSM("$Z","$"_%F1("CODE"),FIND,.FOUND)
|
|---|
| 114 | ;
|
|---|
| 115 | ; go evaluate the arguments
|
|---|
| 116 | G GG
|
|---|
| 117 | ;
|
|---|
| 118 | ;
|
|---|
| 119 | SPV ; intrinsic special variables (FUNC)
|
|---|
| 120 | I $E(%,%I+1)?1U S %I=%I+1,%C=%C_$E(%,%I) G SPV
|
|---|
| 121 | I ",D,EC,ES,ET,K,P,Q,ST,SY,TL,TR,"[(","_%C_",") G E ; SAC
|
|---|
| 122 | I "HIJSTXYZ"[%C&(%C?1U)!(%C?1"Z".U) D G GG
|
|---|
| 123 | . Q:$E(%C)'="Z"
|
|---|
| 124 | . D DSM("$Z*","$"_%C,FIND,.FOUND)
|
|---|
| 125 | I "[],)><=_&#!'+-*\/?"'[$E(%,%I+1) G E
|
|---|
| 126 | I ",DEVICE,ECODE,ESTACK,ETRAP,KEY,PRINCIPAL,QUIT,STACK,SYSTEM,TLEVEL,TRESTART,"[(","_%C_",") G E ; SAC
|
|---|
| 127 | I ",HOROLOG,IO,JOB,STORAGE,TEST,"[(","_%C_",") G GG
|
|---|
| 128 | E G ERR^ARJTDIM2
|
|---|
| 129 | ;
|
|---|
| 130 | %INC S %I=%I+1,%C=$E(%,%I) Q
|
|---|
| 131 | ;
|
|---|
| 132 | FN ; literal string argument 2 of $FNUMBER (QUOTE)
|
|---|
| 133 | Q:%(%N-1,1)'=1 F %FZ=%I-1:-1 S %FN=$E(%,%FZ) Q:%FN=""""
|
|---|
| 134 | S %FN=$TR($E(%,%FZ+1,%I-1),"pt","PT")
|
|---|
| 135 | F %FZ=1:1 Q:$E(%FN,%FZ)="" I "+-,TP"'[$E(%FN,%FZ) S %ERR=1 Q
|
|---|
| 136 | Q:%ERR I %FN["P" F %FZ=1:1 Q:$E(%FN,%FZ)="" I "+-T"[$E(%FN,%FZ) S %ERR=1 Q
|
|---|
| 137 | Q
|
|---|
| 138 | ;
|
|---|
| 139 | EXT ; extrinsic functions and variables (FUNC)
|
|---|
| 140 | D %INC
|
|---|
| 141 | F %I=%I+1:1 S %C1=$E(%,%I) Q:%C1?1PC&("^%"'[%C1)!(%C1="") S %C=%C_%C1
|
|---|
| 142 | G:%C="" E G:%C?.E1"^" E G:%C["^^" E
|
|---|
| 143 | S %C1=$P(%C,"^",2) I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN G E
|
|---|
| 144 | S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N G E
|
|---|
| 145 | I $E(%,%I)="(",$E(%,%I+1)'=")" S %(%N,0)="P^",(%(%N,1),%(%N,2),%(%N,3))=0,%N=%N+1 G GG
|
|---|
| 146 | S %I=%I+$S($E(%,%I,%I+1)="()":1,1:-1)
|
|---|
| 147 | G GG:"[],)><=_&#!'+-*/\?"[$E(%,%I+1),E
|
|---|
| 148 | ;
|
|---|
| 149 | ADD(ELEMENT,FOUND) ; record element found
|
|---|
| 150 | ; Input: ELEMENT = code for element found, e.g., "F".
|
|---|
| 151 | ; Output: .FOUND(ELEMENT) = increment # times found
|
|---|
| 152 | S FOUND(ELEMENT)=$G(FOUND(ELEMENT))+1
|
|---|
| 153 | Q ; end of DSM
|
|---|
| 154 | ;
|
|---|
| 155 | DSM(ABBREV,ELEMENT,FIND,FOUND) ; record DSM-specific element found
|
|---|
| 156 | ; Input:
|
|---|
| 157 | ; ABBREV = code for element found, e.g., "V"
|
|---|
| 158 | ; ELEMENT = name of element found, e.g., "VIEW".
|
|---|
| 159 | ; Output:
|
|---|
| 160 | ; .FOUND(ABBREV) = increment # times found
|
|---|
| 161 | ; .FOUND("DSM",ELEMENT) = ditto
|
|---|
| 162 | I $G(ABBREV)'="" D ADD(ABBREV,.FOUND)
|
|---|
| 163 | I FIND["DSM" D
|
|---|
| 164 | . S FOUND=1
|
|---|
| 165 | . ;JOHN HARVEY 7/20/02 CHECK 'ELEMENT' for NOT NULL
|
|---|
| 166 | . ;S FOUND("DSM",ELEMENT)=$G(FOUND("DSM",ELEMENT))+1
|
|---|
| 167 | . ;JOHN HARVEY 7/20/02 Add screen to fix $&% type elements
|
|---|
| 168 | . I ELEMENT["$&%" S ELEMENT="%"_$P(ELEMENT,"%",2)
|
|---|
| 169 | . I ELEMENT'="" S FOUND("DSM",ELEMENT)=$G(FOUND("DSM",ELEMENT))+1
|
|---|
| 170 | Q ; end of DSM
|
|---|
| 171 | ;
|
|---|
