Routine: CIAUSTX

CIAUSTX ;MSC/IND/DKM - M syntax analyzer;04-May-2006 08:19;DKM

 ;;1.2;CIA UTILITIES;;Mar 20, 2007

 ;;Copyright 2000-2006, Medsphere Systems Corporation

 ;=================================================================

 ; Perform syntactic analysis of a line of M code.

 ; Inputs:

 ;   CIAM = M statement(s)

 ;   CIAO = 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(CIAM,CIAO) ;

 N CIAPSN,CIALEN,CIAERR,CIARN,CIAQT,CIAF,CIAPID,CIACMD

 S CIAM=$$UP^XLFSTR(CIAM),CIAO=$$UP^XLFSTR($G(CIAO)),CIAPSN=1,CIALEN=$L(CIAM),CIAERR=0,CIAQT="""",CIAF=0,CIAPID="CIAUSTX",U="^"

 D LOAD:CIAO'["N",PARSE:CIALEN

 K:CIAO'["D" ^TMP(CIAPID,$J)

 Q $S(CIAERR:CIAERR_U_$S(CIAPSN>CIALEN:CIALEN,1:CIAPSN)_U_$S(CIAERR<0:$$EC^%ZOSV,1:$P($T(ERRORS+CIAERR),";;",2)),1:0)

PARSE N CIAZ,CIAZ1

 S @$$TRAP^CIAUOS("ERROR^CIAUSTX")

 I CIAO["L" D  Q:CIAERR

 .S:$E(CIAM)'=" " CIAPSN=$$LABEL^CIAUSTX0

 .I $$NEXT^CIAUSTX0("("),'$$NEXT^CIAUSTX0(")") D

 ..F CIAPSN=CIAPSN:1 D  Q:$E(CIAM,CIAPSN)'=","!CIAERR

 ...S CIAPSN=$$NAME^CIAUSTX0(CIAPSN,"L%")

 ..Q:CIAERR

 ..S:'$$NEXT^CIAUSTX0(")") CIAERR=3

 .S:" "'[$E(CIAM,CIAPSN) CIAERR=2

 I CIAO["." F CIAPSN=CIAPSN:1:CIALEN+1 Q:". "'[$E(CIAM,CIAPSN)

 F  Q:CIAERR  D SKPSPC Q:";"[$E(CIAM,CIAPSN)  D

 .S CIACMD=""

 .F CIAPSN=CIAPSN:1 S CIAZ=$E(CIAM,CIAPSN) Q:CIAZ'?1A  S CIACMD=CIACMD_CIAZ

 .I CIACMD="" S CIAERR=4 Q

 .I $D(^TMP(CIAPID,$J,"CMD",CIACMD)) S CIACMD=^(CIACMD)

 .E  I CIAO["Z" S CIACMD="PC;OPT;ARGS("":M"")"

 .E  S CIAERR=4 Q

 .F CIARN=1:1:$L(CIACMD,";") D CMD^CIAUSTX0($P(CIACMD,";",CIARN)) Q:CIAERR!'CIARN

 .I 'CIAERR," "'[$E(CIAM,CIAPSN) S CIAERR=2

 .E  S CIAPSN=CIAPSN+1

 ; Skip over blanks

SKPSPC F  Q:'$$NEXT^CIAUSTX0(" ")

 ; Load tables

LOAD N CIAZ,CIAZ1,CIAZ2,CIAL

 K ^TMP(CIAPID,$J)

 F CIAL="CMD","FCN","SYS" D

 .F CIAZ=1:1 S CIAZ1=$P($T(@CIAL+CIAZ),";;",2,999) Q:CIAZ1=""  D

 ..S CIAZ2=$P(CIAZ1,";"),CIAZ1=$P(CIAZ1,";",2,999)

 ..F  Q:CIAZ2=""  D

 ...S ^TMP(CIAPID,$J,CIAL,$P(CIAZ2,","))=CIAZ1,CIAZ2=$P(CIAZ2,",",2,999)

ERROR S CIAERR=-1

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

 ;;ES,ESTACK;N

 ;;EC,ECODE;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

 ;;Name too long

 ;;13

CIAUSTX   ;MSC/IND/DKM - M syntax analyzer;04-May-2006 08:19;DKM

 +1       ;;1.2;CIA UTILITIES;;Mar 20, 2007

 +2       ;;Copyright 2000-2006, Medsphere Systems Corporation

 +3       ;=================================================================

 +4       ; Perform syntactic analysis of a line of M code.

 +5       ; Inputs:

 +6       ;   CIAM = M statement(s)

 +7       ;   CIAO = Options:

 +8       ;      L = Line label allowed

 +9       ;      . = Dotted syntax allowed

 +10      ;      N = Do not init parsing tables

 +11      ;      D = Do not delete parsing tables

 +12      ;      Z = Process all Z-extensions as valid

 +13      ; Outputs:

 +14      ;   Returns 0 if successfully parsed.  Otherwise returns E^P^M

 +15      ;   where E is an error code (see ERRORS label), P is the

 +16      ;   character position where the error occurred, and M is the

 +17      ;   error message.

 +18      ;=================================================================

ENTRY(CIAM,CIAO) ;

 +1        NEW CIAPSN,CIALEN,CIAERR,CIARN,CIAQT,CIAF,CIAPID,CIACMD

 +2        SET CIAM=$$UP^XLFSTR(CIAM)

           SET CIAO=$$UP^XLFSTR($GET(CIAO))

           SET CIAPSN=1

           SET CIALEN=$LENGTH(CIAM)

           SET CIAERR=0

           SET CIAQT=""""

           SET CIAF=0

           SET CIAPID="CIAUSTX"

           SET U="^"

 +3        IF CIAO'["N"

               DO LOAD

           IF CIALEN

               DO PARSE

 +4        IF CIAO'["D"

               KILL ^TMP(CIAPID,$JOB)

 +5        QUIT $SELECT(CIAERR:CIAERR_U_$SELECT(CIAPSN>CIALEN:CIALEN,1:CIAPSN)_U_$SELECT(CIAERR<0:$$EC^%ZOSV,1:$PIECE($TEXT(ERRORS+CIAERR),";;",2)),1:0)

PARSE      NEW CIAZ,CIAZ1

 +1        SET @$$TRAP^CIAUOS("ERROR^CIAUSTX")

 +2        IF CIAO["L"

               Begin DoDot:1

 +3                IF $EXTRACT(CIAM)'=" "

                       SET CIAPSN=$$LABEL^CIAUSTX0

 +4                IF $$NEXT^CIAUSTX0("(")

                       IF '$$NEXT^CIAUSTX0(")")

                           Begin DoDot:2

 +5                            FOR CIAPSN=CIAPSN:1

                                   Begin DoDot:3

 +6                                    SET CIAPSN=$$NAME^CIAUSTX0(CIAPSN,"L%")

                                   End DoDot:3

                                   IF $EXTRACT(CIAM,CIAPSN)'=","!CIAERR

                                       QUIT

 +7                            IF CIAERR

                                   QUIT

 +8                            IF '$$NEXT^CIAUSTX0(")")

                                   SET CIAERR=3

                           End DoDot:2

 +9                IF " "'[$EXTRACT(CIAM,CIAPSN)

                       SET CIAERR=2

               End DoDot:1

               IF CIAERR

                   QUIT

 +10       IF CIAO["."

               FOR CIAPSN=CIAPSN:1:CIALEN+1

                   IF ". "'[$EXTRACT(CIAM,CIAPSN)

                       QUIT

 +11       FOR

               IF CIAERR

                   QUIT

               DO SKPSPC

               IF ";"[$EXTRACT(CIAM,CIAPSN)

                   QUIT

               Begin DoDot:1

 +12               SET CIACMD=""

 +13               FOR CIAPSN=CIAPSN:1

                       SET CIAZ=$EXTRACT(CIAM,CIAPSN)

                       IF CIAZ'?1A

                           QUIT

                       SET CIACMD=CIACMD_CIAZ

 +14               IF CIACMD=""

                       SET CIAERR=4

                       QUIT

 +15               IF $DATA(^TMP(CIAPID,$JOB,"CMD",CIACMD))

                       SET CIACMD=^(CIACMD)

 +16              IF '$TEST

                       IF CIAO["Z"

                           SET CIACMD="PC;OPT;ARGS("":M"")"

 +17              IF '$TEST

                       SET CIAERR=4

                       QUIT

 +18               FOR CIARN=1:1:$LENGTH(CIACMD,";")

                       DO CMD^CIAUSTX0($PIECE(CIACMD,";",CIARN))

                       IF CIAERR!'CIARN

                           QUIT

 +19               IF 'CIAERR

                       IF " "'[$EXTRACT(CIAM,CIAPSN)

                           SET CIAERR=2

 +20              IF '$TEST

                       SET CIAPSN=CIAPSN+1

               End DoDot:1

 +21       QUIT

 +22      ; Skip over blanks

SKPSPC     FOR

               IF '$$NEXT^CIAUSTX0(" ")

                   QUIT

 +1        QUIT

 +2       ; Load tables

LOAD       NEW CIAZ,CIAZ1,CIAZ2,CIAL

 +1        KILL ^TMP(CIAPID,$JOB)

 +2        FOR CIAL="CMD","FCN","SYS"

               Begin DoDot:1

 +3                FOR CIAZ=1:1

                       SET CIAZ1=$PIECE($TEXT(@CIAL+CIAZ),";;",2,999)

                       IF CIAZ1=""

                           QUIT

                       Begin DoDot:2

 +4                        SET CIAZ2=$PIECE(CIAZ1,";")

                           SET CIAZ1=$PIECE(CIAZ1,";",2,999)

 +5                        FOR

                               IF CIAZ2=""

                                   QUIT

                               Begin DoDot:3

 +6                                SET ^TMP(CIAPID,$JOB,CIAL,$PIECE(CIAZ2,","))=CIAZ1

                                   SET CIAZ2=$PIECE(CIAZ2,",",2,999)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +7        QUIT

ERROR      SET CIAERR=-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      ;;ES,ESTACK;N

 +18      ;;EC,ECODE;S

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      ;;Name too long

 +13      ;;13

CIAUSTX.m