Return to %SYSPOLY.m CVS log

Up to [Coherent Logic Development] / freem / mlib

Phase 3 of REUSE compliance and header reformatting

    1: %SYSPOLY ;V4W/DLW-FREEM POLYFILLS; 9/2/2021 7:52 PM
    2:     ;0.0;FreeM;****FREEM**;Serena Willis @2021
    3:     ; 
    4:     ;   $Id: %SYSPOLY.m,v 1.3 2025/03/10 00:38:15 snw Exp $
    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:     ;
   28:     ;   $Log: %SYSPOLY.m,v $
   29:     ;   Revision 1.3  2025/03/10 00:38:15  snw
   30:     ;   Phase 3 of REUSE compliance and header reformatting
   31:     ;
   32:     ;
   33:     ; SPDX-FileCopyrightText:  (C) 2025 Coherent Logic Development LLC
   34:     ; SPDX-License-Identifier: AGPL-3.0-or-later    
   35: MERGE(SOURCE,DESTINATION) ; Implement the MERGE command
   36: 	; SOURCE = M array to merge from passed by name indirection
   37: 	; DESTINATION = M array to merge to passed by name indirection
   38: 	; returns 0 on success, -1 on error
   39: 	;
   40: 	; SOURCE is an array descendant of DESTINATION; throw M19 (error code 158)
   41: 	IF $EXTRACT(SOURCE,1,$LENGTH(DESTINATION))=DESTINATION QUIT -1
   42: 	; DESTINATION is an array descendant of SOURCE; throw M19 (error code 158)
   43: 	IF $EXTRACT(DESTINATION,1,$LENGTH(SOURCE))=SOURCE QUIT -1
   44: 	;
   45: 	; save SOURCE and DESTINATION in order to reset the naked indicator at the end
   46: 	NEW SAVESRC,SAVEDST
   47: 	SET SAVESRC=SOURCE,SAVEDST=DESTINATION
   48: 	;
   49: 	; set DESTINATION clear base name
   50: 	NEW DST
   51: 	SET DST=DESTINATION
   52: 	;
   53: 	; set SOURCE break flag
   54: 	NEW SRC
   55: 	SET SRC=SOURCE,$QSUBSCRIPT(SRC,0)="",$EXTRACT(SRC,$LENGTH(SRC))=""
   56: 	;
   57: 	; set the SOURCE POP offset
   58: 	NEW POP
   59: 	IF $QLENGTH(SOURCE)>$QLENGTH(DESTINATION) SET POP=$QLENGTH(SOURCE)-$QLENGTH(DESTINATION)
   60: 	ELSE  SET POP=0
   61: 	;
   62: 	; set the DESTINATION PUSH offset
   63: 	NEW PUSH
   64: 	IF $QLENGTH(DESTINATION)>$QLENGTH(SOURCE) SET PUSH=$QLENGTH(DESTINATION)-$QLENGTH(SOURCE)
   65: 	ELSE  SET PUSH=0
   66: 	;
   67: 	; merge initial node, if it exists
   68: 	SET:$DATA(@SOURCE)#2 @DESTINATION=@SOURCE
   69: 	;
   70: 	; merge the rest of the nodes
   71: 	NEW I,TST
   72: 	FOR  SET SOURCE=$QUERY(@SOURCE) QUIT:(SOURCE="")!(SRC=-1)  DO
   73: 	. ; quit at the end of a SOURCE sub-tree
   74: 	. SET TST=SOURCE,$QSUBSCRIPT(TST,0)="",TST=$EXTRACT(TST,1,$LENGTH(SRC))
   75: 	. IF TST'=SRC SET SRC=-1 QUIT
   76: 	. ;
   77: 	. ; clear DESTINATION keys
   78: 	. SET DESTINATION=DST
   79: 	. ; rebuild the DESTINATION array keys
   80: 	. FOR I=1:1:($QLENGTH(SOURCE)-POP) DO
   81: 	. . SET $QSUBSCRIPT(DESTINATION,I+PUSH)=$QSUBSCRIPT(SOURCE,I+POP)
   82: 	. ;
   83: 	. ; set the next node
   84: 	. SET @DESTINATION=@SOURCE
   85: 	;
   86: 	; reset the naked indicator
   87: 	SET SAVESRC=$GET(@SAVESRC),SAVEDST=$GET(@SAVEDST)
   88: 	;
   89: 	QUIT 0
   90: REVQUERY(CURRENT,PREVIOUS) ; Implement reverse $QUERY
   91: 	; CURRENT = global or local query reference passed by name indirection
   92: 	; PREVIOUS = previous global or local node, regardless of depth, passed by reference
   93: 	; returns 0
   94: 	;
   95: 	; if root node, return the empty string
   96: 	IF $QLENGTH(CURRENT)=0 SET PREVIOUS="" QUIT 0
   97: 	ELSE  SET PREVIOUS=CURRENT
   98: 	;
   99: 	NEW FLAG SET FLAG=0
  100: 	NEW I,SUB
  101: 	; loop backwards, stripping off subscript levels on the same line
  102: 	FOR I=1:1:$QLENGTH(CURRENT) QUIT:FLAG  DO
  103: 	. SET SUB=$ORDER(@PREVIOUS,-1)
  104: 	. SET PREVIOUS=$NAME(@PREVIOUS,$QLENGTH(PREVIOUS)-1)
  105: 	. ;
  106: 	. ; if we moved to a new line, start looking forward
  107: 	. IF SUB'="" DO  SET FLAG=1
  108: 	. . SET PREVIOUS=$NAME(@PREVIOUS@(SUB))
  109: 	. . ;
  110: 	. . NEW SAVE
  111: 	. . ; loop forwards until we hit the original node
  112: 	. . FOR  DO  QUIT:(PREVIOUS="")  QUIT:($NAME(@PREVIOUS)=$NAME(@CURRENT))
  113: 	. . . ; save off the correct previous node to return
  114: 	. . . SET SAVE=PREVIOUS
  115: 	. . . SET PREVIOUS=$QUERY(@PREVIOUS)
  116: 	. . ;
  117: 	. . SET PREVIOUS=SAVE
  118:         . ELSE  IF $DATA(@PREVIOUS)#2 SET FLAG=1
  119: 	;
  120: 	; if root node doesn't exist, return the empty string
  121: 	SET:(($QLENGTH(PREVIOUS)=0)&($DATA(@PREVIOUS)#2=0)) PREVIOUS=""
  122: 	;
  123: 	QUIT 0