112 lines
3.3 KiB
Plaintext
112 lines
3.3 KiB
Plaintext
|
subroutine U0190( proc, ibn, pib, sib, ip, obn, pob, sob )
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* Perform aritemetic on reverse Polish string in current output buffer
|
||
|
|
*
|
||
|
|
* Module %M% Version %I% Date %H%
|
||
|
|
*
|
||
|
|
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
|
||
|
|
* This is unpublished proprietary source code of Ardent Software Inc.
|
||
|
|
* The copyright notice above does not evidence any actual or intended
|
||
|
|
* publication of such source code.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* Maintenence log - insert most recent change descriptions at top
|
||
|
|
*
|
||
|
|
* Date.... GTAR# WHO Description.........................................
|
||
|
|
* 10/14/98 23801 SAP Change copyrights.
|
||
|
|
* 07/25/88 - - Maintenence log purged at 5.2.1, see release 5.1.10.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
* This "user-exit", called from a ProVerb, takes the string in the
|
||
|
|
* current output buffer (delimited on the left by an arbitrary character
|
||
|
|
* specified in the calling sequence, on the right by an '?'), evaluates
|
||
|
|
* the entire string, deletes the string (including any delimiters),
|
||
|
|
* and sends the answer to the specified target.
|
||
|
|
*
|
||
|
|
* Usage:
|
||
|
|
* U0190
|
||
|
|
* left.delimiter target
|
||
|
|
*
|
||
|
|
* Where target can be:
|
||
|
|
* T - terminal
|
||
|
|
* S - Current output buffer
|
||
|
|
* A - Alternate output buffer
|
||
|
|
* P - Primary input buffer
|
||
|
|
*
|
||
|
|
* Arguments to this subroutine are:
|
||
|
|
* proc - the text of the proc itself
|
||
|
|
* ibn - the current input buffer switch (0 = primary;
|
||
|
|
* 1 = secondary)
|
||
|
|
* pib - the primary input buffer
|
||
|
|
* sib - the secondary input buffer
|
||
|
|
* ip - the input buffer pointer (character count)
|
||
|
|
* obn - the current output buffer switch (0 = primary;
|
||
|
|
* 1 = secondary)
|
||
|
|
* pob - the primary output buffer
|
||
|
|
* sob - the secondary output buffer
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
|
||
|
|
DIM parse( 200 )
|
||
|
|
*
|
||
|
|
* The "REMOVE" pointer has been initialized to the current line in the proc.
|
||
|
|
* Get next proc line after "U0190" to see where the output goes.
|
||
|
|
*
|
||
|
|
REMOVE target FROM proc SETTING x
|
||
|
|
leftdelim = ( TRIM( target ))[ 1, 1 ]
|
||
|
|
target = TRIM( target[ 2, 99 ])
|
||
|
|
|
||
|
|
stack = IF obn THEN sob ELSE pob
|
||
|
|
start = INDEX( stack, leftdelim, 1 )
|
||
|
|
i = 1
|
||
|
|
LOOP
|
||
|
|
finish = INDEX( stack, "?", i )
|
||
|
|
UNTIL finish > start DO
|
||
|
|
i += 1
|
||
|
|
REPEAT
|
||
|
|
stack = stack[ start + 1, finish - start - 1 ]
|
||
|
|
|
||
|
|
IF obn THEN
|
||
|
|
sob = sob[ 1, start - 1 ] : sob[ finish + 1, len( sob )]
|
||
|
|
END ELSE
|
||
|
|
pob = pob[ 1, start - 1 ] : pob[ finish + 1, len( pob )]
|
||
|
|
END
|
||
|
|
|
||
|
|
answer = stack< 1 >
|
||
|
|
DEL stack< 1 >
|
||
|
|
CALL $STKMATH( answer, stack )
|
||
|
|
|
||
|
|
BEGIN CASE
|
||
|
|
CASE target = "S"
|
||
|
|
IF( obn ) THEN
|
||
|
|
sob = answer
|
||
|
|
END ELSE
|
||
|
|
pob = answer
|
||
|
|
END
|
||
|
|
|
||
|
|
CASE target = "A"
|
||
|
|
IF( obn ) THEN
|
||
|
|
pob = answer
|
||
|
|
END ELSE
|
||
|
|
sob = answer
|
||
|
|
END
|
||
|
|
|
||
|
|
CASE target = "P"
|
||
|
|
IF pib[ ip, 1 ] = @AM THEN ip += 1
|
||
|
|
first.part = pib[ 1, ip - 1 ] : answer : @AM
|
||
|
|
last.part = pib[ ip + 1, len( pib )]
|
||
|
|
DEL last.part< 1 >
|
||
|
|
pib = first.part : last.part
|
||
|
|
|
||
|
|
CASE target = "T"
|
||
|
|
print answer
|
||
|
|
|
||
|
|
CASE target = "T+"
|
||
|
|
print answer:
|
||
|
|
|
||
|
|
END CASE
|
||
|
|
RETURN
|
||
|
|
END
|