source: cprs/branches/tmg-cprs/m_files/TMGCOD1.m@ 1742

Last change on this file since 1742 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 5.7 KB
RevLine 
[796]1TMGCODT1 ;TMG/kst/A Code Analysis Tools ;08/17/08
2 ;;1.0;TMG-LIB;**1**;08/17/08
3
4ScanAll
5 new pArray
6 set pArray=$name(^TMG("MODULE CALLS"))
7
8 new Itr,index
9 new abort set abort=0
10 set index=$$ItrAInit^TMGITR($name(^DIC(9.8,"B")),.Itr)
11 do PrepProgress^TMGITR(.Itr,20,1,"index")
12 set index="TMGKIDS" ;"temp!
13 if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="")!abort
14 . if $$UserAborted^TMGUSRIF set abort=1 quit
15 . ;"write index,!
16 . do GetCalls(index,pArray)
17 do ProgressDone^TMGITR(.Itr)
18
19 quit
20
21GetCalls(Module,pArray)
22 ;"Purpose: To scan one code module and look for *static* calls to other
23 ;" modules. It will NOT detect indirection (i.e. do @X).
24 ;" Call MUST have a tag. MyTag^MyMod is detected, but ^MyMod is NOT
25 ;"Input: Module -- the name of the module to scan, as would be used
26 ;" in $text(). I.e. XUP, but not ^XUP, not XUP.m
27 ;" Array -- PASS BY NAME, an OUT PARAMETER. Format below.
28 ;"Output: Array filled as follows:
29 ;" Array(Module,Addr)=OutSideAddr (Example of Addr=A+5^MYFUNCT)
30
31 new curModule set curModule=$get(Module)
32 new blankLines set blankLines=0
33 new offset set offset=1
34 new curLabel set curLabel=""
35
36 for do quit:(blankLines>30)
37 . new Addr set Addr=curLabel_"+"_offset_"^"_curModule
38 . new oneLine set oneLine=$text(@Addr)
39 . new firstChar set firstChar=$extract(oneLine,1,1)
40 . set offset=offset+1
41 . if oneLine="" set blankLines=blankLines+1 quit
42 . set oneLine=$$CutComment(oneLine)
43 . new tempLabel set tempLabel=$$GetLabel(oneLine)
44 . if tempLabel'="" set curLabel=tempLabel,offset=1
45 . new tempS set tempS=oneLine
46 . if tempS'["^" quit
47 . new done set done=0
48 . for quit:(tempS'["^")!(done=1) do
49 . . if $$InQt^TMGSTUTL(tempS,$find(tempS,"^")-1)=1 set done=1 quit
50 . . new preS,postS
51 . . do GetPrePost(.tempS,.preS,.postS)
52 . . if (preS="")!(postS="") quit
53 . . ;"write curLabel,"+",offset,"--> "
54 . . ;"write preS,"^",postS," [",$$Trim^TMGSTUTL(oneLine),"]",!
55 . . ;"if preS["$" quit
56 . . new tempAddr set tempAddr=preS_"^"_postS
57 . . ;"write "==> ",$text(@tempAddr),!
58 . . ;"set @pArray@("CALLS OUT",curModule,curLabel,offset,tempAddr)=""
59 . . set @pArray@("CALLS IN",postS_"::"_preS,curModule,curLabel,offset)=""
60
61 quit
62
63
64CutComment(oneLine)
65 ;"Purpose: to cut off any comments from line, indicated by ;
66 ;"Input: oneLine : string to alter
67 ;"Result: modified inputline
68
69 new i,L,result
70 set result=$get(oneLine)
71 if result'[";" goto CCmDone
72
73 new inStr,done,ch
74 set inStr=0,done=0
75 set L=$length(oneLine)
76 for i=1:1:L do quit:done
77 . set ch=$extract(oneLine,i)
78 . if ch="""" do
79 . . if inStr=0 set inStr=1 quit
80 . . if $extract(oneLine,i+1)="""" set i=i+1 quit
81 . . set inStr=0
82 . if (ch=";")&(inStr=0) do quit
83 . . set result=$extract(oneLine,1,i-1)
84 . . set done=1
85
86CCmDone quit result
87
88
89GetLabel(oneLine)
90 ;"Purpose: Get label for a line, if one exists
91 ;"Input: oneLine : string to scan
92 ;"Result: Label, or "" if none
93
94 new result set result=$get(oneLine) ;"default to entire line is label
95 new ch set ch=$extract(oneLine,1)
96 if (ch=" ")!(ch=$char(9)) do goto GLDone
97 . set result=""
98
99 new i,done set done=0
100 for i=1:1:$length(oneLine) do quit:done
101 . set ch=$extract(oneLine,i)
102 . if (ch=" ")!(ch=$char(9))!(ch="(")!(ch=";") do quit
103 . . set result=$extract(oneLine,1,i-1)
104 . . set done=1
105
106GLDone quit result
107
108
109GetPrePost(oneLine,preS,postS)
110 ;"Purpose: To take a string like 'write $$MyFunct^MyModule(123)' and return
111 ;" '$$MyFunct' in preS, and 'MyModule' in postS. Also shorten
112 ;" input string, oneLine, so that other calls on the same line
113 ;" can be processed on a separate run.
114 ;"Input: oneLine -- the string to process. PASS BY REFERENCE to get back
115 ;" shortened line with first instance cut off.
116 ;" preS -- PASS BY REFERENCE, an OUT PARAMETER
117 ;" postS -- PASS BY REFERENCE, an OUT PARAMETER
118 ;"Output: See purpose above
119 ;"Result: none
120
121 new done,p
122
123 ;"Work first on preS
124 set preS=$piece(oneLine,"^",1)
125 set p=$length(preS)
126 set done=0
127 if p>0 for do quit:(p=0)!(done=1)
128 . new ch set ch=$extract(preS,p)
129 . set p=p-1
130 . if ch?1(1A,1N) quit
131 . set p=p+2,done=1
132 set preS=$extract(preS,p,999)
133
134 ;"weed out entries like '_^DIC' or '_U_^TMP'
135 ;"if ($extract(preS,1)="_")!($extract(preS,$length(preS))="_" set preS=""
136
137
138 ;"Now work on postS
139 set postS=$piece(oneLine,"^",2,$length(oneLine,"^"))
140 set p=1,done=0
141 for do quit:(p>$length(postS))!(done=1)
142 . new ch set ch=$extract(postS,p)
143 . set p=p+1
144 . if ch?1(1A,1N,1"_") quit
145 . set p=p-2,done=1
146
147 set oneLine=$extract(postS,p+1,999)
148 set postS=$extract(postS,1,p)
149
150 quit
151
152 ;"=======================================================
153test
154 new array
155 new DIC,X,Y
156 set DIC=9.8
157 set DIC(0)="MAEQ"
158t1
159 do ^DIC write !
160 if +Y'>0 goto testDone
161 ;"kill array
162 do GetCallsOut($piece(Y,"^",2),"array")
163 if $data(array) zwr array
164 goto t1
165
166testDone
167 quit
168
Note: See TracBrowser for help on using the repository browser.