222 lines
12 KiB
Mathematica
222 lines
12 KiB
Mathematica
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; ;
|
|
; Copyright 2010, 2013 Fidelity Information Services, Inc ;
|
|
; ;
|
|
; This source code contains the intellectual property ;
|
|
; of its copyright holder(s), and is made available ;
|
|
; under a license. If you do not know the terms of ;
|
|
; the license, please stop and do not read further. ;
|
|
; ;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
map: ;create maps for put and show, names for get and show
|
|
PUTMAKE
|
|
k lexnams n t1
|
|
d SHOWMAKE
|
|
s s1=$ztr($zj("",SIZEOF("mident"))," ",$zch(255)),t1=$ztr($zj("",SIZEOF("mident"))," ",$zch(0))
|
|
f s s2=s1,s1=$o(map(s1),-1),map(s2_$ze(t1,$zl(s2)+1,SIZEOF("mident")))=map(s1) q:s1="$" k map(s1)
|
|
s map("#)"_$ze(t1,3,SIZEOF("mident")))=map("#)"),map("%"_$ze(t1,2,SIZEOF("mident")))=map("$")
|
|
f s2="#","#)","$" k map(s2)
|
|
q
|
|
;----------------------------------------------------------------------------------------------------------------------------------
|
|
SHOWMAKE
|
|
n lexnams s s=""
|
|
f s s=$o(nams(s)) q:'$zl(s) d lexins(s)
|
|
s map("$")=nams("*"),map("#")=nams("#")
|
|
s i=1
|
|
f s i=$o(lexnams(i)) q:'$zl(i) d showstar(i)
|
|
s s=""
|
|
f s s=$o(lexnams(0,s),-1) q:'$zl(s) d pointins(s,lexnams(0,s))
|
|
s s1=$o(map(""),-1)
|
|
f s s2=s1,s1=$o(map(s1),-1) q:s2="$" i map(s1)=map(s2) k map(s2)
|
|
q
|
|
;----------------------------------------------------------------------------------------------------------------------------------
|
|
SHOWNAM
|
|
n lexnams,t1,map
|
|
d SHOWMAKE
|
|
s s1=$ztr($zj("",SIZEOF("mident"))," ",$zch(255)),t1=$ztr($zj("",SIZEOF("mident"))," ",$zch(0))
|
|
f s s2=s1,s1=$o(map(s1),-1),map(s2)=map(s1) q:s1="$" k map(s1)
|
|
k map("#") i '$$MAP2NAM(.map) zm gdeerr("GDECHECK")\2*2
|
|
q
|
|
;----------------------------------------------------------------------------------------------------------------------------------
|
|
MAP2NAM(list)
|
|
n maxMap,currMap,currMapLen,prevMap,prevMapLen,currReg,prevPrefix,currPrefix
|
|
n namSpc,currNam,currNamLen,stopLoop,i,startMap,midentSize,prevPrevMap
|
|
s currMap=$o(list("")) q:currMap'="#)" 0
|
|
s currMap=$o(list(currMap))
|
|
i currMap="%" s list("$")=list("%") ; if "$" is missing, assign it the same value as "%"
|
|
e q:currMap'="$" 0
|
|
s maxMap=$ztr($zj("",SIZEOF("mident"))," ",$zch(255)),currMap=$o(list(""),-1) q:currMap'=maxMap 0
|
|
k nams
|
|
f q:currMap="$" s prevMap=$o(list(currMap),-1) d s currMap=prevMap
|
|
. s currReg=list(currMap)
|
|
. ; Note that with the above mapping, all keys in the range [prevMap,currMap) are mapped to currReg.
|
|
. ; where [ denotes closed interval and ) denotes open interval i.e. prevMap <= key < currMap
|
|
. ; Case (1a) : If currMap contains ")" (e.g. "abc)"), it most likely means prevMap would be "abc".
|
|
. ; In this case, just add "abc" as a namespace. No more processing needed for currMap.
|
|
. ; Case (1b) : But it is also possible prevMap is not "abc".
|
|
. ; In this case, do the "abc" namespace addition (as if prevMap was "abc").
|
|
. ; But also proceed with the current iteration of the for loop as if "currMap" was "abc".
|
|
. s currMapLen=$zl(currMap)
|
|
. i $ze(currMap,currMapLen)=")" d q:prevMap=namSpc
|
|
. . s namSpc=$ze(currMap,1,currMapLen-1),nams(namSpc)=currReg
|
|
. . i prevMap'=namSpc s currMap=namSpc,currMapLen=currMapLen-1
|
|
. ; Case (3) : If prevMap contains ")" (e.g. "abc)"), then check to see if its previous entry (say prevPrevMap)
|
|
. ; is the same region as currReg. If so, we can coalesce the entire range [prevPrevMap,currMap) into one with the
|
|
. ; exception of "abc" for which add an explicit namespace. Do this for as many ")" prevMap entries that you can find
|
|
. ; as long as its prevPrevMap entry is the same region as currReg. This could potentially coalesce a lot of intervals.
|
|
. ; Note: Need to handle a situation like Case (1b) here too. We do this by keeping prevMap as it is but adjusting
|
|
. ; just prevMapLen to be 1 byte less (to remove trailing ")").
|
|
. s stopLoop=0
|
|
. f d q:stopLoop
|
|
. . s prevMapLen=$zl(prevMap)
|
|
. . i $ze(prevMap,prevMapLen)'=")" s stopLoop=1 q
|
|
. . s namSpc=$ze(prevMap,1,$i(prevMapLen,-1))
|
|
. . s prevPrevMap=$o(list(prevMap),-1)
|
|
. . i prevPrevMap'=namSpc s stopLoop=1 q
|
|
. . s nams(namSpc)=list(prevMap)
|
|
. . i list(prevMap)'=currReg s stopLoop=1 q
|
|
. . s prevMap=$o(list(prevMap),-1)
|
|
. . i prevMap="$" s stoploop=1,prevMapLen=1 q
|
|
. ; Note: At this point prevMap could contain a trailing ")" but in that case prevMapLen would have been adjusted to
|
|
. ; not consider that last byte. As long as all following usages of prevMap are of the form $ze(prevMap,1,prevMapLen)
|
|
. ; we will never see the ")" in prevMap.
|
|
. ; Case (4) : The map entry "currMap" exists and "prevMap" is the previous map entry.
|
|
. ; Determine the namespaces that potentially lie between the two map entries.
|
|
. ; And add them to the "nams" array.
|
|
. f i=1:1:currMapLen i $ze(currMap,i)'=$ze(prevMap,i) q
|
|
. s matchLen=i-1 ; the length of the maximal common prefix between prevMap and currMap
|
|
. ; Subcase (4a) : matchLen == prevMapLen
|
|
. ; In this case we are guaranteed that prevMapLen < currMapLen, and we need to add only ONE namespace.
|
|
. ; Example prevMap="ag", currMap="agk". Here, matchLen=2, prevMapLen=2, currMapLen=3. Add only "ag*".
|
|
. i (matchLen=prevMapLen)&(prevMapLen<currMapLen) s namSpc=$ze(prevMap,1,prevMapLen)_"*",nams(namSpc)=currReg q
|
|
. ; Subcase (4b) : matchLen < prevMapLen
|
|
. ; Again we are guaranteed that matchLen < currMapLen.
|
|
. ; Example prevMap="agxy", currMap="ajk". Here, matchLen=1, prevMapLen=4, currMapLen=3
|
|
. ; In this case, we need to add namespace for "aj*", "ai*", "ah*" as a first step.
|
|
. ; Whether or not we can add "ag*" depends on an optimization check explained below.
|
|
. ; If "ag*" can be added, then we add it and are done.
|
|
. ; If not, then we need to add one or more smaller namespaces under "ag" explained below as the SECOND PART.
|
|
. ; To explain the optimization check, let us say the "list" variable contains the following.
|
|
. ; list("ag")="DEFAULT"
|
|
. ; list("ag)")="STAR2"
|
|
. ; list("agQ")="STAR1"
|
|
. ; .
|
|
. ; .
|
|
. ; list("agwx")="STAR1"
|
|
. ; list("agxy")="STAR2"
|
|
. ; list("ajk")="STAR1" <-- currMap points here
|
|
. ; Let us say currMap = "ajk". So prevMap = "agxy". In this case, we would definitely add "aj*", "ai*" and "ah*".
|
|
. ; To determine whether we need to add "ag*", we take a look at where the start of "ag*" namespace maps to.
|
|
. ; And that would be the entry following list("ag") i.e. list("ag)"). This maps to STAR2 but since it is a point
|
|
. ; mapping (no * specification), we can skip that as an exception. The next entry list("agQ") maps to STAR1 region.
|
|
. ; Since this is the same region as the region of currMap, we can safely add just one namespace "ag*" to cover
|
|
. ; the entire range from list("ag)") to list("ajk") with entries in between covering sub-namespaces that are
|
|
. ; exceptions (i.e. those which dont map to STAR1). If list("agQ") maps to a region other than STAR1, we need to
|
|
. ; add more sub-namespaces under the "ag*" namespace which is explained in the SECOND PART below.
|
|
. ; The FIRST PART of adding "aj*", "ai*" and "ah*" is taken care of by the simple for loop below.
|
|
. ; There is one exception though.
|
|
. ; a) If prevMap="ER1" and currMap="ER2", matchLen=2, prevMapLen=3, currMapLen=3
|
|
. ; But we should not add the "ER2*" namespace.
|
|
. ; This is achieved by the "i<currMapLen" check before the for loop.
|
|
. i currMap=maxMap s currMapLen=1,currMap=$zch(1+$za("z")) ; needed to help lexPrev call return "z"
|
|
. s prevPrefix=$ze(prevMap,1,i),currPrefix=$ze(currMap,1,i)
|
|
. i (i<currMapLen) s namSpc=currPrefix_"*",nams(namSpc)=currReg
|
|
. ; Note: If i=1, it is possible that prevMap="$" in which case, $$lexprev would return "%" and then "" (but not "$").
|
|
. ; So currPrefix=prevPrefix will not work in that case. Hence the additional check for "" return below.
|
|
. f s currPrefix=$$lexprev(currPrefix) q:(currPrefix=prevPrefix)!('$zl(currPrefix)) d
|
|
. . s namSpc=currPrefix_"*",nams(namSpc)=currReg
|
|
. ; Do the optimization check.
|
|
. s currPrefix=prevPrefix ; reset currPrefix to be equal to prevPrefix just in case it is ""
|
|
. s startMap=$$findStartMap(currPrefix)
|
|
. i list(startMap)=currReg s i=prevMapLen ; set i to force skip of SECOND PART of processing below.
|
|
. ; The SECOND PART does the additional "ag" specific processing. Since the stop point is "agxy", we need to add
|
|
. ; namespaces "agz*", "agy*" first. And then by the same reasoning (for not adding "ag*" in the FIRST PART),
|
|
. ; we cannot add "agx*" unless the optimization check says it is okay to do so. Assuming it says that is not okay,
|
|
. ; we go further down by adding "agxz*" and then "agxy*" and then stop.
|
|
. f s i=i+1 q:i>prevMapLen d
|
|
. . s currPrefix=prevPrefix_"z",prevPrefix=$ze(prevMap,1,i)
|
|
. . f q:currPrefix=prevPrefix s namSpc=currPrefix_"*",nams(namSpc)=currReg,currPrefix=$$lexprev(currPrefix)
|
|
. . ; Do optimization check at each sub-namespaces level. If it succeeds, stop processing any higher level sub-namespaces.
|
|
. . s startMap=$$findStartMap(currPrefix)
|
|
. . i list(startMap)=currReg s i=prevMapLen q ; set i to force quit out of for loop
|
|
. s namSpc=currPrefix_"*",nams(namSpc)=currReg
|
|
; Update "nams" variable to contain # of elements in "nams" array
|
|
; Take this opportunity to remove redundant namespaces.
|
|
; Example : If "a*" and "ab*" both map to the same region, the namespace "ab*" can be safely removed.
|
|
; But if "a*" maps to AREG, "aa*" maps to BREG, and "aaa*" maps to AREG, we cannot remove "aaa*" because
|
|
; "a*" and "aaa*" maps to the same reg. This is because there is a more restrictive mapping "aa*" which
|
|
; maps to a different region than "aaa*". That should prevail.
|
|
; Similarly if "ab*" and "abc" both map to the same region, the namespace "abc" can be safely removed.
|
|
; But if "abc*" also is mapped and to a different region than "abc", then "abc" cannot be removed.
|
|
s currNam="",nams=0
|
|
; With SIZEOF("mident")=32, we allow a max of 31-byte global name specifications.
|
|
; But with SIZEOF("mident")=8 (for older versions with no longnames support, we allow a max of 8-byte global names.
|
|
; Handle this 1-byte discrepancy for the 8-byte case by setting the variable midentSize accordingly.
|
|
s midentSize=$s(SIZEOF("mident")=8:9,1:SIZEOF("mident"))
|
|
s nams("*")=list("$")
|
|
f s currNam=$o(nams(currNam)) q:currNam="" s nams=nams+1 d
|
|
. s currNamLen=$zl(currNam)
|
|
. s currReg=nams(currNam)
|
|
. s killed=0,quitLoop=0
|
|
. f i=$s($ze(currNam,currNamLen)="*":(currNamLen-2),1:currNamLen):-1:0 d q:quitLoop
|
|
. . s currPrefix=$ze(currNam,1,i)_"*"
|
|
. . s prevReg=$g(nams(currPrefix))
|
|
. . i (""'=prevReg) d
|
|
. . . s quitLoop=1
|
|
. . . i currReg=prevReg k nams(currNam) s nams=nams-1,killed=1
|
|
. i 'killed,currNamLen'<midentSize k nams(currNam) s nams($ze(currNam,1,midentSize-1))=currReg
|
|
; Do some final cleanup
|
|
s nams("#")=list("#)"),nams=nams+1
|
|
q 1
|
|
;----------------------------------------------------------------------------------------------------------------------------------
|
|
lexins:(s)
|
|
n x,l
|
|
i s["*" s l=$zl(s)
|
|
e s l=0
|
|
s lexnams(l,s)=nams(s)
|
|
q
|
|
showstar:(i)
|
|
s j=""
|
|
f s j=$o(lexnams(i,j),-1) q:'$zl(j) d starins($ze(j,1,$zl(j)-1),lexnams(i,j))
|
|
q
|
|
starins:(s,reg)
|
|
n next
|
|
s next=$$lexnext(s)
|
|
i $zl(next),'$d(map(next)) s map(next)=map($o(map(next),-1))
|
|
s map(s)=reg
|
|
q
|
|
pointins:(s,reg)
|
|
n next
|
|
s next=$$alphnext(s)
|
|
i $zl(next),'$d(map(next)) s map(next)=map($o(map(next),-1))
|
|
s map(s)=reg
|
|
q
|
|
alphnext:(s)
|
|
i $zl(s)=MAXNAMLN q $$lexnext(s)
|
|
e q s_")"
|
|
;
|
|
lexnext:(s)
|
|
n len,last,succ
|
|
s len=$zl(s),last=$ze(s,len)
|
|
i last="z" f s len=len-1,last=$ze(s,len) q:last'="z"!'len
|
|
i 'len q ""
|
|
s s=$ze(s,1,len-1),succ=$zch($za(last)+1)
|
|
i succ?1AN q s_succ
|
|
i "A"]succ q s_"A"
|
|
i "a"]succ q s_"a"
|
|
q ""
|
|
lexprev:(s)
|
|
n len,last,prio
|
|
s len=$zl(s),last=$ze(s,len)
|
|
s s=$ze(s,1,len-1),prio=$zch($za(last)-1)
|
|
i prio?1AN q s_prio
|
|
i prio]"Z" q s_"Z"
|
|
i prio]"9" q:len=1 "%" q s_"9"
|
|
q ""
|
|
findStartMap:(key)
|
|
n startMap
|
|
s startMap=$o(list(key))
|
|
s startMapLen=$zl(startMap)
|
|
i ($ze(startMap,startMapLen)=")")&($ze(startMap,1,startMapLen-1)=key) s startMap=$o(list(startMap))
|
|
q startMap
|