Return to %SYSPOLY.m CVS log

Up to [Coherent Logic Development] / freem / mlib

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

1.1       snw         1: %SYSPOLY ;V4W/DLW-FREEM POLYFILLS; 9/2/2021 7:52 PM
1.2     ! snw         2:     ;0.0;FreeM;****FREEM**;Serena Willis @2021
1.1       snw         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