source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/ARJTDIM1.m@ 1789

Last change on this file since 1789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 6.6 KB
Line 
1ARJTDIM1 ;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 ;
10GG ; 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
21EXP 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
36PERIOD 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
45GG1 ;
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 ;
49QUOTE ; 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 ;
54FUNC ; 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
75FNC ;;,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 ;
77FUNC1 ; 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 ;
82FUNC2 ; 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 ;
119SPV ; 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
128E G ERR^ARJTDIM2
129 ;
130%INC S %I=%I+1,%C=$E(%,%I) Q
131 ;
132FN ; 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 ;
139EXT ; 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 ;
149ADD(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 ;
155DSM(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 ;
Note: See TracBrowser for help on using the repository browser.