Return to %SYSPOLY.m CVS log

Up to [Coherent Logic Development] / freem / mlib

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

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