Return to %SYSPOLY.m CVS log

Up to [Coherent Logic Development] / freem / mlib

Annotation of freem/mlib/%SYSPOLY.m, revision 1.1

1.1     ! snw         1: %SYSPOLY ;V4W/DLW-FREEM POLYFILLS; 9/2/2021 7:52 PM
        !             2:     ;0.0;FreeM;****FREEM**;John P Willis @2021
        !             3:     ;
        !             4:     ;                            *
        !             5:     ;                           * *
        !             6:     ;                          *   *
        !             7:     ;                     ***************
        !             8:     ;                      * *       * *
        !             9:     ;                       *  MUMPS  *
        !            10:     ;                      * *       * *
        !            11:     ;                     ***************
        !            12:     ;                          *   *
        !            13:     ;                           * *
        !            14:     ;                            *
        !            15:     ;
        !            16:     ;   %ZUTILS.m
        !            17:     ;    FreeM Polyfills
        !            18:     ;
        !            19:     ;
        !            20:     ;   Author: David Wicksell <dlwicksell@fourthwatchsoftware.com>
        !            21:     ;    Copyright (C) 1998 MUG Deutschland
        !            22:     ;    Copyright (C) 2020, 2021, 2023 Fourth Watch Software LC
        !            23:     ;
        !            24:     ;
        !            25:     ;   This file is part of FreeM.
        !            26:     ;
        !            27:     ;   FreeM is free software: you can redistribute it and/or modify
        !            28:     ;   it under the terms of the GNU Affero Public License as published by
        !            29:     ;   the Free Software Foundation, either version 3 of the License, or
        !            30:     ;   (at your option) any later version.
        !            31:     ;
        !            32:     ;   FreeM is distributed in the hope that it will be useful,
        !            33:     ;   but WITHOUT ANY WARRANTY; without even the implied warranty of
        !            34:     ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
        !            35:     ;   GNU Affero Public License for more details.
        !            36:     ;
        !            37:     ;   You should have received a copy of the GNU Affero Public License
        !            38:     ;   along with FreeM.  If not, see <https://www.gnu.org/licenses/>.
        !            39:     ;
        !            40: MERGE(SOURCE,DESTINATION) ; Implement the MERGE command
        !            41:        ; SOURCE = M array to merge from passed by name indirection
        !            42:        ; DESTINATION = M array to merge to passed by name indirection
        !            43:        ; returns 0 on success, -1 on error
        !            44:        ;
        !            45:        ; SOURCE is an array descendant of DESTINATION; throw M19 (error code 158)
        !            46:        IF $EXTRACT(SOURCE,1,$LENGTH(DESTINATION))=DESTINATION QUIT -1
        !            47:        ; DESTINATION is an array descendant of SOURCE; throw M19 (error code 158)
        !            48:        IF $EXTRACT(DESTINATION,1,$LENGTH(SOURCE))=SOURCE QUIT -1
        !            49:        ;
        !            50:        ; save SOURCE and DESTINATION in order to reset the naked indicator at the end
        !            51:        NEW SAVESRC,SAVEDST
        !            52:        SET SAVESRC=SOURCE,SAVEDST=DESTINATION
        !            53:        ;
        !            54:        ; set DESTINATION clear base name
        !            55:        NEW DST
        !            56:        SET DST=DESTINATION
        !            57:        ;
        !            58:        ; set SOURCE break flag
        !            59:        NEW SRC
        !            60:        SET SRC=SOURCE,$QSUBSCRIPT(SRC,0)="",$EXTRACT(SRC,$LENGTH(SRC))=""
        !            61:        ;
        !            62:        ; set the SOURCE POP offset
        !            63:        NEW POP
        !            64:        IF $QLENGTH(SOURCE)>$QLENGTH(DESTINATION) SET POP=$QLENGTH(SOURCE)-$QLENGTH(DESTINATION)
        !            65:        ELSE  SET POP=0
        !            66:        ;
        !            67:        ; set the DESTINATION PUSH offset
        !            68:        NEW PUSH
        !            69:        IF $QLENGTH(DESTINATION)>$QLENGTH(SOURCE) SET PUSH=$QLENGTH(DESTINATION)-$QLENGTH(SOURCE)
        !            70:        ELSE  SET PUSH=0
        !            71:        ;
        !            72:        ; merge initial node, if it exists
        !            73:        SET:$DATA(@SOURCE)#2 @DESTINATION=@SOURCE
        !            74:        ;
        !            75:        ; merge the rest of the nodes
        !            76:        NEW I,TST
        !            77:        FOR  SET SOURCE=$QUERY(@SOURCE) QUIT:(SOURCE="")!(SRC=-1)  DO
        !            78:        . ; quit at the end of a SOURCE sub-tree
        !            79:        . SET TST=SOURCE,$QSUBSCRIPT(TST,0)="",TST=$EXTRACT(TST,1,$LENGTH(SRC))
        !            80:        . IF TST'=SRC SET SRC=-1 QUIT
        !            81:        . ;
        !            82:        . ; clear DESTINATION keys
        !            83:        . SET DESTINATION=DST
        !            84:        . ; rebuild the DESTINATION array keys
        !            85:        . FOR I=1:1:($QLENGTH(SOURCE)-POP) DO
        !            86:        . . SET $QSUBSCRIPT(DESTINATION,I+PUSH)=$QSUBSCRIPT(SOURCE,I+POP)
        !            87:        . ;
        !            88:        . ; set the next node
        !            89:        . SET @DESTINATION=@SOURCE
        !            90:        ;
        !            91:        ; reset the naked indicator
        !            92:        SET SAVESRC=$GET(@SAVESRC),SAVEDST=$GET(@SAVEDST)
        !            93:        ;
        !            94:        QUIT 0
        !            95: REVQUERY(CURRENT,PREVIOUS) ; Implement reverse $QUERY
        !            96:        ; CURRENT = global or local query reference passed by name indirection
        !            97:        ; PREVIOUS = previous global or local node, regardless of depth, passed by reference
        !            98:        ; returns 0
        !            99:        ;
        !           100:        ; if root node, return the empty string
        !           101:        IF $QLENGTH(CURRENT)=0 SET PREVIOUS="" QUIT 0
        !           102:        ELSE  SET PREVIOUS=CURRENT
        !           103:        ;
        !           104:        NEW FLAG SET FLAG=0
        !           105:        NEW I,SUB
        !           106:        ; loop backwards, stripping off subscript levels on the same line
        !           107:        FOR I=1:1:$QLENGTH(CURRENT) QUIT:FLAG  DO
        !           108:        . SET SUB=$ORDER(@PREVIOUS,-1)
        !           109:        . SET PREVIOUS=$NAME(@PREVIOUS,$QLENGTH(PREVIOUS)-1)
        !           110:        . ;
        !           111:        . ; if we moved to a new line, start looking forward
        !           112:        . IF SUB'="" DO  SET FLAG=1
        !           113:        . . SET PREVIOUS=$NAME(@PREVIOUS@(SUB))
        !           114:        . . ;
        !           115:        . . NEW SAVE
        !           116:        . . ; loop forwards until we hit the original node
        !           117:        . . FOR  DO  QUIT:(PREVIOUS="")  QUIT:($NAME(@PREVIOUS)=$NAME(@CURRENT))
        !           118:        . . . ; save off the correct previous node to return
        !           119:        . . . SET SAVE=PREVIOUS
        !           120:        . . . SET PREVIOUS=$QUERY(@PREVIOUS)
        !           121:        . . ;
        !           122:        . . SET PREVIOUS=SAVE
        !           123:         . ELSE  IF $DATA(@PREVIOUS)#2 SET FLAG=1
        !           124:        ;
        !           125:        ; if root node doesn't exist, return the empty string
        !           126:        SET:(($QLENGTH(PREVIOUS)=0)&($DATA(@PREVIOUS)#2=0)) PREVIOUS=""
        !           127:        ;
        !           128:        QUIT 0