RGUTSTX ;CAIRO/DKM - M syntax analyzer;22-Oct-1998 10:39;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
;=================================================================
; Perform syntactic analysis of a line of M code.
; Inputs:
; RGM = M statement(s)
; RGO = Options:
; L = Line label allowed
; . = Dotted syntax allowed
; N = Do not init parsing tables
; D = Do not delete parsing tables
; Z = Process all Z-extensions as valid
; Outputs:
; Returns 0 if successfully parsed. Otherwise returns E^P^M
; where E is an error code (see ERRORS label), P is the
; character position where the error occurred, and M is the
; error message.
;=================================================================
ENTRY(RGM,RGO) ;
N RGPSN,RGLEN,RGERR,RGRN,RGQT,RGF,RGPID,RGCMD
S RGM=$$UP^XLFSTR(RGM),RGO=$$UP^XLFSTR($G(RGO)),RGPSN=1,RGLEN=$L(RGM),RGERR=0,RGQT="""",RGF=0,RGPID="RGUTSTX"_$J,U="^"
D LOAD:RGO'["N",PARSE:RGLEN
K:RGO'["D" ^TMP(RGPID)
Q $S(RGERR:RGERR_U_$S(RGPSN>RGLEN:RGLEN,1:RGPSN)_U_$S(RGERR<0:$$EC^%ZOSV,1:$P($T(ERRORS+RGERR),";;",2)),1:0)
PARSE N RGZ,RGZ1
S @$$TRAP^RGZOSF("ERROR^RGUTSTX")
I RGO["L" D Q:RGERR
.S:$E(RGM)'=" " RGPSN=$$LABEL^RGUTSTX0
.I $$NEXT^RGUTSTX0("("),'$$NEXT^RGUTSTX0(")") D
..F RGPSN=RGPSN:1 D Q:$E(RGM,RGPSN)'=","!RGERR
...S RGPSN=$$NAME^RGUTSTX0(RGPSN,"L%")
..Q:RGERR
..S:'$$NEXT^RGUTSTX0(")") RGERR=3
.S:" "'[$E(RGM,RGPSN) RGERR=2
I RGO["." F RGPSN=RGPSN:1:RGLEN+1 Q:". "'[$E(RGM,RGPSN)
F Q:RGERR D SKPSPC Q:";"[$E(RGM,RGPSN) D
.S RGCMD=""
.F RGPSN=RGPSN:1 S RGZ=$E(RGM,RGPSN) Q:RGZ'?1A S RGCMD=RGCMD_RGZ
.I RGCMD="" S RGERR=4 Q
.I $D(^TMP(RGPID,"CMD",RGCMD)) S RGCMD=^(RGCMD)
.E I RGO["Z" S RGCMD="PC;OPT;ARGS("":M"")"
.E S RGERR=4 Q
.F RGRN=1:1:$L(RGCMD,";") D CMD^RGUTSTX0($P(RGCMD,";",RGRN)) Q:RGERR!'RGRN
.I 'RGERR," "'[$E(RGM,RGPSN) S RGERR=2
.E S RGPSN=RGPSN+1
Q
; Skip over blanks
SKPSPC F Q:'$$NEXT^RGUTSTX0(" ")
Q
; Load tables
LOAD N RGZ,RGZ1,RGZ2,RGL
K ^TMP(RGPID)
F RGL="CMD","FCN","SYS" D
.F RGZ=1:1 S RGZ1=$P($T(@RGL+RGZ),";;",2,999) Q:RGZ1="" D
..S RGZ2=$P(RGZ1,";"),RGZ1=$P(RGZ1,";",2,999)
..F Q:RGZ2="" D
...S ^TMP(RGPID,RGL,$P(RGZ2,","))=RGZ1,RGZ2=$P(RGZ2,",",2,999)
Q
ERROR S RGERR=-1
Q
CMD ;;*Commands*
;;B,BREAK;PC;OPT;ARGS()
;;C,CLOSE;PC;ARGS(":M")
;;D,DO;PC;OPT;LBL(2)
;;E,ELSE;NPC;OPT;ARGS()
;;F,FOR;NPC;OPT;FOR
;;G,GOTO;PC;LBL(1)
;;H,HALT,HANG;PC;OPT;EXP()
;;I,IF;NPC;OPT;ARGS()
;;J,JOB;PC;LBL(2)
;;K,KILL;PC;OPT;KILL
;;L,LOCK;PC;OPT;LOCK
;;M,MERGE;PC;MERGE
;;N,NEW;PC;OPT;NEW
;;O,OPEN;PC;ARGS(":M")
;;Q,QUIT;PC;OPT;EXP()
;;R,READ;PC;READ
;;S,SET;PC;SET
;;U,USE;PC;ARGS(":M")
;;V,VIEW;PC;ARGS(":M")
;;W,WRITE;PC;WRITE
;;X,XECUTE;PC;ARGS(":")
;;ZT,ZTRAP;PC;OPT;EXP()
;;ZS,ZSAVE;PC;OPT;EXP()
;;ZR,ZREMOVE;PC;OPT;LBL(1)
;;ZP,ZPRINT
;;
FCN ;;*Intrinsic functions*
;;A,ASCII;;1-2
;;C,CHAR;;1-999
;;D,DATA;;1-1;V
;;E,EXTRACT;S;1-3
;;F,FIND;;2-3
;;FN,FNUMBER;;2-3
;;G,GET;;1-2;V
;;J,JUSTIFY;;1-3
;;L,LENGTH;;1-2
;;N,NEXT;;1-2
;;NA,NAME;;1-2;V
;;O,ORDER;;1-2;V
;;P,PIECE;S;2-4
;;Q,QUERY;;1-2;V
;;R,RANDOM;;1-1
;;S,SELECT;:;1-999
;;T,TEXT;;1-1;L
;;TR,TRANSLATE;;2-3
;;V,VIEW;;1-999
;;
SYS ;;*System variables*
;;D,DEVICE
;;ET,ETRAP;SN
;;H,HOROLOG
;;I,IO
;;J,JOB
;;K,KEY
;;P,PRINCIPAL
;;S,STORAGE
;;SY,SYSTEM
;;T,TEST
;;TL,TLEVEL
;;TR,TRESTART
;;X;S
;;Y;S
;;ZT,ZTRAP;S
;;ZE,ZERROR;S
;;
ERRORS ;;*Error messages*
;;Bad variable name
;;Syntax error
;;Unbalanced parentheses
;;Unrecognized command
;;Postconditional not allowed
;;Missing operand
;;Unrecognized intrinsic function/variable
;;Incorrect number of arguments
;;Missing closing quote
;;Illegal pattern
;;Bad label name
;;12
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTSTX 3843 printed Dec 13, 2024@02:37:30 Page 2
RGUTSTX ;CAIRO/DKM - M syntax analyzer;22-Oct-1998 10:39;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
+2 ;=================================================================
+3 ; Perform syntactic analysis of a line of M code.
+4 ; Inputs:
+5 ; RGM = M statement(s)
+6 ; RGO = Options:
+7 ; L = Line label allowed
+8 ; . = Dotted syntax allowed
+9 ; N = Do not init parsing tables
+10 ; D = Do not delete parsing tables
+11 ; Z = Process all Z-extensions as valid
+12 ; Outputs:
+13 ; Returns 0 if successfully parsed. Otherwise returns E^P^M
+14 ; where E is an error code (see ERRORS label), P is the
+15 ; character position where the error occurred, and M is the
+16 ; error message.
+17 ;=================================================================
ENTRY(RGM,RGO) ;
+1 NEW RGPSN,RGLEN,RGERR,RGRN,RGQT,RGF,RGPID,RGCMD
+2 SET RGM=$$UP^XLFSTR(RGM)
SET RGO=$$UP^XLFSTR($GET(RGO))
SET RGPSN=1
SET RGLEN=$LENGTH(RGM)
SET RGERR=0
SET RGQT=""""
SET RGF=0
SET RGPID="RGUTSTX"_$JOB
SET U="^"
+3 if RGO'["N"
DO LOAD
if RGLEN
DO PARSE
+4 if RGO'["D"
KILL ^TMP(RGPID)
+5 QUIT $SELECT(RGERR:RGERR_U_$SELECT(RGPSN>RGLEN:RGLEN,1:RGPSN)_U_$SELECT(RGERR<0:$$EC^%ZOSV,1:$PIECE($TEXT(ERRORS+RGERR),";;",2)),1:0)
PARSE NEW RGZ,RGZ1
+1 SET @$$TRAP^RGZOSF("ERROR^RGUTSTX")
+2 IF RGO["L"
Begin DoDot:1
+3 if $EXTRACT(RGM)'=" "
SET RGPSN=$$LABEL^RGUTSTX0
+4 IF $$NEXT^RGUTSTX0("(")
IF '$$NEXT^RGUTSTX0(")")
Begin DoDot:2
+5 FOR RGPSN=RGPSN:1
Begin DoDot:3
+6 SET RGPSN=$$NAME^RGUTSTX0(RGPSN,"L%")
End DoDot:3
if $EXTRACT(RGM,RGPSN)'=","!RGERR
QUIT
+7 if RGERR
QUIT
+8 if '$$NEXT^RGUTSTX0(")")
SET RGERR=3
End DoDot:2
+9 if " "'[$EXTRACT(RGM,RGPSN)
SET RGERR=2
End DoDot:1
if RGERR
QUIT
+10 IF RGO["."
FOR RGPSN=RGPSN:1:RGLEN+1
if ". "'[$EXTRACT(RGM,RGPSN)
QUIT
+11 FOR
if RGERR
QUIT
DO SKPSPC
if ";"[$EXTRACT(RGM,RGPSN)
QUIT
Begin DoDot:1
+12 SET RGCMD=""
+13 FOR RGPSN=RGPSN:1
SET RGZ=$EXTRACT(RGM,RGPSN)
if RGZ'?1A
QUIT
SET RGCMD=RGCMD_RGZ
+14 IF RGCMD=""
SET RGERR=4
QUIT
+15 IF $DATA(^TMP(RGPID,"CMD",RGCMD))
SET RGCMD=^(RGCMD)
+16 IF '$TEST
IF RGO["Z"
SET RGCMD="PC;OPT;ARGS("":M"")"
+17 IF '$TEST
SET RGERR=4
QUIT
+18 FOR RGRN=1:1:$LENGTH(RGCMD,";")
DO CMD^RGUTSTX0($PIECE(RGCMD,";",RGRN))
if RGERR!'RGRN
QUIT
+19 IF 'RGERR
IF " "'[$EXTRACT(RGM,RGPSN)
SET RGERR=2
+20 IF '$TEST
SET RGPSN=RGPSN+1
End DoDot:1
+21 QUIT
+22 ; Skip over blanks
SKPSPC FOR
if '$$NEXT^RGUTSTX0(" ")
QUIT
+1 QUIT
+2 ; Load tables
LOAD NEW RGZ,RGZ1,RGZ2,RGL
+1 KILL ^TMP(RGPID)
+2 FOR RGL="CMD","FCN","SYS"
Begin DoDot:1
+3 FOR RGZ=1:1
SET RGZ1=$PIECE($TEXT(@RGL+RGZ),";;",2,999)
if RGZ1=""
QUIT
Begin DoDot:2
+4 SET RGZ2=$PIECE(RGZ1,";")
SET RGZ1=$PIECE(RGZ1,";",2,999)
+5 FOR
if RGZ2=""
QUIT
Begin DoDot:3
+6 SET ^TMP(RGPID,RGL,$PIECE(RGZ2,","))=RGZ1
SET RGZ2=$PIECE(RGZ2,",",2,999)
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
ERROR SET RGERR=-1
+1 QUIT
CMD ;;*Commands*
+1 ;;B,BREAK;PC;OPT;ARGS()
+2 ;;C,CLOSE;PC;ARGS(":M")
+3 ;;D,DO;PC;OPT;LBL(2)
+4 ;;E,ELSE;NPC;OPT;ARGS()
+5 ;;F,FOR;NPC;OPT;FOR
+6 ;;G,GOTO;PC;LBL(1)
+7 ;;H,HALT,HANG;PC;OPT;EXP()
+8 ;;I,IF;NPC;OPT;ARGS()
+9 ;;J,JOB;PC;LBL(2)
+10 ;;K,KILL;PC;OPT;KILL
+11 ;;L,LOCK;PC;OPT;LOCK
+12 ;;M,MERGE;PC;MERGE
+13 ;;N,NEW;PC;OPT;NEW
+14 ;;O,OPEN;PC;ARGS(":M")
+15 ;;Q,QUIT;PC;OPT;EXP()
+16 ;;R,READ;PC;READ
+17 ;;S,SET;PC;SET
+18 ;;U,USE;PC;ARGS(":M")
+19 ;;V,VIEW;PC;ARGS(":M")
+20 ;;W,WRITE;PC;WRITE
+21 ;;X,XECUTE;PC;ARGS(":")
+22 ;;ZT,ZTRAP;PC;OPT;EXP()
+23 ;;ZS,ZSAVE;PC;OPT;EXP()
+24 ;;ZR,ZREMOVE;PC;OPT;LBL(1)
+25 ;;ZP,ZPRINT
+26 ;;
FCN ;;*Intrinsic functions*
+1 ;;A,ASCII;;1-2
+2 ;;C,CHAR;;1-999
+3 ;;D,DATA;;1-1;V
+4 ;;E,EXTRACT;S;1-3
+5 ;;F,FIND;;2-3
+6 ;;FN,FNUMBER;;2-3
+7 ;;G,GET;;1-2;V
+8 ;;J,JUSTIFY;;1-3
+9 ;;L,LENGTH;;1-2
+10 ;;N,NEXT;;1-2
+11 ;;NA,NAME;;1-2;V
+12 ;;O,ORDER;;1-2;V
+13 ;;P,PIECE;S;2-4
+14 ;;Q,QUERY;;1-2;V
+15 ;;R,RANDOM;;1-1
+16 ;;S,SELECT;:;1-999
+17 ;;T,TEXT;;1-1;L
+18 ;;TR,TRANSLATE;;2-3
+19 ;;V,VIEW;;1-999
+20 ;;
SYS ;;*System variables*
+1 ;;D,DEVICE
+2 ;;ET,ETRAP;SN
+3 ;;H,HOROLOG
+4 ;;I,IO
+5 ;;J,JOB
+6 ;;K,KEY
+7 ;;P,PRINCIPAL
+8 ;;S,STORAGE
+9 ;;SY,SYSTEM
+10 ;;T,TEST
+11 ;;TL,TLEVEL
+12 ;;TR,TRESTART
+13 ;;X;S
+14 ;;Y;S
+15 ;;ZT,ZTRAP;S
+16 ;;ZE,ZERROR;S
+17 ;;
ERRORS ;;*Error messages*
+1 ;;Bad variable name
+2 ;;Syntax error
+3 ;;Unbalanced parentheses
+4 ;;Unrecognized command
+5 ;;Postconditional not allowed
+6 ;;Missing operand
+7 ;;Unrecognized intrinsic function/variable
+8 ;;Incorrect number of arguments
+9 ;;Missing closing quote
+10 ;;Illegal pattern
+11 ;;Bad label name
+12 ;;12
