PXRMSTAC ;SLC/PKR - Stack routines for use by PXRM. ;12/24/2013
;;2.0;CLINICAL REMINDERS;**18,26**;Feb 04, 2005;Build 404
;
;=====================================================
POP(STACK) ;Pop an element off of the stack.
I STACK(0)=0 Q ""
N IND,TEMP
S TEMP=STACK(1)
F IND=2:1:STACK(0) S STACK(IND-1)=STACK(IND)
K STACK(STACK(0))
S STACK(0)=STACK(0)-1
Q TEMP
;
;=====================================================
POSTFIX(EXPR,OPERS,PFSTACK) ;Given an expression, EXPR, in infix notation
;convert it to postfix and return the result in PFSTACK. PFSTACK(0)
;will contain the number of elements in PFSTACK. OPERS is a
;string containing allowable operators.
N CHAR,IND,LEN,NSYM,OPERP,PFP,QF,QUOTE,SP,STACK,SYM,SYMP,SYMT
N TEMP,UNARYOPS
S UNARYOPS=""
F TEMP="+","-","'" I OPERS[TEMP S UNARYOPS=UNARYOPS_TEMP
S QUOTE=$C(34)
S OPERP=OPERS_"()"
S LEN=$L(EXPR)
;Break the expression into (, ), operators, and operands.
;Put the symbols onto the symbol stack in left to right order.
;Symbol number 1 is SYM(1).
S QF=0,NSYM=0,TEMP=""
F IND=1:1:LEN D
. S CHAR=$E(EXPR,IND)
. I (CHAR=QUOTE),('QF) S TEMP=TEMP_CHAR,QF=1 Q
. I (QF),(CHAR'=QUOTE) S TEMP=TEMP_CHAR Q
. I (QF),(CHAR=QUOTE) S TEMP=TEMP_CHAR,QF=0 Q
. I OPERP[CHAR D Q
.. I TEMP'="" S NSYM=NSYM+1,SYM(NSYM)=TEMP,TEMP=""
..;In MUMPS "'&", "'!", "'=", "'<", "'>", "'[", and "']" must be
..;treated as a single operator.
.. I CHAR="'" D
... S TEMP=$E(EXPR,IND+1)
... I (TEMP="=")!(TEMP="<")!(TEMP=">")!(TEMP="&")!(TEMP="!")!(TEMP="[")!(TEMP="]") S CHAR=CHAR_TEMP,IND=IND+1
.. S NSYM=NSYM+1,SYM(NSYM)=CHAR,TEMP=""
. S TEMP=TEMP_CHAR
I (IND=LEN),(TEMP'="") S NSYM=NSYM+1,SYM(NSYM)=TEMP
;Process the symbols.
S (PFP,SP)=0
F SYMP=1:1:NSYM D
. S SYMT=SYM(SYMP)
.;
.;Symbol is "("
. I SYMT="(" S SP=SP+1,STACK(SP)=SYMT Q
.;
.;Symbol is an operator
. I OPERS[SYMT D Q
..;Check for a unary operator, they have the highest precendence.
.. ;The NOT operator is always unary.
.. I SYMT="'" S SYMT=SYMT_"U",SP=SP+1,STACK(SP)=SYMT Q
.. I (SYMP=1),(UNARYOPS[SYMT) S SYMT=SYMT_"U"
.. I (SYMP>1),(OPERS[SYM(SYMP-1)),(UNARYOPS[SYMT) S SYMT=SYMT_"U"
.. I SYMT["U" S SP=SP+1,STACK(SP)=SYMT Q
.. S LEN=SP
.. F IND=LEN:-1:1 S TEMP=STACK(IND) Q:TEMP="(" D
... S PFP=PFP+1,PFSTACK(PFP)=TEMP
... K STACK(SP)
... S SP=SP-1
.. S SP=SP+1
.. S STACK(SP)=SYMT
.;
.;Symbol is ")"
. I SYMT=")" D Q
.. S LEN=SP
.. F IND=LEN:-1:1 S TEMP=STACK(IND) Q:TEMP="(" D
... S PFP=PFP+1,PFSTACK(PFP)=TEMP
... K STACK(SP)
... S SP=SP-1
..;Pop the "(" at the top of the stack.
.. K STACK(SP)
.. S SP=SP-1
.;
.;If we get to here then symbol is an operand.
. S PFP=PFP+1,PFSTACK(PFP)=SYMT
;
;Pop and output anything left on the stack.
F IND=SP:-1:1 S PFP=PFP+1,PFSTACK(PFP)=STACK(IND)
;
;Save the number of elements in PFSTACK.
S PFSTACK(0)=PFP
Q
;
;=====================================================
PUSH(STACK,ELEM) ;Push an element on the stack.
I '$D(STACK) S STACK(1)=ELEM,STACK(0)=1 Q
I STACK(0)=0 S STACK(1)=ELEM,STACK(0)=1 Q
N IND
F IND=STACK(0):-1:1 S STACK(IND+1)=STACK(IND)
S STACK(1)=ELEM,STACK(0)=STACK(0)+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMSTAC 3227 printed Dec 13, 2024@01:49:15 Page 2
PXRMSTAC ;SLC/PKR - Stack routines for use by PXRM. ;12/24/2013
+1 ;;2.0;CLINICAL REMINDERS;**18,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;=====================================================
POP(STACK) ;Pop an element off of the stack.
+1 IF STACK(0)=0
QUIT ""
+2 NEW IND,TEMP
+3 SET TEMP=STACK(1)
+4 FOR IND=2:1:STACK(0)
SET STACK(IND-1)=STACK(IND)
+5 KILL STACK(STACK(0))
+6 SET STACK(0)=STACK(0)-1
+7 QUIT TEMP
+8 ;
+9 ;=====================================================
POSTFIX(EXPR,OPERS,PFSTACK) ;Given an expression, EXPR, in infix notation
+1 ;convert it to postfix and return the result in PFSTACK. PFSTACK(0)
+2 ;will contain the number of elements in PFSTACK. OPERS is a
+3 ;string containing allowable operators.
+4 NEW CHAR,IND,LEN,NSYM,OPERP,PFP,QF,QUOTE,SP,STACK,SYM,SYMP,SYMT
+5 NEW TEMP,UNARYOPS
+6 SET UNARYOPS=""
+7 FOR TEMP="+","-","'"
IF OPERS[TEMP
SET UNARYOPS=UNARYOPS_TEMP
+8 SET QUOTE=$CHAR(34)
+9 SET OPERP=OPERS_"()"
+10 SET LEN=$LENGTH(EXPR)
+11 ;Break the expression into (, ), operators, and operands.
+12 ;Put the symbols onto the symbol stack in left to right order.
+13 ;Symbol number 1 is SYM(1).
+14 SET QF=0
SET NSYM=0
SET TEMP=""
+15 FOR IND=1:1:LEN
Begin DoDot:1
+16 SET CHAR=$EXTRACT(EXPR,IND)
+17 IF (CHAR=QUOTE)
IF ('QF)
SET TEMP=TEMP_CHAR
SET QF=1
QUIT
+18 IF (QF)
IF (CHAR'=QUOTE)
SET TEMP=TEMP_CHAR
QUIT
+19 IF (QF)
IF (CHAR=QUOTE)
SET TEMP=TEMP_CHAR
SET QF=0
QUIT
+20 IF OPERP[CHAR
Begin DoDot:2
+21 IF TEMP'=""
SET NSYM=NSYM+1
SET SYM(NSYM)=TEMP
SET TEMP=""
+22 ;In MUMPS "'&", "'!", "'=", "'<", "'>", "'[", and "']" must be
+23 ;treated as a single operator.
+24 IF CHAR="'"
Begin DoDot:3
+25 SET TEMP=$EXTRACT(EXPR,IND+1)
+26 IF (TEMP="=")!(TEMP="<")!(TEMP=">")!(TEMP="&")!(TEMP="!")!(TEMP="[")!(TEMP="]")
SET CHAR=CHAR_TEMP
SET IND=IND+1
End DoDot:3
+27 SET NSYM=NSYM+1
SET SYM(NSYM)=CHAR
SET TEMP=""
End DoDot:2
QUIT
+28 SET TEMP=TEMP_CHAR
End DoDot:1
+29 IF (IND=LEN)
IF (TEMP'="")
SET NSYM=NSYM+1
SET SYM(NSYM)=TEMP
+30 ;Process the symbols.
+31 SET (PFP,SP)=0
+32 FOR SYMP=1:1:NSYM
Begin DoDot:1
+33 SET SYMT=SYM(SYMP)
+34 ;
+35 ;Symbol is "("
+36 IF SYMT="("
SET SP=SP+1
SET STACK(SP)=SYMT
QUIT
+37 ;
+38 ;Symbol is an operator
+39 IF OPERS[SYMT
Begin DoDot:2
+40 ;Check for a unary operator, they have the highest precendence.
+41 ;The NOT operator is always unary.
+42 IF SYMT="'"
SET SYMT=SYMT_"U"
SET SP=SP+1
SET STACK(SP)=SYMT
QUIT
+43 IF (SYMP=1)
IF (UNARYOPS[SYMT)
SET SYMT=SYMT_"U"
+44 IF (SYMP>1)
IF (OPERS[SYM(SYMP-1))
IF (UNARYOPS[SYMT)
SET SYMT=SYMT_"U"
+45 IF SYMT["U"
SET SP=SP+1
SET STACK(SP)=SYMT
QUIT
+46 SET LEN=SP
+47 FOR IND=LEN:-1:1
SET TEMP=STACK(IND)
if TEMP="("
QUIT
Begin DoDot:3
+48 SET PFP=PFP+1
SET PFSTACK(PFP)=TEMP
+49 KILL STACK(SP)
+50 SET SP=SP-1
End DoDot:3
+51 SET SP=SP+1
+52 SET STACK(SP)=SYMT
End DoDot:2
QUIT
+53 ;
+54 ;Symbol is ")"
+55 IF SYMT=")"
Begin DoDot:2
+56 SET LEN=SP
+57 FOR IND=LEN:-1:1
SET TEMP=STACK(IND)
if TEMP="("
QUIT
Begin DoDot:3
+58 SET PFP=PFP+1
SET PFSTACK(PFP)=TEMP
+59 KILL STACK(SP)
+60 SET SP=SP-1
End DoDot:3
+61 ;Pop the "(" at the top of the stack.
+62 KILL STACK(SP)
+63 SET SP=SP-1
End DoDot:2
QUIT
+64 ;
+65 ;If we get to here then symbol is an operand.
+66 SET PFP=PFP+1
SET PFSTACK(PFP)=SYMT
End DoDot:1
+67 ;
+68 ;Pop and output anything left on the stack.
+69 FOR IND=SP:-1:1
SET PFP=PFP+1
SET PFSTACK(PFP)=STACK(IND)
+70 ;
+71 ;Save the number of elements in PFSTACK.
+72 SET PFSTACK(0)=PFP
+73 QUIT
+74 ;
+75 ;=====================================================
PUSH(STACK,ELEM) ;Push an element on the stack.
+1 IF '$DATA(STACK)
SET STACK(1)=ELEM
SET STACK(0)=1
QUIT
+2 IF STACK(0)=0
SET STACK(1)=ELEM
SET STACK(0)=1
QUIT
+3 NEW IND
+4 FOR IND=STACK(0):-1:1
SET STACK(IND+1)=STACK(IND)
+5 SET STACK(1)=ELEM
SET STACK(0)=STACK(0)+1
+6 QUIT
+7 ;
