         REF      KEYMAX
         PCC      1
         SPACE
         SYSTEM   SIG7
         SYSTEM   BPM
MONPROC  SET      1
UTSPROC  SET      0
         SYSTEM   UTS
         CLOSE    PUSH
         TITLE    'LEMUR3 -- I/O FUNCTIONS'
         SPACE    3
*M*      LEMUR3   I/O ROUTINES FOR LEMUR
         SPACE    3
*P********************************************************************
*P*
*P* NAME:   LEMUR3
*P*
*P* PURPOSE:
*P*      CONTAINS ALL MONITOR-DEPENDENT  CALS; DOES ALL THE WORK
*P*      OF SETTING UP FPTS, VLPS AND BLTS. (WITH MAYO)
*P*
*P* CONTENTS:
*P*      SIREAD   READS A RECORD FROM THE M:SI DCB
*P*      OPENROM  OPENS F:ROM TO A SPECIFIED FILE.
*P*      READROM  READS A RECORD FROM A ROM FILE OR A ROM IN THE LIB.
*P*      OPENLIB  SETS UP F:LIB TO TALK TO A SPECIFIED FILE.
*P*      GTBLK    GETS A BLOCK FOR A REF/DEF ENTRY.
*P*      FREESPC  RELEASES ALL SPACE ACQUIRED THROUGH GTBLK.
*P*      RSTCPY   PREPARES FOR  COPYING A ROM INTO THE LIBRARY
*P*      CPYROM   COPIES A ROM FROM SOURCE (OPENROM) INTO LIBRARY.
*P*      IOERRSW  DOES SMART TABLE BRANCH FOR I/O ERROR HANLERS.
*P*      DICENT   WRITES A DICTIONARY ENTRY FOR A SYMBOL.
*P*      MDICKEY  MAKES A DICTIONARY KEY FOR A SPECIFIED SYMBOL
*P*
*P********************************************************************
         PAGE
         SPACE
*P********************************************************************
*P*
*P* DCB USAGE:
*P*      F:ROMIN  USED TO READ RECORDS FROM A ROM
*P*      F:LIB    USED TO UPDATE THE WORKING LIBRARY.
*P*      F:SORS   USED TO READ THE SOURCE LIBRARY
*P*      M:SI     USED TO READ COMMANDS
*P*      M:LL     GETS OUTPUT FOR LISTS, ETC.
*P*      M:DO     GETS ERROR COMMENTARY.
*P*
*P********************************************************************
         TITLE    'LEMUR3 -- REFS AND DEFS'
         SPACE
*****************************************************************
*
* REFS AND DEFS:
*
*        1.       ROUTINES DEFINED IN THIS MODULE.
*
         SPACE
         DEF      SIREAD            READ RECORD FROM M:SI
         DEF      OPENROM           OPEN F:ROMIN TO A FILE
         DEF      CLSDCB
         DEF      KEYDESC
         DEF      SETNAME           SET N.A.P VLP IN DCB.
         DEF      READROM           READ A RECORD FROM SOURCE ROM.
         DEF      OPENLIB           OPEN F:LIB TO A FILE.
         DEF      CRELIB            CREATE LIBRARY
         DEF      MAKEKEY           MAKE KEY FROM DESCRIPTOR
         DEF      RDKEY             READ KEYED RECORD.
         DEF      GETBLK            GET A REF/DEF BLOCK.
         DEF      FREESPC           RELEASE ALL REF/DEF BLOCKS.
         DEF      RSTCPY            PREPARE FOR COPYING A ROM W/ CPYROM
         DEF      CPYROM            COPY ROM INTO LIBRARY
         DEF      IOERRSW           SMART TABLE BRANCH FOR ERROR HANDERS
         DEF      DICENT            WRITE A DICTIONARY ENTRY FOR A SYMBOL
         DEF      MDICKEY           MAKE A DICTIONARY KEY.
         DEF      GETC              GET A CHARACTER FROM F:ROMIN STREAM
         DEF      OPENSI            OPEN SI DCB FOR INPUT
         DEF      OPENLL            OPEN LL DCB FOR OUTPUT
         DEF      OPENDO            OPEN DO DCB FOR OUTPUT
         DEF      CKCORR            CHECK DCB CORRESPONDENCES
         DEF      WRITELL           WRITE RECORD TO LL
         DEF      ECHOLL            WRITE RECORD TO LL IFFI LL .NE. SI
         DEF      WRITEDO           WRITE RECORD TO DO
         DEF      ECHODO            WRITE RECORD TO DO IFFI DO .NE. SI
         DEF      A2BFBTD           GET WA, BTD FROM DESCRIP
         DEF      HSHINIT           INITIALIZE HASH BUCKETS
         DEF      WINDOWN           TERMINATE RUN.
         DEF      RDERRFL           READ RECORD FROM ERROR FILE.
         DEF      SETRAPS
         DEF      READSEQ           READ NEXT RECORD
         DEF      DELKEY            DELETE A RECORD WITH KEY
         DEF      DELREC            DELETE LAST RECORD READ.
         DEF      DROMS
         DEF      DPOINTERS
         DEF      DICDEL            DELETE SYMBOL FROM DICTIONARY.
         DEF      DLMN              DELETE LMN RECORDS FROM LIB.
         DEF      CLOSEREL
         DEF      CARLMN
         DEF      DICENT1
         DEF      COPY              COPY AN ENTIRE LIBRARY
         DEF      DEMPTY            DELETE FILE IF NO RECS. LEFT.
         DEF      DICCHECK          CHECK FOR DICTIONARY ENTRY.
         PAGE
         SPACE
*
*   2.   ROUTINES DEFINED ELSEWHERE.
*
         SPACE
         REF      APPEND            RTN:   APPENDS ONE STRING TO ANOTHER
         REF      RETURN            RTN:  DOES A POP-JUMP.
         REF      ERRENT            RTN:  DOES ERROR HANDLING.
         REF      RETCC0            RTN:  DOES A POP-JUMP:  CC0-3 := 0
         REF      RETCC3            RTN:   DOES POP-JUMP:  CC := 3
         PAGE
         SPACE
*
*  3.    DYNAMIC DATA.
*
         SPACE
         REF      ADJNAME           FPT:   OPEN-PRIME FPT TO ADJUST
*,*                                        NAME.ACCOUNT.PASSWORD
         REF      BLKEND            PTR:   LAST WORD OF REF/DEF POOL
         REF      BLKPOOL           PTR:   FIRST WORD OF REF/DEF POOL
         REF      BLKPTR            PTR:   NEXT FREE WD OF REF/DEF POOL
         REF      C%OPTS            DWD:   OPTION FLAGS
         REF      DO#LL             CC:    SET ==> M:DO .NE. M:LL
         REF      ERRHIT            CELL:  # OF ERRORS SEEN THIS RUN.
         REF      FACCN             CELL:  START OF ACN AREA IN VLP
*,*                                        PART OF ADJNAME FPT.
         REF      FNAME             CELL:  START OF NAME AREA IN VLP
*,*                                        OF ADJNAME FPT.
         REF      FPASS             CELL:  START OF PASSWORD AREA IN
*,*                                        VLP OF ADJNAME FPT.
         REF      FREECHN           PTR:   HEAD OF FREE-BLOCK CHAIN
         REF      HSHTBL            PTR VECTOR:
*,*                                        HEADS OF HASH CHAINS FOR
*,*                                        THE SYMBOL TABLE.
         REF      IKEYBUF           BUFFER:
*,*                                        GETS RECORD KEY FOR READING
*,*                                        ROM FROM A LIBRARY.
         REF      KEYBUF            BUFFER:
*,*                                        KEY USED BY RDKEY TO GET RECORD
         REF      MODNAME           BUFFER:
*,*                                        TEXTC OF MODULE BEING ADDED
*,*                                        BY COPYROM
         REF      OKEYBUF           BUFFER:
*,*                                        KEY USED FOR COPYING ROM
*,*                                        INTO LIBRARY.
         REF      ROMBUF            BUFFER:
*,*                                        GETS INPUT RECORDS FROM ROMS
         REF      ROMEOF            FLAG:  BITS=2-3 # 0 MEANS THAT EOF
*,*                                        HAS BEEN DETECTED FOR CURRENT
*,*                                        ROM.
         REF      ROMPT             DESC:  UNREAD PORTION OF ROMBU
         REF      ROMSRC            FLAG:  IF NON-ZERO, THEN ROM IS
*,*                                        COMING FROM FILE, NOT LIB.
         REF      SI#DO             CC:    SET ==> SI .NE. DO
         REF      SI#LL             CC:    SET ==> M:SI .NE. M:LL
         REF      SYM               PTR:   REF/DEF BLOCK WE ARE WORKING
*,*                                        WITH AT THE MOMENT.
         REF      SCRATCH           SCRATCH PAD
         REF      D:DESTMOD
         REF      D:LTYPEX
         REF      L:DCB
         REF      D:SORSMOD
         REF      L:SIZE
         REF      L:PAGES
         REF      L:BUF
         PAGE
         SPACE
*
*  4.    STATIC DATA.
*
         SPACE
         REF      FACCNI            CELL:  INITIAL VALUE FOR FACCN
         REF      FNAMEI            CELL:  INITIAL VALUE FOR FNAME
         REF      FPASSI            CELL:  INITIAL VALUE FOR FPASS
         REF      O%ERR             CELL:  FLAG TO SAY WHETHER TO ABORT
         PAGE
         SPACE
*
*  5.    DATA FROM 'LITERALS.'
*
         SPACE
         REF      BLANK             CELL:  C'    ' (X'40404040')
         REF      BT31TO0           ORDERED TABLE OF BITS FROM LSB TO MSB
         REF      HEX               TABLE OF EBCDIC HEX DIGITS.
         REF      M24               X'00FFFFFF' (-X'FF000001')
         REF      X0                ZERO:
         REF      YFF               X'FF000000'
         REF      YFFFE             X'FFFE0000'
         REF      Y002              X'00200000'
         REF      Y02               X'02000000'
         SPACE    2
*
*  6.    SYMBOLS DEFINED BY MONITOR.
*
         SPACE
         REF      J:TCB             PTR:  @ OF LEMUR'S TCB TEMP STACK
         PAGE
*
*  7.    DCBS CREATED BY LOADER
         REF      M:SI,M:LL,M:DO
*
         PAGE
         SPACE
*
*  7.    ERROR CODES.
*
         SPACE
         REF      E#CCRL            CAN'T CREATE LIBRARY
         REF      E#COF             CAN'T OPEN FILE
         REF      E#COL             CAN'T OPEN LIBRARY
         REF      E#ILRC            ILLEGAL ROM BYTE COUNT
         REF      E#ILRH            ILLEGAL ROM HEADER
         REF      E#IOERR           I/O ERROR DETECTED
         REF      E#IOERRA          I/O ERROR DETECTED:  ABORT.
         REF      E#ISTBG           INPUT STRING IS TOO BIG (>255 CH)
         REF      E#NES             NOT ENOUGH SPACE (FOR REF/DEF BLOCKS)
         REF      E#NLIB            NOT A LIBRARY FILE
         REF      E#OLIB            OLD-STYLE LIBRARY FILE.
         REF      E#IDS             ILLEGAL DUPLICATE SYMBOL
         SPACE
         REF      E#NOCORE
*
*  8.    CONSTANTS DEFINED ELSEWHERE IN LEMUR:
*
         SPACE
         REF      BLK:L             CONSTANT:  # OF WORDS/BLOCK
         REF      D:LTYPE           DESCRIPTOR TABLE OF LMN REC. TYPES.
         REF      HSH:N             CONSTANT:  LOG-2 OF # OF WDS IN HSHTBL
         REF      BLANKS
         SPACE
*
*  9.    SYMBOLS DEFINED ELSEWHERE IN LEMUR
*
         SPACE
         REF      ROMSIZE
         REF      D:LTYPELAST
         TITLE    'LEMUR3 -- DCBS'
         SPACE
F:LIB    DSECT
F:LIB    M:DCB    (FILE),KEYED,DIRECT,INOUT,SAVE,;
                  (EXECUTE),(EXPIRE),(PASS),(READ),(SYNON),;
                  (UNDER),(WRITE)
         PAGE
         SPACE
F:ROMIN  DSECT
F:ROMIN  M:DCB    (FILE),(CONSEC),(SEQUEN),(IN),(SAVE),;
                  (EXECUTE),(EXPIRE),(PASS),(READ),(SYNON),;
                  (UNDER),(WRITE)
         PAGE
F:SORS   DSECT
F:SORS   M:DCB    (FILE),KEYED,DIRECT,INOUT,SAVE,;
                  (EXECUTE),(EXPIRE),(PASS),(READ),(SYNON),;
                  (UNDER),(WRITE)
         PAGE
         SPACE
         PAGE
         SPACE
*
*        F:ERR    --USED TO READ ERROR MESSAGES
*
         SPACE
F:ERR    DSECT    2
         SPACE
F:ERR    M:DCB    (FILE,'ERRMSG',':SYS'),(IN),(DIRECT),(PASS)
         TITLE    'LEMUR3 -- MISCELLANEOUS DEFINITIONS'
         SPACE
***************************************************************
*
* REGISTER DEFINITIONS
*
I1       EQU      1
I2       EQU      2
I3       EQU      3
T0       EQU      4
T1       EQU      5
T2       EQU      6
T3       EQU      7
R0       EQU      8
R1       EQU      9
R2       EQU      10
R3       EQU      11
A0       EQU      12
A1       EQU      13
A2       EQU      14
A3       EQU      15
RTN      EQU      A3
*
* I AGREE, THEY ARE RATHER NON-STANDARD.
*
***************************************************************
         PAGE
         SPACE
*************************************************************
*
* CONTROL SECTIONS --
*
         SPACE
CODE     CSECT    1
STRINGS  CSECT    1
         M:PT     1
         SPACE
TYPE     EQU      1                 TYPE FIELD IS IN WORD 1 OF THE DCB
         PAGE
         SPACE
***************************************************************
*
*  TYPES OF OBJECTS IN SCTBL--
*
* NAME            VALUE             MEANING                DESCRIPTORS
* ----            -----             -------                -----------
         SPACE
T%MNAME  EQU      1                 MODULE NAME            1
T%GRP    EQU      2                 GROUP NAME             1
T%DNAME  EQU      3                 SYMBOL (DEF)           1
T%LID    EQU      4                 LIBRARY NAME (N).A.P   3
T%FID    EQU      5                 FILE NAME N(.(A)(.P))  3
T%DEF    EQU      6                 DEF W/ MNAME DEF>>M    2
T%EOL    EQU      7                 END OF LINE
T%GRNCH  EQU      8                 N(.(A)(.P))<GNAM>/MNAM 5
T%UN     EQU      9                 + (UNION OP)           0
T%INT    EQU      10                - (INTERSECTION)       0
T%EQ     EQU      11                = (REPLACEMENT)        0
T%ON     EQU      12                'ON'/'TO'              0
T%OVER   EQU      13                'OVER'                 0
T%USING  EQU      14                'USING'                0
         TITLE    'LEMUR3 -- MACROS'
         SPACE
***************************************************************
*
*  MISCELLANEOUS MACROS--
*
*        CALL     ROUTINE
*                 EMITS A STANDARD (BAL,RTN) CALL TO AF(1)
*
CALL     S:SIN,1  X'6AF'
         SPACE
*
*
* SUBROUTINE:
*        GENERATES A 'PSW,15 *J:TCB'
*
SUBROUTINE ;
         CNAME
         PROC
LF       EQU,0    %
         PSW,RTN  *J:TCB
         PEND
         PAGE
         SPACE
*
*        PUSH     R                 PUSHES REGISTER 'R' ONTO TEMP STACK IN TCB
*        POP      R                 POPS TCB STACK INTO REGISTER R
*        PUSH     R1,R2             PUSHES REGISTERS R1 THROUGH R2 ON
*                                   TCB TEMP STACK
*        POP      R1,R2             POPS REGISTERS R1 THROUGH R2 FROM
*                                   TCB TEMP STACK
*
         SPACE
PUSH     CNAME    1
POP      CNAME    0
         PROC
LF       EQU,0    %
         LOCAL    I
         DO       NUM(AF)>1
I        SET      ((AF(2)-AF(1))+17)&X'F'
         DO1      I=1
I        SET      0
         LCI      I
         ELSE                       JUST A SIMPLE PSW,OR PLW, PLEASE.
I        SET      1                 PUSHING 1 WORD.
         FIN
         GEN,1,5,1,1,4,3,17 1,2,I~=1,NAME,AF(1),0,J:TCB
         PEND
         PAGE
         SPACE
*
*  D(STRING)
*        RETURNS AS ITS VALUE THE DESCRIPTOR OF ITS ARGUMENT
D        FNAME
         PROC
         LOCAL    HERE,I
HERE     EQU      %
         USECT    STRINGS
I        TEXT     AF
         USECT    HERE
         PEND     (S:NUMC(AF)**24)+BA(I)
         SPACE
*
*  E(ERROR NUMBER)
*        RETURNS AS ITS VALUE THE ADDRESS TO BRANCH TO FOR
*        THAT ERROR CODE.
*
E        FNAME
         PROC
         PEND     +AF
*
IOERR    COM,8,7,17  CF(2)**-8,CF(2)&X'7F',AF
         TITLE    'LEMUR3 -- SIREAD -- READS A COMMAND'
         SPACE
         USECT    CODE              ---START OF CODE---
         SPACE
*F************************************************************
*F*
*F* NAME:  SIREAD
*F*      READS RECORD FROM M:SI, APPENDING IT TO STRING DESCRIBED
*F*      BY (A2).
*F*
*F* DESCRIPTION:
*F*      RECORD IS DIRECTLY APPENDED TO THE SPECIFIED STRING BY
*F*      THE M:READ CAL; NOTE THAT A STRING WHICH WOULD EXCEED
*F*      256 CHARACTERS IF THE INPUT WERE APPENDED CAUSES ERROR
*F*      E#ISTBG (INPUT STRING TOO BIG).
*F*
*F*************************************************************
         PAGE
         SPACE
SIREAD   SUBROUTINE                 LINK = RTN
         STW,A2   SCRATCH           SAVE BUFFER IN CASE WE READ A
*                                   COMMENT.
         LB,A0    A2                GET LENGTH OF STRING,
         LCW,R3   A0                CALCULATE # OF CHARACTERS TO READ
         AI,R3    +255              (MAX):  CURRENT N-255 => # AVAIL.
         BLEZ     E(E#ISTBG)        B/NO SPACE AVAILABLE TO READ INTO.
         AW,A0    A2                MAKE BA OF NEXT CH AFTER STRING,
         LW,A1    A0                GET COPY TO MAKE BTD,
         SLS,A0   -2                GET WORD @ OF STRING.
         M:READ   M:SI,(BUF,*A0),(BTD,*A1),(SIZE,*R3),;
                  (ABN,SIECCH),(ERR,SIECCH)
         LH,T3    M:SI+ARS          GET SIZE OF INPUT LINE,
         SLS,T3   -1                MAKE IT A BYTE COUNT,
         AW,T3    A1                GET ADR OF END OF STRING,
         AI,T3    -1                POINT TO LAST BYTE,
         LB,R0    0,T3              GET LAST BYTE,
         CI,R0    +X'C0'            IS IT A CONTROL CODE?
         BAZ      %+2               B/ YES.
         AI,T3    +1                ELSE SAVE LAST CHARACTER,
         PUSH     T3
         PUSH     A2
         SW,T3    A1                COMPUTE DESCRIPTOR OF INPUT LINE.
         STB,T3   A1
         LW,A2    A1
         LC       DO#LL             SHOULD I ECHO TO M:DO AND M:LL?
         BE       %+2               B/ NO, DON'T ECHO TO M:DO.
         CALL     ECHODO            ELSE WRITE TO M:DO IF IT AIN'T THERE
         BAL,RTN  ECHOLL            ECHO TO LL
         POP      A2
         POP      T3
         SW,T3    A2
         STB,T3   A2                COMPUTE DESCRIPTOR OF TOTAL LINE.
         LB,T3    *A0               SEE IF WE HAVE A COMMENT.
         CI,T3    '*'
         BNE      RETCC0            B/NO CLEAR CC AND RETURN.
         LW,A2    SCRATCH           YES. COMMENT, READ NEXT LINE.
         B        SIREAD+1
         SPACE
SIECCH   EQU,0    %
         CALL     IOERRSW
         IOERR,X'0500'  RETCC3      END OF DECK ==> ALL DONE
         IOERR,X'0600'  RETCC3      END OF FILE ==> ALL DONE
         IOERR,X'0700'  E(E#ISTBG) LOST DATA, BUFF TOO SMALL.
         IOERR,0  E(E#IOERR)        ELSE GO REPORT ERROR AND QUIT.
         SPACE
BNR8     B        *8                HANDY TO HAVE AROUND.
         TITLE    'LEMUR3 -- RDKEYSQ -- READ NEXT KEY IN SEQUENCE'
         SPACE
*F***************************************************************
*F*
*F* NAME:  RDKEYSQ
*F*      READS FIRST RECORD AFTER OR INCLUDING A SPECIFIED KEY.
*F*
*F* DESCRIPTION:
*F*      TALKING THROUGH F:LIB, WE FIRST ATTEMPT TO READ A RECORD
*F*      WITH THE KEY WHOSE DESCRIPTOR IS (A2).  IF THIS FAILS, THEN
*F*      WE ATTEMPT TO READ THE NEXT RECORD AFTER THE ONE SPECIFIED;
*F*      IF NONE IS FOUND, THEN WE RETURN CC3,4=3.
*F*
*F***************************************************************
         PAGE
         SPACE
RDKEYSQ  SUBROUTINE
         LI,A1    +KEYBUF           FIRST, GO COPY KEY INTO KEYBUF;
         BAL,T3   MAKEKEY
         LW,R0    Y002              CHECK:  IS F:LIB TALKING TO ...
         CW,R0    *L:DCB            ...ANYTHING AT THE MOMENT?
         BAZ      RETCC3            B/ NOT OPEN, TREAT AS END OF FILE.
         M:READ   *L:DCB,(KEY,KEYBUF),(ERR,RDKYSQE),(ABN,RDKYSQE),;
                  (SIZE,0)
* HMM....I GOT A RECORD.  I HOPE YOU KNOW WHAT TO DO IF THE KEY D
* ACTUALLY EXISTS...
         SPACE
RDKYSQ0  EQU      %
         LW,T3    L:DCB             GET KEY ADDRESS.
         LW,A2    KBUF,T3
         LI,RTN   RETCC0            WHEN DONE, WE HAVE SUCCEEDED;
         B        KEYDESC           B/ GO MAKE A DESCRIPTOR OF KEY IN A2.
         SPACE
* GOT AN ERROR WHILE TRYING TO READ A RECORD --
RDKYSQE  CALL     IOERRSW
         IOERR,X'0700'  BNR8        LOST DATA ==> WE GOT A RECORD?!
         IOERR,X'4300'  RDKYSQ2     NO RECORD W/KEY; GET NEXT.
         IOERR,X'0600'  RETCC3      END OF FILE ==> NO RECORD AFTER
*                                   THIS KEY.
         IOERR,0        E(E#IOERR)  ELSE REPORT ERROR AND CROAK.
         SPACE
* NO RECORD BY ORIGINAL KEY; TRY FOR FIRST ONE AFTER...
RDKYSQ2  EQU,0    %
         M:READ   *L:DCB,(ABN,RDKYSQE),(ERR,RDKYSQE),(SIZE,0)
         B        RDKYSQ0           B/ GOT THE RECORD, GO RETURN KEY.
         TITLE 'LEMUR3 -- MAKEKEY -- MAKES DESCRIBED STRING INTO KEY'
         SPACE
*F**************************************************************
*F*
*F* NAME:  MAKEKEY
*F*      MAKES DESCRIBED STRING INTO FILE-SYSTEM-STYLE KEY.
*F*
*F* DESCRIPTION:
*F*      THE STRING WHOSE DESCRIPTOR IS (A2) IS COPIED INTO THE BUFFER
*F*      WHOSE WORD ADDRESS IS (A1); THE RESULTING STRING IS IN
*F*      TEXTC FORM.
*F*
*F**************************************************************
         SPACE
MAKEKEY  EQU,0    %
         LB,A0    A2                GET LENGTH OF STRING,
         STB,A0   *A1               AND POKE IT AWAY.
         SLS,A1   +2                MAKE BYTE ADDRESS OF DESTINATION,
         AI,A1    +1                POINT TO BYTE AFTER COUNT,
         STB,A0   A1                MAKE DESCRIPTOR OF DESTINATION,
         LW,A0    A2                ON YOUR MARK, GET SET,...
         MBS,A0   +0                ...GO!
         B        0,T3              B/ ALL DONE, GO AWAY.
         TITLE    'LEMUR3 -- KEYDESC -- MAKES DESCRIPTOR FROM TEXTC'
         SPACE
*F*************************************************************
*F*
*F* NAME:  KEYDESC
*F*      GIVEN WORD ADDRESS OF TEXTC STRING, CONSTRUCTS DESCRIPTOR.
*F*
*F* DESCRIPTION:
*F*      WHAT CAN I SAY?  (I KNOW, YOU'VE BEEN WONDERING.)  GIVEN
*F*      THAT (A2) IS WORD ADDRESS OF TEXTC STRING, WE RETURN
*F*      (A2) AS DESCRIPTOR OF SAME.  ONLY CLOBBERS A1.
*F*
*F*************************************************************
         SPACE
KEYDESC  EQU,0    %
         LB,A1    *A2               GET THE COUNT,
         SLS,A2   +2                MAKE THE BASE ADDRESS,
         AI,A2    +1                ...
         STB,A1   A2                AND POKE THE COUNT AWAY.
         B        *RTN              ALL DONE.
         TITLE    'LEMUR3 -- OPENROM -- PREPARES TO READ A ROM'
         SPACE
*F****************************************************************
*F*
*F* NAME:  OPENROM
*F*      OPENS F:ROMIN TO FILE SPECIFIED BY DESCRIPTORS POINTED
*F*      TO BY (A1).  (A1) IS THE INDEX TO THE FIRST OF A VECTOR
*F*      OF THREE DESCRIPTORS.
*F*
*F****************************************************************
         SPACE
OPENROM  EQU,0    %
         LI,A2    +1                MARK ROM AS COMING FROM A FILE, NOT
         STW,A2   ROMSRC            ...FROM THE LIBRARY.
         LI,T2    +F:ROMIN          MAKE SURE THIS DCB IS CLOSED...
         BAL,T3   SETNAME           ...BY TELLING SOMEONE ELSE TO DO
*                                    SOMETHING TO IT.
*** NEXT, OPEN THE DCB FOR INPUT, AND DO ALL THE SETUP FOR
*** READING THE ROM.
         LI,T1    +E(E#COF)         IF WE CAN'T OPEN, BITCH.
         BAL,T3   OPNDCBI           ELSE OPEN THE DCB FOR INPUT
*                                   (LOOK UP ABOVE:  (T2) = .F:ROMIN
         LCI      +0                REMEMBER THAT WE HAVEN'T SEEN
         STCF     ROMEOF            ...END OF FILE YET.
         LI,R0    +0                ZAP ERROR/ABN ADDRESS
         BAL,T3   SETDCB            SO THAT BIZZARRE I/O ERRORS WONT
*                                   ...DO BIZZARRE THINGS.
         STW,R0   ROMPT             REMEMBERING THAT SETDCB DOESN'T ...
*                                   CHANGE R0, SET FLAG FOR GETC:
*                                   WE NEED TO READ A RECORD FROM ROM.
         B        *RTN              AND EXIT.
         TITLE    'LEMUR3 -- SETNAME -- SETS VLPS IN DCB'
         SPACE
*F**************************************************************
*F*
*F* NAME:  SETNAME
*F*      BUILDS ADJUST DCB PLIST TO SET NAME, ACCOUNT, PASSWORD
*F*      AS PER 3-WORD VECTOR OF DESCRIPTORS, THE @ OF WHICH
*F*      IS IN A1.  IT THEN PERFORMS THE OPEN' CAL, OPERATING
*F*      ON THE DCB WHOSE @ IS IN T2.  LINK IS T3.
*F*        T2, T3, A1 AND RTN ARE PRESERVED; THE DCB IS CLOSED.
*F*
*F**************************************************************
         SPACE
SETNAME  EQU,0    %
         PUSH     T2,T3             SAVE DCB NAME, RETURN @
         BAL,T3   CLSDCB            MAKE SURE DCB IS CLOSED.
         SPACE
*** AT THIS POINT, WE NEED TO BUILD AN OPEN' FPARAM LIST SO WE
*** CAN SET THE DCB'S NAME.
*** WE START BY MOVING IN THE NAME.
         LW,T0    A1                COPY THE INDEX INTO A USEFUL PLACE,
         LW,R0    FNAMEI            SET UP THE FILE-NAME WORD OF THE VLP
         STW,R0   FNAME
         LW,A2    0,T0              GET DESCRIPTOR OF NAME,
         LI,A1    FNAME+1           GET DESTINATION ADDRESS,
         BAL,T3   MAKEKEY           AND MAKE A TEXTC STRING (CHEEP).
         SPACE
*** NOW, MOVE IN THE ACCOUNT NAME, IF ONE WAS SPECIFIED.
         LW,R0    FACCNI            PRESET SIGNIFICANCE WORD FOR ACN.
         LW,R1    BLANK             PRESET ACCOUNT NAME TO BLANKS,
         STD,R1   FACCN+1           (NOTE: FACCN+1 MUST BE DWORD BOUND)
         LW,T2    1,T0              GET DESCRIPTOR OF ACCOUNT,
         BEZ      OPENRMP           B/ NONE, GO EAT PSW.
         LB,T1    T2                GET COUNT OF PASSWORD,
         CI,T1    +8                MORE THAN EIGHT CHARACTERS?
         BL       %+2               B/ YES: FORCE TO EIGHT.
         LI,T1    +8                FORCE TO EIGHT CHARACTERS,
         LI,T3    +BA(FACCN+1)      GET DESTINATION ADDRESS,
         STB,T1   T3                SAVE THE COUNT,
         MBS,T2   +0                AND COPY THE ACCOUNT IN.
         AI,R0    +X'200'           REMEMBER THAT THESE ARE SIGNIFICANT
*                                   WORDS, AND...
OPENRMP  STW,R0   FACCN             SAVE THE ACCOUNT INFO.
         SPACE
*
* NOW MOVE IN THE PASSWORD.
         LW,R0    FPASSI            GET INITIAL PASSWORD PRESENCE WORD.
         STD,R1   FPASS+1           PRESET ACCOUNT NAME TO BLANKS.
         LW,T2    2,T0              GET DESCRIPTOR OF PASSWORD.
         BEZ      OPNROMC           IF NONE, GO SAVE PARAMETER WD
* A PASSWORD IS WAITING TO BE MOVED IN...
         LB,T1    T2                GET THE COUNT OF THE PASSWORD,
         CI,T1    +8                IS IT TOO LONG?
         BLE      %+2               B/ NO, GO AHEAD.
         LI,T1    +8                ELSE FORCE TO MAX ALLOWED.
         LI,T3    +BA(FPASS+1)      GET DESTINATION ADDRESS,
         STB,T1   T3                POKE THE COUNT INTO THE DEST. PTR,
         MBS,T2   +0                AND MERGE THE PASSWORD INTO THE FPT.
         AI,R0    +X'200'           MARK THESE WORDS AS BEING SIGNIFICANT.
OPNROMC  STW,R0   FPASS             NOW, SAVE THE PARAM. WD. IN ITS
*                                   PROPER PLACE.
         SPACE
*** THE OPEN' PLIST HAS BEEN BUILT...
*** NOW DO A NUMBER ON THE F:ROMIN DCB.
         POP      T2,T3             GET DCB NAME, RTN ADDRESS.
         CAL1,1   ADJNAME           AND MERGE IN NAME, ACNT, & PSW.
         B        0,T3              ALL DONE.  BYE.
         SPACE    2
*** NOW, WASN'T THAT EASY???
***
         TITLE    'LEMUR3 -- SETLIB -- SET LIBRARY NAME'
         TITLE    'LEMUR3 -- OPNDCBI -- OPENS A SPECIFIED DCB,TINPUT'
         SPACE
OPNDCBI  EQU,0    %                 LINK = T3, DCB = T2, ERROR/ABN=T1
         M:SETDCB *T2,(ERR,*T1),(ABN,*T1)
         M:OPEN   *T2,(IN),(ERR,*T1),(ABN,*T1)
         B        0,T3              ALL DONE, EXIT.
         TITLE    'LEMUR3 -- CLSDCB -- CLOSES A DCB, SAVE'
         SPACE
CLSDCB   EQU,0    %                 LINK = T3, T2B==.DCB
         LW,R0    Y002              IS DCB ALREADY CLOSED:
         CW,R0    0,T2
         BAZ      0,T3              B/ YES:  EXIT, NOTHING TO DO.
,CLSDCBF M:CLOSE  *T2,SAVE          ELSE CLOSE W/ SAVE,
         B        0,T3              NOW EXIT.
         TITLE    'LEMUR3 -- READROM -- READS A RECORD THROUGH F:ROMIN'
         SPACE
*F*************************************************************
*F*
*F* NAME:  READROM
*F*      READS A RECORD FROM A ROM WHICH IS EITHER IN THE LIBRARY
*F*      OR IN AN EXTERNAL FILE.
*F*
*D* CALL:
*D*      T3,<= BYTE ADDRESS OF BUFFER INTO WHICH RECORD SHOULD BE READ.
*D*      BAL,T2   READROM
*D*
*D* REGISTERS:
*D*      I1, T0, T2, A2 AND RTN ARE PRESERVED; ALL OTHERS ARE CHANGED.
*D*
*D* OUTPUT:
*D*      T3 <= DESCRIPTOR OF RECORD AS READ.
*D*      CC1-4  <= 0 IF A RECORD WAS READ,
*D*             <= 3 IF END-OF-FILE WAS HIT.
*D*
         PAGE
         SPACE
READROM  EQU,0    %
         MTW,0    ROMSRC            IS ROM COMING FROM LIB OR FILE
         BEZ      RDROMLB           B/ FROM A LIBRARY.
         LC       ROMEOF            DID WE HIT END-OF-FILE BEFORE?
         BNE      0,T2              B/YES.  RETURN APPROP. CC & XIT.
         SPACE
*** READING A ROM FROM A FILE:
         M:READ   F:ROMIN,(BUF,*T3),(SIZE,120),(ERR,RDROMER),;
                  (ABN,RDROMER)
         SPACE
*** GOT THE RECORD;
         LI,T1    +F:ROMIN          GET ADDRESS OF DCB,
RDROM1   LW,R0    +RWS,T1           GET BYTE COUNT OF RECORD,
         SLS,T3   +2                MAKE A BYTE ADDRESS FOR BUFFER,
         STB,R0   T3                AND POKE IN COUNT, MAKING DESCRIPTOR.
         LCI      +0                SIGNAL SUCCESS,
         B        0,T2              AND EXIT SUCCESSFULLY.
         SPACE
*** WE ENCOUNTERED AN ERROR READING THE ROM:
RDROMER  PUSH     RTN               SAVE AN IMPORTANT REGISTER,
         BAL,RTN  IOERRSW           AND GO FIND OUT WHO DONE IT.
         IOERR,X'0600' RDROMEN      --HIT END-OF-FILE.
         IOERR,X'4300'  RDROMEN     --NO REC BY KEY ==> END OF LIB ROM.
         IOERR,0       E(E#IOERR)   --I DUNNO WHAT TO DO,-SO PUNT.
         SPACE
*** WE HIT END-OF-FILE ON A ROM:
RDROMEN  POP      RTN               GET THAT REGISTER BACK,
         LCI      +3                REMEMBER END-OF-FILE,
         STCF     ROMEOF            (MOSTLY FOR READING FROM F:LIB)
         B        0,T2              AND EXIT *WITH THOSE CC*
         SPACE
*** READING A ROM FROM A LIBRARY FILE (F:LIB):
RDROMLB  EQU      %
         M:READ   *L:DCB,(BUF,*T3),(SIZE,120),(KEY,IKEYBUF),;
                  (ERR,RDROMER),(ABN,RDROMER)
         LI,R0    IKEYBUF           BUFFER WHICH HOLDS KEY OF LAST..
         BAL,T1   INCKBUF           ..RECORD, NEEDS TO POINT TO NEXT.
         LW,T1    L:DCB             GET DCB ADDRESS.
         B        RDROM1            AND GO MAKE A DESCRIPTOR.
         TITLE    'LEMUR3 -- SETDCB -- CHANGES ERR/ABN IN A DCB'
         SPACE
SETDCB   EQU,0    %                 LINK = T3, DCB = T2, ERR/ABN = R0
         LI,R1    +X'1FFFF'         LOAD MASK FOR COMPARISON;
         CS,R0    +ERA,T2           DOES ERROR ADR NEED CHANGING?
         BNE      SETDCB1           B/ YES: CHANGE BOTH.
         CS,R0    +ABA,T2           DOES ABN NEED CHANGING?
         BE       0,T3              B/ NO, NOTHING TO DO THEN.
         SPACE
* EITHER ERR OR ABN OR BOTH SHOULD BE CHANGED:
SETDCB1  EQU,0    %
,STDCBFP M:SETDCB *T2,(ERR,*R0),(ABN,*R0)
         B        0,T3              NOW GO AWAY.
         TITLE    'LEMUR3 -- INCKBUF -- INCREMENTS SPECIFIED KEYBUF'
         SPACE
INCKBUF  EQU,0    %                 LINK=T1, .KEYBUF=R0
         LB,I3    *R0               GET LENGTH OF KEY,
         MTB,+1   *R0,I3            POINT TO NEXT.
         BNC      0,T1              B/ NO CARRY, ALL DONE.
         AI,I3    -1                ELSE PROPOGATE CARRY.
         MTB,+1   *R0,I3            (BUT ONLY ONE BYTE).
         B        0,T1              AND EXIT.
         TITLE 'LEMUR3 -- OPENLIB -- OPEN F:LIB DCB'
         SPACE
OPENLIB  SUBROUTINE
         LW,R0    Y002              IS DCB ALREADY OPEN?
         CW,R0    *L:DCB
         BANZ     OPNLIB1           B/ YES, LEAVE IT ALONE.
         M:OPEN   *L:DCB,(DIRECT),(INOUT),(ABN,OPNLIBE),(ERR,OPNLIBE)
OPNLIB1  LI,R0    +0
         LW,T2    L:DCB
         BAL,T3   SETDCB            RESET THE ERROR/ABN ADDRESSES,
         LI,R0    +X'F0'            IS IT A KEYED FILE?
         LW,T3    ORG,T2
         AND,R0   T3
         CI,R0    +X'20'
         BNE      E(E#NLIB)         B/ NO: NOT A LIBRARY.
         SPACE
*E* ERROR:        E#NLIB (07-05-00)
*E*
*E* MESSAGE:      THAT'S NO LIBRARY!
*E*
*E* MEANING:      THE LIBRARY FILE SPECIFIED EXISTS, BUT IS NOT
*E*               A KEYED FILE.
         SPACE
************CODE OLD-STYLE LIBRARY CHECK HERE************
***********READ FIRST RECORD AND SEE WHETHER ITS A DICTIONARY ENTRY**
         B        RETCC0            AND EXIT:  THE FILE IS OPEN.
         SPACE
*** ERROR WHILE ATTEMPTING TO OPEN F:LIB
OPNLIBE  CALL     IOERRSW           FIND OUT WHO WE STEPPED ON.
         IOERR,X'0300' RETCC3       NO SUCH FILE:  TELL HIM THAT.
         IOERR,X'1414' BNR8         EXECUTE ONLY ==> KEEP TRUCKING.
         IOERR,0       E(E#COL)     ELSE SOME HORRIBLE ERROR: CRY.
         TITLE 'LEMUR3 -- CRELIB -- CREATES LIBRARY FILE'
         SPACE
CRELIB   EQU,0    %
         M:OPEN   F:LIB,(DIRECT),(KEYED),(OUT),(SAVE),(KEYM,KEYMAX),;
                  (ERR,E(E#CCRL)),(ABN,CRELIBE)
         LI,T2    +F:LIB            NOW CLOSE THE TURKEY
         M:CLOSE,E CLSDCBF          (WITH SAVE)
         B        OPENLIB           AND RE OPEN IT.
         SPACE
CRELIBE  LW,T3    RTN               SAVE RETURN ADR,
         CALL     IOERRSW           AND FIND OUT WHO DONE IT
         IOERR,X'1414'   CRLBE1     EXECUTE ONLY ==> GO ON.
         IOERR,0         E(E#CCRL)  ELSE CROAK.
         SPACE
CRLBE1   EQU,0    %
         LW,RTN   T3                GET BACK THE RETURN ADDRESS,
         B        *R0               AND GO BACK WHERE YOU CAME FROM.
         TITLE 'LEMUR3 -- RSTCPY -- DO SETUP FOR ROM COPY INTO LIB'
         SPACE
*F****************************************************************
*F*
*F* NAME:  RSTCPY
*F*      INITIALIZES ALL THE NEAT STUFF FOR COPYING A BUNCH OF
*F*      ROMS INTO THE MODULE WHOSE DESCRIPTOR IS IN A2
*F*
*D* CALL:
*D*      BAL,RTN  RSTCPY
*D*      I3=KEY BUFFER
*D*
*D* REGISTERS:
*D*      A2, RTN ARE PRESERVED.
*D*
*D* OUTPUT:
*D*      OKEYBUF <= TEXTC(A2->NAME||X'0000')
*D*
         SPACE
RSTCPY   SUBROUTINE
         AI,I3    1                 GET PAST COUNT BYTE
         LW,I2    A2                MOVE KEY INTO OKEYBUF
         CALL     APPEND            AND APPEND THE STRING.
         LW,I2    =X'02000000'+BA(X0) NOW, APPEND A PAIR OF NULLS,
         CALL     APPEND
         LB,I2    I3                GET THE LENGTH OF THE KEY,
         MTW,-1   I3
         STB,I2   0,I3              AND SAVE THE LENGTH.
         B        RETURN            ALL DONE.
         TITLE 'LEMUR3 -- CPYROM -- COPIES A ROM INTO A LIBRARY'
         SPACE
CPYROM   SUBROUTINE                 (EVERYTHING IS IN CORE CONTEXT)
         LI,R0    +CPYROME          MAKE SURE FOR ERRORS ...
         LI,T2    F:LIB             ...THAT WE COME TO...
         BAL,T3   SETDCB            ...THE RIGHT PLACE.
         LI,R0    RDROMER
         LI,T2    F:SORS
         BAL,T3   SETDCB
         LI,R0    RDROMER
         LI,T2    F:ROMIN
         BAL,T3   SETDCB
CPYROML  LI,T3    +ROMBUF           GET @ OF ROMBUF,
         BAL,T2   READROM           AND READ A RECORD INTO IT.
         BNE      RETURN            HIT END OF FILE, DONE W/ THIS.
         LB,T3    T3                GET THE RECORD'S SIZE,
         M:WRITE  F:LIB,(SIZE,*T3),(BUF,ROMBUF),(KEY,OKEYBUF),;
                  (NEWKEY),(ERR,CPYROME),(ABN,CPYROME)
         LI,R0    +OKEYBUF          NOW, POINT TO NEXT RECORD,
         BAL,T1   INCKBUF           POINT TO NEXT RECORD IN FILE.
         B        CPYROML           AND GO DO ANOTHER.
         SPACE
*** ERROR ENCOUNTERED WHILE TRYING TO WRITE FILE.
CPYROME  EQU      E(E#IOERRA)       ABORTING I/O ERROR.
         TITLE 'LEMUR3 -- IOERRSW -- SMART TABLE BRANCH FOR I/O ERRS'
         SPACE
IOERRSW  EQU,0    %                 LINK = RTN
         LW,R3    YFFFE             GET MASK FOR CHECKING CODES.
IOERRS0  CS,R2    *RTN              IS THIS A MATCH?
         BNE      IOERRS2           B/ NO, TRY NEXT.
IOERRS1  LW,RTN   *RTN              MATCH:  GET BRANCH @
         B        *RTN              AND GO GET 'EM.
IOERRS2  CW,R3    *RTN              IS THIS THE END?
         BAZ      IOERRS1                     B/ YES, FOR
         AI,RTN   +1                ELSE POINT TO NEXT,
         B        IOERRS0           AND TRY AGAIN.
         TITLE    'LEMUR3 -- GETBLK -- GETS A REF/DEF BLOCK'
         SPACE
GETBLK   EQU,0    %                 SYM := .(REF/DEF BLOCK)
         LW,A1    BLKPTR            PICK IT UP FOR EASY REFERENCE,
         AI,A1    +BLK:L            SEE IF WE CAN GET IN ANOTHER BLOCK
         CW,A1    BLKEND            OUT OF SPACE?
         BG       GTBLK1            B/ YES, TRY TO GET SOME MORE.
         XW,A1    BLKPTR            UPDATE POINTER, AND GET .(BLOCK)
         STW,A1   SYM               SAVE THE POINTER.
         B        *RTN              ALL DONE, EXIT.
         SPACE
*** CAN'T ALLOCATE A NEW BLOCK, TRY TO GET FROM FREE SPACE LIST.
GTBLK1   LW,T3    FREECHN           GET POINTER TO HEAD OF FREECHAIN,
         BEZ      E(E#NES)          B/ NONE:  ERROR, NOT ENOUGH ROOM.
         LW,A1    +1,T3             PICK UP POINTER TO NEXT IN CHAIN,
         STW,A1   FREECHN           MAKE IT FIRST,
         STW,T3   SYM               AND SAVE OLD HEAD AS NEW BLOCK.
         B        *RTN              NOW WAVE GOODBYE TO THE NICE PEOPLE.
         TITLE 'LEMUR3 -- FREESPC -- INITIALIZES FREE SPACE POOL.'
         SPACE
FREESPC  EQU,0    %
         LW,A1    BLKPOOL           POINT TO START OF POOL,
         STW,A1   BLKPTR
         LI,A1    +0                SET HEAD OF FREE-SPACE CHAIN...
         STW,A1   FREECHN           ...TO NIL,
         B        HSHINIT           AND GO INITIALIZE THE HASH TABLE.
         TITLE 'LEMUR3 -- DICENT -- ENTERS A SYMBOL IN THE LIBRARY DIC'
         SPACE
DICENT   EQU      %                 LINK =RTN, I2=@ OF REF/DEF SYM.
         BAL,A1   MDICKEY           OBKEYBUF := KEY FOR THIS SYM
         LI,A1    0                 SET LAST BYTE OF MODULE NAME TO 00.
         LI,I1    11
         STB,A1   MODNAME,I1        (THIS IS LOADER-REQUIRED.)
DICENT1  EQU      %
         M:WRITE  F:LIB,(BUF,MODNAME),(NEWKEY),(SIZE,12),;
                  (KEY,OKEYBUF),(ERR,E(E#IOERR)),(ABN,E(E#IOERR))
         B        *RTN              ALL DONE.
         TITLE    'LEMUR3 -- MDICKEY -- MAKES A DICTIONARY KEY'
         SPACE
MDICKEY  EQU,0    %                 I2 = .REF/DEF, A1 = LINK.
         LCI      3
         LM,I3    BLANKS
         STM,I3   OKEYBUF
         LW,I3    YFF               NOW, EXTRACT COUNT FROM SYMBOL...
         AND,I3   +3,I2             ...IN I2->(REF/DEF BLOCK)
         AI,I3    +BA(OKEYBUF)+2    GET DESTINATION @ FOR MBS;
         SLS,I2   +2                MAKE BYTE @ OF SOURCE;
         MBS,I2   +(3*4)+1          AND START W/ 3RD WORD, 2ND BYTE.
         AI,I3    -(BA(OKEYBUF)+1)  HOW MANY BYTES (W/ LEADING BLANK)?
         STB,I3   OKEYBUF           REMEMBER THAT.
         B        *A1               ALL DONE.
         TITLE 'LEMUR3 -- GETC -- GET ANOTHER CHARACTER FROM ROMIN'
         SPACE
GETC     EQU,0    %                 RTN=LINK, T2:=CH, T3:=X,
*                                   CC:=0 MEANS CHAR WAS READ,
*                                   CC:=3 MEANS END-OF-FILE WAS READ.
         LW,T3    ROMPT             GET DESCRIPTOR OF REST OF RECORD.
         CW,T3    YFF               ANY CH LEFT?
         BANZ     GETC1             B/ YES, JUST DO LOAD & EXIT.
         SPACE
* RECORD EXHAUSTED:  READ ANOTHER.
         LI,T3    +ROMBUF           GET BUFFER @;
GETC0    BAL,T2   READROM           GET RECORD;
         BNE      *RTN              B/ END OF FILE SEEN:  EXIT
         LB,T2    0,T3              GET TYPE-CODE FOR THIS RECORD:
         CI,T2    +X'3C'            IS IT 'ROM, NOT LAST RECORD' ?
         BE       GETCOK            B/ YES:  GO BUILD DESCRIPTOR.
         CI,T2    +X'1C'            IS 'ROM, LAST RECORD' ?
         BNE      E(E#ILRH)         B/ NO:  ERROR, ILLEGAL ROM HEADER.
         SPACE
*E*      ERROR:   E#ILRH
*E*      MESSAGE:  ILLEGAL ROM RECORD HEADER.
         SPACE
* HEADER SEEMS OK:  CONSTRUCT DESCRIPTOR.
GETCOK   LI,T2    +X'FF'            GET # OF BYTES IN THIS RECORD:
         AND,T2   ROMBUF
         CB,T2    T3                ARE THERE AT LEAST THAT MANY BYTES?
         BG       E(E#ILRC)         B/ NO:  ERROR, ILLEGAL ROM BYTE COUNT
         SPACE
*E* ERROR:  E#ILRC
*E*
*E* MESSAGE:      INCORRECT BYTE COUNT IN ROM HEADER.
*E*
*E* MEANING:      A RECORD IN AN INPUT ROM SPECIFIED A BYTE COUNT
*E*               IN ITS HEADER WHICH WAS LONGER THAN THE PHYSICAL
*E*               RECORD.
         SPACE
         AI,T2    -4                SCRUB OFF THE HEADER BYTES,
         BEZ      GETC0             B/ NOTHING IN THE RECORD.
         STB,T2   T3                SAVE REAL COUNT IN DESCRIPTOR,
         AI,T3    +4                AND START W/ THE FIRST CODE BYTE.
         SPACE
* DESCRIPTOR IS NOW IN T3;
GETC1    LB,T2    0,T3              GET DATA CHARACTER,
         SW,T3    M24               INCREMENT BYTE POINTER, DECREMENT CT.
         STW,T3   ROMPT             SAVE IT IN THE ROM POINTER,
         LCI      +0                RETURN AN APPROPRIATE CC,
         B        *RTN              AND EXIT.
         TITLE    'LEMUR3 -- OPENSI -- OPENS THE M:SI DCB'
         SPACE
OPENSI   EQU,0    %                 **NO ARGS**
         LW,R0    Y002              IS IT ALREADY OPEN?
         CW,R0    M:SI
         BANZ     *RTN              B/ YUP.  BYE.
*D*      IF THE M:SI DCB IS NOT ALREADY OPEN, THEN WE DO THE
*D*      CAL TO OPEN IT;  IF IT WON'T OPEN, WE ABORT.
         SPACE
         M:OPEN   M:SI,(IN),(ERR,E(E#IOERRA)),(ABN,OPENSIE)
         B        *RTN              OPEN, GO HOME.
         SPACE
OPENSIE  EQU,0    %                 ERROR (ECCH)
         LW,8     RTN               SO WE CAN GET OUT QUICK,
         CALL     IOERRSW           GO FIND OUT WHAT IT WAS.
         IOERR,X'1414'   BNR8       EXECUTE ONLY?  WEIRD BUT OK.  GO HOME
         IOERR,0  E(E#IOERRA)       ANYTHING ELSE ==> ABORT.
         TITLE    'LEMUR3 -- OPENLL/DO -- OPENS LL AND DO DCBS'
         SPACE
OPENLL   EQU,0    %                 NO ARGS******
         LI,T2    +M:LL             GET .M:LL DCB;
         B        OPENLL1           B/ GO OPEN IT FOR OUTPUT.
         SPACE
OPENDO   EQU,0    %                 NO ARGS******
         LI,T2    +M:DO             GET .M:DO DCB;
         SPACE
OPENLL1  EQU,0    %
         LW,R1    Y002              CHECK THAT DCB ISN'T ALREADY OPEN,
         CW,R1    0,T2
         BANZ     *RTN              OPEN? THEN ALL DONE.
         M:OPEN   *T2,(OUT),(ERR,E(E#IOERRA)),(ABN,OPENLLE)
         B        *RTN
         SPACE
OPENLLE  EQU,0    %                 ERROR TRYING TO OPEN THESE?
         LW,T3    RTN               GET A COPY OF THE RETURN @
         CALL     IOERRSW
         IOERR,X'1414'    OPNLLE1   EXECUTE ONLY ==> DO PFILE TO END.
         IOERR,0  E(E#IOERRA)       ANYTHING ELSE ==> ABORT.
         SPACE
OPNLLE1  EQU,0    %                 DO A PFILE FOR EXECUTE ONLY.
         M:PFIL   *T2,EOF           POSITION TO END OF FILE,
         B        0,T3              AND **GO AWAY**
         TITLE    'LEMUR3 -- CKCORR -- CHECKS DCB CORRESPONDENCES'
         SPACE
CKCORR   EQU,0    %                 LINK = RTN
         LI,A1    +X'3F0'           LOAD MASK FOR TYPE (HANDY LATER)
         SPACE
*D*      WE EXTRACT THE 'ASN' FIELD FROM THE DCBS INTO THE FOLLOWING
*D*      REGISTERS:
*D*      M:SI.ASN ==> R0
*D*      M:LL.ASN ==> R1
*D*      M:DO.ASN ==> R2
*D*
         LI,R0    +X'F'             GET ASN MASK,
         AND,R0   M:SI+ASN
         LI,R1    +X'F'
         AND,R1   M:LL+ASN
         LI,R2    +X'F'
         AND,R2   M:DO+ASN
         SPACE
*D*      NEXT WE DETERMINE WHETHER M:SI IS A DEVICE.  IF NOT,
*D*      THEN M:SI CANNOT BE THE SAME AS M:LL OR M:DO, SO WE
*D*      SET SI#DO & SI#LL ACCORDINGLY AND CHECK M:LL VERSUS M:DO.
         SPACE
         CI,R0    +3                IS M:SI A DEVICE?
         STCF     SI#LL             SAVE RESULTS...
         STCF     SI#DO             ...IF NOT, THEN THESE FLAGS ARE SETUP
         BNE      CKCRLD            B/ SI NOT DEVICE, GO CPR LL/DO
         SPACE
*D*      IF M:SI IS A DEVICE, THEN WE CHECK WHETHER M:LL IS A DEVICE.
*D*      IF NOT, THEN WE SET SI#LL AND GO CHECK SI VERSUS DO.
         SPACE
         CI,R1    +3                IS M:LL A DEVICE?
         STCF     SI#LL             SAVE RESULTS...
         BNE      CKCRSD            B/ NOT DEVICE:  GO CHECK SI VS. DO
         SPACE
*D*      IF M:LL AND M:SI ARE BOTH DEVICES, THEN WE COMPARE THEIR
*D*      TYPES; IF THE SAME, THEN WE CLEAR SI#LL.
         SPACE
         LW,A0    M:SI+TYPE         GET TYPE WORD,
         CS,A0    M:LL+TYPE         ARE THEY THE SAME?
         STCF     SI#LL             SAVE THE RESULT.
         SPACE
*D*      NEXT, WE SEE IF SI AND DO ARE THE SAME.  WE DO THE SAME
*D*      RIGAMAROLE WITH DO, EXITING IF IT IS NOT A DEVICE.
         SPACE
CKCRSD   CI,R2    +3                IS M:DO A DEVICE?
         STCF     SI#DO             GMM.
         STCF     DO#LL             IF NOT, NONE OF THESE CORRESPONDENCES
*                                          WORK.
         BNE      *RTN              B/ NOT A DEVICE, ALL DONE.
         LW,A0    M:DO+TYPE         ELSE GET AND CHECK TYPES
         CS,A0    M:SI+TYPE
         STCF     SI#DO             SAVE RESULT.
         B        CKCRLD1           B/ WE KNOW THAT DO IS A DEVICE.
         SPACE
*D*      NEXT WE DO ALL THIS WORK FOR LL VS. DO.   IF WE HAPPEN TO
*D*      ALREADY KNOW THAT DO IS A DEVICE, THEN THIS CODE SHOULD BE ENTERED
*D*      BY CKCRLD1.
         SPACE
CKCRLD   CI,R2    +3                IS DO A DEVICE?
         STCF     DO#LL             SAVE RESULTS,
         BNE      *RTN              B/ NOPE, ALL DONE.
         LW,A0    M:DO+TYPE         ELSE GET TYPE...
         SPACE
CKCRLD1  CI,R1    +3                IS LL A DEVICE?
         STCF     DO#LL             SAVE RESULTS,
         BNE      *RTN              B/ NOPE, ALL DONE.
         CS,A0    M:LL+TYPE         ELSE CHECK TYPE FIELDS,
         STCF     DO#LL             SAVE RESULTS,
         B        *RTN              AND EXIT.
         TITLE    'LEMUR3 -- WRITELL -- WRITES RECORD TO LL'
         SPACE
ECHOLL   EQU,0    %                 DOES WRITE IFFI SI NOT= DO
         LC       SI#LL             IS THIS OPERATION OK?
         BE       *RTN              B/ SI=LL ==> NOTHING TO DO.
         SPACE
WRITELL  EQU,0    %                 DOES WRITE ALWAYS.
         BAL,T3   A2BFBTD           ELSE GET BUF/BTD IN A0,A1
         LB,T3    A2                ELSE GET SIZE<
         BE       *RTN              B/ NOTHING TO DO.
         LI,T2    +M:LL
,WRSOFPT M:WRITE  *T2,(SIZE,*T3),(BUF,*A0),(BTD,*A1),;
                  (ERR,E(E#IOERRA)),(ABN,E(E#IOERRA))
         B        *RTN
         TITLE    'LEMUR3 -- A2BFBTD -- CALCULATES .BUF, BTD FROM DESC'
         SPACE
A2BFBTD  EQU,0    %                 A2 = DESCRIPTOR, T3 = LINK;
*                                   A0 := .BUFFER,
*                                   A1 := BTD.
         SPACE
         LI,A0    +X'7FFFF'         LOAD BYTE ADDRESS MASK,
         AND,A0   A2                GET BYTE ADDRESS,
         LI,A1    +0                PRESET BTD TO ZERO,
         SLD,A0   -2                GET WA, BTD LEFT JUSTIFIED.
         SCS,A1   +2                GET BTD IN RIGHT PLACE.
         B        0,T3              BUG OUT.
         TITLE    'LEMUR3 -- WRITEDO -- WRITES RECORD TO DO'
         SPACE
ECHODO   EQU,0    %                 WRITES RECORD TO DO IFFI M:DOONE M:SI
         LC       SI#DO             HMM.
         BE       *RTN              B/ NOTHING TO DO.
         SPACE
WRITEDO  EQU,0    %                 WRITES RECORD TO DO
         BAL,T3   A2BFBTD           GET BUF/BTD
         LB,T3    A2                GET SIZE,
         BEZ      *RTN              NULL ==> NOTHING TO DO.
         LI,T2    +M:DO             ELSE WRITE THE RECORD.
         M:WRITE,E WRSOFPT
         B        *RTN              B/ ALL DONE.
         TITLE    'LEMUR3 -- HSHINIT -- INITIALIZES HASH TABLE'
         SPACE
HSHINIT  EQU,0    %
         LI,A1    +0                PREPARE TO INITIALIZE THE HASH BUCKEETS
         LW,T3    BT31TO0+HSH:N     GET # OF DWORDS IN HASH TABLS,
         STD,A1   HSHTBL-2,T3       ZERO THIS ONE,
         BDR,T3   %-1               AND ZERO ANOTHER.
         B        *RTN              NOW EXIT.
         TITLE    'LEMUR3 -- WINDOWN -- WRAPS UP THIS RUN'
         SPACE
WINDOWN  EQU,0    %
         LI,T2    +F:LIB
         BAL,T3   CLSDCB
         LI,T2    +M:SI
         BAL,T3   CLSDCB
         LI,T2    +M:DO
         BAL,T3   CLSDCB
         LI,T2    +M:LL
         BAL,T3   CLSDCB
         MTW,+0   ERRHIT            ERRORS SEEN?
         BEZ      WINDOWX           B/ NONE.  BYE.
         LW,R1    O%ERR             ABORT ON ERRORS?
         CW,R1    C%OPTS
         BAZ      WINDOWX           B/ NOPE.  BYE.
         M:XXX
WINDOWX  EQU,0    %
         M:EXIT
         TITLE 'LEMUR3 -- RDKEY -- READS RECORD BY GIVEN KEY'
         SPACE
RDKEY    SUBROUTINE
         CALL     OPENLIB           OPEN LIBRARY...
         BNE      RETCC3            B/ NO SUCH LIBRARY ==> NO SUCH RECORD
         LW,A2    I3                GET DESCRIPTOR
         LI,A1    IKEYBUF           MAKE KEY,
         BAL,T3   MAKEKEY
         LW,T2    L:DCB
         LI,R0    +RDKEYER
         BAL,T3   SETDCB
         M:READ   *L:DCB,(KEY,IKEYBUF),(SIZE,*L:SIZE),(ERR,RDKEYER),;
                  (ABN,RDKEYER),(BUF,*L:BUF)
         B        RETCC0            IT EXISTS
RDKEYER  CALL     IOERRSW
         IOERR,X'0700'  RETCC0      LOST DATA ==> RECORD EXISTS
         IOERR,X'4300'  RETCC3      NO SUCH RECORD ==> RETURN.
         IOERR,0  E(E#IOERR)        ELSE IOERROR.
         TITLE    'LEMUR3 -- RDERRFL -- READS RECORD FROM ERROR FILE'
         SPACE
RDERRFL  SUBROUTINE                 A1=KEY, A2=BA(BUFFER); A2:= DESC.
         STW,A1   KEYBUF            SAVE KEY,
         LI,T2    +F:ERR            GET DCB @
         LI,R0    +RDERRF1          GET ERROR @
         BAL,T3   SETDCB            AND PREPARE FOR ACTION.
         BAL,T3   A2BFBTD           A0:=WA(BUFFER), A1:=BTD
         M:READ   F:ERR,(BUF,*A0),(BTD,*A1),(KEY,KEYBUF),;
                  (SIZE,255),(ERR,RDERRF1),(ABN,RDERRF1)
         LW,A1    F:ERR+RWS         GET SIZE OF RECORD,
         STB,A1   A2                POKE AWAY,
         BAL,T3   CLSDCB            AND CLOSE F:ERR.
         B        RETURN            EXIT.
         SPACE
*** ERROR TRYING TO READ ERROR FILE:  WHAT HAPPENED?
RDERRF1  CALL     IOERRSW           FIND OUT.
         IOERR,X'0700'  BNR8        TOO LONG ==> THAT'S OK, BOSS.
         IOERR,X'0000'  RDERRFX     OTHERWISE ==> MAKE HEX & LEAVE.
         SPACE
*** MAKE HEX CODE IN BUFFER AND SPLIT.
RDERRFX  LW,T3    KEYBUF            GET KEY,
         SLS,T3   +8                GET RID OF COUNT BYTE,
         LW,T1    A2                GET BUFFER @
         LI,R0    +6                GET LOOP COUNT,
         STB,R0   A2                AND SET LENGTH OF STRING.
*
RDERRXL  LI,T2    +0                SET DIGIT TO ZERO,
         SLD,T2   +4                GET NEXT HEX DIGIT,
         LB,T2    HEX,T2            GET EBCDIC THEREOF,
         STB,T2   0,T1              AND POKE INTO BUFFER.
         AI,T1    +1                POINT TO NEXT BYTE,
         BDR,R0   RDERRXL           AND GO UNTIL DONE.
         B        RETURN            B/ EXIT.
         TITLE    'LEMUR3 -- SETRAPS -- SETS ERROR TRAPS, PROMPT'
         SPACE
*F************************************************************************
*F*
*F* NAME:  SETRAPS
*F*
*F*      SETS FIXED POINT TRAPS TO IGNORE, PROMPT CHARACTER TO
*F*      '>'.
*F*
*F************************************************************************
         SPACE
SETRAPS  EQU,0    %
         M:TRAP   (IGNORE,FX)
         M:PC     '>'
         B        *RTN
         TITLE    'LEMUR3'
         SPACE
*F************************************************************
*F*
*F*  NAME*  READSEQ
*F*         READS NEXT RECORD AND RETURNS KEY DESCRIPTOR
*F*         IN A2.  CC=3 IF END OF FILE
*F*
READSEQ  SUBROUTINE
         M:READ   *L:DCB,(ERR,RDSEQE),(ABN,RDSEQE),(BUF,*L:BUF),;
                  (SIZE,*L:SIZE)
         B        RDKYSQ0           NORMAL RETURN. GET KEY DESCRIPTOR.
RDSEQE   CALL     IOERRSW
         IOERR,X'0700'  RDKYSQ0     LOST DATA. WE DID GET A RECORD.
         IOERR,X'0600'  RETCC3      END-OF-FILE
         IOERR,0        E(E#IOERR)
         SPACE
*F**************************************************************
*F*
*F*  NAME* DELKEY
*F*        DELETES THE RECORD WHOSE KEY IS IN OKEYBUF.  CC=3
*F*        IF NO RECORD WITH THAT KEY
*F*
DELKEY   SUBROUTINE
         LI,T2    F:LIB
         LI,R0    DLRECE            SET ERR,ABN FOR M:DELREC
         BAL,T3   SETDCB
         M:DELREC F:LIB,(KEY,OKEYBUF)
         B        RETCC0            RECORD DELETED.
DLRECE   CALL IOERRSW
         IOERR,X'1300'  RETCC3      KEY NOT FOUND
         IOERR,X'1500' E(E#IOERR)
         IOERR,0        E(E#IOERR)
         SPACE
*F***************************************************************
*F*
*F*  NAME:  DELREC
*F*      DELREC DELETES THE LAST RECORD READ THROUGH F:LIB
DELREC   SUBROUTINE
         LI,T2    F:LIB
         LI,R0    DLRECE            SET ERR,ABN FOR M:DELREC
         BAL,T3   SETDCB
         M:DELREC F:LIB
         B        RETCC0            RECORD DELETED.
         PAGE
*F****************************************************
*F*
*F*  NAME:  DPOINTERS
*F*         DELETE ALL DICTIONARY ENTRIES WHICH POINT TO THE
*F*         DESTINATION MODULE (IN D:DESTMOD)
*F*
         SPACE
DPOINTERS SUBROUTINE
         LI,T2    ROMBUF
         STW,T2   L:BUF
         LI,T2    ROMSIZE
         STW,T2   L:SIZE
         LI,A2    ROMBUF
         STW,A2   L:BUF
         LI,T2    F:LIB
         STW,T2   L:DCB
         BAL,T3   CLSDCB            CLOSE AND OPEN TO ENSURE THAT WE
         CALL     OPENLIB           POINT TO THE FIRST RECORD.
RDMORDIC EQU      %
         CALL READSEQ               GET NEXT RECORD.
         BCS,3    E(E#NLIB)         EOF. THIS WAS A FUNNY LIBRARY.
         LW,I2    A2                KEY DESCRIPTOR IS IN A2.
         LB,I2    0,I2              GET FIRST BYTE OF KEY.
         CI,I2    X'40'             IS IT A BLANK?
         BNE      RETURN            BRANCH IF NO. (WE'VE REACHED THE END)
         LB,A0    D:DESTMOD         SEE IF THE COUNTS ARE EQUAL.
         CB,A0    ROMBUF
         BNE      RDMORDIC          BRANCH IF NO. NOT OUR MODULE.
         LW,A1    D:DESTMOD         YES. NOW COMPARE THE TEXT.
         LI,A0    BA(ROMBUF)+1
         CBS,A0   0
         BCS,3    RDMORDIC          BRANCH IF NOT OURS.
         CALL     DELREC            YES, GO DELETE IT.
         BCS,3    E(E#IOERR)        I JUST READ YOU.  YOU HAVE TO EXIST..
         B        RDMORDIC
         SPACE
*F****************************************************************
*F*
*F*  NAME:  DROMS
*F*
*F*         DELETES ALL RECORDS IN THE LIBRARY BELONGING TO TO
*F*         DESTINATION MODULE.
*F*
         SPACE
DROMS    SUBROUTINE
         LW,A2    D:DESTMOD
         LI,R0    F:LIB
         STW,R0   L:DCB
         LI,I3    BA(OKEYBUF)
         CALL     RSTCPY            PUT THE INITIAL KEY IN OKEYBUF.
DMORRECS  EQU     %
         CALL     DELKEY            DELETE THE RECORD.
         BCS,3    RETURN            NO RECORD WITH THAT KEY.  WE MUST
*                                   HAVE REACHED END OF MODULE.
         LI,R0    OKEYBUF           GO INCREMENT THE KEY.
         BAL,T1   INCKBUF
         B        DMORRECS
*
*F*****************************************************************
*F*  NAME: DICDEL
*F*     DELETES DICTIONARY ENTRY FOR THE SYMBOL WHOSE
*F*    ADDRESS IS IN I2.
*
*       LINK=RTN, I2= ADDRESS OF SYMBOL
*       OKEYBUF= KEY FOR THIS SYMBOL
*
DICDEL   SUBROUTINE
*                                   MAKE A DICTIONARY KEY.
         BAL,A1   MDICKEY
         CALL     DELKEY
         B        RETURN
DICCHECK SUBROUTINE
         BAL,A1   MDICKEY           MAKE DICTIONARY KEY OUT OF
*,*                                 SYMBOL POINTED TO BY A2.
         LI,I3    BA(OKEYBUF)+1     KEY IS IN OKEYBUF.
         LB,A2    OKEYBUF           PUT KEY IN IKEYBUF.
         STB,A2   I3
         CALL     RDKEY
         BCS,3    RETURN
         B        E(E#IDS)          KEY EXISTS. ERROR
         PAGE
*F*****************************************************************
*F*
*F*  NAME:  DLMN
*F*         THE DESTINATION MODULE IS DELETED FROM THE
*F*         DESTINATION LIBRARY.  ASSUMPTION IS MADE THAT THE
*F*         LIBRARY EXISTS AND THAT THE MODULE EXISTS WITHIN IT.
*
         SPACE
DLMN     SUBROUTINE
         LI,I3    F:LIB
         STW,I3   L:DCB
         LI,I3    D:LTYPE           INITIALIZE THE LOCATION OF THE
         STW,I3   D:LTYPEX          LMN RECORD TYPE DESCRIPTOR.
DLMN1    EQU      %
         LI,I3    BA(IKEYBUF)
         LW,I2    D:DESTMOD         PUT MODULE NAME IN A TEMP.
         CALL     APPEND
         LW,I2    *D:LTYPEX
         CALL APPEND                APPEND THE LMN REC TYPE TO MOD NAME.
         LI,A1    OKEYBUF           PUT THE WHOLE THING IN KEY FORM
         LW,A2    I3                IN OKEYBUF.
         BAL,T3   MAKEKEY
         CALL     DELKEY            NOW GO DELETE A RECORD WITH THAT KEYY.
         MTW,1    D:LTYPEX
         LW,I2    D:LTYPEX          ARE THERE MORE RECORDS TO DELETE?
         CI,I2    D:LTYPELAST
         BL       DLMN1             BRANCH YES.
         B        RETURN            ALL DONE DELETING LMN RECORDS.
         SPACE
         SPACE
CLOSEREL SUBROUTINE
*                                   CLOSE WITH RELEASE.
*                                   DCB IS IN T2
         M:CLOSE  *T2,(REL),(ERR,E(E#IOERRA)),(ABN,E(E#IOERRA))
         B        RETURN
         SPACE
DEMPTY   SUBROUTINE
         M:REW    F:LIB
         CALL     READSEQ           SEE IF WE GET A RECORD.
         BCR,3    RETURN
         CALL     CLOSEREL          EOF ENCOUNTERED. DELETE THE FILE.
         B        RETURN
         PAGE
*        ROUTINE TO COPY A LMN FROM SOURCE TO DESTINATION
*        LIBRARY.  THE HEAD RECORD IS READ TO DETERMINE
*        THE MAXIMUM BUFFER SIZE IN PAGES.  THE PAGES ARE
*        GOTTEN (M:GP) AND THE MODULE IS COPIED.  IF SOURCE AND
*        DESTINATION MODULE NAMES ARE DIFFERENT, THE KEYS ARE
*        ALTERED TO BEGIN WITH DESTINATION MODULE NAME.
*
CARLMN   SUBROUTINE
*
*        ITS A LMN.  CARRY IT TO DEST LIB..
*
         LI,I3    BA(OKEYBUF)
         LW,I2    D:SORSMOD
         CALL     APPEND
         LW,I2    =D('HEAD')        LOOK IN HEAD RECORD TO FIND
         CALL     APPEND
*                                   RECORD SIZES.
         LI,R0    X'B'**2           HEAD RECORD SIZE (IN BYTES)
         STW,R0   L:SIZE
         LI,R0    ROMBUF
         STW,R0   L:BUF
         CALL     RDKEY
         BCS,3    E(E#IOERR)
*        COMPUTE MAX RECORD SIZE TO DETERMINE BUFFER SIZE.
         LH,R0    ROMBUF+3
         CH,R0    ROMBUF+4
         BGE      %+2
         LH,R0    ROMBUF+4
         CH,R0    ROMBUF+5
         BGE      %+2
         LH,R0    ROMBUF+5
         CH,R0    ROMBUF+6
         BGE      %+2
         LH,R0    ROMBUF+6
         STW,R0   L:SIZE
         SLS,R0   1                 COMPUTE NO. OF PAGES TO GET.
         STW,R0   L:SIZE
         AI,R0    X'1FF'
         SLS,R0   -9
         STW,R0   L:PAGES
         M:GP     *L:PAGES         GET PAGES
         CW,8     L:PAGES           DID WE GET ALL WE NEED?
         BL       E(E#NOCORE)       OH-OH
         STW,9    L:BUF            SAVE BUFFER ADDRESS.
         LW,R0    L:SIZE
         SLS,R0   2                 COMPUTE MAX BYTE COUNT.
         STW,R0   L:SIZE
         LI,I3    D:LTYPE
         STW,I3   D:LTYPEX
CARLMN1  EQU      %
         LI,I3    BA(OKEYBUF)
         LW,I2    D:SORSMOD        GET SOURCE MODULE NAME
         CALL     APPEND
         LW,I2    *D:LTYPEX
         CALL     APPEND           APPEND LMN RECORD TYPE.
         CALL     RDKEY            READ THE RECORD.
         BCS,3    CARLMN4
         LI,I3    BA(IKEYBUF)
         LW,I2    D:DESTMOD        GET DEST. MOD NAME.
         CALL     APPEND
         LW,I2    *D:LTYPEX
         CALL     APPEND           APPEND LMN RECORD TYPE.
         LI,A1    OKEYBUF
         LW,A2    I3
         BAL,T3   MAKEKEY          MAKE THE KEY
         LW,T1    L:DCB            GET RECORD SIZE
         LW,R0    RWS,T1
         M:WRITE  F:LIB,(SIZE,*R0),(BUF,*L:BUF),(KEY,OKEYBUF),;
                  (NEWKEY),(ERR,E(E#IOERRA)),(ABN,E(E#IOERRA))
CARLMN4  EQU      %
         MTW,1    D:LTYPEX         ARE THERE MORE?
         LW,I2    D:LTYPEX
         CI,I2    D:LTYPELAST
         BL       CARLMN1
         M:FP     *L:PAGES         NO. RELEASE THE PAGES
         B        RETURN            ...AND RETURN.
         PAGE
COPY     SUBROUTINE
         CALL     CRELIB            CREATE THE DEST. LIB.
         LI,I1    4
         STW,I1   L:PAGES           GET 4 PAGES (AND PRAY)
         M:GP     *L:PAGES
         CW,8     L:PAGES           DID WE GET ALL WE WANT?
         BL       E(E#NOCORE)
         STW,9    L:BUF
         LI,T2    F:SORS
         STW,T2   L:DCB
         LI,A1    (4*512)**2        MAX RECORD SIZE= 4 PAGES(IN BYTES).
         STW,A1   L:SIZE
         LI,R0    RDSEQE
         BAL,T3   SETDCB
         LI,T2    F:LIB
         LI,R0    E#IOERRA
         BAL,T3   SETDCB
COPY2    EQU      %
         CALL     READSEQ           READ NEXT RECORD
         BCS,3    COPY4             B IF END OF FILE
         LI,A1    OKEYBUF
         BAL,T3   MAKEKEY
         LW,R0    F:SORS+RWS        GET NO. OF WORDS READ
         M:WRITE  F:LIB,(SIZE,*R0),(BUF,*L:BUF),(KEY,OKEYBUF),;
                  (ERR,E(E#IOERRA)),(NEWKEY),(ABN,E(E#IOERRA))
         B        COPY2             GO READ NEXT RECORD.
COPY4    EQU      %                 ALL DONE.
         M:FP     *L:PAGES
         B        RETURN
         END

