From 4596fbd399f489de4a6992985a4654320c4fddf9 Mon Sep 17 00:00:00 2001 From: John Ganci <58781735+jyganci@users.noreply.github.com> Date: Fri, 9 Aug 2024 10:14:46 -0500 Subject: [PATCH] Is509 correct errors in z390 implementation of HLASM built-in functions (#541) * is509 fixes for HLASM built-in functions * update readme * correct typo in comment * change TOPR2 report file name to TOPR2.TST * change comment HLASM LR to HLASM LangRef * add additional regression tests * remove unused statement and correct typo --- rt/bash/errora2btests | 40 + rt/bash/errorisbintests | 36 + rt/bash/errorisdectests | 35 + rt/bash/errorishextests | 35 + rt/bash/errorissymtests | 35 + rt/bash/errorslatests | 35 + rt/bash/readme.txt | 8 + rt/bash/runhlasmbiftests | 25 + rt/bash/x00c2bdxtests | 22 + rt/mlc/A2BE1.MLC | 20 + rt/mlc/A2BE2.MLC | 20 + rt/mlc/C2BDX00.MLC | 34 + rt/mlc/ISBINE1.MLC | 20 + rt/mlc/ISDECE1.MLC | 20 + rt/mlc/ISHEXE1.MLC | 20 + rt/mlc/ISSYME1.MLC | 20 + rt/mlc/SLAE1.MLC | 192 ++ rt/mlc/TESTASC1.MLC | 21 +- rt/mlc/TESTDC1.MLC | 21 +- rt/mlc/TOPR2.MLC | 1779 +++++++++++++++++ rt/test/TESTOPR2.MLC | 1410 +++++++++++++ src/az390.java | 33 +- src/mz390.java | 818 ++++++-- .../test/RunHLASMBuiltInFunctionsTests.groovy | 116 ++ zcobol/mac/GEN_MOVE.MAC | 3 +- zopcheck/ZOPMACRO.CPY | 19 +- 26 files changed, 4659 insertions(+), 178 deletions(-) create mode 100755 rt/bash/errora2btests create mode 100755 rt/bash/errorisbintests create mode 100755 rt/bash/errorisdectests create mode 100755 rt/bash/errorishextests create mode 100755 rt/bash/errorissymtests create mode 100755 rt/bash/errorslatests create mode 100755 rt/bash/runhlasmbiftests create mode 100755 rt/bash/x00c2bdxtests create mode 100644 rt/mlc/A2BE1.MLC create mode 100644 rt/mlc/A2BE2.MLC create mode 100644 rt/mlc/C2BDX00.MLC create mode 100644 rt/mlc/ISBINE1.MLC create mode 100644 rt/mlc/ISDECE1.MLC create mode 100644 rt/mlc/ISHEXE1.MLC create mode 100644 rt/mlc/ISSYME1.MLC create mode 100644 rt/mlc/SLAE1.MLC create mode 100644 rt/mlc/TOPR2.MLC create mode 100644 rt/test/TESTOPR2.MLC create mode 100644 z390test/src/test/groovy/org/z390/test/RunHLASMBuiltInFunctionsTests.groovy diff --git a/rt/bash/errora2btests b/rt/bash/errora2btests new file mode 100755 index 000000000..4f9ef4864 --- /dev/null +++ b/rt/bash/errora2btests @@ -0,0 +1,40 @@ +#!/bin/bash + +# errora2btests: regression test A2B error + +# global variable containing name of script; used by error function +scriptName="errora2btests" + +######################################## +# print error message and exit +# +# input: +# $1 name of program for the error +# $2 program expected return code +# $3 program actual return code +######################################## + +function error { + echo "$scriptName ERROR: $1 expected RC=$2 but actual RC=$3; exiting" + exit 8 +} + +#set -e # exit on all errors; not for this script +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +prog="A2BE1" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 12 ]; then error "$prog" 12 $rc; fi + +prog="A2BE2" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 12 ]; then error "$prog" 12 $rc; fi + +# if we get here, there were no errors +rc=0 +echo "$scriptName exiting with RC=$rc" +exit $rc diff --git a/rt/bash/errorisbintests b/rt/bash/errorisbintests new file mode 100755 index 000000000..96337fefd --- /dev/null +++ b/rt/bash/errorisbintests @@ -0,0 +1,36 @@ +#!/bin/bash + +# errorisbintests: regression test ISBIN error + +# global variable containing name of script; used by error function +scriptName="errorisbintests" + +######################################## +# print error message and exit +# +# input: +# $1 name of program for the error +# $2 program expected return code +# $3 program actual return code +######################################## + +function error { + echo "$scriptName ERROR: $1 expected RC=$2 but actual RC=$3; exiting" + exit 8 +} + + +#set -e # exit on all errors; not for this script +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +prog="ISBINE1" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 8 ]; then error "$prog" 8 $rc; fi + +# if we get here, there were no errors +rc=0 +echo "$scriptName exiting with RC=$rc" +exit $rc diff --git a/rt/bash/errorisdectests b/rt/bash/errorisdectests new file mode 100755 index 000000000..b5967b7a4 --- /dev/null +++ b/rt/bash/errorisdectests @@ -0,0 +1,35 @@ +#!/bin/bash + +# errorisdectests: regression test ISDEC error + +# global variable containing name of script; used by error function +scriptName="errorisdectests" + +######################################## +# print error message and exit +# +# input: +# $1 name of program for the error +# $2 program expected return code +# $3 program actual return code +######################################## + +function error { + echo "$scriptName ERROR: $1 expected RC=$2 but actual RC=$3; exiting" + exit 8 +} + +#set -e # exit on all errors; not for this script +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +prog="ISDECE1" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 8 ]; then error "$prog" 8 $rc; fi + +# if we get here, there were no errors +rc=0 +echo "$scriptName exiting with RC=$rc" +exit $rc diff --git a/rt/bash/errorishextests b/rt/bash/errorishextests new file mode 100755 index 000000000..08a461b49 --- /dev/null +++ b/rt/bash/errorishextests @@ -0,0 +1,35 @@ +#!/bin/bash + +# errorishextests: regression test ISHEX error + +# global variable containing name of script; used by error function +scriptName="errorishextests" + +######################################## +# print error message and exit +# +# input: +# $1 name of program for the error +# $2 program expected return code +# $3 program actual return code +######################################## + +function error { + echo "$scriptName ERROR: $1 expected RC=$2 but actual RC=$3; exiting" + exit 8 +} + +#set -e # exit on all errors; not for this script +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +prog="ISHEXE1" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 8 ]; then error "$prog" 8 $rc; fi + +# if we get here, there were no errors +rc=0 +echo "$scriptName exiting with RC=$rc" +exit $rc diff --git a/rt/bash/errorissymtests b/rt/bash/errorissymtests new file mode 100755 index 000000000..2e6a9fce7 --- /dev/null +++ b/rt/bash/errorissymtests @@ -0,0 +1,35 @@ +#!/bin/bash + +# errorissymtests: regression test ISSYM error + +# global variable containing name of script; used by error function +scriptName="errorissymtests" + +######################################## +# print error message and exit +# +# input: +# $1 name of program for the error +# $2 program expected return code +# $3 program actual return code +######################################## + +function error { + echo "$scriptName ERROR: $1 expected RC=$2 but actual RC=$3; exiting" + exit 8 +} + +#set -e # exit on all errors; not for this script +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +prog="ISSYME1" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 8 ]; then error "$prog" 8 $rc; fi + +# if we get here, there were no errors +rc=0 +echo "$scriptName exiting with RC=$rc" +exit $rc diff --git a/rt/bash/errorslatests b/rt/bash/errorslatests new file mode 100755 index 000000000..8ceb24602 --- /dev/null +++ b/rt/bash/errorslatests @@ -0,0 +1,35 @@ +#!/bin/bash + +# errorslatests: regression test SLA errors + +# global variable containing name of script; used by error function +scriptName="errorslatests" + +######################################## +# print error message and exit +# +# input: +# $1 name of program for the error +# $2 program expected return code +# $3 program actual return code +######################################## + +function error { + echo "$scriptName ERROR: $1 expected RC=$2 but actual RC=$3; exiting" + exit 8 +} + +#set -e # exit on all errors; not for this script +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +prog="SLAE1" +bash/asm rt/mlc/$prog +rc=$? +if [ $rc -ne 8 ]; then error "$prog" 8 $rc; fi + +# if we get here, there were no errors +rc=0 +echo "$scriptName exiting with RC=$rc" +exit $rc diff --git a/rt/bash/readme.txt b/rt/bash/readme.txt index 6f67b2b18..7b2abfaef 100644 --- a/rt/bash/readme.txt +++ b/rt/bash/readme.txt @@ -14,5 +14,13 @@ runtbrctx - verify closed issue #238 runtestopt - verify indirection usage in options files runbr14owe - verifies test IEFBR14 asm[l[g]] with Okay, Warning, Error variants runcodepagetests - verifies usage of CODEPAGE issue #451 +runhlasmbiftests - run HLASM built-in function tests issue 509 +errora2btests - verify A2B error tests +errorisbintests - verify ISBIN error tests +errorisdectests - verify ISDEC error tests +errorishextests - verify ISHEX error tests +errorissymtests - verify ISSYM error tests +errorslatests - verify SLA error tests +x00c2bdxtests - verify C2B, C2D, C2X tests that have X'00' in argument End regression test commands diff --git a/rt/bash/runhlasmbiftests b/rt/bash/runhlasmbiftests new file mode 100755 index 000000000..ed67f6384 --- /dev/null +++ b/rt/bash/runhlasmbiftests @@ -0,0 +1,25 @@ +#!/bin/bash + +# runhlasmbiftests: regression test HLASM built-in functions + +set -e # exit on all errors +cd $(dirname $0) # set to directory of script - rt/bash +cd .. # up to rt +cd .. # up to z390 + +sysmac='sysmac(mac)' +optable='optable(z390)' + +dir1="rt/test" +dir2="rt/mlc" + +bash/asmlg ${dir1}/TESTOPR2 trace noloadhigh noinit $sysmac + +export REPORT=${dir2}/TOPR2.TST +bash/asmlg ${dir2}/TOPR2 trace noloadhigh noinit $sysmac + +# if we get here, there were no errors +echo "Verify tests ran without errors" +echo " View ${dir1}/TESTOPR2.PRN to see tests checked with MNOTE,AIF" +echo " View ${dir2}/TOPR2.TXT to see tests checked with code" +exit 0 diff --git a/rt/bash/x00c2bdxtests b/rt/bash/x00c2bdxtests new file mode 100755 index 000000000..51c7e0535 --- /dev/null +++ b/rt/bash/x00c2bdxtests @@ -0,0 +1,22 @@ +#!/bin/bash + +# x00c2bdxtests: regression test HLASM built-in functions + +set -e # exit on all errors +cd $(dirname $0) # set to directory of script +cd ../.. # up two directories; the z390 directory + +sysmac='sysmac(mac)' + +# assemble test program +bash/asm rt/mlc/C2BDX00 trace noloadhigh $sysmac +rc=$? +if [ $rc -ne 0 ]; then + echo "Error assembling test program; rc=$rc" + exit $rc +fi + +# if we get here, there were no errors +echo "Verify tests ran without errors" +echo " View rt/mlc/C2BDX00.PRN to see tests" +exit 0 diff --git a/rt/mlc/A2BE1.MLC b/rt/mlc/A2BE1.MLC new file mode 100644 index 000000000..1f58fee4e --- /dev/null +++ b/rt/mlc/A2BE1.MLC @@ -0,0 +1,20 @@ +* Test A2B built-in function error +A2BE1 CSECT + SR 15,15 + BR 14 +* + LCLC &C +* +* HLASM LangRef example +* +*&C SETC 'abc' Preset result field +&C SETC 'abc' +* +*&C SETC A2B(2345678901) Error; too large +&C SETC A2B(2345678901) + MNOTE 'A2B(2345678901)=&C' + AIF ('&C' EQ 'abc').OK + MNOTE 12.'Error; expected value is abc' +.OK ANOP +* + END diff --git a/rt/mlc/A2BE2.MLC b/rt/mlc/A2BE2.MLC new file mode 100644 index 000000000..c0b7f4627 --- /dev/null +++ b/rt/mlc/A2BE2.MLC @@ -0,0 +1,20 @@ +* Test A2B built-in function error +A2BE2 CSECT + SR 15,15 + BR 14 +* + LCLC &C +* +* z390 example +* +*&C SETC 'abc' Preset result field +&C SETC 'abc' +* +*&C SETC A2B(--2147483648) Error; overflow +&C SETC A2B(--2147483648) + MNOTE 'A2B(--2147483648)=&C' + AIF ('&C' EQ 'abc').OK + MNOTE 12.'Error; expected value is abc' +.OK ANOP +* + END diff --git a/rt/mlc/C2BDX00.MLC b/rt/mlc/C2BDX00.MLC new file mode 100644 index 000000000..b054124bb --- /dev/null +++ b/rt/mlc/C2BDX00.MLC @@ -0,0 +1,34 @@ +* Test HLASM built-in functions that have X'00' in argument string +C2BDX00 CSECT + LCLC &C2B,&C2D,&C2X +* + LCLC &NULL,&NULLj +* +* &NULL,&NULLj values taken from HLASM LangRef B2C examples +&NULL SETC B2C('0') value 'n' = null char = X'00' +&NULLj SETC '&NULL'.'j' value 'nj' +* +* HLASM LangRef examples +* +*&C2B SETC C2B('n') n = null char = X'00' +&C2B SETC C2B('&NULL') + MNOTE 'C2B(''&NULL'')=&C2B' + AIF ('&C2B' EQ '00000000').OKC2B + MNOTE 8,'C2B: Generated value not equal to expected value' +.OKC2B ANOP +* +*&C2D SETC C2D('nj') n = null char = X'00' +&C2D SETC C2D('&NULLj') + MNOTE 'C2D(''&NULLj'')=&C2D' + AIF ('&C2D' EQ '+145').OKC2D + MNOTE 8,'C2D: Generated value not equal to expected value' +.OKC2D ANOP +* +*&C2X SETC C2X('n') n = null char = X'00' +&C2X SETC C2X('&NULL') + MNOTE 'C2X(''&NULL'')=&C2X' + AIF ('&C2X' EQ '00').OKC2X + MNOTE 8,'C2X: Generated value not equal to expected value' +.OKC2X ANOP +* + END diff --git a/rt/mlc/ISBINE1.MLC b/rt/mlc/ISBINE1.MLC new file mode 100644 index 000000000..a48978e11 --- /dev/null +++ b/rt/mlc/ISBINE1.MLC @@ -0,0 +1,20 @@ +* Test ISBIN built-in function error +ISBINE1 CSECT + SR 15,15 + BR 14 +* + LCLA &A +* +* HLASM LangRef example +* +*&A SETA 123 Preset return value +&A SETA 123 +*&A ISBIN('') Error +&A SETA ISBIN('') 0 + MNOTE 'ISBIN('''')=&A' + DC F'&A' + AIF (&A EQ 0).OK + MNOTE 12,'Error; expected value is 0' +.OK ANOP +* + END diff --git a/rt/mlc/ISDECE1.MLC b/rt/mlc/ISDECE1.MLC new file mode 100644 index 000000000..37463f46a --- /dev/null +++ b/rt/mlc/ISDECE1.MLC @@ -0,0 +1,20 @@ +* Test ISDEC built-in function error +ISDECE1 CSECT + SR 15,15 + BR 14 +* + LCLA &A +* +* HLASM LangRef example +* +*&A SETA 123 Preset return value +&A SETA 123 +*&A ISDEC('') Error +&A SETA ISDEC('') 0 + MNOTE 'ISDEC('''')=&A' + DC F'&A' + AIF (&A EQ 0).OK + MNOTE 12,'Error; expected value is 0' +.OK ANOP +* + END diff --git a/rt/mlc/ISHEXE1.MLC b/rt/mlc/ISHEXE1.MLC new file mode 100644 index 000000000..6d6191bcc --- /dev/null +++ b/rt/mlc/ISHEXE1.MLC @@ -0,0 +1,20 @@ +* Test ISHEX built-in function error +ISHEXE1 CSECT + SR 15,15 + BR 14 +* + LCLA &A +* +* HLASM LangRef example +* +*&A SETA 123 Preset return value +&A SETA 123 +*&A ISHEX('') Error +&A SETA ISHEX('') 0 + MNOTE 'ISHEX('''')=&A' + DC F'&A' + AIF (&A EQ 0).OK + MNOTE 12,'Error; expected value is 0' +.OK ANOP +* + END diff --git a/rt/mlc/ISSYME1.MLC b/rt/mlc/ISSYME1.MLC new file mode 100644 index 000000000..f549aa4c1 --- /dev/null +++ b/rt/mlc/ISSYME1.MLC @@ -0,0 +1,20 @@ +* Test ISSYM built-in function error +ISSYME1 CSECT + SR 15,15 + BR 14 +* + LCLA &A +* +* HLASM LangRef example +* +*&A SETA 123 Preset return value +&A SETA 123 +*&A ISSYM('') Error +&A SETA ISSYM('') 0 + MNOTE 'ISSYM('''')=&A' + DC F'&A' + AIF (&A EQ 0).OK + MNOTE 12,'Error; expected value is 0' +.OK ANOP +* + END diff --git a/rt/mlc/SLAE1.MLC b/rt/mlc/SLAE1.MLC new file mode 100644 index 000000000..9ab365643 --- /dev/null +++ b/rt/mlc/SLAE1.MLC @@ -0,0 +1,192 @@ +* Test SLA built-in function error +* +*********************************************************************** +* Macro to show operands and result of +* &SLA SETA (&OP1 SLA &OP2) +* in binary, hexadecimal, and signed decimal +* +* Sample output +* &OP1 SETA 16+1 +* &OP2 SETA 31-5 +* &SLA SETA (&OP1 SLA &OP2) valid; shifts 1 into bit 1 +* SHOWSBC +* + MNOTE '(X'00000011' SLA 26) = 1140850688 (X'44000000')' +* + MNOTE 'Binary OP1 00000000000000000000000000010001' +* + MNOTE 'Binary OP2 00000000000000000000000000011010' +* + MNOTE 'Binary SLA 01000100000000000000000000000000' +*********************************************************************** +* + MACRO + SHOWSBC + GBLA &OP1,&OP2,&SLA + LCLC &SOP1,&SOP2,&SSLA + LCLC &BOP1,&BOP2,&BSLA + LCLC &XOP1,&XOP2,&XSLA +.* +&SSLA SETC (SIGNED &SLA) +&BSLA SETC A2B(&SLA) +&XSLA SETC A2X(&SLA) +.* +&SOP1 SETC SIGNED(&OP1) +&BOP1 SETC A2B(&OP1) +&XOP1 SETC A2X(&OP1) +.* +&SOP2 SETC (SIGNED &OP2) +&BOP2 SETC A2B(&OP2) +&XOP2 SETC A2X(&OP2) +.* + MNOTE '(X''&XOP1'' SLA &SOP2) = &SSLA (X''&XSLA'')' + MNOTE 'Binary OP1 &BOP1' + MNOTE 'Binary OP2 &BOP2' + MNOTE 'Binary SLA &BSLA' +.* + MEND +*********************************************************************** + GBLA &OP1,&OP2,&SLA +* +* Show SLA results +* +* GBLA &OP1,&OP2,&SLA preset via "&SLA SETA (&OP1 SLA &OP2)" +* +*********************************************************************** +SLAE1 CSECT + SR 15,15 + BR 14 +* + LCLA &A +* +* z390 examples +* +*********************************************************************** +&OP1 SETA 1 +&OP2 SETA -1 +&SLA SETA 2 +*&OP1 SETA 1 +*&OP2 SETA -1 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) Invalid; shifts >= 32 bits +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK1 Expected value? + MNOTE 12,'Expected value is 0' +.OK1 ANOP +*********************************************************************** +&OP1 SETA 1 +&OP2 SETA 63 +&SLA SETA 2 +*&OP1 SETA 1 +*&OP2 SETA 63 +*&SLA SETA 2 Preset result +**SLA SETA (&OP1 SLA &OP2) Invalid; shifts >- 32 bits +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK2 Expected value? + MNOTE 12,'Expected value is 0' +.OK2 ANOP +*********************************************************************** +&OP1 SETA 2147483647 +&OP2 SETA 1 +&SLA SETA 2 +*&OP1 SETA 2147483647 +*&OP2 SETA 1 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) Invalid; shifts 1 into sign bit +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK3 Expected value? + MNOTE 12,'Expected value is 0' +.OK3 ANOP +*********************************************************************** +&OP1 SETA 1 +&OP2 SETA 31 +&SLA SETA 2 +*&OP1 SETA 1 +*&OP2 SETA 31 +*&SLA SETA 2 Preset result +**SLA SETA (&OP1 SLA &OP2) Invalid; shifts 11 into sign bit +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK4 Expected value? + MNOTE 12,'Expected value is 0' +.OK4 ANOP +*********************************************************************** +&OP1 SETA -1 +&OP2 SETA 32 +&SLA SETA 2 +*&OP1 SETA -1 +*&OP2 SETA 32 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) Invalid; non-zero; >=32 bits +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK5 Expected value? + MNOTE 12,'Expected value is 0' +.OK5 ANOP +*********************************************************************** +&OP1 SETA -2147483647 +&OP2 SETA 1 +&SLA SETA 2 +*&OP1 SETA -2147483647 +*&OP2 SETA 1 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) invalid; shifts 0 to sign bit +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK6 Expected value? + MNOTE 12,'Expected value is 0' +.OK6 ANOP +*********************************************************************** +&OP1 SETA -2147483647 +&OP2 SETA 32 +&SLA SETA 2 +*&OP1 SETA -2147483647 +*&OP2 SETA 32 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) Invalid; non-zero >=32 bits +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK7 Expected value? + MNOTE 12,'Expected value is 0' +.OK7 ANOP +*********************************************************************** +&OP1 SETA -2147483648 +&OP2 SETA 1 +&SLA SETA 2 +*&OP1 SETA -2147483648 +*&OP2 SETA 1 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) Invalid; shift 0 int sign bit +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK8 Expected value? + MNOTE 12,'Expected value is 0' +.OK8 ANOP +*********************************************************************** +&OP1 SETA 16+1 +&OP2 SETA 31-4 +&SLA SETA 2 +*&OP1 SETA 16+1 +*&OP2 SETA 31-4 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) invalid; shifts 1 into sign bit +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK9 Expected value? + MNOTE 12,'Expected value is 0' +.OK9 ANOP +*********************************************************************** +&OP1 SETA -16-1 +&OP2 SETA 31-4 +&SLA SETA 2 +*&OP1 SETA -16-1 +*&OP2 SETA 31-4 +*&SLA SETA 2 Preset result +*&SLA SETA (&OP1 SLA &OP2) invalid; shifts 0 into sigh bit +&SLA SETA (&OP1 SLA &OP2) + SHOWSBC + AIF (&SLA EQ 0).OK10 Expected value? + MNOTE 12,'Expected value is 0' +.OK10 ANOP +*********************************************************************** +* + END diff --git a/rt/mlc/TESTASC1.MLC b/rt/mlc/TESTASC1.MLC index 63da96297..e4de93bed 100644 --- a/rt/mlc/TESTASC1.MLC +++ b/rt/mlc/TESTASC1.MLC @@ -50,6 +50,7 @@ * 01/25/11 RPI 1139 C2X ARG IN QUOTES FOR NOALLOW * 2022-05-03 update copyright, add to z390\rt\mlc, fix SETC '&&' to '&' * 2022-05-07 replace TESTSUB1 with CVTTOHEX to remove dependency +* 2024-07-24 #509 comment tests that now fail due to #509 changes ********************************************************************* PRINT DATA TESTDC1 RT1 MAIN @@ -439,14 +440,20 @@ CVTTOHEX2 RT1 CCE,=VD(CVTTOHEX),=AL8(CVTTOHEX) RPI 1044 DIFF ADDR &AVAL SETA 2147483647 &CHEX SETC A2X(&AVAL) RT1 CCE,=C'&CHEX',=C'7FFFFFFF' +* Next test succeeds; will fail when 2147483648 flagged as error #509 RT1 CCE,=A(2147483648),=X'80000000' TEST SETA OVERFLOW -&AVAL SETA 2147483648 -&CHEX SETC A2X(&AVAL) TEST NEG A2X - RT1 CCE,=C'&CHEX',=C'80000000' - RT1 CCE,=A(2147483649),=X'80000001' -&AVAL SETA 2147483649 -&CHEX SETC A2X(&AVAL) - RT1 CCE,=C'&CHEX',=C'80000001' +* Before SETA; now fails, as it should #509 +*&AVAL SETA 2147483648 #509 +* After SETA; did the SETA fail? Yes #509 +*&CHEX SETC A2X(&AVAL) TEST NEG A2X #509 +* RT1 CCE,=C'&CHEX',=C'80000000' #509 +* Next test succeeds; will fail when 2147483649 flagged as error #509 + RT1 CCE,=A(2147483649),=X'80000001' +* Before SETA; now fails, as it should #509 +*&AVAL SETA 2147483649 #509 +* After SETA; did it fail? Yes #509 +*&CHEX SETC A2X(&AVAL) #509 +* RT1 CCE,=C'&CHEX',=C'80000001' #509 &AVAL SETA 1/0 RT1 CCE,=A(&AVAL),=A(0) TEST SETA DIVIDE BY 0 &CVAL SETC '12345' diff --git a/rt/mlc/TESTDC1.MLC b/rt/mlc/TESTDC1.MLC index 6137d652d..2e974bb17 100644 --- a/rt/mlc/TESTDC1.MLC +++ b/rt/mlc/TESTDC1.MLC @@ -50,6 +50,7 @@ * 01/25/11 RPI 1139 C2X ARG IN QUOTES FOR NOALLOW * 2022-05-03 update copyright, add to z390\tests, fix SETC '&&' to '&' * 2022-05-07 replace TESTSUB1 with CVTTOHEX to remove dependency +* 2024-07-24 #509 comment tests that now fail due to #509 changes ********************************************************************* PRINT DATA TESTDC1 RT1 MAIN @@ -439,14 +440,20 @@ CVTTOHEX2 RT1 CCE,=VD(CVTTOHEX),=AL8(CVTTOHEX) RPI 1044 DIFF ADDR &AVAL SETA 2147483647 &CHEX SETC A2X(&AVAL) RT1 CCE,=C'&CHEX',=C'7FFFFFFF' +* Next test succeeds; will fail when 2147483648 flagged as error #509 RT1 CCE,=A(2147483648),=X'80000000' TEST SETA OVERFLOW -&AVAL SETA 2147483648 -&CHEX SETC A2X(&AVAL) TEST NEG A2X - RT1 CCE,=C'&CHEX',=C'80000000' - RT1 CCE,=A(2147483649),=X'80000001' -&AVAL SETA 2147483649 -&CHEX SETC A2X(&AVAL) - RT1 CCE,=C'&CHEX',=C'80000001' +* Before SETA; now fails, as it should #509 +*&AVAL SETA 2147483648 #509 +* After SETA; did the SETA fail? Yes #509 +*&CHEX SETC A2X(&AVAL) TEST NEG A2X #509 +* RT1 CCE,=C'&CHEX',=C'80000000' #509 +* Next test succeeds; will fail when 2147483649 flagged as error #509 + RT1 CCE,=A(2147483649),=X'80000001' +* Before SETA; now fails, as it should #509 +*&AVAL SETA 2147483649 #509 +* After SETA; did it fail? Yes #509 +*CHEX SETC A2X(&AVAL) #509 +* RT1 CCE,=C'&CHEX',=C'80000001' #509 &AVAL SETA 1/0 RT1 CCE,=A(&AVAL),=A(0) TEST SETA DIVIDE BY 0 &CVAL SETC '12345' diff --git a/rt/mlc/TOPR2.MLC b/rt/mlc/TOPR2.MLC new file mode 100644 index 000000000..799f1251e --- /dev/null +++ b/rt/mlc/TOPR2.MLC @@ -0,0 +1,1779 @@ +*********************************************************************** +* z390 - Mainframe assembler emulator and run-time engine +* Copyright (C) 2021 z390 Assembler LLC +* +* This file is part of z390. +* +* z390 is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* z390 is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program; if not, see https://www.gnu.org/licenses. +*********************************************************************** +* 2024-07-25 #509 New program +*********************************************************************** +* +* +*********************************************************************** +* Both rt/mlc/TOPR2.MLC and rt/test/TESTOPR2.MLC test the HLASM +* built-in functions. +* +* TOPR2 uses code to test HLASM built-in functions. +* TESTOPR2, modelled on original rt/test/TESTOPR1.MLC, uses MNOTE,AIF. +*********************************************************************** +* +*********************************************************************** +* TESTOPR2 is modeled on the previous TESTOPR1 test program to test +* the HLASM built-in functions. TESTOPR1 tests a built-in function +* as follows: +* 1. Invoke the built-in function +* 2. Use MNOTE to display the result +* 3. Check the result using AIF, branching to an error MNOTE +* if the generated value is not the expected value. +* For example, the TESTOPR1 test for the X2C built-in function is +* +* &X2C SETC (X2C('F1')) +* MNOTE 'X2C(''F1'')=&X2C' +* AIF ('&X2C'(4,1) NE '1').X2ERR +* ... +* .X2ERR MNOTE 12,'X2 OPERATOR ERROR' +* AGO .EXIT +* ... +* +* Note that if a test fails, all remaining tests are skipped. +* +*---------------------------------------------------------------------- +* +* TOPR2 performs tests using assembler code and DC statements to +* invoke and verify results. In addition, the HLASM Language +* Reference examples for each built-in function are added as +* tests (there are a few exceptions). Where a code test +* completely replaces the corresponding MNOTE.AIF test(s) done +* in TESTOPR2, the original test(s) are left in place but +* branched around via AGO. +* +* The first version of TOPR2 replaces the tests for the +* DCVAL and DEQUOTE built-in functions and adds tests for the +* DOUBLE built-in function. The tests for each is done in a +* separate subroutine. The tests write output to a file, +* TOPR2.TXT, that produces output similar to the TESTOPR2 +* MNOTE,AIF output. +* +* If a test case fails, error messages are written and testing +* continues. +* +* Sample output for the DCVAL test and a simulated error. +* +* DCVAL tests: Begin +* DCVAL('') = "" +* DCVAL('''') = "'" +* *** Fail *** DCVAL('&&') = "&" +* Error for test group DCVAL test number 3 +* Generated 016E504C +* Expected 026E504C00 +* DCVAL('a''''b') = "a'b" +* DCVAL('a''''b&&c') = "a'b&c" +* DCVAL('&&&&''''') = "&&''" +* DCVAL('''&&1''') = "'&&1'" +* DCVAL tests: num pass 6 num fail 1 +* +* Tests 1-2 and 4-7 succeed. Test 3 fails. +* +* The error shown is artificial. It was forced by changing the +* expected length, 1, to 2. +* Note that three error messages follow the "*** Fail ***" line: +* 1, A message showing the test group and the test number +* within the test group. +* 2. The generated value (the result of the DCVAL invocation) is +* shown in printable hexadecimal, as is the expected value. +* See the comments for the DCVAL test subroutine, TDCVAL, for +* for a description of the displayed values. Briefly, each +* is of the form +* FL1'length-of-value',C'>value<' +* The ">" and "<" delimit the value; they are present in case +* the value is null, which avoids an assembly error for C''. +* 3. The third test is converting two ampersands to one ampersand. +* The generated length is 1 and the generated value is +* X'50', which is the EBCDIC value of ampersand. Changing the +* expected length back to 1 results in all tests succeeding. +* +*---------------------------------------------------------------------- +* +* Registers on entry: +* R15 emtry point +* R14 return address +* R13 usable save area +* +* Registers on exit: +* R0 -- R14 as at entry +* R15 return code +* 0 all code tests passed +* 8 at least one code test failed +* Files: +* Input: none +* +* Output: DDNAME = REPORT file to contain code tests and results +* +*********************************************************************** +* +TOPR2 CSECT + STM 14,12,12(13) Save caller's registers + LR 12,15 R12 = base register + USING TOPR2,12 Establish addressability + L 11,=A(COMSTOR) Common storage + USING COMSTOR,11 Overly common storage + LA 14,SAS Current save area (1st in SA set) + ST 14,8(,13) Chain + ST 13,4(,14) save areas + LR 13,14 Current save area +* + OPEN (REPORT,OUTPUT) Open report file +* + BAS 14,WrtBegCT Write begin code tests header +* +* Perform tests done with code +* + SR 0,0 Initialize totals + ST 0,Tot#P Number of tests that pass + ST 0,Tot#F Number of tests that fail +* + LM 3,5,TesTsH R3 --> first test header entry +* R4 = length of entry +* R5 --> last test header entry +TLp1 DS 0H + L 1,0(,3) R1 --> parameter list for test group + BAS 14,WrtBegHd Write begin test header + L 15,4(,3) R15 --> A(test code) + L 15,0(,15) R15 --> test code + BASR 14,15 Perform tests for test group + C 15,MaxRC New maximum return code? + BNH TLp1A No + ST 15,MaxRC Save new maximum return code +TLp1A DS 0H +* +* Accumulate num pass, num fail totals and write subtotals +* + L 2,4(,1) R2 --> word = num tests that pass + L 0,Tot#P Add + A 0,0(,2) subtotal + ST 0,Tot#P to total +* + L 2,8(,1) R2 --> word = num tests that fail + L 0,Tot#F Add + A 0,0(,2) subtotal + ST 0,Tot#F to total +* + BAS 14,WrtSTot Write subtotals +* + PUT REPORT,Spaces Blank line +* + BXLE 3,4,TLp1 Process all test headers +* + BAS 14,WrtGTot Write grand totals +* + BAS 14,WrtEndCT Write end code tests trailer +* + CLOSE (REPORT) Close report file +* + L 15,MaxRC Set return code + L 13,4(,13) Caller's save area + RETURN (14,12),RC=(15) Restore R14, R0-R12; return +* + LTORG +* +* Pre-chained save area set +* +SAS DS 0D Save area set for program + DC F'0' + DC A(0,*-8+72) + DC 15F'0' +* + DC F'0' + DC A(*-4-72,*-8+72) + DC 15F'0' +* + DC F'0' + DC A(*-4-72,*-8+72) + DC 15F'0' +* + DC F'0' + DC A(*-4-72,*-8+72) + DC 15F'0' +* + DC F'0' + DC A(*-4-72,*-8+72) + DC 15F'0' +* + DC F'0' + DC A(*-4-72,0) + DC 15F'0' +* +*********************************************************************** +* SYM equate used for SYSATTRA, SYSATTRP tests +* +* RETURN macro in main code used in operator type O tests +*********************************************************************** +* +SYM EQU 1,2,C'3',C'PGMA',gr32 +* +*SYM EQU val,len attr val, type attr val, pgm type val, asm type val +* +* +*********************************************************************** +* Begin internal subroutines for main code +*********************************************************************** +* +*********************************************************************** +* WrtBegCT Write begin code tests header +* +* Registers at entry +* R11 common area +* R12 base register of caller +* R13 chained save area +* R14 return address +* +* Registers at exit +* R0-R15 same as at entry +*********************************************************************** +* +WrtBegCT DS 0H + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area +* + MVC RptLn,Spaces Initialize report line + LA 2,L'RLBegCT-1 Length code of begin header line + LA 14,RptLn Destination + LA 15,RLBegCT Source + EX 2,CpyVal Copy to report line +* + PUT REPORT,RptLn Write begin header + PUT REPORT,Spaces Write blank line +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +*********************************************************************** +* WrtEndCT Write end code tests trailer +* +* Registers at entry +* R11 common area +* R12 base register of caller +* R13 chained save area +* R14 return address +* +* Registers at exit +* R0-R15 same as at entry +*********************************************************************** +* +WrtEndCT DS 0H + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area +* + MVC RptLn,Spaces Initialize report line + PUT REPORT,RptLn Write blank line +* + LA 2,L'RLEndCT-1 Length code of end header line + LA 14,RptLn Destination + LA 15,RLEndCT Source + EX 2,CpyVal Copy to report line +* + PUT REPORT,RptLn Write end trailer +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +*********************************************************************** +* WrtBegHd Write test group begin header +* +* Registers at entry +* R1 --> test parameter list +* +0 --> test group literal; FL1'len-lit',C'literal' +* remainder not referenced +* R11 common area +* R12 base register of caller +* R13 chained save area +* R14 return address +* +* Registers at exit +* R0-R15 same as at entry +*********************************************************************** +* +WrtBegHd DS 0H + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area +* + L 2,0(,1) Address of test literal + SR 3,3 Prepare to get length + IC 3,0(,2) Length of literal + MVC RLBegLit,Spaces Initialize area for literal + LA 14,RLBegLit Destination + LA 15,1(,2) Source + BCTR 3,0 Length code + EX 3,CpyVal Copy literal to buffer +* + MVC RptLn,Spaces Initialize report line + LA 2,L'RLBeg-1 Length code of begin header line + LA 14,RptLn Destination + LA 15,RLBeg Source + EX 2,CpyVal Copy to report line +* + PUT REPORT,RptLn Write begin header +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +*********************************************************************** +* WrtSTot Write number pass, number fail subtotals +* +* Registers at entry +* R1 --> test parameter list +* +0 --> test group literal; FL1'len-lit',C'literal' +* +4 --> word = number of tests that passed +* +8 --> word = number of tests that failed +* R11 common area +* R12 base register of main code +* R13 chained save area +* R14 return address +* +* Registers at exit +* R0-R15 same as at entry +*********************************************************************** +* +WrtSTot DS 0H + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area +* + L 2,0(,1) Address of test literal + SR 3,3 Prepare to get length + IC 3,0(,2) Length of literal + MVC RLTotLit,Spaces Initialize area for literal + LA 14,RLTotLit Destination + LA 15,1(,2) Source + BCTR 3,0 Length code + EX 3,CpyVal Copy literal to work area +* + LM 8,9,4(1) R8 --> number pass subtotal +* R9 --> number fail subtotal + L 0,0(,8) Number of passed tests + CVD 0,DW Convert to decimal + MVC EDWK1,Pat1 Copy edit pattern + ED EDWK1,DW+5 Convert to printable + MVC RLTot#P,EDWK1+1 Copy to work area + L 0,0(,9) Number of failed tests + CVD 0,DW Convert to decimal + MVC EDWK1,Pat1 Copy edit pattern + ED EDWK1,DW+5 Convert to printable + MVC RLTot#F,EDWK1+1 Copy to work area +* + MVC RptLn,Spaces Initialize report line + LA 2,L'RLTot-1 Length code of subtotals line + LA 14,RptLn Destination + LA 15,RLTot Source + EX 2,CpyVal Copy to report line +* + PUT REPORT,RptLn Write subtotals +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +*********************************************************************** +* WrtGTot Write number pass, number fail grand totals +* +* Registers at entry +* R11 common area +* R12 base register of caller +* R13 chained save area +* R14 return address +* +* Registers at exit +* R0-R15 same as at entry +*********************************************************************** +* +WrtGTot DS 0H + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area +* + MVC RLTotLit,Spaces Initialize area for literal + MVC RLTotLit(L'TotLit),TotLit Copy literal +* + L 0,Tot#P Number of passed tests + CVD 0,DW Convert to decimal + MVC EDWK1,Pat1 Copy edit pattern + ED EDWK1,DW+5 Convert to printable + MVC RLTot#P,EDWK1+1 Copy to work area + L 0,Tot#F Number of failed tests + CVD 0,DW Convert to decimal + MVC EDWK1,Pat1 Copy edit pattern + ED EDWK1,DW+5 Convert to printable + MVC RLTot#F,EDWK1+1 Copy to work area +* + MVC RptLn,Spaces Initialize report line + LA 2,L'RLTot-1 Length code of totals line + LA 14,RptLn Destination + LA 15,RLTot Source + EX 2,CpyVal Copy to report line +* + PUT REPORT,RptLn Write grand totals +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +*********************************************************************** +* End internal subroutines for main code +*********************************************************************** +* + LTORG , +* + DROP 12 End main code +* +*********************************************************************** +* Begin internal subroutines for tests done with code +*********************************************************************** +* +* +*********************************************************************** +* Chk1CV: Do one check for character valued built-in function +* +* Registers at entry +* R15 = entry point +* R14 = return address +* R13 --> chained save area +* R1 --> parameter block; DSECT CCVPB +* +* Registers at exit +* R0-R15 same as at entry +*********************************************************************** +* +Chk1CV DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area + LR 12,15 R12 = base register + USING Chk1CV,12 Establish addressability + L 11,=A(COMSTOR) Common storage + USING COMSTOR,11 Overlay common storage +* + LR 10,1 R10 --> parameter block + USING CCVPB,10 Overlay parameter block +* + LM 8,9,CCV#PF@ R8 --> word = number passed tests +* R9 --? word = number failed tests +* + L 14,CCVT#@ S(word = last test number) + L 15,0(,14) Increment + AHI 15,1 test + ST 15,0(,14) count + LR 1,10 R1 --> parameter block + L 15,=A(ChkChVal) Check one pair + BASR 14,15 + LTR 5,15 Values equal? (save rc) + BZ Chk1CV10 Yes; test passed + ST 15,CCVRC No; save return code + L 14,0(,9) Increment + AHI 14,1 number + ST 14,0(,9) failed + B Chk1CV20 Show status +Chk1CV10 DS 0H + L 14,0(,8) Increment + AHI 14,1 number + ST 14,0(,8) passed +Chk1CV20 DS 0H + LR 1,10 A(parameter block) + L 15,=A(BldCVF) Build "f('arg') = 'gval'" + BASR 14,15 + MVC RptLn,Spaces Initialize report line + L 2,CCVBLOA@ A(Length of built output) + L 2,0(,2) Length of built output + BCTR 2,0 Length code + LA 14,RptLn+L'ErrMsg1+1 Destination + L 15,CCVOA Source + EX 2,CpyVal Copy built output to report line + LTR 5,5 Did check fail? + BZ Chk1CV30 No; skip error message + MVC RptLn(L'ErrMsg1),ErrMsg1 Copy error message +Chk1CV30 DS 0H + PUT REPORT,RptLn Write the built data + LTR 5,5 Error occurred? + BZ Chk1CV40 No + LR 1,10 Parameter block + L 15,=A(WrtChVal) Write values with error message + BASR 14,15 +Chk1CV40 DS 0H + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore all registers + BR 14 Return to caller +* + LTORG , +* + POP USING +* +*********************************************************************** +* ChkChVal Check charVal generated result versus actual result +* +* Results of the form +* FL1'len-value',C'>value<' +* Value is delimited by ">" and "<"; value may be null +* +* Examples: FL1'1',C'>''<' value is single apostrophe +* FL1'0',C'><' value is null (empty string) +* +* Registers on entry +* R15 entry point +* R14 return address +* R13 usable save area on chain +* R1 parameter block; DSECT CCVPB +* +* Registers at exit +* R0-R14 as at entry +* R15 return code +* 0 generated value same as actual value +* 8 generated value differs from actual value +*********************************************************************** +* +ChkChVal DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area + LR 12,15 R12 = base register + USING ChkChVal,12 Establish addressability +* + SR 10,10 Initialize return code +* + USING CCVPB,1 Overlay parameter block + L 2,CCVLIT@ R2 --> address of test literal + L 3,CCVT#@ R3 --> word = test number + LM 4,5,CCVGE@ R4 --> generated value +* R5 --> expected value +* + CLC 0(1,4),0(5) Lengths the same? + BNE CCVRC8 No; then values are different + CLI 0(4),0 Lengths are zero? + BE CCVExit Yes; then values are equal + SR 6,6 Prepare to get length + IC 6,0(,4) Length of both values + BCTR 6,0 Length code + EX 6,CCVComp Compare values + BZ CCVExit Equal; done +*NSI B CCVRC8 Not equal +CCVRC8 DS 0H + LA 10,8 Values not equal +*NSI B CCVExit All done +CCVExit DS 0H + LR 15,10 Get return code + L 13,4(,13) Caller's save area + L 14,12(,13) Restore caller's registers + LM 0,12,20(13) ... except R15 + BR 14 Return to caller +* +CCVComp CLC 2(*-*,4),2(5) Compare the values +* + LTORG , +* + POP USING +* +*********************************************************************** +* WrtChVal Write printable hexadecimal values for charVal +* generated result and expected result +* +* Results of the form +* FL1'len-value',C'>value<' +* Character value is delimited by ">" and "<"; value may be null +* +* Examples: FL1'1',C'>''<' value is single apostrophe +* FL1'0',C'><' value is null (empty string) +* +* The printable hexadecimal for the first example above is +* 016E7D4C +* > ' < +* +* Registers on entry +* R15 entry point +* R14 return address +* R13 usable save area on chain +* R1 parameter block; DSECT CCVPB +* +* Registers at exit +* R0-R15 as at entry +*********************************************************************** +* +WrtChVal DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area + LR 12,15 R12 = base register + USING WrtChVal,12 Establish addressability + L 11,=A(COMSTOR) Common storage + USING COMSTOR,11 Overlay storage +* + USING CCVPB,1 Overlay parameter block + L 3,CCVLIT@ R3 --> address of test literal + L 6,CCVT#@ R6 --> word = test number + LM 4,5,CCVGE@ R4 --> generated value +* R5 --> expected value + DROP 1 End parameter block overlay +* + L 6,0(,6) Test number +* + SR 1,1 Prepare to get length + IC 1,0(,3) Length of test group literal + CHI 1,L'WCV1TG Too big? + BNH WCV100 No; use value + LA 1,L'WCV1TG Yes; set to max value +WCV100 DS 0H +* +* Write test group and test number +* + BCTR 1,0 Convert to length code + MVC WCV1TG,Spaces Initialize output area + + LA 14,WCV1TG Destination + LA 15,1(,3) Source + EX 1,CpyVal Copy literal to buffer +* + CVD 6,DW Convert test number to packed dec + MVC WCVEDWk,WCVPAT1 Copy edit pattern + ED WCVEDWk,DW+6 Convert to printable + MVC WCV1T#,WCVEDWk+1 Copy to buffer + MVC RptLn,Spaces Initialize report line + MVC RptLn+L'ErrMsg1+1(L'WCVRL1),WCVRL1 Copy to report line + PUT REPORT,RptLn Write error message 1 +* +* Write generated value in printable hex +* + MVC WCV2L,WCV2LG Copy literal to buffer + MVC WCV2V,Spaces Initialize output area +* + MVC WCVX2PWK,Spaces Initialize work area + SR 1,1 Prepare to get length + IC 1,0(4) Length of generated value + AHI 1,1+2 Account for FL1, >, < + BCTR 1,0 Length code + LA 14,WCVX2PWK Destination + LR 15,4 Source + EX 1,CpyVal Copy to work + AHI 1,1 Back to length + LA 15,WCVX2PWK Source + LA 14,WCV2V Destination +WCVGLp DS 0H + CHI 1,4 At least 4 bytes? + BL WCVGELp No; done + UNPK DW(9),0(5,15) Convert 4 bytes + TR DW,H2P ... to printable hex + MVC 0(8,14),DW Copy to buffer + AHI 1,-4 Decrement length + AHI 15,4 Next 4 source bytes + AHI 14,8 Next destination area + B WCVGLp Do all bytes +WCVGELp DS 0H + LTR 1,1 1-3 bytes left? + BNP WCVGPRT No; write message + UNPK DW(9),0(5,15) Convert 4 bytes + TR DW,H2P ... to printable hex + AR 1,1 Double number of bytes + BCTR 1,0 Length code + LA 15,DW Final source + EX 1,CpyVal Copy to buffer + LA 14,1(1,14) Past end +WCVGPRT DS 0H + LR 2,14 Past end of data + LA 15,WCVRL2 Begin of buffer + SR 2,15 Length of buffer used + BCTR 2,0 Length code + MVC RptLn,Spaces Initialize report line + LA 14,RptLn+L'ErrMsg1+1 Destination + EX 2,CpyVal Copy data to report line + PUT REPORT,RptLn Show hex generated value +* +* Display expected value in printable hex +* + MVC WCV2L,WCV2LE Copy literal to buffer + MVC WCV2V,Spaces Initialize output area +* + MVC WCVX2PWK,Spaces Initialize work area + SR 1,1 Prepare to get length + IC 1,0(5) Length of expected value + AHI 1,1+2 Account for FL1, >, < + BCTR 1,0 Length code + LA 14,WCVX2PWK Destination + LR 15,5 Source + EX 1,CpyVal Copy to work + AHI 1,1 Back to length + LA 15,WCVX2PWK Source + LA 14,WCV2V Destination +WCVELp DS 0H + CHI 1,4 At least 4 bytes? + BL WCVEELp No; done + UNPK DW(9),0(5,15) Convert 4 bytes + TR DW,H2P ... to printable hex + MVC 0(8,14),DW Copy to buffer + AHI 1,-4 Decrement length + AHI 15,4 Next 4 source bytes + AHI 14,8 Next destination area + B WCVELp Do all bytes +WCVEELp DS 0H + LTR 1,1 1-3 bytes left? + BNP WCVEWRT No; write the report line + UNPK DW(9),0(5,15) Convert 4 bytes + TR DW,H2P ... to printable hex + AR 1,1 Double number of bytes + BCTR 1,0 Length code + LA 15,DW Final source + EX 1,CpyVal Copy to buffer + LA 14,1(1,14) Past end +WCVEWRT DS 0H + LR 2,14 Past end of data + LA 15,WCVRL2 Begin of buffer + SR 2,15 Length of buffer used + BCTR 2,0 Length code + MVC RptLn,Spaces Initialize report line + LA 14,RptLn+L'ErrMsg1+1 Destination + EX 2,CpyVal Copy data to report line + PUT REPORT,RptLn Show hex expected value +* +* Exit +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +WCVDW DS D,XL1 Doubleword work and pad +WCVFW DS F,XL1 Fullword work and pad +WCVPat1 DC X'40202120' Edit pattern 3 digits +WCVEDWk DS CL4 Edit work area +* +WCVRL1A DS 0C + DC C'Error for test group' + DC C' ' +WCV1TG DS CL8 + DC C' ' + DC C'test number' + DC C' ' +WCV1T# DS CL3 +WCVRL1B DS 0C +WCVRL1 EQU WCVRL1A,WCVRL1B-WCVRL1A,C'C' +* +WCVRL2A DS 0C +WCV2L DS CL9 + DC C' ' +WCV2V DS CL80 +WCVRL2B DS 0C +WCVRL2 EQU WCVRL2A,WCVRL2B-WCVRL2A,C'C' +* +WCV2LG DC CL(L'WCV2L)'Generated' +WCV2LE DC CL(L'WCV2L)'Expected' +* +WCVX2PWK DS CL40 +* + LTORG , +* + POP USING +* +*********************************************************************** +* BldCVF Build charVal function invocation string +* +* Results of the form +* FL1'len-value',C'>value<' +* Value is delimited by ">" and "<"; value may be null +* +* Examples: FL1'1',C'>''<' value is single apostrophe +* FL1'0',C'><' value is null (empty string) +* +* Registers on entry +* R15 entry point +* R14 return address +* R13 usable save area on chain +* R11 address of common storage +* R1 parameter list +* +0 --> address of test group litersl +* +4 --> word = test number +* +8 --> generated value +* +12 --> expected value +* +16 --> argument value +* +20 --> word = length of output area; max = 256 +* +24 --> output area for printable function and value +* +28 --> word to contain length of built output +* +* Registers at exit +* R0-R15 as at entry +*********************************************************************** +* +BldCVF DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area + LR 12,15 R12 = base register + USING BldCVF,12 Establish addressability + L 11,=a(COMSTOR) Common storage + USING COMSTOR,11 Overlay Common storage +* + USING CCVPB,1 Overlay parameter block +* + LM 6,10,0(1) R6 = address of test group literal +* R7 --> word = test number +* R8 --> generated value +* R9 --> actual value +* R10 --> function argument value + LR 3,6 Test group literal + LR 4,8 Generated value + LR 5,9 Expected value + L 6,0(,7) Test number +* +* Initialize output area +* + L 2,CCVLOA@ R2 --> word = length of output area + L 2,0(,2) R2 = length of output area + CHI 2,L'Spaces More than max length? + BNH BCVF100 No; length okay + LHI 2,L'Spaces Yes; set maximum length +BCVF100 DS 0H + L 7,CCVOA R7 --> output area + BCTR 2,0 Length code + LR 14,7 Destination + LA 15,Spaces Source + EX 2,CpyVal Initialize output area to spaces +* +* Build report line +* 1. Function name +* 2. "('" +* 3. argument value +* 4. "')" +* 5. " = "" +* 6 generated value +* 7. """ +* +* 1. Function name +* + SR 2,2 Prepare to get length + IC 2,0(,3) Len test grp lit (function name) + BCTR 2,0 Convert to length code + LR 14,7 Destination + LA 15,1(,3) Source + EX 2,CpyVal Copy function name to output area + LA 7,1(2,7) Next position +* +* 2. "('" +* + MVC 0(L'BCVFOP,7),BCVFOP Copy open paren and single quote + LA 7,L'BCVFOP(,7) Next position +* +* 3. Function argument +* + SR 2,2 Prepare to get length + IC 2,0(,10) Len function argument value + LTR 2,2 Len might be zero + BZ BCVF200 Skip copy if null argument value + BCTR 2,0 Convert to length code + LR 14,7 Destination + LA 15,2(,10) Source (skip over len, '>' + EX 2,CpyVal Copy function name to report line + LA 7,1(2,7) Next position +BCVF200 DS 0H +* +* 4. "')" +* + MVC 0(L'BCVFCP,7),BCVFCP Copy single quote & close paren + LA 7,L'BCVFCP(,7) Next position +* +* 5. " = "" +* + MVC 0(L'BCVFEQ,7),BCVFEQ Copy equal sign and double quote + LA 7,L'BCVFEQ(,7) Next position +* +* 6. Generated function value +* + SR 2,2 Prepare to get length + IC 2,0(,8) Len generated value + LTR 2,2 Len might be zero + BZ BCVF300 Skip copy if null argument value + BCTR 2,0 Convert to length code + LR 14,7 Destination + LA 15,2(,4) Source + EX 2,CpyVal Copy function name to output area + LA 7,1(2,7) Next position +BCVF300 DS 0H +* +* 7. """ +* + MVI 0(7),C'"' Closing double quote + LA 7,1(,7) Next position +* + L 15,CCVBLOA@ A(word for built length) + S 7,CCVOA Built length + ST 7,0(,15) Return built length +* + DROP 1 Done with parameter list +* +* Exit +* + L 13,4(,13) Caller's save area + LM 14,12,12(13) Restore caller's registers + BR 14 Return to caller +* +BCVFOP DC C'(''' Open paren and single quote +BCVFCP DC C''')' Single quote and close paren +BCVFEQ DC C' = "' Equal sign, double quote +* + LTORG , +* + POP USING +* +* +*********************************************************************** +* End internal subroutines for tests done with code +*********************************************************************** +* +* +*********************************************************************** +* Common storage +*********************************************************************** +* +COMSTOR DS 0D + DC CL8'COMSTOR' Eyecatcher +* +* Tables for tests that are done using code +* + DS 0D +* +* Header for test headers +* +TestsH DC A(T01H,8,TNH,0) 1st, len 1, last, unused +* +T01H DS 0D + DC A(T01P,T01@) Parm list, address of test code + DC A(T02P,T02@) + DC A(T03P,T03@) +*********************************************************************** +* Put new entries above this line +*********************************************************************** +TNH EQU *-8 +* +* DCVAL tests +* +T01P DS 0D Parameter list for test + DC A(T01L) Test Literal + DC A(T01#P) Number of tests that pass + DC A(T01#F) Number of tests that fail +* +T01L DC AL1(L'T01LV) Test literal +T01LV DC C'DCVAL' +T01#P DC F'0' Number of tests that pass +T01#F DC F'0' Number of tests that fail +* +T01@ DC A(TDCVAL) Address of test code +* +* DEQUOTE tests +* +T02P DS 0D Parameter list for test + DC A(T02L) Test Literal + DC A(T02#P) Number of tests that pass + DC A(T02#F) Number of tests that fail +* +T02L DC AL1(L'T02LV) +T02LV DC C'DEQUOTE' +T02#P DC F'0' Number of tests that pass +T02#F DC F'0' Number of tests that fail +* +T02@ DC A(TDEQUOTE) +* +* DOUBLE tests +* +T03P DS 0D Parameter list for test + DC A(T03L) Test Literal + DC A(T03#P) Number of tests that pass + DC A(T03#F) Number of tests that fail +* +T03L DC AL1(L'T03LV) +T03LV DC C'DOUBLE' +T03#P DC F'0' Number of tests that pass +T03#F DC F'0' Number of tests that fail +* +T03@ DC A(TDOUBLE) +* +*********************************************************************** +* End test data +*********************************************************************** +* +Tot#P DC F'0' Total number of tests that pass +Tot#F DC F'0' Total number of tests that fail +* +MaxRC DC F'0' Maximum return code +* +Spaces DC CL(RptLnLen)' ' Line of spaces +* +DW DS D,XL1 Doubleword work and pad +Pat1 DC X'402020202120' Edit pattern +EDWK1 DS CL(L'Pat1) Edit work area +* +* Error messages +* +ErrMsg1 DC C'*** Fail ***' Error message; test failed +* +* Report DCB and records +* +RptLnLen EQU 120 Length of report line +* +REPORT DCB DDNAME=REPORT,DSORG=PS,RECFM=FT,LRECL=120,MACRF=PM +* +RptLn DS CL(RptLnLen) Report line +* +TotLit DC C'Totals' Literal for totals +* +RLBegCTA DS 0C + DC C'*************** ' + DC C'Begin TOPR2 code tests ' + DC C'***************' +RLBegCTB DS 0C +RLBegCT EQU RLBegCTA,RLBegCTB-RLBegCTA,C'C' +* +RLEndCTA DS 0C + DC C'*************** ' + DC C'End TOPR2 code tests ' + DC C'***************' +RLEndCTB DS 0C +RLEndCT EQU RLEndCTA,RLEndCTB-RLEndCTA,C'C' +* +RLBegA DS 0C +RLBegLit DS CL8 + DC CL1' ' + DC C'tests: ' + DC C'Begin' +RLBegB DS 0C +RLBeg EQU RLBegA,RLBegB-RLBegA,C'C' +* +RLTotA DS 0C +RLTotLit DS CL8 + DC CL1' ' + DC C'tests: ' + DC C'number pass ' + +RLTot#P DS CL5 + DC CL2' ' + DC C'number fail ' +RLTot#F DS CL5 +RLTotB DS 0C +RLTot EQU RLTotA,RLTotB-RLTotA,C'C' +* +* Executed instructions +* +CpyVal MVC 0(*-*,14),0(15) Copy value +* +*********************************************************************** +* HLASM LR uses bold n to represent X'00', bold f for X'FF' +*********************************************************************** +* +T00FF2nf DC 256AL1(*-T00FF2nf) Translate X'00' to n, X'FF' to f + ORG T00FF2nf+0 + DC C'n' + ORG T00FF2nf+X'FF' + DC C'f' + ORG , +* +H2P EQU *-240 Hex to printable hex + DC C'0123456789ABCDEF' + DS 0D End on doubleword +COMSTORL EQU *-COMSTOR Length of common storage area +* +* +*********************************************************************** +* End of main code and storage. +*********************************************************************** +* +* +*********************************************************************** +*********************************************************************** +* Begin code tests +*********************************************************************** +*********************************************************************** +* +* +*********************************************************************** +* Begin DCVAL tests +*********************************************************************** +* +* +*********************************************************************** +* The DCVAL tests use ampersands and apostrophes. The original +* z390 test source rt/test/TESTOPR1.MLC uses MNOTE and AIF +* to show and verify DCVAL results. The test +* &DCVSTR SETC '''''&&&&1''''' +* &DCVAL SETC (DCVAL('&DCVSTR')) +* MNOTE 'DCVAL(&DCVSTR)=&DCVAL' +* AIF ('&DCVAL' NE '''&&1''').DCVERR RPI 1080 +* when run using HLASM generates +* ** ASMA163W Operand not properly enclosed in quotes +* when processing the MNOTE while z390 does not generate +* an error. +* +* The new tests use DC statements of the form +* &C SETC DCVAL('testString') +* &DC SETC DOUBLE('&C') +* &K SETA K'&C +* DC FL1'&K',C'>&DC<' +* The &K value is the actual length of the DCVAL result. +* The &DC value is the DCVAL result with doubled +* ampersands and apostrophes, making the value +* suitable for using in the generated DC statement +* shown above. (The enclosing ">", "<" avoid an assembly +* error when &C is the null (empty) string.) +* +* Code validates that the generated value is the expected +* value, which appears in a separate similar DC statement. +* For example, +* &NDX SETA &NDX+1 current test +* B DCVX&NDX branch to code +* &C SETC DCVAL('''') should be one apostrophe +* &DC SETC DOUBLE('&C') double the value +* &K SETA K'&C should be 1 +* DCVA&NDX DC FL1'2',C'>''''<' function argument value +* DCVG&NDX DC FL1'&K',C'>&DC<' generated value +* DCVE&NDX DC FL'1',C'>''<' expected value +* * X'016E7D4C' +* * --==-- +* * > ' < +* DCVX&NDX DS 0H +* LA 1,DCVG&NDX generated value +* LA 2,DCVE&NDX expected value +* LA 3,DCVA&NDX function argument value +* STM 1,3,CCVGEF@ put in parameter block +* LR 1,10 parameter block +* L 15,=A(Chk1CV) generated : actual +* BASR 14,15 perform test +* +* The original DCVAL tests that use the MNOTE and AIF +* tests are left in TESTOPR2 but branched around via AGO. +********************************************************************** +* +* +*********************************************************************** +* TDCVAL Test DCVAL +* +* Registers at entry: +* R15 entry point +* R14 return address +* R13 current chained save area +* R1 --> literal for test group; FL1'len-lit',C'lit' +* R1 --> parameter list +* +0 --> literal for test group; FL1'len-lit',C'lit' +* +4 --> word for number of tests that pass +* +8 --> word for number of tests that fail +* R11 --> common storage +* +* Registers at exit: +* R0--R14 as at entry +* R15 return code +* 0 all tests passed +* 8 at least one test failed +*********************************************************************** +TDCVAL DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area on chain + LR 12,15 R12 = base register + USING TDCVAL,12 Establish addressability + L 11,=A(COMSTOR) Common storage area + USING COMSTOR,11 Overlay common storage +* + XC DCVPB,DCVPB Initialize parameter block storage + LA 10,DCVPB R10 --> parameter block + USING CCVPB,10 Overlay parameter block +* + L 0,0(,1) A(literal for test) +* + ST 0,CCVLIT@ Put in parameter block + LA 2,DCVT# Word = test number + ST 2,CCVT#@ Put in parameter block + LA 2,DCVLOA Word = length of output area + ST 2,CCVLOA@ Put in parameter block + LA 2,DCVOA Output area + ST 2,CCVOA Put in parameter block + LA 2,DCVBLOA Word to contain built output length + ST 2,CCVBLOA@ Put in parameter block +* + LM 8,9,4(1) R8 --> word = subtotal num pass +* R9 --> word = subtotal num fail + STM 8,9,CCV#PF@ Put in parameter block +* + SR 15,15 Initialize values to zero + ST 15,0(,8) Number tests passed + ST 15,0(,9) Number tests failed + ST 15,DCVT# Current test number +* +&NDX SETA 0 Test case +* +& SETC '&&'(1,1) LR p341; one ampersand +* +*---------------------------------------------------------------------- +* HLASM LR examples +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('') value is "" (null string) +&C SETC DCVAL('') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DCVA&NDX DC FL1'0',C'><' Function argument value +DCVG&NDX DC FL1'&K',C'>&DC<' Generated value +DCVE&NDX DC FL1'0',C'><' Expected value +DCVX&NDX DS 0H + LA 1,DCVG&NDX A(generated value) + LA 2,DCVE&NDX A(expected value) + LA 3,DCVA&NDX A(function argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('''') value is "'" (single apostrophe) +&C SETC DCVAL('''') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DCVA&NDX DC FL1'2',C'>''''<' Argument value +DCVG&NDX DC FL1'&K',C'>&DC<' Generated value +DCVE&NDX DC FL1'1',C'>''''<' Expected value +DCVX&NDX DS 0H + LA 1,DCVG&NDX + LA 2,DCVE&NDX + LA 3,DCVA&NDX + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('&&') value is "&" (single ampersand) +&C SETC DCVAL('&&') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DCVA&NDX DC FL1'2',C'>&&&&<' Argument value +DCVG&NDX DC FL1'&K',C'>&DC<' Generated value +DCVE&NDX DC FL1'1',C'>&&<' Expected value +DCVX&NDX DS 0H + LA 1,DCVG&NDX + LA 2,DCVE&NDX + LA 3,DCVA&NDX + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('a''''b') value is "a'b" +&C SETC DCVAL('a''''b') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DCVA&NDX DC FL1'6',C'>a''''''''b<' +DCVG&NDX DC FL1'&K',C'>&DC<' +DCVE&NDX DC FL1'3',C'>a''b<' +DCVX&NDX DS 0H + LA 1,DCVG&NDX + LA 2,DCVE&NDX + LA 3,DCVA&NDX + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('a''''b&&c') value is "a'b&c" +&C SETC DCVAL('a''''b&&c') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DCVA&NDX DC FL1'9',C'>a''''''''b&&&&c<' +DCVG&NDX DC FL1'&K',C'>&DC<' +DCVE&NDX DC FL1'5',C'>a''b&&c<' +DCVX&NDX DS 0H + LA 1,DCVG&NDX + LA 2,DCVE&NDX + LA 3,DCVA&NDX + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +* Preset &C to "&&&&''''" (4 ampersands and 4 apostrophes) +&C SETC '&'.'&'.'&'.'&'.'''''''''' (4 & 4 ') +* +*&DC SETC DOUBLE('&C') +*&K SETA K'&C +* DC FL1'&K',C'>&DC<' +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('&C') value is "&&''" (2 of each) +&X SETC DCVAL('&C') +&DX SETC DOUBLE('&X') +&K SETA K'&X +DCVA&NDX DC FL1'8',C'>&&&&&&&&''''''''<' +DCVG&NDX DC FL1'&K',C'>&DX<' +DCVE&NDX DC FL1'4',C'>&&&&''''<' +DCVX&NDX DS 0H + LA 1,DCVG&NDX + LA 2,DCVE&NDX + LA 3,DCVA&NDX + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +*---------------------------------------------------------------------- +* z390 tests +* +* Preset &C to "''&&1''" (4 ', 2 &, digit 1; len 7) +&C SETC '''''&&&&1''''' string "''&&1''" len 7 +* +&NDX SETA &NDX+1 Current test + B DCVX&NDX Branch around test +* +* SETC DCVAL('&C') value is "'&&1'" len 5 +&X SETC DCVAL('&C') +&DX SETC DOUBLE('&X') +&K SETA K'&X +DCVA&NDX DC FL1'7',C'>''''&&&&1''''<' +DCVG&NDX DC FL1'&K',C'>&DX<' +DCVE&NDX DC FL1'5',C'>''&&&&1''<' +DCVX&NDX DS 0H + LA 1,DCVG&NDX + LA 2,DCVE&NDX + LA 3,DCVA&NDX + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +DCVExit DS 0H + L 15,CCVRC Get return code from parm block + L 13,4(,13) Caller's save area + L 14,12(,13) Restore caller's registers + LM 0,12,20(13) ... except R15 + BR 14 Return to caller +* + LTORG , +* + DS 0D +DCVPB DS XL(CCVPBLEN) Parameter block storage +* +DCVT# DC F'0' Test number +DCVLOA DC A(L'DCVOA) Length of output area +DCVBLOA DC F'0' Length of built output +DCVOA DS CL80 Output area +* + POP USING +* +* +*********************************************************************** +* End DCVAL tests +*********************************************************************** +* +* +*********************************************************************** +* Begin DEQUOTE tests +*********************************************************************** +* +* +*********************************************************************** +* The DEQUOTE tests use ampersands and apostrophes. The same +* reasons listed in the DCVAL tests apply here. Similar +* processing is done. Read the details in the TDCVAL section. +* +* The original DEQUOTE tests in TESTOPR2 are left in but +* branched around via AGO. +*********************************************************************** +* +* +*********************************************************************** +* TDEQUOTE Test DEQUOTE +* +* Registers at entry: +* R15 entry point +* R14 return address +* R13 current chained save area +* R1 --> parameter list +* +0 --> literal for test group; FL1'len-;it',C'lit' +* +4 --> word for number of tests that pass +* +8 --> word for number of tests that fail +* R11 --> common storage +* +* Registers at exit: +* R0--R14 as at entry +* R15 return code +* 0 all tests passed +* 8 at least one test failed +*********************************************************************** +* +TDEQUOTE DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area on chain + LR 12,15 R12 = base register + USING TDEQUOTE,12 Establish addressability + L 11,=A(COMSTOR) Common storage area + USING COMSTOR,11 Overlay common storage +* + XC DEQPB,DEQPB Initialize parameter block storage + LA 10,DEQPB R10 --> parameter block + USING CCVPB,10 Overlay parameter block +* + L 0,0(,1) A(literal for test) + ST 0,CCVLIT@ Put in parameter block + LA 2,DEQT# Word = test number + ST 2,CCVT#@ Put in parameter block + LA 2,DEQLOA Word = length of output area + ST 2,CCVLOA@ Put in parameter block + LA 2,DEQOA Output area + ST 2,CCVOA Put in parameter block + LA 2,DEQBLOA Word to contain built output length + ST 2,CCVBLOA@ Put in parameter block +* + LM 8,9,4(1) R8 --> word = subtotal num pass +* R9 --> word = subtotal num fail + STM 8,9,CCV#PF@ Put in parameter block +* + SR 15,15 Initialize values to zero + ST 15,0(,8) Number tests passed + ST 15,0(,9) Number tests failed + ST 15,DEQT# Current test number +* +&NDX SETA 0 Test case +* +& SETC '&&'(1,1) LR p341; one ampersand +* +*---------------------------------------------------------------------- +* HLASM LR examples +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +* SETC DEQUOTE('charstring') value is "charstring" +&C SETC DEQUOTE('charstring') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'10',C'>charstring<' Argument value +DEQG&NDX DC FL1'&K',C'>&C< ' Generated value +DEQE&NDX DC FL1'10',C'>charstring<' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +* SETC DEQUOTE('') value is "" +&C SETC DEQUOTE('') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'0',C'><' Argument value +DEQG&NDX DC FL1'&K',C'>&C< ' Generated value +DEQE&NDX DC FL1'0',C'><' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +* SETC DEQUOTE('a') value is "a" +&C SETC DEQUOTE('a') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'1',C'>a<' Argument value +DEQG&NDX DC FL1'&K',C'>&C< ' Generated value +DEQE&NDX DC FL1'1',C'>a<' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +&ARG SETC '''a''' +*&ARG SETC '''a''' &ARG is "'a'" +* SETC DEQUOTE('&ARG') value is "a" +&C SETC DEQUOTE('&ARG') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'3',C'>''a''<' Argument value +DEQG&NDX DC FL1'&K',C'>&C< ' Generated value +DEQE&NDX DC FL1'1',C'>a<' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +* SETC DEQUOTE('a''b') value is "a'b" +&C SETC DEQUOTE('a''b') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'4',C'>a''''b<' Argument value +DEQG&NDX DC FL1'&K',C'>&DC< ' Generated value +DEQE&NDX DC FL1'3',C'>a''b<' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +&ARG SETC '''''' +*&ARG SETC '''''' &ARG is "''" +* SETC DEQUOTE('&ARG') value is "" +&C SETC DEQUOTE('&ARG') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'2',C'>''''<' Argument value +DEQG&NDX DC FL1'&K',C'>&C< ' Generated value +DEQE&NDX DC FL1'0',C'><' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +*---------------------------------------------------------------------- +* z390 tests +* +&NDX SETA &NDX+1 Current test + B DEQX&NDX Branch around test +* +&ARG SETC '''ABC''' +*&ARG SETC '''ABC''' &ARG is "'ABC'" +* SETC DEQUOTE('&ARG') value is "ABC" +&C SETC DEQUOTE('&ARG') +&DC SETC DOUBLE('&C') +&K SETA K'&C +DEQA&NDX DC FL1'5',C'>''ABC''<' Argument value +DEQG&NDX DC FL1'&K',C'>&C< ' Generated value +DEQE&NDX DC FL1'3',C'>ABC<' Expected value +DEQX&NDX DS 0H + LA 1,DEQG&NDX A(generated value) + LA 2,DEQE&NDX A(expected value) + LA 3,DEQA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +DEQExit DS 0H + L 15,CCVRC Get return code from parameter block + L 13,4(,13) Caller's save area + L 14,12(,13) Restore caller's registers + LM 0,12,20(13) ... except R15 + BR 14 Return to caller +* + LTORG , +* + DS 0D +DEQPB DS XL(CCVPBLEN) Parameter block storage +* +DEQT# DC F'0' Test number +DEQLOA DC A(L'DEQOA) Length of output area +DEQBLOA DC F'0' Length of built output +DEQOA DS CL80 Output area +* + POP USING +* +* +*********************************************************************** +* End DEQUOTE tests +*********************************************************************** +* +* +*********************************************************************** +* Begin DOUBLE tests +*********************************************************************** +* +* +*********************************************************************** +* TDOUBLE Test DOUBLE +* +* Registers at entry: +* R15 entry point +* R14 return address +* R13 current chained save area +* R1 --> parameter list +* +0 --> literal for test group; FL1'len-;it',C'lit' +* +4 --> word for number of tests that pass +* +8 --> word for number of tests that fail +* R11 --> common storage +* +* Registers at exit: +* R0--R14 as at entry +* R15 return code +* 0 all tests passed +* 8 at least one test failed +*********************************************************************** +* +TDOUBLE DS 0H + PUSH USING + STM 14,12,12(13) Save caller's registers + L 13,8(,13) Next save area on chain + LR 12,15 R12 = base register + USING TDOUBLE,12 Establish addressability + L 11,=A(COMSTOR) Common storage area + USING COMSTOR,11 Overlay common storage +* + XC DOUPB,DOUPB Initialize parameter block storage + LA 10,DOUPB R10 --> parameter block + USING CCVPB,10 Overlay parameter block +* + L 0,0(,1) A(literal for test) +* + ST 0,CCVLIT@ Put in parameter block + LA 2,DOUT# Word = test number + ST 2,CCVT#@ Put in parameter block + LA 2,DOULOA Word = length of output area + ST 2,CCVLOA@ Put in parameter block + LA 2,DOUOA Output area + ST 2,CCVOA Put in parameter block + LA 2,DOUBLOA Word to contain built output length + ST 2,CCVBLOA@ Put in parameter block +* + LM 8,9,4(1) R8 --> word = subtotal num pass +* R9 --> word = subtotal num fail + STM 8,9,CCV#PF@ Put in parameter block +* + SR 15,15 Initialize values to zero + ST 15,0(,8) Number tests passed + ST 15,0(,9) Number tests failed + ST 15,DOUT# Current test number +* +&NDX SETA 0 Test case +* +& SETC '&&'(1,1) LR p341; one ampersand +* +*---------------------------------------------------------------------- +* HLASM LR examples +* +&NDX SETA &NDX+1 Current test + B DOUX&NDX Branch around test +* +* Preset &C +&C SETC '&'.'&'.''''''.'&' LR p331 "&&''&"; (2 ', 3 &) +* +* &C contains "&&''&" (2 apostrophes, 3 ampersands) +* SETC DOUBLE('&C') +&DC SETC DOUBLE('&C') +&DDC SETC DOUBLE('&DC') +&K SETA K'&DC +DOUA&NDX DC FL1'5',C'>&&&&''''&&<' +DOUG&NDX DC FL1'&K',C'>&DDC<' +DOUE&NDX DC FL1'10',C'>&&&&&&&&''''''''&&&&<' +DOUX&NDX DS 0H + LA 1,DOUG&NDX A(generated value) + LA 2,DOUE&NDX A(expected value) + LA 3,DOUA&NDX A(argument value) + STM 1,3,CCVGEF@ Put in parameter block + LR 1,10 R1 --> parameter block + L 15,=A(Chk1CV) Test routine + BASR 14,15 Perform test +* +*---------------------------------------------------------------------- +* z390 tests +* +* No z390 tests +* +DOUExit DS 0H + L 15,CCVRC Get return code from parameter block + L 13,4(,13) Caller's save area + L 14,12(,13) Restore caller's registers + LM 0,12,20(13) ... except R15 + BR 14 Return to caller +* + LTORG , +* + DS 0D +DOUPB DS XL(CCVPBLEN) Parameter block storage +* +DOUT# DC F'0' Test number +DOULOA DC A(L'DOUOA) Length of output area +DOUBLOA DC F'0' Length of built output +DOUOA DS CL80 Output area +* + POP USING +* +* +*********************************************************************** +* End DOUBLE tests +*********************************************************************** +* +* +*********************************************************************** +*********************************************************************** +* End code tests +*********************************************************************** +*********************************************************************** +* + TITLE 'DSECTs' +*********************************************************************** +* Parameter block for ChkChVal and subroutines +*********************************************************************** +* +CCVPB DSECT +CCVLIT@ DS A Test group literal +CCVT#@ DS A A(word = test number) +CCVGEF@ DS 0AL12 A(gen,expected,argument values) +CCVGE@ DS 0AL8 A(generated,expected values) +CCVGV DS A A(generated value) +CCVEV DS A A(expected value) +CCVFAV DS A A(function argument value) +CCVLOA@ DS A A(word = length output area) +CCVOA DS A A(output area) +CCVBLOA@ DS A A(word = built output length) +CCVRC DS F Return code from failed test(s); +* Zero if all tests passed +CCV#PF@ DS 0AL8 A(num pass, num fail tests) +CCV#P@ DS A A(word = number of passed tests) +CCV#F@ DS A A(word = number of failed tests) +CCVPBLEN EQU *-CCVPB Length of parameter block +* + END diff --git a/rt/test/TESTOPR2.MLC b/rt/test/TESTOPR2.MLC new file mode 100644 index 000000000..727572aac --- /dev/null +++ b/rt/test/TESTOPR2.MLC @@ -0,0 +1,1410 @@ +*********************************************************************** +* z390 - Mainframe assembler emulator and run-time engine +* Copyright (C) 2021 z390 Assembler LLC +* +* This file is part of z390. +* +* z390 is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* z390 is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program; if not, see https://www.gnu.org/licenses. +*********************************************************************** +* 2024-07-25 #509 New program +*********************************************************************** +* +* +*********************************************************************** +* TESTOPR2 modelled on original rt/test/TESTOPR1.MLC +*********************************************************************** +* +* Generate a box with border character and containing 'text' +* +* MBOX 'Hello World',BORDER=$ gemerates +* +* $$$$$$$$$$$$$$$$$$$$$$$ +* $$$ Hello World $$$ +* $$$$$$$$$$$$$$$$$$$$$$$ +* + MACRO + MBOX &TEXT,&BORDER=* + LCLA &I,&N + LCLC &L,&R,&M,&S,&T + AIF (K'&TEXT LT 3).EXIT No box if no text +&S SETC '*' Default border character + AIF (K'&BORDER EQ 0).BOK +&S SETC '&BORDER'(1,1) Get supplied border character +.BOK ANOP +&M SETC '&TEXT'(2,K'&TEXT-2) Extract message from 'text' +&L SETC '&S'.'&S'.'&S'.' ' ' Left side and pad +&R SETC ' '.'&S'.'&S'.'&S' Pad and right side +&I SETA 1 +&N SETA K'&L+k'&M+K'&R Width of box (height is 3) +&T SETC '' +.L1 ANOP Build top and bottom border + AIF (&I GT &N).EL1 +&T SETC '&T'.'&S' +&I SETA &I+1 + AGO .L1 +.EL1 ANOP +.* Display the box + MNOTE '&T' + MNOTE '&L.&M.&R' + MNOTE '&T' + AGO .EXIT +.EXIT ANOP + MEND +* +* Variables used by most of the tests +* + LCLC & + LCLC &C,&DC,&X,&DX + LCLA &K + LCLA &NDX +* +*********************************************************************** +* TESTOPR2 is modelled on the previous TESTOPR1 test program to test +* the HLASM built-in functions. TESTOPR1 tests a built-in function +* as follows: +* 1. Invoke the built-in function +* 2. Use MNOTE to display the result +* 3. Check the result using AIF, branching to an error MNOTE +* if the generated value is not the expected value. +* For example, the TESTOPR1 test for the X2C built-in function is +* +* &X2C SETC (X2C('F1')) +* MNOTE 'X2C(''F1'')=&X2C' +* AIF ('&X2C'(4,1) NE '1').X2ERR +* ... +* .X2ERR MNOTE 12,'X2 OPERATOR ERROR' +* AGO .EXIT +* ... +* +* Note that if a test fails, all remaining tests are skipped. In +* addition, the assembly of TESTOPR2 fails, so neither the link +* nor the execution is done. +* +*---------------------------------------------------------------------- +* +* TESTOPR2 also uses this technique. However, some tests have been +* moved to a new test program, rt/mlc/TOPR2.MLC, which does its +* tests using assembler code and DC statements to invoke and +* verify results. In addition, the HLASM Language Reference examples +* for each built-in function are added as TESTOPR2 tests (there are +* a few exceptions). Where code tests in TOPR2 completely replace +* the corresponding MNOTE.AIF tests, the original tests are +* left in but branched around via AGO. +* +*---------------------------------------------------------------------- +* +* Registers on entry: +* R15 entry point +* R14 return address +* R13 usable save area +* +* Registers on exit: +* R0 -- R14 as at entry +* R15 return code +* 0 always +* +* Note: Since all tests are done via MNOTE and AIF, if a test fails +* then the assembly fails due to an error MNOTE. Therefore, +* if the assembly succeeds, all tests have succeeded. +* +*********************************************************************** +* +TESTOPR2 CSECT + STM 14,12,12(13) Save caller's registers + LR 12,15 R12 = base register + USING TESTOPR2,12 Establish addressability +* + WTO 'TESTOPR2 Test HLASM built-in functions via MNOTE,AIF' +* + SR 15,15 Set return code + RETURN (14,12),RC=(15) Restore R14, R0-R12; return +* + LTORG +* +*********************************************************************** +* SYM equate used for SYSATTRA, SYSATTRP tests +* +* RETURN macro in main code used in operator type O tests +*********************************************************************** +* +SYM EQU 1,2,C'3',C'PGMA',gr32 +* +*SYM EQU val,len attr val, type attr val, pgm type val, asm type val +* +.LOOP ANOP +&PASS SETA &PASS+1 + AIF (&PASS GE 2).ENDLOOP + MNOTE 'TESTOPR1 Pass &PASS' +*********************************************************************** + MBOX 'Test UPPER and LOWER' +*AGO .SKPUL +&MC SETC 'aBcDeFg' +&LC SETC 'abc' + AIF ('&LC' NE 'abc').LCERR +&LC SETC '&MC' + AIF ('&LC' NE 'aBcDeFg').LCERR +*&UC SETC (UPPER '&LC') +&UC SETC (UPPER '&LC') + AIF ('&UC' NE 'ABCDEFG').UCERR +&UC SETC 'ABC' + AIF ('&UC' NE 'ABC').UCERR +&UC SETC '&MC' + AIF ('&UC' NE 'aBcDeFg').UCERR +*&LC SETC (LOWER '&UC') +&LC SETC (LOWER '&UC') + AIF ('&LC' NE 'abcdefg').LCERR +.SKPUL ANOP +*********************************************************************** + MBOX 'Test ?2? functions' +*AGO .SKPX2Y +*====================================================================== + MNOTE '********** Begin A2B tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&A2B SETC A2B(0) + MNOTE 'A2B(0)=&A2B' + AIF ('&A2B' NE '00000000000000000000000000000000').A2ERR +&A2B SETC A2B(5) + MNOTE 'A2B(5)=&A2B' + AIF ('&A2B' NE '00000000000000000000000000000101').A2ERR +&A2B SETC A2B(1022) + MNOTE 'A2B(1022)=&A2B' + AIF ('&A2B' NE '00000000000000000000001111111110').A2ERR +&A2B SETC A2B(-7) + MNOTE 'A2B(-7)=&A2B' + AIF ('&A2B' NE '11111111111111111111111111111001').A2ERR +* Put next (error) test in separate test #999 +*&A2B SETC A2B(2345678901) error; too large +* MNOTE 'A2B(2345678901)=&A2B' +** ASMA037E Illegal self-defining value - 2345678901) + +*---------------------------------------------------------------------- +* z390 tests + +&A2B SETC A2B(4) + MNOTE 'A2B(4)=&A2B' + AIF ('&A2B' NE '00000000000000000000000000000100').A2ERR +&A2B SETC A2B(-4) + MNOTE 'A2B(-4)=&A2B' + AIF ('&A2B' NE '11111111111111111111111111111100').A2ERR +*---------------------------------------------------------------------- + MNOTE '********** End A2B tests **********' +*====================================================================== + MNOTE '********** Begin A2C tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&A2C SETC A2C(0) + MNOTE 'A2C(0)=>&A2C<' + AIF (K'&A2C NE 4).A2ERR + DC C'&A2C' X'00000000' +&A2C SETC A2C(241) + MNOTE 'A2C(241)=>&A2C<' + AIF ('&A2C'(4,1) NE '1').A2ERR + DC C'&A2C' X'000000',C'1' +&A2C SETC A2C(20046) + MNOTE 'A2C(20056)=>&A2C<' + AIF ('&A2C'(3,2) NE '++').A2ERR + DC C'&A2C' X'0000',C'++' +&A2C SETC A2C(-252645136) + MNOTE 'A2C(-252645136)=>&A2C<' + AIF ('&A2C' NE '0000').A2ERR +*---------------------------------------------------------------------- + MNOTE '********** End A2C tests **********' +*====================================================================== + MNOTE '********** Begin A2D tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&A2D SETC A2D(0) + MNOTE 'A2D(0)=>&A2D<' + AIF ('&A2D' NE '+0').A2ERR +&A2D SETC A2D(241) + MNOTE 'A2D(241)=>&A2D<' + AIF ('&A2D' NE '+241').A2ERR +&A2D SETC A2D(16448) + MNOTE 'A2D(16448)=>&A2D<' + AIF ('&A2D' NE '+16448').A2ERR +&A2D SETC A2D(-3) + MNOTE 'A2D(-3)=>&A2D<' + AIF ('&A2D' NE '-3').A2ERR +*---------------------------------------------------------------------- +* z390 tests +* +&A2D SETC A2D(-241) + MNOTE 'A2D(-241)=>&A2D<' + AIF ('&A2D' NE '-241').A2ERR +*---------------------------------------------------------------------- + MNOTE '********** End A2D tests **********' +*====================================================================== + MNOTE '********** Begin A2X tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&A2X SETC A2X(0) + MNOTE 'A2X(0)=>&A2X<' + AIF ('&A2X' NE '00000000').A2ERR +&A2X SETC A2X(10) + MNOTE 'A2X(10)=>&A2X<' + AIF ('&A2X' NE '0000000A').A2ERR +&A2X SETC A2X(257) + MNOTE 'A2X(257)=>&A2X<' + AIF ('&A2X' NE '00000101').A2ERR +&A2X SETC A2X(1022) + MNOTE 'A2X(1022)=>&A2X<' + AIF ('&A2X' NE '000003FE').A2ERR +&A2X SETC A2X(-7) + MNOTE 'A2X(-7)=>&A2X<' + AIF ('&A2X' NE 'FFFFFFF9').A2ERR +*---------------------------------------------------------------------- +* z390 tests + +&A2X SETC A2X(241) + MNOTE 'A2X(241)=>&A2X<' + AIF ('&A2X' NE '000000F1').A2ERR +&A2X SETC A2X(-241) + MNOTE 'A2X(-241)=>&A2X<' + AIF ('&A2X' NE 'FFFFFF0F').A2ERR +*---------------------------------------------------------------------- + MNOTE '********** End A2X tests **********' +*====================================================================== + MNOTE '********** Begin B2A tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&B2A SETA B2A('') + MNOTE 'B2A('''')=&B2A' + AIF (&B2A NE 0).B2ERR +&B2A SETA B2A('0000000101') + MNOTE 'B2A(''0000000101'')=&B2A' + AIF (&B2A NE 5).B2ERR +&B2A SETA B2A('11111111111111111111111111111110') +&SB2A SETC SIGNED(&B2A) + MNOTE 'B2A(''11111111111111111111111111111110'')=&SB2A' + AIF (&B2A NE -2).B2ERR + AIF ('&SB2A' NE '-2').B2ERR +*---------------------------------------------------------------------- +* z390 tests + +&B2A SETA B2A('100') + MNOTE 'B2A(''100'')=&B2A' + AIF (&B2A NE 4).B2ERR +*---------------------------------------------------------------------- + MNOTE '********** End B2A tests **********' +*====================================================================== + MNOTE '********** Begin B2C tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&B2C SETC B2C('11110011') + MNOTE 'B2C(''11110011'')=&B2C' + AIF ('&B2C' NE '3').B2ERR +&B2C SETC B2C('101110011110001') + MNOTE 'B2C(''101110011110001'')=&B2C' + AIF ('&B2C' NE '*1').B2ERR +&B2C SETC B2C('0') EBCDIC null character + MNOTE 'B2C(''0'')=>&B2C<' + AIF (K'&B2C NE 1).B2ERR + DC C'&B2C' value X'00' +&B2C SETC B2C('00010010001') + MNOTE 'B2C(''00010010001'')=&B2C' + AIF (K'&B2C NE 2).B2ERR + AIF ('&B2C'(2,1) NE 'j').B2ERR + DC C'&B2C' value X'00',C'j' +&B2C SETC B2C('000000000') two EBCDIC nulls + MNOTE 'B2C(''000000000'')=&B2C' + AIF (K'&B2C NE 2).B2ERR + DC C'&B2C' value X'0000' +&B2C SETC B2C('') null string + MNOTE 'B2C('''')=>&B2C<' null string + AIF (K'&B2C NE 0).B2ERR +*---------------------------------------------------------------------- + MNOTE '********** End B2C tests **********' +*====================================================================== + MNOTE '********** Begin B2D tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&B2D SETC B2D('') + MNOTE 'B2D('''')=&B2D' + AIF ('&B2D' NE '+0').B2ERR +&B2D SETC B2D('00010010001') + MNOTE 'B2D(''00010010001'')=&B2D' + AIF ('&B2D' NE '+145').B2ERR +&B2D SETC B2D('11110001') + MNOTE 'B2D(''11110001'')=&B2D' + AIF ('&B2D' NE '+241').B2ERR +&B2D SETC B2D('01111111111111111111111111111111') + MNOTE 'B2D(''01111111111111111111111111111111'')=&B2D' + AIF ('&B2D' NE '+2147483647').B2ERR +&B2D SETC B2D('11111111111111111111111111110001') + MNOTE 'B2D(''11111111111111111111111111110001'')=&B2D' + AIF ('&B2D' NE '-15').B2ERR +*---------------------------------------------------------------------- + MNOTE '********** End B2D tests **********' +*====================================================================== + MNOTE '********** Begin B2X tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&B2X SETC B2X('') + MNOTE 'B2X('''')=>&B2X<' + AIF (K'&B2X NE 0).B2ERR +&B2X SETC B2X('00000') + MNOTE 'B2X(''00000'')=&B2X' + AIF ('&B2X' NE '00').B2ERR +&B2X SETC B2X('0000010010001') + MNOTE 'B2X(''0000010010001'')=&B2X' + AIF ('&B2X' NE '0091').B2ERR +&B2X SETC B2X('11110001') + MNOTE 'B2X(''11110001'')=&B2X' + AIF ('&B2X' NE 'F1').B2ERR +&B2X SETC B2X('1111110001') + MNOTE 'B2X(''1111110001'')=&B2X' + AIF ('&B2X' NE '3F1').B2ERR +*---------------------------------------------------------------------- + MNOTE '********** End B2X tests **********' +*====================================================================== + MNOTE '********** Begin C2A tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&C2A SETA C2A('') + MNOTE 'C2A('''')=&C2A' + AIF (&C2A NE 0).C2ERR +&C2A SETA C2A('+') + MNOTE 'C2A(''+'')=&C2A' + AIF (&C2A NE 78).C2ERR +&C2A SETA C2A('1') + MNOTE 'C2A(''1'')=&C2A' + AIF (&C2A NE 241).C2ERR +&C2A SETA C2A('0000') +&SC2A SETC SIGNED(&C2A) + MNOTE 'C2A(''0000'')=&SC2A' + AIF (&C2A NE -252645136).C2ERR + AIF ('&SC2A' NE '-252645136').C2ERR +*---------------------------------------------------------------------- + MNOTE '********** End C2A tests **********' +*====================================================================== + MNOTE '********** Begin C2B tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&C2B SETC C2B('') + MNOTE 'C2B('''')=>&C2B<' + AIF (K'&C2B NE 0).C2ERR +* Put next (successful) test in separate test #999 +*&C2B SETC C2B('n') n = null char = X'00' +* MNOTE 'C2B(''n'')=&C2B' +* AIF ('&C2B' NE '00000000').C2ERR +&C2B SETC C2B(' ') + MNOTE 'C2B('' '')=&C2B' + AIF ('&C2B' NE '01000000').C2ERR +&C2B SETC C2B('1') + MNOTE 'C2B(''1'')=&C2B' + AIF ('&C2B' NE '11110001').C2ERR +&C2B SETC C2B('1234') + MNOTE 'C2B(''1234'')=&C2B' + AIF ('&C2B' NE '11110001111100101111001111110100').C2ERR +&C2B SETC C2B('A1') Begin z390 tests + MNOTE 'C2B(''A1'')=&C2B' + AIF ('&C2B' NE '1100000111110001').C2ERR +&C2B SETC C2B('+') + MNOTE 'C2B(''+'')=&C2B' +* AIF ('&C2B' NE '1100000111110001').C2ERR +&C2B SETC C2B('&&') error if only 1; returns 2 + MNOTE 'C2B(''&&&&'')=&C2B' + AIF ('&C2B' NE '0101000001010000').C2ERR +*z390 AIF ('&C2B' NE '01010000').C2ERR +&C2B SETC C2B('''') error if only 1; returns 1 + MNOTE 'C2B('''''''')=&C2B' + AIF ('&C2B' NE '01111101').C2ERR +*---------------------------------------------------------------------- + MNOTE '********** End C2B tests **********' +*====================================================================== + MNOTE '********** Begin C2D tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&C2D SETC C2D('') at most 4 characters + MNOTE 'C2D('''')=&C2D' + AIF ('&C2D' NE '+0').C2ERR +* Put next (successful) test in separate test #999 +*&C2D SETC C2D('nj') n = null character = X'00' +* MNOTE 'C2D(''nj'')=&C2D' +* AIF ('&C2D' NE '+145').C2ERR +&C2D SETC C2D('1') + MNOTE 'C2D(''1'')=&C2D' + AIF ('&C2D' NE '+241').C2ERR +&C2D SETC C2D('0000') + MNOTE 'C2D(''0000'')=&C2D' + AIF ('&C2D' NE '-252645136').C2ERR +*---------------------------------------------------------------------- +* z390 tests + +&C2D SETC C2D('&&') error if only 1; returns 2 + MNOTE 'C2D(''&&&&'')=&C2D' + AIF ('&C2D' NE '+20560').C2ERR +&C2D SETC C2D('''') error if only 1; returns 1 + MNOTE 'C2D('''''''')=&C2D' + AIF ('&C2D' NE '+125').C2ERR +*---------------------------------------------------------------------- + MNOTE '********** End C2D tests **********' +*====================================================================== + MNOTE '********** Begin C2X tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&C2X SETC C2X('') + MNOTE 'C2X('''')=>&C2X<' + AIF (K'&C2X NE 0).C2ERR +* Put next (successful) test in separate test #999 +*&C2X SETC C2X('n') n = null character = X'00' +* MNOTE 'C2X(''n'')=&C2X' +* AIF ('&C2X' NE '00').C2ERR +&C2X SETC C2X('1') + MNOTE 'C2X(''1'')=&C2X' + AIF ('&C2X' NE 'F1').C2ERR +&C2X SETC C2X('a') + MNOTE 'C2X(''a'')=&C2X' + AIF ('&C2X' NE '81').C2ERR +&C2X SETC C2X('1234567R') + MNOTE 'C2X(''1234567R'')=&C2X' + AIF ('&C2X' NE 'F1F2F3F4F5F6F7D9').C2ERR +*---------------------------------------------------------------------- + MNOTE '********** End C2X tests **********' +*====================================================================== + MNOTE '********** Begin D2A tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&D2A SETA D2A('') returns 0 + MNOTE 'D2A('''')=&D2A' + AIF (&D2A NE 0).D2ERR +&D2A SETA D2A('000') + MNOTE 'D2A(''000'')=&D2A' + AIF (&D2A NE 0).D2ERR +&D2A SETA D2A('10') + MNOTE 'D2A(''10'')=&D2A' + AIF (&D2A NE 10).D2ERR +&D2A SETA D2A('+100') + MNOTE 'D2A(''+100'')=&D2A' + AIF (&D2A NE 100).D2ERR +&D2A SETA D2A('-5') +&SD2A SETC SIGNED(&D2A) + MNOTE 'D2A(''-5'')=&SD2A' + AIF (&D2A NE -5).D2ERR + AIF ('&SD2A' NE '-5').D2ERR +*---------------------------------------------------------------------- +* z390 tests + +&D2A SETA D2A('-10') +&SD2A SETC SIGNED(&D2A) + MNOTE 'D2A(''-10'')=&SD2A' + AIF (&D2A NE -10).D2ERR + AIF ('&SD2A' NE '-10').D2ERR +*---------------------------------------------------------------------- + MNOTE '********** End D2A tests **********' +*====================================================================== + MNOTE '********** Begin D2B tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&D2B SETC D2B('') + MNOTE 'D2B('''')=>&D2B<' + AIF (K'&D2B NE 0).D2ERR +&D2B SETC D2B('0') + MNOTE 'D2B(''0'')=&D2B' + AIF ('&D2B' NE '00000000000000000000000000000000').D2ERR +&D2B SETC D2B('+5') + MNOTE 'D2B(''5'')=&D2B' + AIF ('&D2B' NE '00000000000000000000000000000101').D2ERR +&D2B SETC D2B('1022') + MNOTE 'D2B(''1022'')=&D2B' + AIF ('&D2B' NE '00000000000000000000001111111110').D2ERR +&D2B SETC D2B('-7') + MNOTE 'D2B(''-7'')=&D2B' + AIF ('&D2B' NE '11111111111111111111111111111001').D2ERR +*---------------------------------------------------------------------- + MNOTE '********** End D2B tests **********' +*====================================================================== + MNOTE '********** Begin D2C tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +* For the first example, HLASM LR states "indicates an error". +* However, HLASM does not generate an error and returns +* an empty string. +&D2C SETC D2C('') indicates an error; set to '' + MNOTE 'D2C('''')=>&D2C<' + AIF (K'&D2C NE 0).D2ERR +&D2C SETC D2C('0') four EBCDIC null bytes + MNOTE 'D2C(''0'')=&D2C' + AIF (K'&D2C NE 4).D2ERR + DC C'&D2C' X'00000000' +&D2C SETC D2C('+126') + MNOTE 'D2C(''+126'')=&D2C' + AIF ('&D2C'(4,1) NE '=').D2ERR + DC C'&D2C' X'000000',C'=' +&D2C SETC D2C('247') + MNOTE 'D2C(''247'')=&D2C' + AIF ('&D2C'(4,1) NE '7').D2ERR + DC C'&D2C' X'000000',C'7' +&D2C SETC D2C('23793') + MNOTE 'D2C(''23793'')=&D2C' + AIF ('&D2C'(3,2) NE '*1').D2ERR + DC C'&D2C' X'0000',C'*1' +&D2C SETC D2C('-7') + MNOTE 'D2C(''-7'')=&D2C' + AIF ('&D2C'(4,1) NE '9').D2ERR + DC C'&D2C' X'FFFFFF',C'9' +*---------------------------------------------------------------------- + MNOTE '********** End D2C tests **********' +*====================================================================== + MNOTE '********** Begin D2X tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +* For the first example, HLASM LR states "indicates an error". +* However, HLASM does not generate an error and returns +* an empty string. +&D2X SETC D2X('') indicates an error; set to '' + MNOTE 'D2X('''')=>&D2X<' + AIF (K'&D2X NE 0).D2ERR +&D2X SETC D2X('0') + MNOTE 'D2X(''0'')=&D2X' + AIF ('&D2X' NE '00000000').D2ERR +&D2X SETC D2X('+5') + MNOTE 'D2X(''+5'')=&D2X' + AIF ('&D2X' NE '00000005').D2ERR +&D2X SETC D2X('255') + MNOTE 'D2X(''255'')=&D2X' + AIF ('&D2X' NE '000000FF').D2ERR +&D2X SETC D2X('01022') + MNOTE 'D2X(''01022'')=&D2X' + AIF ('&D2X' NE '000003FE').D2ERR +&D2X SETC D2X('-7') + MNOTE 'D2X(''-7'')=&D2X' + AIF ('&D2X' NE 'FFFFFFF9').D2ERR +*---------------------------------------------------------------------- + MNOTE '********** End D2X tests **********' +*====================================================================== + MNOTE '********** Begin X2A tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&X2A SETA X2A('00000101') + MNOTE 'X2A(''00000101'')=&X2A' + AIF (&X2A NE 257).X2ERR +&X2A SETA X2A('C1') + MNOTE 'X2A(''C1'')=&X2A' + AIF (&X2A NE 193).X2ERR +&X2A SETA X2A('') + MNOTE 'X2A('''')=&X2A' + AIF (&X2A NE 0).X2ERR +&X2A SETA X2A('FFFFFFF0') +&SX2A SETC SIGNED(&X2A) + MNOTE 'X2A(''FFFFFFF0'')=&SX2A' + AIF (&X2A NE -16).X2ERR + AIF ('&SX2A' NE '-16').X2ERR +*---------------------------------------------------------------------- +* z390 tests + +&X2A SETA X2A('F1') + MNOTE 'X2A(''F1'')=&X2A' + AIF (&X2A NE 241).X2ERR +*---------------------------------------------------------------------- + MNOTE '********** End X2A tests **********' +*====================================================================== + MNOTE '********** Begin X2B tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&X2B SETC X2B('') + MNOTE 'X2B('''')=>&X2B<' + AIF (K'&X2B NE 0).X2ERR +&X2B SETC X2B('00') + MNOTE 'X2B(''00'')=&X2B' + AIF ('&X2B' NE '00000000').X2ERR +&X2B SETC X2B('1') + MNOTE 'X2B(''1'')=&X2B' + AIF ('&X2B' NE '0001').X2ERR +&X2B SETC X2B('F3') + MNOTE 'X2B(''F3'')=&X2B' + AIF ('&X2B' NE '11110011').X2ERR +&X2B SETC X2B('00F3') + MNOTE 'X2B(''00F3'')=&X2B' + AIF ('&X2B' NE '0000000011110011').X2ERR +*---------------------------------------------------------------------- +* z390 tests + +&X2B SETC X2B('1F') + MNOTE 'X2B(''1F'')=&X2B' + AIF ('&X2B' NE '00011111').X2ERR +*---------------------------------------------------------------------- + MNOTE '********** End X2B tests **********' +*====================================================================== + MNOTE '********** Begin X2C tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&X2C SETC X2C('') + MNOTE 'X2C('''')=>&X2C<' + AIF (K'&X2C NE 0).X2ERR + DC C'>&X2C<' C'><' +&X2C SETC X2C('F3') + MNOTE 'X2C(''F3'')=&X2C' + AIF ('&X2C' NE '3').X2ERR +&X2C SETC X2C('0') + MNOTE 'X2C(''0'')=&X2C' + AIF (K'&X2C NE 1).X2ERR + DC C'&X2C' X'00' +&X2C SETC X2C('F1F2F3F4F5') + MNOTE 'X2C(''F1F2F3F4F5'')=&X2C' + AIF ('&X2C' NE '12345').X2ERR +&X2C SETC X2C('000F1') + MNOTE 'X2C(''000F1'')=&X2C' + AIF (K'&X2C NE 3).X2ERR + AIF ('&X2C'(3,1) NE '1').X2ERR + DC C'&X2C' X'0000',C'1' +*---------------------------------------------------------------------- +* z390 tests + +&X2C SETC X2C('F1') + MNOTE 'X2C(''F1'')=&X2C' + AIF ('&X2C' NE '1').X2ERR +*---------------------------------------------------------------------- + MNOTE '********** End X2C tests **********' +*====================================================================== + MNOTE '********** Begin X2D tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&X2D SETC X2D('') + MNOTE 'X2D('''')=&X2D' + AIF ('&X2D' NE '+0').X2ERR +&X2D SETC X2D('91') + MNOTE 'X2D(''91'')=&X2D' + AIF ('&X2D' NE '+145').X2ERR +&X2D SETC X2D('000F1') + MNOTE 'X2D(''000F1'')=&X2D' + AIF ('&X2D' NE '+241').X2ERR +&X2D SETC X2D('7FFFFFFF') + MNOTE 'X2D(''7FFFFFFF'')=&X2D' + AIF ('&X2D' NE '+2147483647').X2ERR +&X2D SETC X2D('FFFFFFF1') + MNOTE 'X2D(''FFFFFFF1'')=&X2D' + AIF ('&X2D' NE '-15').X2ERR +*---------------------------------------------------------------------- +* z390 tests + +&X2D SETC X2D('F1') + MNOTE 'X2D(''F1'')=&X2D' + AIF ('&X2D' NE '+241').X2ERR +*---------------------------------------------------------------------- + MNOTE '********** End X2D tests **********' +*====================================================================== +.SKPX2Y ANOP +*********************************************************************** +* MBOX 'Test DCLEN, DCVAL, DEQUOTE' + MBOX 'Test DCLEN' +*AGO .SKPDC +*====================================================================== + MNOTE '********** Begin DCLEN tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&DCLEN SETA DCLEN('') null string + MNOTE 'DCLEN('''')=&DCLEN' + AIF (&DCLEN NE 0).DCLERR +&DCLEN SETA DCLEN('''') single apostrophe + MNOTE 'DCLEN('''''''')=&DCLEN' + AIF (&DCLEN NE 1).DCLERR +&DCLEN SETA DCLEN('''''') two apostrophes + MNOTE 'DCLEN('''''''''''')=&DCLEN' + AIF (&DCLEN NE 1).DCLERR +&DCLEN SETA DCLEN('&&') two ampersands + MNOTE 'DCLEN(''&&&&'')=&DCLEN' + AIF (&DCLEN NE 1).DCLERR +&DCLEN SETA DCLEN('a''''b') string is "a'b" + MNOTE 'DCLEN(''a''''''''b'')=&DCLEN' + AIF (&DCLEN NE 3).DCLERR +&DCLEN SETA DCLEN('a''''b&&c') string is "a'b&c"" + MNOTE 'DCLEN(''a''''''''b&&&&c'')=&DCLEN' + AIF (&DCLEN NE 5).DCLERR +&DCLEN SETA DCLEN('&&&&'.'''''''') string is "&&''" + MNOTE 'DCLEN(''&&&&&&&&''.'''''''''''''''')=&DCLEN' + AIF (&DCLEN NE 4).DCLERR +*---------------------------------------------------------------------- +* z390 tests + +&DCLSTR SETC '''''''''&&&&&&&&1''''''''' len 17; see MNOTE below +&K SETA K'&DCLSTR +&DDCLSTR SETC DOUBLE('&DCLSTR') double for MNOTE and DC +* + MNOTE 'K''&&DCLSTR=&K &&DCLSTR = >&DDCLSTR<' +*********************************************************************** +* On z390 the preceding MNOTE displays +* +* MNOTE 'K'&DCLSTR=17 &DCLSTR = >''''''''&&&&&&&&&&&&&&&&1''''''''<' +* +* Using HLASM the MNOTE displays +* +* +K'&DCLSTR=17 &DCLSTR = >''''&&&&&&&&1''''< +* +* Looks like mz390 just shows the MNOTE with the message +* text doubled, not the actual output of the MNOTE. +* +* The following DC statement is the same for both z390 & HLASM. +*********************************************************************** + PUSH PRINT + PRINT DATA + DC FL1'&K',C'>&DDCLSTR<' + POP PRINT +* +&DCLEN SETA DCLEN('&DCLSTR') + MNOTE 'DCLEN(''&&DCLSTR'')=&DCLEN' + AIF (&DCLEN NE 9).DCLERR +*---------------------------------------------------------------------- + MNOTE '********** End DCLEN tests **********' +*====================================================================== + AGO .SKPDCVO DCVAL tests now done in rt/mlc/TOPR2.MLC + MNOTE '********** Begin DCVAL tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples +* +******** old DCVAL tests +&DCVAL SETC DCVAL('') null string +&K SETA K'&DCVAL + MNOTE 'DCVAL('''')=>&DCVAL< length = &K' + AIF (K'&DCVAL NE 0).DCVERR +* +&DCVAL SETC DCVAL('''') one apostrophe +&K SETA K'&DCVAL + MNOTE 'DCVAL('''''''')=>&DCVAL&DCVAL< length = &K' +&K SETA K'&DCVAL + MNOTE 'K''&&DCVAL = &K' + AIF ('&DCVAL' NE '''').DCVERR +* +&DCVAL SETC DCVAL('&&') one ampersand +&K SETA K'&DCVAL +&DCVAL2 SETC '&DCVAL'.'&DCVAL' + MNOTE 'DCVAL(''&&&&'')=>&DCVAL2<' + AIF ('&DCVAL2' NE '&&').DCVERR +* +&DCVAL SETC DCVAL('a''''b') string is "a'b" +&K SETA K'&DCVAL +* MNOTE 'DCVAL(''a''''''''b'')=>&DCVAL< length = &K' + AIF ('&DCVAL' NE 'a''b').DCVERR +* AGO .JJG3 +* +&DCVAL SETC DCVAL('a''''b&&c') string is "a'b&c" +&K SETA K'&DCVAL +&W1 SETC DOUBLE('a''''b&&c') +&W2 SETC DOUBLE('&DCVAL') +&K SETA K'&DCVAL +******** MNOTE 'DCVAL(''a''''''''b&&c'')=>&DCVAL< length = &K' + AGO .JJG3 + AIF ('&DCVAL' NE 'a''b&&c').DCVERR +* +&DCVAL SETC DCVAL('&&&&'.'''''''') string is "&&''" +&K SETA K'&DCVAL +* MNOTE 'DCVAL(''&&&&&&&&''.'''''''''''''''')=&DCVAL length = &K' + AIF ('&DCVAL' NE '&&&&''''').DCVERR +.JJG3 ANOP +*---------------------------------------------------------------------- +* z390 tests + +&DCVSTR SETC '''''&&&&1''''' string "''&&1''" len 7 +&DCVAL SETC DCVAL('&DCVSTR') + MNOTE 'DCVAL(''&DCVSTR'')=&DCVAL' + AIF ('&DCVAL' NE '''&&1''').DCVERR +*---------------------------------------------------------------------- + MNOTE '********** End DCVAL tests **********' +.SKPDCVO ANOP +*====================================================================== + AGO .SKPDEQO DEQUOTE tests now done in rt/mlc/TOPR2.MLC + MNOTE '********** Begin DEQUOTE tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&DCESTR SETC '''ABC''' +&DEQUOTE SETC DEQUOTE('&DCESTR') + MNOTE 'DEQUOTE(''&DCESTR'')=&DEQUOTE' + AIF ('&DEQUOTE' NE 'ABC').DCEERR + MNOTE 'Examples from HLASM LR' +&C SETC DEQUOTE('charstring') + MNOTE '&&C SETC DEQUOTE(''charstring''); &&C=&C' + AIF ('&C' NE 'charstring').DCEERR +&C SETC DEQUOTE('') + MNOTE '&&C SETC DEQUOTE(''''); &&C=&C' + AIF (K'&C NE 0).DCEERR +&C SETC DEQUOTE('a') + MNOTE '&&C SETC DEQUOTE(''a''); &&C=&C' + AIF ('&C' NE 'a').DCEERR +&ARG SETC '''a''' +&C SETC DEQUOTE('&ARG') + MNOTE '&&C SETC DEQUOTE(''&ARG''); &&C=&C' + AIF ('&C' NE 'a').DCEERR +&C SETC DEQUOTE('a''b') + MNOTE '&&C SETC DEQUOTE(''a''''b''); &&C=&C' + AIF ('&C' NE 'a''b').DCEERR +&ARG SETC '''''' +&C SETC DEQUOTE('&ARG') + MNOTE '&&C SETC DEQUOTE(''&ARG''); &&C=&C' + AIF (K'&C NE 0).DCEERR +.SKPDC ANOP +*---------------------------------------------------------------------- + MNOTE '********** End DEQUOTE tests **********' +.SKPDEQO ANOP +*====================================================================== + MBOX 'Test ISBIN, ISDEC, ISHEX, ISSYM' +*AGO .SKPIS +*====================================================================== + MNOTE '********** Begin ISBIN tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&ISBIN SETA ISBIN('10101') + MNOTE 'ISBIN(''10101'')=&ISBIN' + AIF (&ISBIN NE 1).ISERR +&ISBIN SETA ISBIN('101010101010101010101010101010101') excess digits + MNOTE 'ISBIN(''101010101010101010101010101010101'')=&ISBIN' + AIF (&ISBIN NE 0).ISERR +&ISBIN SETA ISBIN('12121') non-binary digits + MNOTE 'ISBIN(''12121'')=&ISBIN' + AIF (&ISBIN NE 0).ISERR +* Put next (error) test in separate test #999 +*ISBIN SETA ISBIN('') error condition +* MNOTE 'ISBIN('''')=&ISBIN' +* AIF (&ISBIN NE 0).ISERR +*---------------------------------------------------------------------- +* z390 tests + +&ISBIN SETA ISBIN('100') + MNOTE 'ISBIN(''100'')=&ISBIN' + AIF (&ISBIN NE 1).ISERR +&ISBIN SETA ISBIN('+100') non-bin char + MNOTE 'ISBIN(''+100'')=&ISBIN' +* AIF (&ISBIN NE 0).ISERR +&ISBIN SETA ISBIN('123') + MNOTE 'ISBIN(''123'')=&ISBIN' + AIF (&ISBIN NE 0).ISERR +&ISBIN SETA ISBIN('000000000000000000000000000000000') excess digits + MNOTE 'ISBIN(''000000000000000000000000000000000'')=&ISBIN' + AIF (&ISBIN NE 0).ISERR +*---------------------------------------------------------------------- + MNOTE '********** End ISBIN tests **********' +*====================================================================== + MNOTE '********** Begin ISDEC tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&ISDEC SETA ISDEC('12345678') okay + MNOTE 'ISDEC(''12345678'')=&ISDEC' + AIF (&ISDEC NE 1).ISERR +&ISDEC SETA ISDEC('+25') non-digit + MNOTE 'ISDEC(''+25'')=&ISDEC' + AIF (&ISDEC NE 0).ISERR +&ISDEC SETA ISDEC('2147483648') too large + MNOTE 'ISDEC(''2147483648'')=&ISDEC' + AIF (&ISDEC NE 0).ISERR +&ISDEC SETA ISDEC('00000000005') too many digits; max 10 + MNOTE 'ISDEC(''00000000005'')=&ISDEC' + AIF (&ISDEC NE 0).ISERR +* Put next (error) test in separate test #999 +*&ISDEC SETA ISDEC('') error condition +* MNOTE 'ISDEC('''')=&ISDEC' +* AIF (&ISDEC NE 0).ISERR +*---------------------------------------------------------------------- +* z390 tests + +&ISDEC SETA ISDEC('123') + MNOTE 'ISDEC(''123'')=&ISDEC' + AIF (&ISDEC NE 1).ISERR +&ISDEC SETA ISDEC('-123') non-digit + MNOTE 'ISDEC(''-123'')=&ISDEC' + AIF (&ISDEC NE 0).ISERR +&ISDEC SETA ISDEC('12A') + MNOTE 'ISDEC(''12A'')=&ISDEC' + AIF (&ISDEC NE 0).ISERR +&ISDEC SETA ISDEC('00000000000') too many digits; max 10 + MNOTE 'ISDEC(''00000000000'')=&ISDEC' + AIF (&ISDEC NE 0).ISERR +*---------------------------------------------------------------------- + MNOTE '********** End ISDEC tests **********' +*====================================================================== + MNOTE '********** Begin ISHEX tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&ISHEX SETA ISHEX('ab34CD9F') + MNOTE 'ISHEX(''ab3fCD9F'')=&ISHEX' + AIF (&ISHEX NE 1).ISERR +&ISHEX SETA ISHEX('abcdEFGH') + MNOTE 'ISHEX(''abcdEFGH'')=&ISHEX' non-hexadecimal digits + AIF (&ISHEX NE 0).ISERR +&ISHEX SETA ISHEX('123456789') too many chars; 8 max + MNOTE 'ISHEX(''123456789'')=&ISHEX' + AIF (&ISHEX NE 0).ISERR +* Put next (error) test in separate test #999 +*&ISHEX SETA ISHEX('') error condition +* MNOTE 'ISHEX('''')=&ISHEX' +* AIF (&ISHEX NE 0).ISERR +*---------------------------------------------------------------------- +* z390 tests + +&ISHEX SETA ISHEX('F0') + MNOTE 'ISHEX(''F0'')=&ISHEX' + AIF (&ISHEX NE 1).ISERR +&ISHEX SETA ISHEX('+F0') non-hex char + MNOTE 'ISHEX(''+F0'')=&ISHEX' + AIF (&ISHEX NE 0).ISERR +&ISHEX SETA ISHEX('FG') + MNOTE 'ISHEX(''FG'')=&ISHEX' + AIF (&ISHEX NE 0).ISERR +&ISHEX SETA ISHEX('000000000') too many chars; 8 max + MNOTE 'ISHEX(''000000000'')=&ISHEX' + AIF (&ISHEX NE 0).ISERR +*---------------------------------------------------------------------- + MNOTE '********** End ISHEX tests **********' +*====================================================================== + MNOTE '********** Begin ISSYM tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&ISSYM SETA ISSYM('Abcd_1234') + MNOTE 'ISSYM(''Abcd_1234'')=&ISSYM' + AIF (&ISSYM NE 1).ISERR +&ISSYM SETA ISSYM('_Abcd1234') + MNOTE 'ISSYM(''_Abcd1234'')=&ISSYM' + AIF (&ISSYM NE 1).ISERR +&ISSYM SETA ISSYM('##@$_') + MNOTE 'ISSYM(''##@$_'')=&ISSYM' + AIF (&ISSYM NE 1).ISERR +&ISSYM SETA ISSYM('1234_Abcd') invalid initial char + MNOTE 'ISSYM(''1234_Abcd'')=&ISSYM' + AIF (&ISSYM NE 0).ISERR +* Put next (error) test in separate test #999 +*&ISSYM SETA ISSYM('') error condition +* MNOTE 'ISSYM('''')=&ISSYM' +* AIF (&ISSYM NE 0).ISERR +*---------------------------------------------------------------------- +* z390 tests + +&ISSYM SETA ISSYM('AZ090#$_') + MNOTE 'ISSYM(''AZ090#$_'')=&ISSYM' + AIF (&ISSYM NE 1).ISERR +&ISSYM SETA ISSYM('AZ090#$_**') + MNOTE 'ISSYM(''AZ090#$_**'')=&ISSYM' + AIF (&ISSYM NE 0).ISERR +.SKPIS ANOP +*---------------------------------------------------------------------- + MNOTE '********** End ISSYM tests **********' +*********************************************************************** + MBOX 'Test AND, NOT, OR, XOR' +*AGO .SKPLOG +*====================================================================== + MNOTE '********** Begin AND, NOT, OR, XOR tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&OP1 SETA 10 +&OP2 SETA 6 HLASM LR uses 2 +&BOP1 SETC A2B(&OP1) +&BOP2 SETC A2B(&OP2) + MNOTE 'OP1 = &OP1 (B''&BOP1'')' + MNOTE 'OP2 = &OP2 (B''&BOP2'')' +* +&AND SETA (&OP1 AND &OP2) +&BAND SETC A2B(&AND) + MNOTE '(&OP1 AND &OP2) = &AND (B''&BAND'')' + AIF (&AND NE 2).LOERR +&NOT SETA (NOT &OP1) +&SNOT SETC SIGNED(&NOT) +&BNOT SETC A2B(&NOT) + MNOTE '(NOT &OP1) = &SNOT (B''&BNOT'')' + AIF (&NOT NE -11).LOERR +&OR SETA (&OP1 OR &OP2) +&BOR SETC A2B(&OR) + MNOTE '(&OP1 OR &OP2) = &OR (B''&BOR'')' + AIF (&OR NE 14).LOERR +&XOR SETA (&OP1 XOR &OP2) +&BXOR SETC A2B(&XOR) + MNOTE '(&OP1 XOR &OP2) = &XOR (B''&BXOR'')' + AIF (&XOR NE 12).LOERR +.SKPLOG ANOP +*---------------------------------------------------------------------- + MNOTE '********** End AND, NOT,OR, XOR tests **********' +*********************************************************************** + MBOX 'Test SIGNED, SYSATTRA, SYSATTRP' +*AGO .SKPSSS +*====================================================================== + MNOTE '********** Begin SIGNED tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&SIGNED SETC SIGNED(10) + MNOTE 'SIGNED(10)=&SIGNED' + AIF ('&SIGNED' NE '10').SIGNERR +&SIGNED SETC SIGNED(-10) + MNOTE 'SIGNED(-10)=&SIGNED' + AIF ('&SIGNED' NE '-10').SIGNERR +*---------------------------------------------------------------------- +* z390 tests + +&SIGNED SETC SIGNED(-241) + MNOTE 'SIGNED(-241)=&SIGNED' + AIF ('&SIGNED' NE '-241').SIGNERR +*---------------------------------------------------------------------- + MNOTE '********** End SIGNED tests **********' +*====================================================================== + MNOTE '********** Begin SYSATTRA, SYSATTRP tests **********' +*---------------------------------------------------------------------- +* z390 tests + +&SYSATTRA SETC SYSATTRA('SYM') see HLASM LR p339 + MNOTE 'SYSATTRA(''SYM'')=&SYSATTRA' + AIF ('&SYSATTRA' NE 'GR32').SYERR +&SYSATTRP SETC SYSATTRP('SYM') see HLASM LR pp339-340 + MNOTE 'SYSATTRP(''SYM'')=&SYSATTRP' + AIF ('&SYSATTRP' NE 'PGMA').SYERR +.SKPSSS ANOP +*---------------------------------------------------------------------- + MNOTE '********** End SYSATTRA, SYSATTRP tests **********' +*********************************************************************** + MBOX 'Test SLA, SLL, SRA, SRL' +*AGO .SKPSHFT +*====================================================================== + MNOTE '********** Begin SLA tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&OP1S SETA 2 +&OP2S SETA 2 + +&SLA SETA (&OP1S SLA &OP2S) + MNOTE '(&OP1S SLA &OP2S) = &SLA' + AIF (&SLA NE 8).SLAERR +*---------------------------------------------------------------------- +* z390 tests + +&SLA SETA (1 SLA 2) + MNOTE '(1 SLA 2) = &SLA' + AIF (&SLA NE 4).SLAERR +&SLA SETA (X'3FFFFFFF' SLA 1) + MNOTE '(X''3FFFFFFF'' SLA 1) = &SLA' + AIF (&SLA NE X'7FFFFFFE').SLAERR +* Put next two (error) test in separate tests #999 +*&SLA SETA (X'7FFFFFFF' SLA 1) ASMA075E arith overflow +* MNOTE '(X''7FFFFFFF'' SLA 1) = &SLA' +* AIF (&SLA NE X'7FFFFFFE').SLAERR +*&SLA SETA (X'80000001' SLA 1) ASMA075E arith overflow +* MNOTE '(X''80000001'' SLA 1) = &SLA' +* AIF (&SLA NE X'80000002').SLAERR +&SLA SETA (X'C0000001' SLA 1) okay +&SSLA SETC (SIGNED &SLA) +&XSLA SETC A2X(&SLA) + MNOTE '(X''C0000001'' SLA 1) = &SSLA (X''&XSLA'')' + AIF (&SLA NE X'80000002').SLAERR +*---------------------------------------------------------------------- + MNOTE '********** End SLA tests **********' +*====================================================================== + MNOTE '********** Begin SLL tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&OP1S SETA 10 +&OP2S SETA 2 + +&SLL SETA (&OP1S SLL &OP2S) + MNOTE '(&OP1S SLL &OP2S) = &SLL' + AIF (&SLL NE 40).SLLERR +*---------------------------------------------------------------------- +* z390 tests + +&SLL SETA (1 SLL 2) + MNOTE '(1 SLL 2) = &SLL' + AIF (&SLL NE 4).SLLERR +&SLL SETA (X'7FFFFFFF' SLL 1) +&SSLL SETC (SIGNED &SLL) +&XSLL SETC A2X(&SLL) + MNOTE '(X''7FFFFFFF'' SLL 1) = &SSLL (X''&XSLL'')' + AIF (&SLL NE X'FFFFFFFE').SLLERR +*---------------------------------------------------------------------- + MNOTE '********** End SLL tests **********' +*====================================================================== + MNOTE '********** Begin SRA tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&OP1S SETA 10 +&OP2S SETA 2 + +&SRA SETA (&OP1S SRA &OP2S) + MNOTE '(&OP1S SRA &OP2S) = &SRA' + AIF (&SRA NE 2).SRAERR + +&OP1S SETA -344 +&OP2S SETA 40 + +&SRA SETA (&OP1S SRA &OP2S) +&SSRA SETC (SIGNED &SRA) +&SOP1S SETC (SIGNED &OP1S) + MNOTE '(&SOP1S SRA &OP2S) = &SSRA' + AIF (&SRA NE -1).SRAERR + +&XSRA SETC A2X(&SRA) +&XOP1S SETC A2X(&OP1S) + MNOTE '(X''&XOP1S'' SRA &OP2S) = &SSRA (X''&XSRA'')' +*---------------------------------------------------------------------- +* z390 tests + +&SRA SETA (4 SRA 2) + MNOTE '(4 SRA 2) = &SRA' + AIF (&SRA NE 1).SRAERR +&SRA SETA (X'FFFFFFFE' SRA 1) +&SSRA SETC (SIGNED &SRA) + MNOTE '(X''FFFFFFFE'' SRA 1) = &SSRA' + AIF (&SRA NE X'FFFFFFFF').SRAERR +*---------------------------------------------------------------------- + MNOTE '********** End SRA tests **********' +*====================================================================== + MNOTE '********** Begin SRL tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&OP1S SETA 10 +&OP2S SETA 2 + +&SRL SETA (&OP1S SRL &OP2S) + MNOTE '(&OP1S SRL &OP2S) = &SRL' + AIF (&SRL NE 2).SRLERR + +&OP1S SETA -344 +&OP2S SETA 40 + +&SRL SETA (&OP1S SRL &OP2S) +&SSRL SETC (SIGNED &SRL) +&SOP1S SETC (SIGNED &OP1S) + MNOTE '(&SOP1S SRL &OP2S) = &SSRL' + AIF (&SRL NE 0).SRLERR +*---------------------------------------------------------------------- +* z390 tests + +&SRL SETA (4 SRL 2) + MNOTE '(4 SRL 2) = &SRL' + AIF (&SRL NE 1).SRLERR +&SRL SETA (X'FFFFFFFE' SRL 1) +&XSRL SETC A2X(&SRL) + MNOTE '(X''FFFFFFFE'' SLL 1) = &SRL (X''&XSRL'')' + AIF (&SRL NE X'7FFFFFFF').SRLERR +.SKPSHFT ANOP +*---------------------------------------------------------------------- + MNOTE '********** End SRL tests **********' +*********************************************************************** + MBOX 'Test operator types A,E,M,O,S,U' +*AGO .SKPOT +&OT SETC O'PUSH + MNOTE 'O''PUSH = &OT' + AIF (O'PUSH NE 'A').OTERR Assembler code +&OT SETC O'BER + MNOTE 'O''BER = &OT' + AIF (O'BER NE 'E').OTERR Extended mnemonic code +&OT SETC O'BE + MNOTE 'O''BE = &OT' + AIF (O'BE NE 'E').OTERR Extended mnemonic code +&OT SETC O'JE + MNOTE 'O''JE = &OT' + AIF (O'JE NE 'E').OTERR Extended mnemonic code +&OT SETC O'SRNM + MNOTE 'O''SRNM = &OT' + AIF (O'SRNM NE 'O').OTERR Machine code +&OT SETC O'BCR + MNOTE 'O''BCR = &OT' + AIF (O'BCR NE 'O').OTERR Machine code +&OT SETC O'BC + MNOTE 'O''BC = &OT' + AIF (O'BC NE 'O').OTERR Machine code +&OT SETC O'BRC + MNOTE 'O''BRC = &OT' + AIF (O'BRC NE 'O').OTERR Machine code +&OT SETC O'SAVE + MNOTE 'O''SAVE = &OT' + AIF (O'SAVE NE 'S').OTERR Library macro found +&OT SETC O'RETURN + MNOTE 'O''RETURN = &OT' + AIF (O'RETURN NE 'M').OTERR Loaded macro +&OT SETC O'XXXXX + MNOTE 'O''XXXXX = &OT' + AIF (O'XXXXX NE 'U').OTERR Undefined +.SKPOT ANOP +*********************************************************************** + MBOX 'Test string duplication in expression' +&A SETC 'A' + AIF ('&A'.(2)'B' NE 'ABB').DUPERR + AIF ('A'.(2)'B' NE 'ABB').DUPERR +*********************************************************************** + MBOX 'Test FIND, INDEX' +*====================================================================== + MNOTE '********** Begin FIND tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&OP1F SETC 'abcdef' +&OP2F SETC 'cde' order irrelevant +&VARF SETA ('&OP1F' FIND '&OP2F') + MNOTE '''&OP1F'' FIND ''&OP2F''' + MNOTE '&&VARF=&VARF' + AIF (&VARF NE 3).FINDERR finds 'c' in 'abcdef' + +&OP1F SETC 'abcdef' +&OP2F SETC 'gde' +&VARF SETA ('&OP1F' FIND '&OP2F') + MNOTE '''&OP1F'' FIND ''&OP2F''' + AIF (&VARF NE 4).FINDERR finds 'd' in 'abcdef' + +&OP1F SETC 'abcdef' +&OP2F SETC 'egd' +&VARF SETA ('&OP1F' FIND '&OP2F') + MNOTE '''&OP1F'' FIND ''&OP2F''' + AIF (&VARF NE 4).FINDERR finds 'd' in 'abcdef' +*---------------------------------------------------------------------- +* z390 tests + +&IX SETA FIND('abc','b') + MNOTE 'IX=&IX' + AIF (&IX NE 2).FINDERR +&IX SETA FIND('abc','xb') + MNOTE 'IX=&IX' + AIF (&IX NE 2).FINDERR +&IX SETA FIND('abc','cb') + MNOTE 'IX=&IX' + AIF (&IX NE 2).FINDERR +&IX SETA FIND('abc','d') + MNOTE 'IX=&IX' + AIF (&IX NE 0).FINDERR +&IX SETA FIND('abc','d') + MNOTE 'IX=&IX' + AIF (&IX NE 0).FINDERR +*---------------------------------------------------------------------- + MNOTE '********** End FIND tests **********' +*********************************************************************** +*====================================================================== + MNOTE '********** Begin INDEX tests **********' +*---------------------------------------------------------------------- +* HLASM LR examples + +&IX SETA INDEX('ABC','B') + MNOTE 'IX=&IX' + AIF (&IX NE 2).INDXERR +&IX SETA INDEX('ABC','D') + MNOTE 'IX=&IX' + AIF (&IX NE 0).INDXERR +*---------------------------------------------------------------------- +* z390 tests + +&IX SETA INDEX('ABXBC','BC') + MNOTE 'IX=&IX' + AIF (&IX NE 4).INDXERR +&IX SETA INDEX('ABC','D') + MNOTE 'IX=&IX' + AIF (&IX NE 0).INDXERR +&IX SETA INDEX('ABC','ABC') + MNOTE 'IX=&IX' + AIF (&IX NE 1).INDXERR +&IX SETA INDEX('ABC','ABCD') + MNOTE 'IX=&IX' + AIF (&IX NE 0).INDXERR +*---------------------------------------------------------------------- + MNOTE '********** End INDEX tests **********' +*********************************************************************** + AGO .LOOP +.ENDLOOP ANOP + MNOTE '*********************************************' + MNOTE 'TESTOPR2 MNOTE,AIF section ended successfully' + MNOTE '*********************************************' + AGO .EXIT +*********************************************************************** +* Error MNOTEs +*********************************************************************** +.LCERR ANOP + MNOTE 12,'LOWER CASE TEST ERROR' + AGO .EXIT +.UCERR ANOP + MNOTE 12,'UPPER CASE TEST ERROR' + AGO .EXIT +.A2ERR ANOP + MNOTE 12,'A2 OPERATOR ERROR' + AGO .EXIT +.B2ERR ANOP + MNOTE 12,'B2 OPERATOR ERROR' + AGO .EXIT +.C2ERR ANOP + MNOTE 12,'C2 OPERATOR ERROR' + AGO .EXIT +.D2ERR ANOP + MNOTE 12,'D2 OPERATOR ERROR' + AGO .EXIT +.X2ERR ANOP + MNOTE 12,'X2 OPERATOR ERROR' + AGO .EXIT +.DCLERR ANOP + MNOTE 12,'DCLEN OPERATOR ERROR' + AGO .EXIT +.DCVERR ANOP + MNOTE 12,'DCVAL OPERATOR ERROR' + AGO .EXIT +.DCEERR ANOP + MNOTE 12,'DCEQUOTE OPERATOR ERROR' + AGO .EXIT +.ISERR ANOP + MNOTE 12,'IS??? OPERATOR ERROR' + AGO .EXIT +.LOERR ANOP + MNOTE 12,'LOGIC OPERATOR ERROR' + AGO .EXIT +.SIGNERR ANOP + MNOTE 12,'SIGNED OPERATOR ERROR' + AGO .EXIT +.SYERR ANOP + MNOTE 12,'SYSATTR A/P OPERATOR ERROR' + AGO .EXIT +.SLAERR ANOP + MNOTE 12,'SLA OPERATOR ERROR' + AGO .EXIT +.SLLERR ANOP + MNOTE 12,'SLL OPERATOR ERROR' + AGO .EXIT +.SRAERR ANOP + MNOTE 12,'SRA OPERATOR ERROR' + AGO .EXIT +.SRLERR ANOP + MNOTE 12,'SRL OPERATOR ERROR' + AGO .EXIT +.OTERR ANOP + MNOTE 12,'OPERATION TYPE TEST ERROR' + AGO .EXIT +.DUPERR ANOP + MNOTE 12,'DUPLICATION TYPE TEST ERROR' + AGO .EXIT +.FINDERR ANOP + MNOTE 12,'FIND ERROR' + AGO .EXIT +.INDXERR ANOP + MNOTE 12,'INDEX ERROR' + AGO .EXIT +.EXIT ANOP +* + END diff --git a/src/az390.java b/src/az390.java index 9d4822a65..a807e79ab 100644 --- a/src/az390.java +++ b/src/az390.java @@ -422,6 +422,7 @@ public class az390 implements Runnable { * 2022-10-24 jjg #451 z390 ignores CODEPAGE option for input; * replace non-printable with '.' in PRN, BAL, PCH * 2024-05-29 afk #500 List suboption for options optable/machine not implemented correctly + * 2024-07-03 jjg #509 generate error in process_dcc_data if "DC C''" ***************************************************** * Global variables last rpi *****************************************************/ @@ -9414,20 +9415,24 @@ private void process_dcc_data(){ } dc_index = dc_index + dcc_next + 1; dcc_len = dcc_text.length(); - dcc_ascii_req = - (dcc_quote == '\'' - && ( (tz390.opt_ascii - && dc_type_sfx != 'E' - ) - || dc_type_sfx == 'A' - ) - ) - | dcc_quote == '"'; //RPI5 and RPI73 - if (dc_bit_len){ - gen_dcc_bits(); - } else { - gen_dcc_bytes(); - } + if (dcc_len > 0 || dc_len_explicit) { // #509 + dcc_ascii_req = + (dcc_quote == '\'' + && ( (tz390.opt_ascii + && dc_type_sfx != 'E' + ) + || dc_type_sfx == 'A' + ) + ) + | dcc_quote == '"'; //RPI5 and RPI73 + if (dc_bit_len){ + gen_dcc_bits(); + } else { + gen_dcc_bytes(); + } + } else { // #509 + log_error(88,"invalid data field expression - " + dc_field); // #509 + } // #509 dc_len = 0; } private void gen_dcc_bits(){ diff --git a/src/mz390.java b/src/mz390.java index d944ca8fb..d4c392312 100644 --- a/src/mz390.java +++ b/src/mz390.java @@ -30,6 +30,7 @@ import java.util.LinkedList; import java.util.regex.Matcher; import java.util.regex.Pattern; +import java.util.regex.PatternSyntaxException; // #509 import javax.swing.JTextArea; @@ -446,6 +447,7 @@ public class mz390 { * 2023-04-12 #458 B2C issue; insure X2C length is multiple of 2 * 2023-06-21 #485 fix O attribute value for extended mnemonics * 2024-06-02 #527 set &SYSOPT_OPTABLE to correct value + * 2024-07-03 #509 fixes for HLASM built-in functions ******************************************************** * Global variables (last RPI) *****************************************************/ @@ -456,6 +458,13 @@ public class mz390 { int max_substring_len = 100000; int max_ap_files = 10; // max concurrent AREAD and PUNCH files int max_lcl_key_root = 47; // hash index for each macro instance + /* + * constants // #509 + */ + int max_mac_dec_digits = 10; // #509 + int max_mac_bin_digits = 32; // #509 + int max_mac_hex_digits = 8; // #509 + String max_pos_int_plus_one = "2147483648"; // #509 /* * subordinate */ @@ -738,6 +747,10 @@ public class mz390 { Matcher symbol_match = null; Pattern exec_pattern = null; Matcher exec_match = null; + Pattern signedDecimalPattern = null; // #509 + Pattern binDigitsPattern = null; // #509 + Pattern decDigitsPattern = null; // #509 + Pattern hexDigitsPattern = null; // #509 int label_comma_index = 0; // parm into to comma after macro label else -1 int sublist_count = 0; int tot_pos_parm = 0; // cur pos parms on stack @@ -1520,6 +1533,32 @@ private void compile_patterns(){ } catch (Exception e){ abort_error(4,"expression pattern error - " + e.toString()); } + /* + * signed or unsigned decimal integer // #509 + */ + try { // #509 + signedDecimalPattern = Pattern.compile("([-+]?)([0-9]+)"); // #509 + } catch (PatternSyntaxException e) { // #509 + abort_error(5,"signed decimal pattern error - " + e.toString()); // #509 + } // #509 + /* + * binary, decimal and hexadecimal digits // #509 + */ + try { // #509 + binDigitsPattern = Pattern.compile("[01]+"); // #509 + } catch (PatternSyntaxException e) { // #509 + abort_error(6,"binary digits pattern error - " + e.toString()); // #509 + } // #509 + try { // #509 + decDigitsPattern = Pattern.compile("[0-9]+"); // #509 + } catch (PatternSyntaxException e) { // #509 + abort_error(7,"decimal digits pattern error - " + e.toString()); // #509 + } // #509 + try { // #509 + hexDigitsPattern = Pattern.compile("[0-9a-fA-F]+"); // #509 + } catch (PatternSyntaxException e) { // #509 + abort_error(8,"hexadecimal digits pattern error - " + e.toString()); // #509 + } // #509 } private void open_files(){ /* @@ -5829,7 +5868,7 @@ private void exp_perform_prefix_op(){ */ exp_pop_op(); if (tz390.opt_traceall){ - tz390.put_trace(" PREFIX OP=" + exp_prev_op + "VARS=" +tot_exp_stk_var); + tz390.put_trace(" PREFIX OP=" + exp_prev_op + " VARS=" +tot_exp_stk_var); // #509 } if (tot_exp_stk_var < 1 && exp_stk_op[tot_exp_stk_op].charAt(0) != 'U'){ log_error(175,"missing argument for prefix operator"); @@ -7072,11 +7111,93 @@ private void exp_term(){ log_error(35,"expression parsing error - total stack values=" + tot_exp_stk_var + " total ops=" + tot_exp_stk_op); // RPI 260 } } + // Begin #509 //////////////////////////////////////////////////////////////////////// + /** + * Check if a string is of the form "B'1-32 binary digits'" + * + * @param s the string to check + * @return {@code true} if the string + * (1) begins with "B'" + * (2) ends with "'" + * (3) has 1-32 binary digits between the quotes + * {@code false} otherwise + */ + private boolean isQuotedBinInteger(String s) { // #509 + if (s == null || s.length() != s.trim().length()) return false; + if (s.length() < 4) return false; + if (s.charAt(0) != 'B' || s.charAt(1) != '\'' || s.charAt(s.length()-1) != '\'') return false; + return is32BitBinaryInteger(s.substring(2, s.length()-1), 2); + } + /** + * Check if a string is of the form "X'1-8 hexadecimal digits'" + * + * @param s the string to check + * @return {@code true} if the string + * (1) begins with "X'" + * (2) ends with "'" + * (3) has 1-8 hexadecimal digits between the quotes + * {@code false} otherwise + */ + private boolean isQuotedHexInteger(String s) { // #509 + if (s == null || s.length() != s.trim().length()) return false; + if (s.length() < 4) return false; + if (s.charAt(0) != 'X' || s.charAt(1) != '\'' || s.charAt(s.length()-1) != '\'') return false; + return is32BitBinaryInteger(s.substring(2, s.length()-1), 16); + } + /** + Validate that a string represents a valid 32-bit binary integer + + @param s string to validate + @param base number base of the digits in the string; 10, 16 or 2 + @return true if valid 32-bit binary integer, false otherwise + */ + private boolean is32BitBinaryInteger(String s, int base) { // #509 + if (s == null || s.length() != s.trim().length()) return false; + switch (base) + { + case 10: + if (!isDecDigits(s) || s.length() > 10) return false; + try { if (Long.parseUnsignedLong(s) >= Integer.MAX_VALUE + 1L) return false; } + catch (NumberFormatException e) { return false; } + break; + case 16: + return isHexInt(s); + case 2: + return isBinInt(s); + default: + return false; + } + return true; + } + /** + * Determine whether string is equal to the decimal digits + * representing one more than Integer.MAX_VALUE (2147483647+1) + * @param s string to check + * @return {@code true} if string is "2147483648", + * {@code false} otherwise + */ + private boolean isMaxPosIntPlusOne(String s) { // #509 + return s != null && s.equals(max_pos_int_plus_one) ? true : false; + } + /** + * Determine whether exp_stk_op entry at top + * (most recently added) + offset is unary minus + * @param offset offset from top; less than or equal to zero + * @return {@code true} if unary minus at top + offset + * {@code false} if not or top + offset out of stack range + */ + private boolean isUnaryMinusAtOffset(int offset) // #509 + { + int i = tot_exp_stk_op - 1 + offset; + if (i < 0 || i >= tot_exp_stk_op) return false; + return (exp_stk_op[i].equals("U-") && exp_stk_op_class[i] == exp_class_oper) ? true :false; + } + // End #509 ////////////////////////////////////////////////////////////////////////// private int get_int_from_string(String setc_text,int base){ /* * return integer from string using specified base * Notes: - * 1. return numeric value of string base 10 or 16 + * 1. return numeric value of string base 2, 10 or 16 // #509 * 2. If base 10, ignore trailing non digits * */ @@ -7089,7 +7210,7 @@ private int get_int_from_string(String setc_text,int base){ if (index >= 0){ seta_value = az390.sym_loc[index]; if (tz390.opt_traceall){ - tz390.put_trace("get_int_from_string(" + setc_value + ")=" + seta_value); // rpi 2210 + tz390.put_trace("get_int_from_string(" + setc_value + "," + base + ")=" + seta_value); // rpi 2210 #509 } return seta_value; } @@ -7117,7 +7238,8 @@ private int get_int_from_string(String setc_text,int base){ } return value; } else { - log_error(123,"invalid hex string - " + setc_text); + String s = (base == 2) ? "binary" : "hex"; // #509 + log_error(123,"invalid " + s + " string - " + setc_text); // #509 return 0; } } @@ -7249,11 +7371,15 @@ private void exp_push_sdt(){ exp_stk_val_type[tot_exp_stk_var - 1] = val_seta_type; switch (setc_value.substring(0,1).toUpperCase().charAt(0)){ case 'B': // B'11000001' binary - seta_value = get_int_from_string(setc_value.substring(2,setc_value.length()-1),2); - if (tz390.opt_traceall){ - tz390.put_trace(" PUSH SDT B'=" + setc_value + " = "+ seta_value); - } - exp_stk_seta[tot_exp_stk_var-1] = seta_value; + if (isQuotedBinInteger(setc_value)){ // #509 + seta_value = Integer.parseUnsignedInt(setc_value.substring(2,setc_value.length()-1), 2); // #509 + exp_stk_seta[tot_exp_stk_var-1] = seta_value; // #509 + if (tz390.opt_traceall){ // #509 + tz390.put_trace(" PUSH SDT B'=" + setc_value + " = "+ seta_value); // #509 + } // #509 + } else { // #509 + log_error(195,"bin invalid self defining term - " + setc_value); // #509 + } // #509 break; case 'C': // RPI192 C'..'|C".."|C!..! char sdt if (!tz390.get_sdt_char_int(setc_value)){ @@ -7263,16 +7389,88 @@ private void exp_push_sdt(){ exp_stk_seta[tot_exp_stk_var-1] = seta_value; break; case 'X': // X'C1' hex - seta_value = Long.valueOf(setc_value.substring(2,setc_value.length()-1),16).intValue(); - exp_stk_seta[tot_exp_stk_var-1] = seta_value; + if (isQuotedHexInteger(setc_value)){ // #509 + seta_value = Integer.parseUnsignedInt(setc_value.substring(2,setc_value.length()-1), 16); // #509 + exp_stk_seta[tot_exp_stk_var-1] = seta_value; // #509 + } else { // #509 + log_error(195,"hex invalid self defining term - " + setc_value); // #509 + } // #509 break; case '*': // return max substring length seta_value = max_substring_len; exp_stk_seta[tot_exp_stk_var-1] = seta_value; break; default: // must be ascii number - seta_value = get_int_from_string(setc_value,10); - exp_stk_seta[tot_exp_stk_var-1] = seta_value; + if (is32BitBinaryInteger(setc_value, 10)){ // #509 + seta_value = get_int_from_string(setc_value,10); // #509 + exp_stk_seta[tot_exp_stk_var-1] = seta_value; // #509 + } else { // #509 + /* + * Special case: SDT started as "-2147483648". This + * results in unary minus ("U-") added to exp_stk_op[], + * followed by new SDT (setc_value) "2147483648". The + * original SDT value is valid -- it represents + * Integer.MIN_VALUE which is -2^31. However, + * setc_value "2147483648" is not a valid 32-bit + * binary integer -- it is one more than + * Integer.MAX_VALUE = 2^31 - 1. + * + * The following code handles this case. It checks to + * see if setc_value is one more than the maximum + * integer value. If yes, it checks to see if a unary + * minus was the last item added to exp_stk_op[]. If not, + * then the setc_value is invalid. We must also check + * to see if two unary minus values were just added to + * exp_stk_op[]. This is also an error since --2147483648 + * is 2147483648, an invalid 32-bit integer. HLASM + * indicates this error as an arithmetic overflow. + * + * if setc_value = "2147483638" and is preceded by + * exactly one unary minus, then it is considered valid. + * The seta_value is computed as indicated below. + * + * NOTE THAT THE RETURNED VALUE IS -2147483648 !!! + * + * The get_int_from_string() method incorrectly computes + * the int value as the minimum integer value. However, + * not to worry. Later on, when the expression stack is + * used to evaluate the expression, the following happens: + * 1. the unary minus is removed from exp_stk_op[] + * 2. the exp_stk_seta[] entry is -2147483648 + * 3. seta_value is set to -exp_stk_seta[] entry + * 4. exp_stk_seta[] entry is set to seta_value + * Note that -Integer.MIN_VALUE = Integer.MIN_VALUE !!! + * Therefore, step 3 "corrects" the invalid value + * originally stored in exp_stk_seta[] and step 4 sets + * exp_stk_seta[] to its original value. At this point, + * the unary minus has been processed and the correct + * result is in seta_value and the exp_stk_seta[] entry. + * + * For a typical SDT like "-1", the unary minus is added + * to exp_stk_op[] and 1 is added to exp_stk_seta[]. + * Steps 2,3 and 4 above are + * 2. exp_stk_seta[] entry is 1 + * 3. seta_value = -exp_stk_seta[] entry = -1 + * 4. exp_stk_seta[] = seta_value = -1 + * In both cases, unary minus processing results in + * the unary minus being popped, seta_value being set + * correctly and the exp_stk_seta[] being set correctly. + */ + if (isMaxPosIntPlusOne(setc_value)) { // #509 + if (isUnaryMinusAtOffset(0)) { // #509 + if (!isUnaryMinusAtOffset(-1)) { // #509 + seta_value = get_int_from_string(setc_value,10); // #509 + exp_stk_seta[tot_exp_stk_var-1] = seta_value; // #509 + } else { // #509 + log_error(195,"dec-3 arithmetic overflow - " + setc_value); // #509 + } // #509 + } else { // #509 + log_error(195,"dec-1 invalid self defining term - " + setc_value); // #509 + } // #509 + } else { // #509 + log_error(195,"dec-2 invalid self defining term - " + setc_value); // #509 + } // #509 + } // #509 } } else { log_error(195,"invalid self defining term - " + setc_value); @@ -11862,7 +12060,7 @@ private void exec_pc_ucomp(){ private void exec_pc_a2b(){ /* * convert int to binary string with - * leading zeros to make length mult. 8 + * leading zeros to make length 32 #509 */ seta_value1 = get_seta_stack_value(-1); tot_exp_stk_var--; @@ -11872,7 +12070,7 @@ private void exec_pc_a2b(){ } private void exec_pc_a2c(){ /* - * convert int to character string + * convert int to character string of length 4 #509 */ seta_value1 = get_seta_stack_value(-1); tot_exp_stk_var--; @@ -11886,7 +12084,7 @@ private void exec_pc_a2c(){ } private void exec_pc_a2d(){ /* - * convert int to decimal string + * convert int to decimal string preceded by a plus or minus sign #509 */ seta_value1 = get_seta_stack_value(-1); tot_exp_stk_var--; @@ -11899,7 +12097,7 @@ private void exec_pc_a2d(){ } private void exec_pc_a2x(){ /* - * convert int to hex string + * convert int to hex string of length 8 #509 */ seta_value1 = get_seta_stack_value(-1); tot_exp_stk_var--; @@ -11913,8 +12111,17 @@ private void exec_pc_b2a(){ */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - setc_value = "B'" + setc_value1 + "'"; - exp_push_sdt(); + if (setc_value1.length() > 0) { // #509 + if (isBinInt(setc_value1)) { // #509 + seta_value = Integer.parseUnsignedInt(setc_value1,2); // #509 + } else { // #509 + create_mnote(8,"B2A invalid operand value - "+setc_value1); // #509 + seta_value = 0; // #509 + } // #509 + } else { // #509 + seta_value = 0; // #509 + } // #509 + put_seta_stack_var(); // #509 } private void exec_pc_b2c(){ /* @@ -11924,30 +12131,41 @@ private void exec_pc_b2c(){ setc_value1 = get_setc_stack_value(); int j = setc_value1.length(); if (j != 0) { - j = j % 8; - if (j != 0) { - setc_value1 = "00000000".substring(0,8 - j)+setc_value1; - } - } - StringBuilder stb = new StringBuilder(""); - for (int i = 0; i < setc_value1.length(); i += 8) { - String str = setc_value1.substring(i, i + 8); - stb.append((char)(((int)tz390.ebcdic_to_ascii[Integer.parseInt(str, 2)]) & 0xff)); - } - setc_value = stb.toString(); + if (isBinDigits(setc_value1)) { // #509 + j = j % 8; + if (j != 0) { + setc_value1 = "00000000".substring(0,8 - j)+setc_value1; + } + StringBuilder stb = new StringBuilder(""); + for (int i = 0; i < setc_value1.length(); i += 8) { + String str = setc_value1.substring(i, i + 8); + stb.append((char)(((int)tz390.ebcdic_to_ascii[Integer.parseInt(str, 2)]) & 0xff)); + } + setc_value = stb.toString(); + } else { // #509 + create_mnote(8,"B2C invalid operand value - "+setc_value1); // #509 + setc_value = ""; // #509 + } // #509 + } else { // #509 + setc_value = ""; // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_b2d(){ /* - * convert binary string to decimal string + * convert binary string to decimal string preceded by plus or minus character #509 */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - seta_value = Integer.valueOf(setc_value1,2); - if (seta_value < 0){ - seta_value = - seta_value; - } - setc_value = Integer.toString(seta_value); + if (setc_value1.length() == 0) setc_value1 = "0"; // #509 + if (isBinInt(setc_value1)) { // #509 + seta_value = Integer.parseUnsignedInt(setc_value1,2); // #509 + setc_value = Integer.toString(seta_value); // #509 + if (seta_value >= 0) setc_value = "+"+setc_value; // #509 + } else { // #509 + create_mnote(8,"B2D invalid operand value - "+setc_value1); // #509 + setc_value = ""; // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_b2x(){ @@ -11956,14 +12174,33 @@ private void exec_pc_b2x(){ */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - seta_value = Integer.valueOf(setc_value1,2); - setc_value = Integer.toHexString(seta_value).toUpperCase(); // RPI 1101 - setc_value = ("00000000" + setc_value).substring(setc_value.length()); + int len = setc_value1.length(); // #509 + if (len == 0) { // #509 + setc_value = ""; // #509 + } else { // #509 + if (isBinDigits(setc_value1)) { // #509 + len = len % 4; // #509 + if (len != 0) { // #509 + setc_value1 = "0000".substring(0,4-len)+setc_value1; // #509 + } // #509 + StringBuilder stb = new StringBuilder(""); // #509 + for (int i = 0; i < setc_value1.length(); i += 4) { // #509 + String str = setc_value1.substring(i, i + 4); // #509 + int j = Integer.parseInt(str, 2); // #509 + char c = Integer.toHexString(j).toUpperCase().charAt(0); // #509 + stb.append(c); // #509 + } // #509 + setc_value = stb.toString(); // #509 + } else { // #509 + create_mnote(8,"B2X invalid operand value - "+setc_value1); // #509 + setc_value = ""; // #509 + } // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_c2a(){ /* - * convert 1-4 character string to int + * convert 0-4 character string to int #509 */ check_setc_quotes(1); // RPI 1139 setc_value = "C'" + get_setc_stack_value() + "'"; @@ -11974,35 +12211,60 @@ private void exec_pc_c2b(){ * convert char string to binary string */ check_setc_quotes(1); // RPI 1139 - setc_value = "C'" + get_setc_stack_value() + "'"; - setc_value1 = setc_value; - if (!tz390.get_sdt_char_int(setc_value)){ - log_error(178,"invalid character sdt " + setc_value); - } - seta_value = tz390.sdt_char_int; - setc_value = Integer.toString(seta_value,2); - seta_value = setc_value.length(); - seta_value = seta_value - seta_value/8*8; - if (seta_value != 0){ - setc_value = "00000000".substring(seta_value) + setc_value; - } + setc_value1 = get_setc_stack_value(); // #509 + if (setc_value1.length() == 0) { // #509 + setc_value = ""; // #509 + } else { // #509 + StringBuilder sb = new StringBuilder(""); // #509 + for (int i = 0; i < setc_value1.length(); i++) { // #509 + byte b = (byte)setc_value1.charAt(i); // #509 + if ( !tz390.opt_ascii ) { // #509 + b = tz390.ascii_to_ebcdic[Byte.toUnsignedInt(b)]; // #509 + } // #509 + String str = byteToBinaryString(b); // #509 + sb.append(str); // #509 + } // #509 + setc_value = sb.toString(); // #509 + } // #509 put_setc_stack_var(); } + /** + * Convert binary byte to length 8 binary string // #509 + * + * @param x byte value to convert + * @return value converted to length 8 binary string + */ + private String byteToBinaryString(byte x) // #509 + { // #509 + String s = Integer.toBinaryString(Byte.toUnsignedInt(x)); // #509 + int j = s.length() % 8; // #509 + if (j != 0) s = "0000000".substring(0,8-j)+s; // #509 + return s; // #509 + } // #509 private void exec_pc_c2d(){ /* - * convert char string to decimal string + * convert char string to decimal string prefixed by plus or minus sign #509 */ check_setc_quotes(1); // RPI 1139 - setc_value = "C'" + get_setc_stack_value() + "'"; - setc_value1 = setc_value; - if (!tz390.get_sdt_char_int(setc_value)){ - log_error(179,"invalid character sdt " + setc_value); - } - seta_value = tz390.sdt_char_int; - if (seta_value < 0){ - seta_value = - seta_value; - } - setc_value = Integer.toString(seta_value); + setc_value1 = get_setc_stack_value(); // #509 + setc_value = ""; // #509 + if (setc_value1.length() > 4) { // #509 + create_mnote(8,"C2D invalid operand value; more than 4 characters - " + setc_value1); // #509 + } else if (setc_value1.length() == 0) { // #509 + setc_value = "+0"; // #509 + } else { // #509 + int val = 0; // #509 + for (int i = 0; i < setc_value1.length(); i++) // #509 + { // #509 + byte b = (byte)setc_value1.charAt(i); // #509 + if (!tz390.opt_ascii) { // #509 + b = tz390.ascii_to_ebcdic[Byte.toUnsignedInt(b)]; // #509 + } // #509 + val = (val << 8) + Byte.toUnsignedInt(b); // #509 + } // #509 + setc_value = Integer.toString(val); // #509 + if (val >= 0) setc_value = "+"+setc_value; // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_c2x(){ @@ -12042,29 +12304,48 @@ private void exec_pc_d2a(){ * convert decimal string to int */ check_setc_quotes(1); // RPI 1139 - boolean save_opt_allow = tz390.opt_allow; // RPI 1204 - tz390.opt_allow = true; // RPI 1204 - seta_value = get_seta_stack_value(-1); - tz390.opt_allow = save_opt_allow; // RPI 1204 setc_value1 = get_setc_stack_value(); + if (setc_value1.length() == 0) { // #509 + // HLASM LangRef states this case indicates an error. // #509 + // HLASM does not produce an error; returns 0. // #509 + // Comment next line so z390 matches HLASM behavior // #509 + //create_mnote(8,"D2A invalid operand value; length is zero"); // #509 + seta_value = 0; // #509 + } // #509 + else { // #509 + if (isSignedDecimalInteger(setc_value1)) { // #509 + seta_value = Integer.parseInt(setc_value1); // #509 + } // #509 + else { // #509 + create_mnote(8,"D2A invalid operand value - "+setc_value1); // #509 + seta_value = 0; // #509 + } // #509 + } // #509 put_seta_stack_var(); } private void exec_pc_d2b(){ /* - * convert decimal string to binary string + * convert decimal string to binary string of length 32 #509 */ check_setc_quotes(1); // RPI 1139 - boolean save_opt_allow = tz390.opt_allow; // RPI 1204 - tz390.opt_allow = true; // RPI 1204 - seta_value = get_seta_stack_value(-1); - tz390.opt_allow = save_opt_allow; // RPI 1204 setc_value1 = get_setc_stack_value(); - setc_value = Integer.toString(seta_value,2); - seta_value = setc_value.length(); - seta_value = seta_value - seta_value/8*8; - if (seta_value != 0){ - setc_value = "00000000".substring(seta_value) + setc_value; - } + if (setc_value1.length() == 0) { // #509 + setc_value = ""; // #509 + } else { // #509 + if (isSignedDecimalInteger(setc_value1)) { // #509 + seta_value = Integer.parseInt(setc_value1); // #509 + setc_value = Integer.toBinaryString(seta_value); // #509 + seta_value = setc_value.length(); // #509 + seta_value = seta_value - seta_value/32*32; // #509 + if (seta_value != 0){ // #509 + setc_value = "00000000000000000000000000000000".substring(seta_value) + setc_value; // #509 + } // #509 + } // #509 + else { // #509 + create_mnote(8,"D2B invalid operand value - "+setc_value1); // #509 + setc_value = ""; // #509 + } // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_d2c(){ @@ -12072,17 +12353,29 @@ private void exec_pc_d2c(){ * convert decimal string to char string */ check_setc_quotes(1); // RPI 1139 - boolean save_opt_allow = tz390.opt_allow; // RPI 1204 - tz390.opt_allow = true; // RPI 1204 - seta_value = get_seta_stack_value(-1); - tz390.opt_allow = save_opt_allow; // RPI 1204 setc_value1 = get_setc_stack_value(); - setc_value = "" - + (char)tz390.ebcdic_to_ascii[seta_value >>> 24] - + (char)tz390.ebcdic_to_ascii[seta_value >>> 16 & 0xff] - + (char)tz390.ebcdic_to_ascii[seta_value >>> 8 & 0xff] - + (char)tz390.ebcdic_to_ascii[seta_value & 0xff] - ; + if (setc_value1.length() == 0) { // #509 + // HLASM LangRef states this case indicates an error. // #509 + // HLASM does not produce an error; returns empty string. // #509 + // Comment next line so z390 matches HLASM behavior // #509 + //create_mnote(8,"D2C invalid operand value; length is zero"); // #509 + setc_value = ""; // #509 + } // #509 + else { // #509 + if (isSignedDecimalInteger(setc_value1)) { // #509 + seta_value = Integer.parseInt(setc_value1); // #509 + setc_value = "" // #509 + + (char)tz390.ebcdic_to_ascii[seta_value >>> 24] // #509 + + (char)tz390.ebcdic_to_ascii[seta_value >>> 16 & 0xff] // #509 + + (char)tz390.ebcdic_to_ascii[seta_value >>> 8 & 0xff] // #509 + + (char)tz390.ebcdic_to_ascii[seta_value & 0xff] // #509 + ; // #509 + } // #509 + else { // #509 + create_mnote(8,"D2C invalid operand value - "+setc_value1); // #509 + setc_value = ""; // #509 + } // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_d2x(){ @@ -12090,13 +12383,25 @@ private void exec_pc_d2x(){ * convert decimal string to hex string */ check_setc_quotes(1); // RPI 1139 - boolean save_opt_allow = tz390.opt_allow; // RPI 1204 - tz390.opt_allow = true; // RPI 1204 - seta_value = get_seta_stack_value(-1); - tz390.opt_allow = save_opt_allow; // RPI 1204 - setc_value1 = get_setc_stack_value();; - setc_value = Integer.toHexString(seta_value).toUpperCase(); // RPI 1101 - setc_value = ("00000000" + setc_value).substring(setc_value.length()); + setc_value1 = get_setc_stack_value(); // #509 + if (setc_value1.length() == 0) { // #509 + // HLASM LangRef states this case indicates an error. // #509 + // HLASM does not produce an error; returns empty string. // #509 + // Comment next line so z390 matches HLASM behavior // #509 + //create_mnote(8,"D2X invalid operand value; length is zero"); // #509 + setc_value = ""; // #509 + } // #509 + else { // #509 + if (isSignedDecimalInteger(setc_value1)) { // #509 + seta_value = Integer.parseInt(setc_value1); // #509 + setc_value = Integer.toHexString(seta_value).toUpperCase(); // RPI 1101 // #509 + setc_value = ("00000000" + setc_value).substring(setc_value.length()); // #509 + } // #509 + else { // #509 + create_mnote(8,"D2X invalid operand value - "+setc_value1); // #509 + setc_value = ""; // #509 + } // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_dclen(){ @@ -12157,44 +12462,179 @@ private void exec_pc_double(){ } private void exec_pc_isbin(){ /* - * return 1 if binary string else 0 + * return 1 if 1-32 binary digits string else 0; error if 0 digits // #509 */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - try { - seta_value = Integer.valueOf(setc_value1,2); - setb_value = 1; - } catch (Exception e){ - setb_value = 0; - } + setb_value = 0; // #509 + if (setc_value1.length() != 0 ) { // #509 + if (isBinInt(setc_value1)) setb_value = 1; // #509 + } else { // #509 + create_mnote(8,"ISBIN invalid operand value; length is zero"); // #509 + } // #509 put_setb_stack_var(); } + // Begin #509 //////////////////////////////////////////////////////////////////////// + /** + * Check if string is all binary digits + * + * @param s string to check + * @return {@code true} if all binary digits + * {@code false} otherwise + */ + private boolean isBinDigits(String s) // #509 + { + return (binDigitsPattern.matcher(s).matches()) ? true : false; + } + /** + * Check if string is 1-32 binary digits + * + * @param s string to check + * @return {@code true} if 1-32 binary digits + * {@code false} otherwise + */ + private boolean isBinInt(String s) // #509 + { + return (s != null && s.length() <= 32 && isBinDigits(s)) ? true : false; + } + /** + * Check if string is 1-10 decimal digits having + * maximum value 2147483647 (Integer.MAX_VALUE) + * + * @param s string to check + * @return {@code true} if 1-10 decimal digits and value <= 2147483647 + * {@code false} otherwise + */ + private boolean isdec(String s) // #509 + { + if (!isDecDigits(s) || s.length() > 10) return false; + try { Integer.parseInt(s); return true; } + catch (NumberFormatException e) { return false; } + } + /** + * Check if string 1-10 decimal digits, with possible + * leading sign, having value in range + * [Integer.MIN_VALUE = -2147483648, 2147483647 = Integer.MAX_VALUE] + * @param s String to check + * @return {@code true} if valid + * {@code false} otherwise + */ + private boolean isSignedDecimalInteger(String s) // #509 + { + if (s == null || s.length() == 0) return false; + + Matcher m; + + m = signedDecimalPattern.matcher(s); + if (m.matches()) + { + String sPlusMinus = m.group(1); + String sDigits = m.group(2); + if ( (sPlusMinus.length() == 1 && sDigits.length() > 10) + || (sPlusMinus.length() == 0 && sDigits.length() > 11) + || sDigits.length() == 0 ) return false; + try { Integer.parseInt(s); return true; } + catch (NumberFormatException e) { return false; } + } + return false; + } + /** + * Check if string is all decimal digits + * + * @param s string to check + * @return {@code true} if all decimal digits + * {@code false} otherwise + */ + private boolean isDecDigits(String s) // #509 + { + return (decDigitsPattern.matcher(s).matches()) ? true : false; + } + /** + * Check if string is all hexadecimal digits + * + * @param s string to check + * @return {@code true} if all hexadecimal digits + * {@code false} otherwise + */ + private boolean isHexDigits(String s) // #509 + { + return (hexDigitsPattern.matcher(s).matches()) ? true : false; + } + /** + * Check if string is 1-8 hexadecimal digits + * + * @param s string to check + * @return {@code true} if 1-8 hexadecimal digits + * {@code false} otherwise + */ + private boolean isHexInt(String s) // #509 + { + return (isHexDigits(s) && s.length() <= 8) ? true : false; + } + /** + * Check if character is a hexadecimal digit + * + * @param c character to check + * @return {@code true} if c is a hexadecimal digit + * {@code false} otherwise + */ + private boolean isHexChar(char c) // #509 + { + switch(c) { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + return true; + default: + return false; + } + } + // End #509 ////////////////////////////////////////////////////////////////////////// private void exec_pc_isdec(){ /* - * if string decimal return 1 else 0 + * if string 1-10 decimal digits <= 2147483647 return 1 else 0; error if 0 digits // #509 */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - try { - seta_value = Integer.valueOf(setc_value1); - setb_value = 1; - } catch (Exception e){ - setb_value = 0; - } + setb_value = 0; // #509 + if (setc_value1.length() != 0 ) { // #509 + if (isdec(setc_value1)) setb_value = 1; // #509 + } else { // #509 + create_mnote(8,"ISDEC invalid operand value; length is zero"); // #509 + } // #509 put_setb_stack_var(); } private void exec_pc_ishex(){ /* - * return 1 if string hex else 0 + * return 1 if string 1-8 hex digits else 0; error if 0 digits // #509 */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - try { - seta_value = Integer.valueOf(setc_value1,16); - setb_value = 1; - } catch (Exception e){ - setb_value = 0; - } + setb_value = 0; // #509 + if (setc_value1.length() != 0 ) { // #509 + if (isHexInt(setc_value1)) setb_value = 1; // #509 + } else { // #509 + create_mnote(8,"ISHEX invalid operand value; length is zero"); // #509 + } // #509 put_setb_stack_var(); } private void exec_pc_issym(){ @@ -12213,6 +12653,9 @@ private void exec_pc_issym(){ } } else { setb_value = 0; + if (setc_value1.length() == 0){ // #509 + create_mnote(8,"ISSYM invalid operand value; length is zero"); // #509 + } // #509 } put_setb_stack_var(); } @@ -12232,17 +12675,64 @@ private void exec_pc_sla(){ seta_value1 = get_seta_stack_value(-2); seta_value2 = get_seta_stack_value(-1); tot_exp_stk_var = tot_exp_stk_var - 2; - seta_value = seta_value1 << seta_value2; - if (seta_value1 >= 0){ - seta_value = seta_value & 0x7fffffff; - } else { - seta_value = seta_value | 0x80000000; - } + seta_value = shiftLeftArithmetic(seta_value1, seta_value2); // #509 if (tz390.opt_tracem){ // RPI 1212 tz390.put_trace("SLA " + seta_value + " = " + seta_value1 + " SLA " + seta_value2); } - put_seta_stack_var(); + put_seta_stack_var(); // #509 } + /** + * Implement HLASM LangRef SLA built-in function // #509 + * + * @param x the number to shift + * @param n the number of bits to shift + * @return x shifted left n bits if no error; else 0 + * + * Note: Only the low 6 bits of n are used. For example, + * n = -1 = X'FFFFFFFF' is changed to X'0000003F' = 63 + * and n = X'80000000' (Integer.MIN_VALUE) is changed + * to 0. + * + * Arithmetic overflow error logged if a bit that is not + * the original sign bit is shifted into the sign position. + */ + private int shiftLeftArithmetic(int x, int n) // #509 + { + n &= 0x3F; // only use the six low-order bits + if (n == 0 || x == 0) return x; + if (n >= 32) // shifting non-zero value through the sign bit + { + create_mnote(8,"SLA: Arithmetic overflow"); + return 0; + } + // 1 <= n <= 31 + // set mask: bits 0..n are 1, n+1..31 are 0 + int mask = Integer.MIN_VALUE >> n; +// System.out.printf("n = %d mask = %08X x = %08X%n",n,mask,x); + // flip mask bits if x is non-negative + if (x >= 0) mask = mask ^ 0xFFFFFFFF; +// System.out.printf("n = %d mask = %08X x = %08X%n",n,mask,x); + mask >>>= 31-n; // move mask bits to right end + int xMask = x >>> 31-n; // same bits in x +// System.out.printf("x bits for mask = %08X mask = %08X%n",xMask,mask); + if (xMask != mask) + { + create_mnote(8,"SLA: Arithmetic overflow"); + return 0; + } + return x << n; + } + /** + * Create mask containing n+1 one bits in the leftmost position // #509 + * + * @param n number of one bits (not including sign bit); 1--31 + * @return an integer containing n+1 one bits in leftmost position + * and zero in the remaining bit positions + */ + private int shiftLeftArithmeticSignMask(int n) // #509 + { + return Integer.MIN_VALUE >> n; + } private void exec_pc_sll(){ /* * shift left logical @@ -12250,7 +12740,8 @@ private void exec_pc_sll(){ seta_value1 = get_seta_stack_value(-2); seta_value2 = get_seta_stack_value(-1); tot_exp_stk_var = tot_exp_stk_var - 2; - seta_value = seta_value1 << seta_value2; + int n = seta_value2 & 0x3F; // #509 + seta_value = (n <= 31) ? seta_value1 << n : 0; // #509 if (tz390.opt_tracem){ // RPI 1212 tz390.put_trace("SLL " + seta_value + " = " + seta_value1 + " SLL " + seta_value2); } @@ -12263,11 +12754,12 @@ private void exec_pc_sra(){ seta_value1 = get_seta_stack_value(-2); seta_value2 = get_seta_stack_value(-1); tot_exp_stk_var = tot_exp_stk_var - 2; - seta_value = seta_value1 >> seta_value2; + int n = seta_value2 & 0x3F; // #509 + seta_value = seta_value1 >> Math.min(n,31); // #509 if (tz390.opt_tracem){ // RPI 1212 tz390.put_trace("SRA " + seta_value + " = " + seta_value1 + " SRA " + seta_value2); } - put_seta_stack_var(); + put_seta_stack_var(); // #509 } private void exec_pc_srl(){ /* @@ -12276,11 +12768,12 @@ private void exec_pc_srl(){ seta_value1 = get_seta_stack_value(-2); seta_value2 = get_seta_stack_value(-1); tot_exp_stk_var = tot_exp_stk_var - 2; - seta_value = seta_value1 >>> seta_value2; + int n = seta_value2 & 0x3F; // #509 + seta_value = (n <= 31) ? seta_value1 >>> n : 0; // #509 if (tz390.opt_tracem){ // RPI 1212 tz390.put_trace("SRL " + seta_value + " = " + seta_value1 + " SRL " + seta_value2); } - put_seta_stack_var(); + put_seta_stack_var(); // #509 } private void exec_pc_sattra(){ /* @@ -12292,6 +12785,7 @@ private void exec_pc_sattra(){ int cur_sym = mz390_find_sym(setc_value1); if (cur_sym >= 0){ setc_value = az390.sym_attra[cur_sym]; + if (setc_value == null) setc_value = ""; // #509 } else { setc_value = ""; } @@ -12330,11 +12824,16 @@ private void exec_pc_x2a(){ */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - try { - seta_value = Integer.valueOf(setc_value1,16); - } catch (Exception e){ - seta_value = 0; // RPI 1085 - } + if (setc_value1.length() > 0) { // #509 + if (isHexInt(setc_value1)) { // #509 + seta_value = Integer.parseUnsignedInt(setc_value1,16); // #509 + } else { // #509 + create_mnote(8,"X2A invalid operand value - "+setc_value1); // #509 + seta_value = 0; // #509 + } // #509 + } else { // #509 + seta_value = 0; // #509 + } // #509 put_seta_stack_var(); } private void exec_pc_x2b(){ @@ -12343,13 +12842,25 @@ private void exec_pc_x2b(){ */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - seta_value1 = Integer.valueOf(setc_value1,16); - setc_value = Integer.toString(seta_value1,2); - seta_value = setc_value.length(); - seta_value = seta_value - seta_value/8*8; - if (seta_value != 0){ - setc_value = "00000000".substring(seta_value) + setc_value; - } + if (setc_value1.length() == 0) { // #509 + setc_value = ""; // #509 + } else { // #509 + StringBuilder sb = new StringBuilder(""); // #509 + for (int i = 0; i < setc_value1.length(); i++) { // #509 + char c = setc_value1.charAt(i); // #509 + if (!isHexChar(c)) { // #509 + sb = new StringBuilder(""); // #509 + create_mnote(8,"X2B invalid operand value - "+setc_value1); // #509 + break; // #509 + } // #509 + int val = Integer.parseInt(setc_value1.substring(i, i+1),16); // #509 + String str = Integer.toBinaryString(val); // #509 + int j = str.length() % 4; // #509 + if (j != 0) str = "000".substring(0,4-j)+str; // #509 + sb.append(str); // #509 + } // #509 + setc_value = sb.toString(); // #509 + } // #509 put_setc_stack_var(); } private void exec_pc_x2c(){ @@ -12363,22 +12874,33 @@ private void exec_pc_x2c(){ StringBuilder stb = new StringBuilder(""); for (int i = 0; i < setc_value1.length(); i += 2) { String str = setc_value1.substring(i, i + 2); - stb.append((char)(((int)tz390.ebcdic_to_ascii[Integer.parseInt(str, 16)]) & 0xff)); + if (isHexInt(str)) { // #509 + stb.append((char)(((int)tz390.ebcdic_to_ascii[Integer.parseInt(str, 16)]) & 0xff)); + } else { // #509 + stb = new StringBuilder(""); // #509 + create_mnote(8,"X2C invalid operand value - "+setc_value1); // #509 + break; // #509 + } // #509 } setc_value = stb.toString(); put_setc_stack_var(); } private void exec_pc_x2d(){ /* - * convert hex string to decimal string + * convert hex string to decimal string preceded by plus or minus sign // #509 */ check_setc_quotes(1); // RPI 1139 setc_value1 = get_setc_stack_value(); - seta_value = Integer.valueOf(setc_value1,16); - if (seta_value < 0){ - seta_value = - seta_value; - } - setc_value = Integer.toString(seta_value); + if (setc_value1.length() == 0) setc_value1 = "0"; // #509 + if (isHexInt(setc_value1)) { // #509 + seta_value = Integer.parseUnsignedInt(setc_value1,16); // #509 + setc_value = Integer.toString(seta_value); // #509 + if (seta_value >= 0) setc_value = "+"+setc_value; // #509 + } else { // #509 + create_mnote(8,"X2D invalid operand value - "+setc_value1); // #509 + setc_value=""; // #509 + seta_value=0; // #509 + } // #509 put_setc_stack_var(); } private void get_pc_created_var(int offset){ @@ -12504,7 +13026,7 @@ private void put_continued_text(BufferedWriter file_buff,String text){ } if (text.length() < tz390.bal_ictl_end + 1){ // RPI 264, RPI 437 RPI 728 tz390.systerm_io++; - // HLASM LR says PUNCH can write all 256 EBCDIC characters. + // HLASM LangRef says PUNCH can write all 256 EBCDIC characters. // Decide if put_bal_line keeps non-printable text. file_buff.write(text_work + tz390.newline); // RPI 500 } else { diff --git a/z390test/src/test/groovy/org/z390/test/RunHLASMBuiltInFunctionsTests.groovy b/z390test/src/test/groovy/org/z390/test/RunHLASMBuiltInFunctionsTests.groovy new file mode 100644 index 000000000..29557414b --- /dev/null +++ b/z390test/src/test/groovy/org/z390/test/RunHLASMBuiltInFunctionsTests.groovy @@ -0,0 +1,116 @@ +package org.z390.test + +import org.junit.jupiter.api.Test + +class RunHLASMBuiltInFunctionsTests extends z390Test { + + /* + * Test the High Level Assembler (HLASM) built-in functions + */ + + var options = ["SYSMAC(${basePath("mac")})"] + + @Test + void test_TESTOPR2() { + + // Tests that use MNOTE, AIF to check results; no errors + + int rc = this.asmlg(basePath("rt", "test", "TESTOPR2"), *options) + this.printOutput() + assert rc == 0 + } + + @Test + void test_TOPR2() { + + // Tests that use code to check results; no errors + + // Where report of test done using code is written + + this.env.put('REPORT', basePath('rt', 'mlc', 'TOPR2.TST')) + + int rc = this.asmlg(basePath("rt", "mlc", "TOPR2"), *options) + this.printOutput() + assert rc == 0 + } + + @Test + void test_C2BDX00() { + + // Tests for C2B. C2D. C2X with X'00' in argument; no errors + + int rc = this.asm(basePath("rt", "mlc", "C2BDX00"), *options) + this.printOutput() + assert rc == 0 + } + + @Test + void test_A2BE1() { + + // Error tests for A2B; 1 invalid self-defining term; rc = 12 + + int rc = this.asm(basePath("rt", "mlc", "A2BE1"), *options) + this.printOutput() + assert rc == 12 + } + + @Test + void test_A2BE2() { + + // Error tests for A2B; 1 arithmetic overflow; rc = 12 + + int rc = this.asm(basePath("rt", "mlc", "A2BE2"), *options) + this.printOutput() + assert rc == 12 + } + + @Test + void test_ISBINE1() { + + // Error tests for ISBIN; 1 invalid operand value - length is 0; rc = 8 + + int rc = this.asm(basePath("rt", "mlc", "ISBINE1"), *options) + this.printOutput() + assert rc == 8 + } + + @Test + void test_ISDECE1() { + + // Error tests for ISDEC; 1 invalid operand value - length is 0; rc = 8 + + int rc = this.asm(basePath("rt", "mlc", "ISDECE1"), *options) + this.printOutput() + assert rc == 8 + } + + @Test + void test_ISHEXE1() { + + // Error tests for ISHEX; 1 invalid operand value - length is 0; rc = 8 + + int rc = this.asm(basePath("rt", "mlc", "ISHEXE1"), *options) + this.printOutput() + assert rc == 8 + } + + @Test + void test_ISSYME1() { + + // Error tests for ISSYM; 1 invalid operand value - length is 0; rc = 8 + + int rc = this.asm(basePath("rt", "mlc", "ISSYME1"), *options) + this.printOutput() + assert rc == 8 + } + + @Test + void test_SLAE1() { + + // Error tests for SLA; 10 arithmetic overflows; rc = 8 + + int rc = this.asm(basePath("rt", "mlc", "SLAE1"), *options) + this.printOutput() + assert rc == 8 + } +} diff --git a/zcobol/mac/GEN_MOVE.MAC b/zcobol/mac/GEN_MOVE.MAC index 585136daa..179bee7e0 100644 --- a/zcobol/mac/GEN_MOVE.MAC +++ b/zcobol/mac/GEN_MOVE.MAC @@ -54,6 +54,7 @@ .* 03/27/12 RPI 1182 support variable length RMD move .* 04/14/12 RPI 1202 use D2A to retrieve neg &NT_IX and &NS_IX .* 04/20/12 RPI 1211 scale value if pic_dec values different +.* 2024/07/03 #509 correct length in &N_TARGET substring extraction .********************************************************************* GEN_MOVE &T_NAME,&T_IX,&S_NAME,&S_IX COPY ZC_WS @@ -2014,7 +2015,7 @@ :&FIELD_OFF SETA D2A('&N_TARGET'(1,&I-1)) RPI 1139 :&J SETA ('&N_TARGET' INDEX ',') AIF (&J GT &I+1) - :&FIELD_LEN SETA D2A('&N_TARGET'(&I+1,&J-1)) + :&FIELD_LEN SETA D2A('&N_TARGET'(&I+1,&J-&I-1)) #509 :&FIELD_REG SETC '&N_TARGET'(&J+1,K'&N_TARGET-&JX -1) :&N_TARGET SETC '&N_TARGET'(1,&I).'&N_TARGET'(&JX diff --git a/zopcheck/ZOPMACRO.CPY b/zopcheck/ZOPMACRO.CPY index 690fd46cb..881c12f60 100644 --- a/zopcheck/ZOPMACRO.CPY +++ b/zopcheck/ZOPMACRO.CPY @@ -23,6 +23,7 @@ * 2020/09/19 DSH RPI 2213 REMOVE TYPE DM, ADD DIAGNOSE/DIAG RS, SIE S * 2020/10/02 DSH RPI 2212 RESTORE TYPE_VRR FROM V1700, ADD VREGS 0-31 * 2021/02/08 DSH RPI 2226 FIX VNOT TO GENERATE V3=V2 FOR VNOT V1,V2 +* 2024/04/26 jjg #509 fix bugs with X2A usage due to X2A changes ************************************************************ GBLA &TOT_OPS,&TOT_MASK,&TOT_DUP,&TOT_UND GBLA &TOT_PROB,&TOT_SUPR,&TOT_MISSING @@ -377,7 +378,11 @@ &HEX SETC '&LAB'(3,2) &HEX2 SETC '&LAB'(5,2) &HEX3 SETC '&LAB_OP'(7,1) + AIF ('&HEX3' NE '_') #509 &M3 SETA X2A('&HEX3') + AELSE #509 +&M3 SETA 0 #509 + AEND #509 AIF (N'&SYSLIST EQ 4 AND '&HEX3' NE '_') GBLA &TOT_MASK &TOT_MASK SETA &TOT_MASK+1 @@ -580,7 +585,11 @@ DC X'&HEX',AL1(&P3*16+0,&P1*16+&P2) AELSE SELGR R1,R2 OOOO3M12 GBLA &TOT_MASK &TOT_MASK SETA &TOT_MASK+1 + AIF ('&LAB_OP'(7,1) NE '_') #509 &M3 SETA X2A('&LAB_OP'(7,1)) + AELSE #509 +&M3 SETA 0 #509 + AEND #509 &LAB_OP ORG &OP_LAB+16 DC X'&HEX',AL1(&P3*16+&M3,&P1*16+&P2) @@ -1608,7 +1617,11 @@ DC X'&HEX',AL1(&P3*16+0,&P1*16+&P2) DC X'&HEX',AL1(&V1*16+&V2),S(&P3),AL1(&M4*16+&VREG_RXB),X'&HEX2' AELSEIF ('&LAB'(3,4) EQ 'E736') VREGS VP1=&P1,VP2=&P2 // RPI 2212 VLM V1,V3,D2(B2),M4 + AIF ('&LAB'(7,1) NE '_') #509 &M3 SETA X2A('&LAB'(7,1)) + AELSE #509 +&M3 SETA 0 #509 + AEND #509 &LAB_OP&LAB_OP ORG &OP_LAB+16 DC X'&HEX',AL1(&V1*16+&V2),S(&P3),AL1(&M3*16+&VREG_RXB),X'&HEX2' AELSEIF ('&LAB'(3,4) EQ 'E738' OR '&LAB'(3,4) EQ 'E73A') @@ -1622,7 +1635,11 @@ DC X'&HEX',AL1(&P3*16+0,&P1*16+&P2) DC X'&HEX',AL1(&V1*16+&P2),S(&P3),AL1(&VREG_RXB),X'&HEX2' AELSEIF ('&LAB'(3,4) EQ 'E73E') VREGS VP1=&P1,VP2=&P2 // RPI 2212 VSTM V1,V3,D2(B2) RPI 2216 + AIF ('&LAB'(7,1) NE '_') #509 &M4 SETA X2A('&LAB'(7,1)) + AELSE #509 +&M4 SETA 0 #509 + AEND #509 &LAB_OP&LAB_OP ORG &OP_LAB+16 DC X'&HEX',AL1(&V1*16+&V2),S(&P3),AL1(&M4*16+&VREG_RXB),X'&HEX2' AELSEIF ('&LAB'(3,4) EQ 'E730') @@ -1704,4 +1721,4 @@ DC X'&HEX',AL1(&P3*16+0,&P1*16+&P2) MNOTE 12,'VSI INVALID OPERAND COUNT &LAB_OP ' AEND MEND -* END OF INS6MACS.CPY BY TESTINS6.MLC \ No newline at end of file +* END OF INS6MACS.CPY BY TESTINS6.MLC