* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
*                             БAЗA ДAHHЫX TP
*                  ПPOГPAMMA TPVOC - ПPOГPAMMA-CЛOBAPЬ
*
*  ФУHKЦИЯ:
*    KOДИPOBAHИE И PACKOДИPOBAHИE CЛOB C ПOMOЩЬЮ CЛOBAPЯ
*
*  BXOД:
*    1) KOДИPOBAHИE CЛOBA
*        R0 = 0
*        R1 = @ БУФEPA, B KOTOPOM HAXOДИTCЯ KOДИPУEMOE CЛOBO. CЛOBO
*        MOЖET COДEPЖATЬ ПPOБEЛЫ. KOHEЦ CЛOBA - ПO HEAЛФABИTHO-ЦИФPO-
*        BOMУ CИMBOЛУ
*    2) PACKOДИPOBAHИE CЛOBA
*        R0 = ИДEHTИФИKATOP CЛOBA B MЛ. ДBУX БAЙTAX
*
* BЫXOД:
*   1) ПPИ KOДИPOBAHИИ CЛOBA
*        R0 = ИДEHTИФИKATOP CЛOBA B MЛAДШEM ПOЛУCЛOBE ИЛИ 0, ECЛИ БЫЛA
*             OШИБKA
*        R1 = @ CИMBOЛA-TEPMИHATOPA B БУФEPE
*   2) ПPИ PACKOДИPOBAHИИ CЛOBA
*        R0 = ДЛИHA PACKOДИPOBAHHOГO CЛOBA ИЛИ 0, ECЛИ БЫЛA OШИБKA
*        R1 = @ БУФEPA, ГДE COДEPЖИTCЯ PACKOДИPOBAHHOE CЛOBO
*   B CЛУЧAE OШИБKИ ГЛOБAЛЬHAЯ ПEPEMEHHAЯ BASERR COДEPЖИT KOД (HEX):
*       100   - HEЛЬЗЯ OTKPЫTЬ H.Д. CЛOBAPЯ
*       101   - HEBEPHЫЙ ИДEHTИФИKATOP (HE COГЛACУETCЯ CO CЛOBAPEM)
*       102   - HEBEPHЫЙ CЛOBAPЬ (HET / ПOCЛE ПOCЛEДHEГO CЛOBA)
*       103   - CЛИШKOM ДЛИHHOE CЛOBO (БOЛЬШE 255 CИMBOЛOB)
*       104   - УKAЗAHHOE CЛOBO HE HAЙДEHO B CЛOBAPE
*   ИЛИ ЖE KOД, BЫДAHHЫЙ ДPУГOЙ ПPOГPAMMOЙ PAБOTЫ C Б.Д.
*
* AЛГOPИTM:
*   ECЛИ ГЛOБAЛЬHAЯ ПEPEMEHHAЯ BASERR УЖE COДEPЖИT KOД OШИБKИ,
*   BЫXOД C R0=0
*   ПPИ ПOИCKE CЛOBA ПO CЛOBAPЮ ЛИДИPУЮЩИE И XBOCTOBЫE ПPOБEЛЫ OБPEЗA-
*   ЮTCЯ, BHУTPEHHИE ПPOБEЛЫ CBOДЯTCЯ K OДHOMУ
*   CЛOBAPЬ - ПOCЛEДOBATEЛЬHЫЙ H.Д., COДEPЖAЩИЙ 1 ЗAПИCЬ HEOПPEДEЛEHHOЙ
*   ДЛИHЫ. ЗAПИCЬ COДEPЖИT CЛOBA, PAЗДEЛEHHЫE CИMBOЛOM /. ПOCЛE ПOCЛ.
*   CЛOBA TAKЖE ДOЛЖHO ИДTИ /. ИДEHTИФИKATOP CЛOBA - HOMEP CЛOBA B
*   ЗAПИCИ H.Д. CЛOBAPЯ.
*   CЛOBAPЬ OПИCЫBAETCЯ DD-ПPEДЛOЖEHИEM VOC. ПPИ ПEPBOM OБPAЩEHИИ K
*   ПPOГPAMME CЛOBAPЬ OTKPЫBAETCЯ И ЧИTAETCЯ EГO ЗAПИCЬ. ПPИ ПOCЛEДУЮ-
*   ЩИX OБPAЩEHИЯX ИCПOЛЬЗУETCЯ ПPOЧИTAHHAЯ ЗAПИCЬ.
*   ПPOГPAMMA HEPEEHTEPAБEЛЬHA.
*
*  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
         EJECT
*                          REGISTERS' USAGE
R0       EQU   0
R1       EQU   1      WORK AND LINK REGISTERS
R14      EQU   14
R15      EQU   15
RW       EQU   4    WORK REGISTER
RL       EQU   5    LOOP & LENGTH REGISTER
RM       EQU   6    WORK
RN       EQU   7    IDENTIFIER
RBASE    EQU   13   BASE REGISTER
RBASE1   EQU   12   SUBROUTINES BASE REGISTER
         SPACE
DELIM    EQU   C'/'                    WORDS DELIMITER IN VOC RECORD
         SPACE
         PRINT NOGEN
         BLOCK (2-14),VS,TPVOC
         SPACE 2
***********************************************************************
*                          ИHИЦИAЛИЗAЦИЯ
         SPACE
         L     R15,=V(BASERR)
         L     R15,0(R15)
         LTR   R15,R15                 Q. WAS A DATA BASE ERROR
         BNE   INC1                    NO - CONTINUE THE WORK
         SR    R0,R0                   ELSE EXIT
         B     EOJ
         SPACE
INC1     INTO  OPEN                    OPEN A VOC DATA SET & READ REC
         LTR   RN,R0                   LOAD AN IDENTIFIER
         BZ    ENCODE                  ENCODE THE WORD
         EJECT
***********************************************************************
*                        DECODE THE WORD
*   RN = IDENTIFIER
*   VOC RECORD HAS BEEN ALREADY WRITTEN INTO BUFFER
         SPACE 2
         L     RW,BUFF@                LOAD VOC RECORD PTR
         LR    RL,RW
         AH    RL,BUFFL                RL = END OF RECORD PTR
         BCTR  RN,0
         LTR   RN,RN                   IF THE 1. WORD IS NEEDED,
         BZ    DCL1EX                  RW HAS YET CONTAINED THE PTR
         SPACE
DCL1     CLI   0(RW),DELIM             FIND THE RN-TH WORD IN
         BE    DCL1C                   VOC RECORD,
         LA    RW,1(RW)                THAT IS SCAN THE DELIMETER
         CR    RW,RL                   RN-1 TIMES
         BNL   ERR1
         B     DCL1
DCL1C    BCT   RN,DCL1
         SPACE
DCL1EX   LR    R1,RW                   PTR TO WORD FOUND
DCL2     CLI   0(RW),DELIM             FIND THE END OF CURRENT
         BE    DCL2EX                  WORD (DELIM SYMBOL)
         LA    RW,1(RW)
         CR    RW,RL
         BNL   ERR2                    ERROR - NO DELIM AFTER THE
         B     DCL2                    LAST WORD
DCL2EX   LR    R0,RW
         SR    R0,R1                   LENGTH OF WORD FOUND
         B     EOJ
         EJECT
***********************************************************************
*                    ENCODE THE WORD
*   R1 = @ WORDS BUFFER
*   VOC RECORD HAS BEEN ALREADY WRITTEN INTO BUFFER
ENCODE   EQU   *
         SPACE
*----------------------------------------------------------------------
*                   WRITE THE WORD TO WORK BUFFER
* CUTTING THE LEADING AND TAIL BLANKS AND COMPRESSING THE INTERMEDIATE
* BLANKS USING THE R-PROGRAMMING TECHNIQUE
         SPACE
CTERM    EQU   1                       END OF WORD SPECIAL SYMBOL
         MACRO
&LABI    RTRAN &SYMB,&NEXT
.*                   R-PROGRAMMING TECHNIQUE
.*
.* &LABI - LABEL OF GROUP OF ACTIONS TO TEST CURRENT SYMBOL
.* &SYMB - IF SYMBOL SPECIFIED MATCHES WITH CURRENT THEN ACTION
.*         IS EXECUTED THAT FOLLOWS THIS MACRO. ELSE THE ACTION IS
.*         SKIPPED TO NEXT RTRAN MACRO
.* &NEXT - LABEL TO WHICH CONTROL IS PASSED AFTER THE ACTION HAS BEEN
.*         EXECUTED
.* EACH GROUP OF RTRAN MACROS MUST BEGIN WITH LABELLED MACRO AND
.* END WITH RTRAN MACRO WITHOUT OPERANDS
.*
.* R1 IS ASSUMED TO BE THE PTR TO NEXT SYMBOL, R0 - CURRENT SYMBOL
         GBLC  &##RTRLE                INTERNAL LABEL OF NEXT MACRO
         GBLC  &##RTRBL                SAME AS  &NEXT OF PREV. MACRO
         AIF   (T'&LABI EQ 'O').GCONT  CONTINUE THE CURRENT GROUP
&LABI    EQU   *                       BEGIN THE NEW GROUP
         SR    R0,R0                   GET THE CURRENT SYMBOL
         IC    R0,0(R1)                IN R0 AND ADVANCE THE
         LA    R1,1(R1)                POINTER
         CH    R0,=Y(C'Ю')             CHECK FOR ALFANUMERIC SYMBOL
         BNL   *+8
         LA    R0,CTERM                ELSE THE SYMBOL-TERMINATOR
         AGO   .SAN
.GCONT   ANOP                          CONTINUE THE CURRENT GROUP
         B     &##RTRBL                END OF PREVIOUS ACTION
         AIF   (T'&NEXT EQ 'O').SAN       -- BRANCH TO &NEXT
&##RTRLE EQU   *                       LABEL TO PASS PREV ACTION
.SAN     ANOP
&##RTRLE SETC  'IHB'.'&SYSNDX'         FORM THE LABEL TO PASS ACTION
         AIF   (T'&SYMB EQ 'O').NOTEST NO TESTING WITH CURRENT SYMBOL
         LA    R15,&SYMB
         CR    R0,R15                  COMPARE WITH CURRENT SYMBOL
         BNE   &##RTRLE                MISMATCH - PASS THE ACTION
.NOTEST  AIF   (T'&NEXT EQ 'O').END
&##RTRBL SETC  '&NEXT'                 SET THE &NEXT LABEL
.END     MEND
         SPACE 2
         MACRO
         MOVEC
.*   MOVE THE CURRENT SYMBOL (R0) TO BUFFER AND CHECK FOR OVERFLOW
         STC   R0,0(RW)
         LA    RW,1(RW)
         CR    RW,RL
         BNL   ERR3
         MEND
         EJECT
*----------------------------------------------------------------------
*                          R-ALGORITHM ITSELF
         SPACE
         LA    RW,STRBUF               PTR TO BEGIN OF WORK BUFFER
         LA    RL,STRBUF+L'STRBUF      PTR TO END OF WORK BUFFER
         SPACE
CRM1     RTRAN C' ',CRM1               SKIP THE LEADING BLANKS
         RTRAN CTERM,ERR4              NULL WORD - NOT FOUND
         RTRAN ,CRM2
         MOVEC
         RTRAN
         SPACE
CRM2     RTRAN CTERM,CREX              END OF WORD IS REACHED
         RTRAN C' ',CRM3               THE BLANK IS OCCURED
         MOVEC                         MOVE IT IN BUFFER
         RTRAN ,CRM2
         RTRAN
         SPACE
CRM3     RTRAN C' ',CRM3               COMPRESS THE INTERMEDIATE BLANKS
         RTRAN CTERM,CREX
         BCTR  RW,0                    DELETE THE TAIL BLANK FROM BUFF
         RTRAN ,CRM2
         MOVEC
         RTRAN
         SPACE 2
CREX     MVI   0(RW),DELIM             INSERT THE DELIMETER AFTER WORD
         EJECT
*----------------------------------------------------------------------
*           SEARCH FOR THE WORD JUST PROCESSED IN THE VOC RECORD
* STRBUF CONTAINS THAT WORD
* DON'T CHANGE R1 !!!
         SPACE
         L     RW,BUFF@                VOC RECORD PTR
         LR    RL,RW
         AH    RL,BUFFL                PTR TO END OF RECORD
         SR    RN,RN                   CLEAR THE COUNTER
         SPACE
CSL1     LA    RN,1(RN)                INCREMENT THE WORD COUNTER
         LR    R0,RW                   PTR TO CURRENT WORD
CSL2     CLI   0(RW),DELIM             SEARCH FOR END OF CURR WORD
         LA    RW,1(RW)
         BNE   CSL2
         CR    RW,RL                   WORD IS NOT FOUND
         BNL   ERR4                                  ERROR
         LR    R15,RW
         SR    R15,R0                  LENGTH OF CURRENT WORD
         BCT   R15,*+10
         CLC   STRBUF(1),0(R1)         COMPARE THE WORDS
         EX    R15,*-6
         BNE   CSL1                    NOT MATCHES - TRY AGAIN
         SPACE
         LR    R0,RN                   SET THE ANSWER
         B     EOJ                                R1 ?????
         EJECT
***********************************************************************
*                         KOHEЦ PAБOTЫ
EOJ      EQU   *
         BEND
         SPACE 2
***********************************************************************
*                        OБPAБOTKA OШИБOK
ERR0     EQU   *                       CAN'T OPEN THE VOC DATA SET
         LA    R0,X'100'               SET ERROR CODE
         B     ERREXIT
         SPACE 2
ERR1     EQU   *                       ILLEGAL IDENTIFIER
         LA    R0,X'101'               SET ERROR CODE
         B     ERREXIT
         SPACE 2
ERR2     EQU   *                       INVALID VOCABULARY
         LA    R0,X'102'               SET ERROR CODE
         B     ERREXIT
         SPACE 2
ERR3     EQU   *                       TOO LONG WORD
         LA    R0,X'103'               SET ERROR CODE
         B     ERREXIT
         SPACE 2
ERR4     EQU   *                       WORD HAS NO BEEN FOUND
         LA    R0,X'104'               SET ERROR CODE
         B     ERREXIT
         SPACE 2
ERREXIT  EQU   *                       ERROR EXIT
         L     R15,=V(BASERR)
         ST    R0,0(R15)
         SR    R0,R0                   INDICATE ERROR
         B     EOJ
         SPACE 2
         EJECT
***********************************************************************
*          П/П OPEN - OTKPЫTИE CЛOBAPЯ И ЧTEHИE EГO ПEPBOЙ ЗAПИCИ B
*                БУФEP, ECЛИ ЭTO HE БЫЛO УЖE CДEЛAHO PAHЬШE
OPEN     BLOCK (0-14),N,BASE=12
         TM    DCB+48,X'10'            Q. DATA SET HAS BEEN OPENED
         BO    OPEX                    YES - ALL ACTION HAS BEEN DONE
         SPACE
         OPEN  (DCB,(INPUT))
         TM    DCB+48,X'10'
         BZ    ERR0                    FAILURE AT OPEN THE VOC
         GET   DCB                     READ THE 1. VOC RECORD
         LA    R1,0(R1)                CLEAR THE HIGH ORDER BYTE
         ST    R1,BUFF@                SAVE THE PTR TO THIS RECORD
         MVC   BUFFL,DCB+82            MOVE THE RECORD LENGTH
         SPACE
OPEX     BEND
         EJECT
***********************************************************************
*                    KOHCTAHTЫ И PAБOЧИE ПOЛЯ
         SPACE
BUFF@    DS    A                       VOC RECORD PTR
BUFFL    DS    H                       VOC RECORD LENGTH
STRBUF   DS    CL256                   WORK BUFFER
DCB      DCB   DSORG=PS,RECFM=U,MACRF=(GL),DDNAME=VOC
         SPACE
         LTORG
         SPACE
         END
