; VAX MACRO ASSEMBLY LANGUAGE CODE
; Programmer: David W. Deley (1987)
;
; This module is used in conjunction with the EDX editor.
; It is called using the TPU command:
;
;      OUTSTR := CALL_USER( CODE, INSTR);
;
; CODE - Integer.  Input.
;        4(AP)  = address of P1.
;        @4(AP) = value of P1.
;
;        INPUT REQUEST CODE:
;        The input request code is split into words.  The high word indicates
;        the general category of the request, the low word indicates the
;        specific request within the category. This simplifies parsing.
;
; INSTR - Input string.
;         8(AP)  = address of string descriptor.
;         The string is passed by a fixed length descriptor of the form:
;
;         -----------------------------------------
;         |  class  |  dtype  |  string length    |
;         -----------------------------------------
;         |                address                |
;         -----------------------------------------
;
;      on VMS 4 the fields are:
;          length  = nn  (length of string)
;          dtype   =  2  (8-bit unsigned data DSC$K_DTYPE_BU)
;          class   =  1  (fixed length descriptor DSC$K_CLASS_S)
;          address = xx  (address of first byte of string)
;
;      but on VMS 5 the fields are:
;          length  = nn  (length of string)
;          dtype   = 14  (character string DSC$K_DTYPE_T)
;          class   =  0  (DSC$K_CLASS_Z unspecified.  This doesn't work for some things)
;          address = xx  (address of first byte of string)
;
;       Because of this we create our own string descriptor for the input
;       string on the stack.  The original string descriptor is copied onto
;       the stack, then the class and dtype fields are filled in.
;
; OUTSTR - Output string.
;          12(AP)  = address of output string descriptor.
;          The string is passed by a dynamic string descriptor where:
;
;           length  =  0  (length of string)
;           dtype   = 14  (character string DSC$K_DTYPE_T)
;           class   =  2  (dynamic string descriptor DSC$K_CLASS_D)
;           address =  0  (invalid address)
;
;            Because the result string is dynamically allocated we use
;            the system service run-time library routine STR$COPY_DX_R8
;            to return the string.
;
;            The first 9 characters of the output string are reserved
;            for RETCODE, the return status code number.  The calling program
;            strips the first 9 characters off the string and converts
;            it to a return status code number using the INT() function.
;
; RETURN STATUS - R0
;      The return status is returned in R0.  This module always places a
;      SS$_NORMAL status in R0 when it returns.  The only way an error
;      status is returned is if an unexpected nasty error happens.  If
;      an error status is returned TPU will take the ON_ERROR -
;      ENDON_ERROR action if one exists in the calling procedure.
;
; INPUT ITEM CODE CATEGORIES:
; ^x0001xxxx - SYSTEM                   (65536)
; ^x00010001 - LOCK FILE                (65537)
;              INSTR = filename
;
; ^x00010002 - UNLOCK FILE              (65538)
;              INSTR = filename
;
; ^x00010003 - SHOW LOGICAL             (65539)
;              INSTR = logical name to translate
;              OUTSTR = logical name translation
;
; ^x00010004 - SHOW SYMBOL              (65540)
;              INSTR = DCL symbol to translate
;              OUTSTR = symbol translation
;
; ^x00010005 - PRINT ERROR MESSAGE      (65541)
;              INSTR = string containing error number (in decimal)
;
; ^x00010006 - CHECK IF FILE IS LOCKED  (65542)
;              INSTR = string containing filename to check
;              Return INCODE = (1 = file locked, 0 file not locked)
;
; ^x00010007 - SET DEFAULT DIRECTORY    (65543)
;              INSTR = string containing new directory to go to.
;
; ^x00010008 - DEFINE LOGICAL NAME      (65544)
;              INSTR = string containing logical name followed by translation.
;                      The string is of the form "log-nam  value", where "log-nam"
;                      is the logical name to be defined and "value" is the
;                      value to be assigned to the logical name.  One or more
;                      spaces must separate the two.
;
; ^x00010009 - SHOW IDENT NUMBER        (65545)
;              OUTSTR = Ident version number.
;
; ^x0001000A - DELETE FILE              (65546)
;              INSTR = Filename to delete.
;
; ^x0001000B - SET SYMBOL               (65547)
;              INSTR = symbol to set
;
;
; ^x0002000n - SENDING MESSAGE FLAGS    (131072)
;          n - Value of message flags setting
;              This code is used when we recursively call ourselves to
;              give ourselves the current value (0-15) of message flags.
;              Used when a message is signaled.
;
;
; ^x0003000n - DIRECTORY                (196608)
;          n - Code used for reentry.
;
;
; ^x00040001 - TRANSLATE FROM EBCDIC TO ASCII   (262145)
;              INSTR = EBCDIC string
;              OUTSTR = ASCII string
;
; ^x00040002 - TRANSLATE FROM ASCII TO EBCDIC   (262146)
;              INSTR = ASCII string
;              OUTSTR = EBCDIC string
;
; ^x00040003 - INITIALIZE RANDOM NUMBER GENERATOR WITH PASSWORD (262147)
;              INSTR = Password
;              OUTSTR = Status
;
; ^x00040004 - ENCRYPT STRING                   (262148)
;              INSTR = String to encrypt
;              OUTSTR = Encrypted string
;
; ^x00040005 - DECRYPT STRING                   (262149)
;              INSTR = String to decrypt
;              OUTSTR = Decrypted string
;
; ^x0005000n - SORT                     (327680)
;          n = 1.  Preparse command line
;              2.  Pass files and do sort (for file sort)
;              3.  Postparse command line
;              4.  Pass a record to sort.  (Repeat until all records passed)
;              5.  Do record sort
;              6.  Receive a record in sorted order.  (Repeat until all records received)
;              7.  Cleanup record sort
;
; ^x0006000n - SPELL            (393216)
;          n = 1.  Dictionary browse previous page
;          n = 2.  Dictionary browse using word
;          n = 3.  Dictionary browse next page
;          n = 4.  Spell textline
;          n = 5.  Spell guess
;          n = 6.  Accept word (add to accepted word list)
;          n = 7.  Add word to personal dictionary.
;          n = 8.  Dump commonwords list
;--
; COMMENTS:
; 1. MODULE FORMAT
; There are four program sections (.PSECT) used:
;       .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC         !non-changing non-shareable (contains .ADDRESS or .ASCID references)
;       .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR     !non-changing shareable (no .ADDRESS or .ASCID references)
;       .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR     !changing data
;       .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR          !static code (shareable)
; STATSHR is used for static variables which don't change (excluding .ADDRESS and .ASCID) references)
; STATIC is used for static variables which are position dependent (.ADDRESS and .ASCID)
; DATA is used for variables which change
; CODE is used for the executable code
;
; By shareable I mean if EDX_CALLUSER is installed via VMS INSTALL with the
; /SHARE qualifier, then only one copy of shareable PSECTs will be in system
; memory, and all processes running EDX will share the same memory.  PSECT
; CODE, for example, never changes and is the same for all processes.  Some
; PSECTs are not shareable in this manner.  PSECT DATA for example holds data
; which is process specific.  Each process running EDX will have it's own
; copy of PSECT DATA.
;
; PSECT STATIC is not shareable because it contains .ADDRESS references (.ASCID
; also implies a .ADDRESS reference).  The addresses are fixed up when this
; shareable image is loaded.  This shareable image is loaded when it is first
; called, not at the startup of EDX.  You may notice a slight delay the first
; time you do a DIRECTORY command, or any command which uses this shareable
; image.  This is because the shareable image is being loaded.  There is no
; delay for subsequent references after this image is loaded.
;
; This shareable image is loaded as a position independent module.  The
; operating system decides where in memory to put it at load time, thus the
; base address of this module may be different for each user running EDX,
; and thus the .ADDRESS fixes applied at load time will be different, and
; PSECTs containing .ADDRESS (or .ASCID) references are not shareable.
;
;
; 2.  INSTALLING EDX_CALLUSER AS A KNOWN IMAGE
; In most cases I do not recommend installing this EDX_CALLUSER shareable image
; file for the following reason.  TPU loads the shareable image pointed to
; by the TPU$CALLUSER logical name by calling LIB$FIND_IMAGE_SYMBOL, which in
; turn calls SYS$IMGACT, which in turn calls IMG$OPEN_IMAGE which in turn
; calls RMS$OPEN specifying the FAB file options bit FAB$V_KFO (known file
; open, undocumented and unsupported for user use).  RMS$OPEN first calls
; its internal subroutine RM$PRFLNM (process file name) which translates the
; logical TPU$CALLUSER passed to it, and then calls INS$KF_SCAN (known file
; scan) which searches it's database of known files for the specified file.
;
; Tests on our VMS 5.1-1 system show that RM$PRFLNM does not translate concealed
; logical names including concealed device names, whereas the known file list
; contains only physical device names, and as a result INS$KF_SCAN does not find
; the known file.  RMS then goes on to find the file in the normal manner.
;
; Interesting things can also happen at this point if there exists a new higher
; version of the installed file.  If the file is installed /OPEN, then the
; lower installed version will still be loaded.  Even if the lower version is
; purged away, it will still be loaded because VMS INSTALL has the file open,
; and the file can not be deleted until VMS INSTALL closes it.  So even though
; the file's name was removed from the directory by a $ PURGE or $DELETE
; command, the file still exists and will still be loaded.  Remember this
; whenever you install a new version of a product.
;
; On the other hand, if the file is not installed /OPEN, and a higher version
; exists, then the higher version will be loaded.  But, if the lower version
; is purged away, then the higher version will not be loaded, RMS will complain
; that the lower version has disappeared.
;
;
; 3. VMS CALLING STANDARD
; The VMS procedure calling standard is not strictly adhered to in that
; parameters are passed back and forth via registers rather than pushing
; them on the stack, and some procedures return parameters in registers.
; The VMS procedure calling standard specifies that a procedure preserve
; the contents of all registers except R0 and R1.
;
; 4. OPTIMIZATION
; To optimize the code, procedures that are often called are placed near
; the beginning, and procedures that are seldom called are placed near
; the end.  This helps to minimize page faulting.
;
;  David Deley  May, 1988  Original
;  David Deley  Nov. 1988  New version compatible with VMS 5.0
;  David Deley  Nov. 1989  v5.7 with string sort
;  David Deley  Mar. 1990  V6.0 with spelling checker dictionary
;------------------------------------------------------------------------------

;  System routines
;  TPU$CALLUSER                 !Main entry point.  Entered via TPU CALL_USER instruction.
;  SHOW_ID                      !Show ident number
;  FMTOUTSTR                    !Format output string
;  EDX_SIGNAL                   !Signal message
;  EDX_SIGMSG                   !Signal warning messages not signaled by TPU
;  HANDLER                      !Error handler
;
;  Display directory listing
;  EDX_DIRECTORY                !Display directory listing
;  GETDEFDIRFLGS                ! support for directory command
;
;Sort Routines:
;  EDX_SORT                     !Main entry.
;  SORT_PREPARSE                !Preparse SORT command
;  SORT_PASSFILES               !Pass filenames for file sort
;  SORT_POSTPARSE               !Finish parsing SORT command
;  SORT_DO_FILE                 !Do file sort
;  SORT_RELEASE_REC             !Give record to sort when using record sort
;  SORT_RETURN_REC              !Get record from sort when using record sort
;
;  Spelling checker and dictionary
;  EDX_SPELL                    !Spelling dictionary main entry
;  SPELL_INIT                   !Initialize spelling checker
;  SPELL_TEXTLINE               !Spell check a line of text
;  DIC_LOOKUP_WORD              !Look up a word in the dictionary
;  DIC_BROWSE                   !Browse through the dictionary
;  DIC_BROWSE_PREV_PAGE         ! support for browse
;  DIC_BROWSE_WORD              ! support for browse
;  DIC_BROWSE_FILL              ! support for browse
;  SPELL_GUESS                  ! Guess the spelling of a word.  From Vassar.
;  SPELL_ACCEPT_WORD            ! Insert word into accepted word tree list
;  TRAVERSE_TREE                ! debug routine for accepted tree list
;  PRINT_NODE                   ! debug routine for accepted tree list
;  ALLOCATE_NODE                ! support routine for accepted tree list
;  COMPARE_NODE                 ! support routine for accepted tree list
;  SPELL_PERSDIC_ADD            ! add word to personal dictionary
;  DUMP_COMMONWORDS             ! dump the commonword list
;
;  Lock and unlock files
;  LOCK_FILE                    !Lock a file preventing others from editing it
;  UNLOCK_FILE                  !Unlock file
;  EDX_CKFILK                   !Check if file is locked
;  SRCH_LNKFABLST               !Search our list of locked files
;  EDX_PARSE                    !Parse a filename
;
;  Miscellaneous
;  EDX_SETDEF                   !Change users default directory
;  SET_LOGICAL                  !Create a logical name
;  SET_SYMBOL                   !Create a DCL symbol
;  SHOW_LOGICAL                 !Show translation of a logical name
;  SHOW_SYMBOL                  !Show translation of a DCL symbol
;  DELETE_FILE                  !Delete a file
;  TRA_EBC_ASC                  !Translate EBCDIC to ASCII
;  TRA_ASC_EBC                  !Translate ASCII to EBCDIC
;
;  Entrypt a buffer
;  ENCRYPT_INIT                 !Initialize encryption algorythm
;  ENCRYPT                      !Encrypt main entry
;  HCKPWD                       !Hack password
;  AUTODIN_CRC                  !Calculate AUTODIN II cyclic redundancy code
;  DES_INIT                     !Data Encryption Standara initialization
;  DES_ENCRYPT                  !Encrypt using Data Encryption Standard
;------------------------------------------------------------------------------

        .TITLE  EDX_CALLUSER
        $CHFDEF                         ;Include CHF$ definitions
        $CLIMSGDEF
        $DSCDEF                         ;Define DSC$ descriptor definitions
        $FABDEF                         ;Include FAB$ definitions
        $LNMDEF                         ;Include LNM$ definitions
        $NAMDEF                         ;Include NAM$ definitions
        $RMSDEF
        $SSDEF                          ;Include SS$ system condition code definitions
        $STSDEF
        $XABDATDEF
        $XABDEF
        $XABFHCDEF

SET_MESSAGE_FLAGS=2                     ;Code for recursive call to set message flags
BUFLEN=256                              ;Usual length of string buffers (evenly divisible by 4 for longword alignment)
MAXLEN=960                              ;Maximum length of line in buffer (evenly divisible by 4 for longword alignment)

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
.ALIGN LONG
INSTR::    .LONG  0                     ;Address of instr descriptor
OUTSTR::   .LONG  0                     ;Address of outstr descriptor

        .MACRO  RETURN
        MOVZBL  #SS$_NORMAL,R0
        RET
        .ENDM   RETURN

        .MACRO  CHECK_STATUS,?DEST
        BLBS    R0,DEST
        PUSHL   R0      ;save R0 status
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL
        POPL    R0      ;restore R0 status
DEST:   .ENDM   CHECK_STATUS

        .MACRO  PUSHQ val
        MOVQ    val,-(SP)
        .ENDM   PUSHQ
;----------------------------------------------------------------------
; OUTSTR := CALL_USER( INCODE, INSTR)

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  TPU$CALLUSER,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>
        MOVAL   HANDLER ,(FP)           ; Establish anti-crashing handler

        ;Get incode
        MOVL    4(AP),R2                ;Address of incode to R2
        MOVL    (R2),R0                 ;Incode to R0
        MOVZWL  R0,R6                   ;Low word of input integer to R6
        EXTZV   #16,#16,R0,R5           ;High word of input integer to R5
        CMPL    R5,#SET_MESSAGE_FLAGS   ;Compare with set message flags code
        BNEQ    CASE                    ;Branch if not
        MOVL    R6,MSGFLGS              ;Save message flags setting
        RETURN                          ;Return.  Exit for (set_message_flags code)

CASE:   ;Save input and output string parameters
        MOVQ    @8(AP),-(SP)                    ;Copy over old descriptor to stack
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(SP)  ;Fill in Type
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(SP)  ;Fill in Class
        MOVL    SP,INSTR                        ;Address of new descriptor to INSTR
        MOVL    12(AP),OUTSTR                   ;Address of output string descriptor

        ;Case incode
        CASEL   R5, #1, #<6-1>          ;Case category item code
1$:     .WORD   CASSYS-1$,-             ; 1 = SYSTEM stuff
                2$-1$,-                 ; 2 = Set message_flags. Should have been taken care of above so branch to error
                SHODIR-1$,-             ; 3 = DIRECTORY
                CASTRN-1$,-             ; 4 = TRANSLATE
                EDXSRT-1$,-             ; 5 = SORT
                EDXSPL-1$               ; 6 = SPELL
2$:     PUSHL   #EDX__UNKNCODE          ;Unknown item code
        CALLS   #1,EDX_SIGNAL           ;Signal internal error
        RETURN

CASSYS: ;Case 0001xxxx system code numbers
        CASEL   R6, #1, #<11-1>         ;Case specific item code
2$:     .WORD   LCKFIL-2$,-             ; 1 = LOCK FILE
                UNLCKF-2$,-             ; 2 = UNLOCK FILE
                SHOLOG-2$,-             ; 3 = SHOW LOGICAL
                SHOSYM-2$,-             ; 4 = SHOW SYMBOL
                SIGMSG-2$,-             ; 5 = SIGNAL ERROR MESSAGE
                CKFILK-2$,-             ; 6 = CHECK IF FILE IS LOCKED
                SETDEF-2$,-             ; 7 = SET DEFAULT DIRECTORY
                SETLOG-2$,-             ; 8 = DEFINE LOGICAL NAME
                SHOWID-2$,-             ; 9 = SHOW IDENT NUMBER
                DELFIL-2$,-             ;10 = DELETE FILE
                SETSYM-2$               ;11 = SET SYMBOL
        PUSHL   #EDX__UNKNCODE          ;Unknown item code
        CALLS   #1,EDX_SIGNAL           ;Signal internal error
        RETURN
LCKFIL: CALLS   #0,LOCK_FILE
        RETURN
UNLCKF: CALLS   #0,UNLOCK_FILE
        RETURN
SHOLOG: CALLS   #0,SHOW_LOGICAL
        RETURN
SHOSYM: CALLS   #0,SHOW_SYMBOL
        RETURN
SIGMSG: CALLS   #0,EDX_SIGMSG
        RETURN
CKFILK: CALLS   #0,EDX_CKFILK
        RETURN
SETDEF: CALLS   #0,EDX_SETDEF
        RETURN
SETLOG: CALLS   #0,SET_LOGICAL
        RETURN
SHOWID: CALLS   #0,SHOW_ID
        RETURN
DELFIL: CALLS   #0,DELETE_FILE
        RETURN
SETSYM: CALLS   #0,SET_SYMBOL
        RETURN

SHODIR: ;Case 0002xxxx directory code numbers
        CALLS   #0,EDX_DIRECTORY
        RETURN

CASTRN: ;Case 0004xxxx translate_string code routines
        CASEL   R6, #1, #<4-1>          ;Case entry point to jump to
4$:     .WORD   EBCASC-4$,-             ;1 = TRANSLATE EBCDIC TO ASCII
                ASCEBC-4$,-             ;2 = TRANSLATE ASCII TO EBCDIC
                ENCINI-4$,-             ;3 = INITIALIZE RANDOM NUMBER GENERATOR WITH PASSWORD
                ENCRPT-4$               ;4 = ENCRYPT/DECRYPT A STRING
        PUSHL   #EDX__UNKNCODE          ;Unknown item code
        CALLS   #1,EDX_SIGNAL           ;Signal internal error
        RETURN
EBCASC: CALLS   #0,TRA_EBC_ASC
        RETURN
ASCEBC: CALLS   #0,TRA_ASC_EBC
        RETURN
ENCINI: CALLS   #0,ENCRYPT_INIT
        RETURN
ENCRPT: CALLS   #0,ENCRYPT
        RETURN

EDXSRT: CALLS   #0,EDX_SORT
        RETURN
EDXSPL: CALLS   #0,G^EDX_SPELL
        RETURN
;------------------------------------------------------------------------------

        .SBTTL  SHOW IDENT VERSION NUMBER
;++
;
; Functional Description:
;       This routine returns the ident version number of this module
;
; Calling Sequence:
;       CALLS   #0,SHOW_ID
;
;--
        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR
        .IDENT  /6.2-297/
IDENT:  .ASCII  /6.2-297/
IDENTL= .-IDENT

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  SHOW_ID,^M<>
        PUSHAL  IDENT                           ;address of output string
        PUSHL   #IDENTL                         ;length of output string
        PUSHL   #1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET

;------------------------------------------------------------------------------

        .SBTTL  INITIALIZE VIRTUAL MEMORY ZONE
;++
;
; Functional Description:
;       This routine calls lib$create_vm_zone to initialize our own
;       personal virtual memory zone.
;
; Calling Sequence:
;       JSB     INITVMZONE
;
; Registers used:
;       none
;--

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR

VM_ZONE::  .LONG  0                             ;Our virtual memory zone id (initialize at zero)
;--

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR
        $LIBVMDEF                                       ;Include LIB$ definitions for virtual memory

VM_FLAGS:   .LONG  <LIB$M_VM_GET_FILL0+ -
                    LIB$M_VM_FREE_FILL1>        ;Flags to LIB$CREATE_VM_ZONE
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR

INITVMZONE::                            ;Create our own personal virtual memory zone
        TSTL    VM_ZONE                 ;Our virtual memory zone id
        BNEQU   1$                      ;Branch if zone already created
        PUSHAL  VM_FLAGS                ;flags
        PUSHL   #0                      ;algorithm-arg
        PUSHL   #0                      ;algorithm
        PUSHAL  VM_ZONE                 ;zone-id
        CALLS   #4,G^LIB$CREATE_VM_ZONE ;Create virtual memory zone
1$:     RSB                             ;Return
;------------------------------------------------------------------------------

        .SBTTL  FMTOUTSTR
;++
;
; Functional Description:
;       This routine combines the return code in RETCODE with the return
;       string specified by
;
; Argument inputs:
;     (AP) - number of arguments (1 or 3)
;    4(AP) - value of return code
;    8(AP) - length of output string   /optional   May also place a string
;   12(AP) - address of output string  \optional   descriptor here.
;
;       FMTOUTSTR STORAGE ALLOCATED ON STACK
;       -----------------------------------------(descriptor for FAO output string)
;       |  class  |  dtype  |  string length    | <00> (R11 = base address)
;       -----------------------------------------
;       |            buffer address             | <04>
;       -----------------------------------------(buffer to place FAO output string)
;       |                                       | <08>
;       -                                       -
;       -                                       -
;       -                                       -
;       |                                       |
;       -----------------------------------------
;                                               | <08+12>
;------------------------------------------------------------------------------
        .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC

.ALIGN LONG
CTLOUTSTR1: .ASCID /!9ZL/

;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  FMTOUTSTR,^M<R2,R3,R4,R5,R6,R7,R8,R11>

        ;Allocate memory on stack
        SUBL2   #<08 + 12>,SP                   ;(actually only use 9 of the 12)
        MOVL    SP,R11                          ;Store base address of memory allocated

        ;Initialize descriptor for FAO output string
        MOVW    #09,DSC$W_LENGTH(R11)           ;Buffer length is 9
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R11) ;Class
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R11) ;Type
        MOVAL   8(R11),DSC$A_POINTER(R11)       ;Buffer address

        ;call sys$fao with 1 argument
        PUSHL   4(AP)                           ;retcode (by value)
        PUSHL   R11                             ;outbuf (by descriptor)
        PUSHL   R11                             ;outlen (word by reference)
        PUSHAQ  CTLOUTSTR1                      ;ctrstr (by descriptor)
        CALLS   #4,G^SYS$FAO                    ;format message string

        ;copy to outstr
        MOVL    R11,R1                          ;src-str (by descriptor)
        MOVL    OUTSTR,R0                       ;dst-str (by descriptor)
        JSB     G^STR$COPY_DX_R8                ;Copy to OUTSTR

        CMPL    (AP),#1                         ;See if there was only one argument
        BEQL    10$                             ;Branch if so

;Reuse string descriptor
        MOVW    8(AP),DSC$W_LENGTH(R11)         ;Buffer length
        MOVL    12(AP),DSC$A_POINTER(R11)       ;Buffer address
        PUSHL   R11                             ;src-str
        PUSHL   OUTSTR                          ;dst-str
        CALLS   #2,G^STR$APPEND                 ;append retstr to end of retcode

10$:    RET
;------------------------------------------------------------------------------

        .SBTTL  EDX_SIGNAL
;++
;
; Functional Description:
;       This routine prints message text to the message buffer.  The routine
;       input is modeled after LIB$SIGNAL.  (See description of LIB$SIGNAL)
;
; Calling Sequence:
;       CALL EDX_SIGNAL (condition-value1
;                       [,number1]
;                       [,FAO-arg1
;                        .
;                        FAO-argn1]
;                       [,condition-value2]
;                       [,number2]
;                       [,FAO-arg2
;                        .
;                        FAO-argn2]
;                       etc.
;
; Argument inputs:
;     (AP) - number of arguments (value)
;    4(AP) - condition-value1 (value)
;    8(AP) - number1 (value)
;   12(AP) - FAO-arg1 (unspecified.  Values sent directly to FAO)
;       etc.
;
; Outline:
;       1.  Allocate memory on stack
;       2.  Check severity of message to signal.  If FATAL then use full
;           message format (facility, identification, severity, text). Otherwise
;           obtain current TPU message flags by calling ourselves using TPU$EXECUTE_COMMAND.
;           The TPU command executed is:
;           EDTN$X_DUMMY := CALL_USER( ^x00020000 + GET_INFO(SYSTEM,"message_flags"), "") )
;           which parses to:
;           EDTN$X_DUMMY := CALL_USER( ^x0002000F, "")
;           where 'F' is the current setting of the message flags (0-F hex).
;           This value gets stored in MSGFLGS.
;       3.  Call sys$getmsg to get message text
;       4.  Call sys$fao to process message text
;       5.  Call tpu$message to write message text to tpu message_buffer.
;
;       EDX_SIGNAL STORAGE ALLOCATED ON STACK
;       -----------------------------------------(descriptor for FAO output string)
;       |  class  |  dtype  |  string length    | <^x00> (R2 = base address)
;       -----------------------------------------
;       |            buffer address             | <^x04>
;       -----------------------------------------(buffer to place FAO output string)
;       |                                       | <^x08>
;       -                                       -
;       -                                       -
;       -                                       -
;       |                                       |
;       -----------------------------------------(descriptor for message string)
;       |  class  |  dtype  |  string length    | <^x08+BUFLEN>
;       -----------------------------------------
;       |            buffer address             | <^x0C+BUFLEN>
;       -----------------------------------------(buffer to place message string)
;       |                                       | <^x10+BUFLEN>
;       -                                       -
;       -                                       -
;       -                                       -
;       |                                       |
;       -----------------------------------------(original stack pointer)
;                                               | <^x10+2*BUFLEN>
;
;------------------------------------------------------------------------------
        .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC

.ALIGN LONG
BELL::      .ASCID <^x07>               ;String containing bell character
.ALIGN LONG
MSGFLGCMD:  .ASCID /EDTN$X_DUMMY:=CALL_USER(131072+GET_INFO(SYSTEM,'MESSAGE_FLAGS'),"")/
;------------------------------------------------------------------------------

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR

.ALIGN LONG
MSGFLGS:   .LONG  ^B1111                ;Current TPU message_flags
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  EDX_SIGNAL,^M<R2,R3>

        ;Allocate memory on stack
        SUBL2   #<^x10 + <2*BUFLEN>>,SP         ;Move stack pointer over memory we claim
        MOVL    SP,R2                           ;Store base address.  We'll use this memory for the message strings

        ;Initialize counter in R3 to count call arguments used
        CLRL    R3

        ;Check severity of primary message.  Ring bell if not good.
        BLBS    4(AP),1$                                ;Branch if success message
        BITL    #^B0011,4(AP)                           ;Test for warning
        BEQL    1$                                      ;No bell if warning
        PUSHAL  BELL                                    ;Ring terminal bell
        CALLS   #1,G^LIB$PUT_OUTPUT

        ;If message is fatal, use full message flags
        BITL    4(AP),#STS$K_SEVERE                     ;Compare with fatal status
        BEQL    1$                                      ;Branch if not fatal
        MOVZBL  #^x0F,MSGFLGS                           ;Use full message format
        BRB     2$

        ;Otherwise if non-fatal status then get current value of message flags
1$:     PUSHAQ  MSGFLGCMD
        CALLS   #1,G^TPU$EXECUTE_COMMAND

        ;Initialize descriptor for message string
2$:     MOVAL   <^x10+BUFLEN>(R2),<^x0C+BUFLEN>(R2)     ;Buffer address
        MOVB    #DSC$K_CLASS_S,<^x0B+BUFLEN>(R2)        ;Class
        MOVB    #DSC$K_DTYPE_T,<^x0A+BUFLEN>(R2)        ;Type

        ;Initialize descriptor for FAO output string
        MOVAL   <^x08>(R2),DSC$A_POINTER(R2)            ;Buffer address
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R2)          ;Class
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R2)          ;Type

        ;BEGIN MAIN LOOP
        ;Initialize buffer length in message string descriptor and FAO output string descriptor
3$:     MOVW    #BUFLEN,<^X08+BUFLEN>(R2)       ;Buffer length in message string descriptor
        MOVW    #BUFLEN,(R2)                    ;Buffer length in FAO output string descriptor

        ;Increment R3 count of arguments used (point to next message-id)
        INCL    R3

        ;Call sys$getmsg
        PUSHL   #0                              ;outadr
        PUSHL   MSGFLGS                         ;flags (by value)
        PUSHAQ  <^x08+BUFLEN>(R2)               ;bufadr (address of descriptor)
        PUSHAW  <^x08+BUFLEN>(R2)               ;msglen (by reference)
        PUSHL   (AP)[R3]                        ;msgid (by value)
        CALLS   #5,G^SYS$GETMSG                 ;get message text

        ;Check for FAO arguments
        INCL    R3                              ;Number of FAO arguments
        INCL    R3                              ;FAO argument #1
        SUBL3   R3,(AP),R1                      ;Number of arguments used - number of arguments given
        BLSS    4$                              ;Branch if no arguments left to use

        ;call sys$fao
        PUSHAL  (AP)[R3]                        ;prmlst
        PUSHL   R2                              ;outbuf
        PUSHL   R2                              ;outlen
        PUSHAQ  <^x08+BUFLEN>(R2)               ;ctrstr
        CALLS   #4,G^SYS$FAOL                   ;format message string

        ;call tpu$message
        PUSHL   R2                              ;Address of output descriptor
        CALLS   #1,G^TPU$MESSAGE                ;Output the string

        ;See if there's another message to do
        DECL    R3                              ;(AP)[R3] is FAO argument count
        ADDL2   (AP)[R3],R3                     ;Increment R3 number of FAO arguments
        CMPL    R3,(AP)                         ;See if call specified more arguments
        BLSS    3$                              ;If so then loop
        RET                                     ;Else return.  All done.

        ;Print out last (or only) message
4$:     PUSHAQ  <^x08+BUFLEN>(R2)               ;Address of output descriptor
        CALLS   #1,G^TPU$MESSAGE                ;Output the message
        RET                                     ;and return
;------------------------------------------------------------------------------

        .SBTTL  EDX_SIGMSG
;++
;
; Functional Description:
;       Prints error message associated with error number in string INSTR
;       only if error status was warning.  TPU prints errors but trapped
;       warnings are not printed, so we call this routine to print the
;       error if it happens to be warning status.
;
; Calling Sequence:
;       CALLS   #0,EDX_SIGMSG
;
; Argument inputs:
;       INSTR = address of string descriptor pointing
;               to string containing error number.
;
; Outputs:
;       Error message is printed to TPU message_buffer
;       if error status was warning.
;
; Outline:
;       1.  String containing error code is translated to numeric value
;       2.  EDX_SIGNAL is called to print error message
;
;--
        .ENTRY  EDX_SIGMSG,^M<R2,R3,R5>
        ;Convert string containing integer to integer by using LIB$CVT_DTB
        PUSHL   #0                      ;Make memory location for result on stack
        MOVL    SP,R2                   ;Address of result
        PUSHL   R2                      ;Address of result
        MOVL    INSTR,R3                ;Address of input string descriptor
        PUSHL   4(R3)                   ;Address of string
        MOVZWL  (R3),R5                 ;Length of string
        PUSHL   R5                      ;Length of string (by value)
        CALLS   #3,G^LIB$CVT_DTB        ;Convert string to integer
        BITL    (R2),#STS$M_SEVERITY    ;Test for warning status
        BNEQ    1$                      ;Branch if not warning
        CALLS   #1,EDX_SIGNAL           ;Signal resulting error number
1$:     RET
;------------------------------------------------------------------------------

        .SBTTL  CONDITION HANDLER
;++
;
; Functional Description:
;       This routine handles unexpected errors that are signaled.
;       The error is printed to the TPU message_buffer.
;       If the error is severe, an attempt is made to return to TPU,
;       otherwise the error is non-fatal and an attempt is made to continue.
;
;       NEW - A signal of any type including Informational (-I-) is not
;       resignaled because the TPU CALL_USER routine establishes it's own
;       condition handler that will be called next if our handler does not
;       handle the condition, and the TPU handler calls LIB$SIG_TO_RET if
;       the signaled condition does not have a facility value of TPU.
;
;       Therefore we never return with SS$_RESIGNAL
;
; Inputs:
;       CHF$L_SIGARGLST(AP) - Address of sigargs array
;--
        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
.ALIGN LONG
;The following errors take the PC and PSL as FAO arguments.  The rest don't.
ERRPCPSL:  .LONG   SS$_ACCVIO
           .LONG   SS$_ARTRES
           .LONG   SS$_INTOVF
           .LONG   SS$_FLTDIV
           .LONG   SS$_FLTUND
           .LONG   SS$_DECOVF
           .LONG   SS$_SUBRNG
           .LONG   SS$_ASTFLT
           .LONG   SS$_BREAK
           .LONG   SS$_CMODSUPR
           .LONG   SS$_CMODUSER
           .LONG   SS$_DEBUG
           .LONG   SS$_OPCCUS
           .LONG   SS$_OPCDEC
           .LONG   SS$_PAGRDERR
           .LONG   SS$_RADRMOD
           .LONG   SS$_ROPRAND
           .LONG   SS$_SSFAIL
           .LONG   SS$_TBIT
NUMPCPSL=19                     ;number in above list

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  HANDLER ^M<R2,R3,R4>
        MOVL    CHF$L_SIGARGLST(AP),R4  ;Get address of signal args
        MOVL    CHF$L_SIG_NAME(R4),R2   ;Get condition code
        CMPL    #SS$_UNWIND,R2          ;Check for unwind operation
        BNEQ    20$                     ;Branch if not
        RET                             ;Return.  Unwinding

        ;Print out all messages, including successfull ones.
20$:    PUSHL   R2
        MOVL    SP,R2                   ;R2 is now address of condition value
        MOVAL   ERRPCPSL,R0             ;set up and call LIB$MATCH_COND
        MOVL    #NUMPCPSL,R1
        DECL    R1                      ;convert to offset
21$:    PUSHAL  (R0)[R1]                ;push all errors which use PC and PSL
        SOBGEQ  R1,21$
        PUSHL   R2                      ;address of condition value
        MOVL    (R2),R2                 ;R2 = condition value again
        ADDL3   #1,#NUMPCPSL,R0         ;total number of arugments
        CALLS   R0,G^LIB$MATCH_COND     ;returns R0 = 0 if not require PC and PSL

        MOVL    CHF$L_SIG_ARGS(R4),R1   ;number of FAO arguments for error
        DECL    R1                      ;remove one for condition name in signal array
        TSTL    R0
        BNEQ    31$
        SUBL2   #2,R1                   ;decrement number by 2 if not require PC and PSL
31$:    MOVL    R1,R3
        MOVAL   CHF$L_SIG_ARG1(R4),R0
        BRB     33$
32$:    PUSHL   (R0)[R1]                ;push arguments on stack
33$:    SOBGEQ  R1,32$
        PUSHL   R3                      ;number of arguments for error
        PUSHL   R2                      ;Push error code on stack

        BITL    #STS$K_SEVERE,R2        ;Check for fatal status
        BNEQ    40$                     ;Branch if fatal
        INCL    R3
        CALLS   R3,EDX_SIGNAL           ;Print error to TPU message_buffer
        MOVL    #SS$_CONTINUE,R0        ;Signal to continue
        RET                             ;Return from exception

;       Handle unexpected fatal errors
40$:    PUSHL   #0                      ;Zero FAO arguments for EDX__UNEXPERR
        PUSHL   #EDX__UNEXPERR          ;Error message
        ADDL3   #3,R3,R0
        CALLS   R0,EDX_SIGNAL           ;Print the error message

        ;Unwind stack and return to TPU
        CALLS   #0,G^SYS$UNWIND         ;unwind stack
        RET
;==============================================================================

        .SUBTITLE EDX_DIRECTORY
;++
;
; Functional Description:
;       Displays a directory listing
;
; Calling Sequence:
;       CALLS   #0,EDX_DIRECTORY
;
; Argument inputs:
;       R6 = Code describing where to reenter (low word of INCODE)
;       INSTR = Address of descriptor of directory command
;               The directory command is of the form:
;               DIRECTORY [/SIZE] [/DATE] [dir-spec]
;
; Outputs:
;       OUTSTR = Line to place in DIR_BUFFER
;       RETCODE = Code to use for consecutive calls
;       (note: OUTSTR and RETCODE are placed together in the returned string
;        by FMTOUTSTR routine.  RETCODE is stored in first 9 characters of
;        the returned output string.)
;
; Comments:
;       For regular directory listing, filenames are placed 4 across
;       staring at column offsets 0,20,40,60.
;
;       For /SIZE or /DATE qualifiers, filenames are placed at column offset 0.
;       Then if col is greater than 18 line is written and new line started
;       Error starts at column offset 19 if there is one
;       else /SIZE starts at offset 19 if specified
;        and /DATE starts at offset 29 if specified
;
;       COL is used as both a length indicator and a column offset indicator.
;       The value of COL is the number of characters in OUTLINE.  When the
;       value of COL is added to the base address of OUTLINE, the result is
;       the address to start adding text to when appending text out OUTLINE.
;
; Outline:
;       1.  Entry code is cased for consecutive reentries
;       2.  On initial entry
;           A.  a.  Dirflgs is initialized
;               b.  The EDX directory command is parsed for /SIZE, /DATE, and dir-spec.
;           B.  Memory is allocated for DIRBLK
;               a.  Create VM_ZONE if we haven't already.
;               b.  If memory base address DIRBLKBSE isn't zero attempt to
;                   deallocate memory which may have been allocated by a
;                   previous call and then aborted by a user's CTRL-C input.
;               c.  Allocate new memory block for DIRBLK.
;           C.  New DIRBLK is initialized
;               a.  FAB block initialized
;               b.  NAM block initialized
;               c.  XABFHC block initialized
;               d.  XABDAT block initialized
;               e.  Variables are initialized
;           D.  Dir-spec placed into FAB
;           E.  Set DIRFLGS according to /SIZE and /DATE qualifiers
;           F.  $PARSE FAB to prepare for wildcard operations
;       3.  $SEARCH FAB for next filename
;       4.  If 'No more files' or 'File Not Found' or other error, exit with code
;       5.  Print new directory heading if needed
;           A.  If this is the first call, return first with the expanded
;               string for the window status line.
;           B.  Print directory heading.
;       6.  Add new file to outline.
;           A.  Move COL offset pointer into outline to next tab stop (0,20,40,60)
;               Print outline if line full.
;           B.  Add filename to outline
;       7.  Check DIRFLGS for qualifiers like /SIZE and /DATE
;           A.  If no qualifiers present then goto step 3.
;           B.  Print outline if filename too long
;           C.  Get file attributes
;           D.  Add size info if requested
;           E.  Add date info if requested
;           F.  Print outine
;           G.  Goto step 3.
;       8.  Repeat until exit by step 4.
;
; Description:
;       The TPU editor calls us with an initial code of START.  We return to
;       the TPU editor with an output string and a code telling the editor what
;       to do with the output string.  Usually the TPU editor is to print the
;       output string to the dir_buffer, occasionally it must add a blank line
;       or two.  It then calls us back passing to us the value of code we gave
;       it.  The value of code tells us where to jump back to.  The TPU editor
;       continues to call us until we pass it the NMF_ERR code.
;
; Register usage:
;       R9 = used as base address of DIRBLK (which is also the address of
;            the FAB block.  This number is permanently stored in DIRBLKBSE)
;       R10= used as base address of NAM block, XABFHC block, and XABDAT block.
;
; Memory Map:
;
;       DIRBLK BLOCK
;       -----------------------------------------(start of FAB block)
;       |         IFI       |    BLN   |   BID  | 00 (base address is DIRBLKBSE also R9)
;       -----------------------------------------
;       |                  FOP                  | 04
;       -----------------------------------------
;       |                  STS                  | 08
;       -----------------------------------------
;       |                  STV                  | 0C
;       -----------------------------------------
;       |                  ALQ                  | 10
;       -----------------------------------------
;       |   SHR   |    FAC  |        DEQ        | 14
;       -----------------------------------------
;       |                  CTX                  | 18
;       -----------------------------------------
;       |   RFM   |   RAT   |   ORG   |   RTV   | 1C
;       -----------------------------------------
;       |         |         |FACILITY | JOURNAL | 20
;       -----------------------------------------
;       |                  XAB                  | 24
;       -----------------------------------------
;       |                  NAM                  | 28
;       -----------------------------------------
;       |                  FNA                  | 2C
;       -----------------------------------------
;       |                  DNA                  | 30
;       -----------------------------------------
;       |        MRS        |   DNS   |   FNS   | 34
;       -----------------------------------------
;       |                  MRN                  | 38
;       -----------------------------------------
;       |   FSZ   |   BKS   |        BLS        | 3C
;       -----------------------------------------
;       |                  DEV                  | 40
;       -----------------------------------------
;       |                  SDC                  | 44
;       -----------------------------------------
;       |   RCF   | ACMODES |        GBC        | 48
;       -----------------------------------------
;       |         |         |         |         | 4C
;       ----------------------------------------- (start of NAM block)
;       |   RSL   |   RSS   |   BLN   |   BID   | 00 + FAB$C_BLN (base address is R10)
;       -----------------------------------------
;       |                  RSA                  | 04
;       -----------------------------------------
;       |   ESL   |   ESS   |   RFS   |   NOP   | 08
;       -----------------------------------------
;       |                  ESA                  | 0C
;       -----------------------------------------
;       |                  RLF                  | 10
;       -----------------------------------------
;       |         |         |         |         | 14
;       -----------------------------------------
;       |         |         |         |         | 18
;       -----------------------------------------
;       |         |         |         |         | 1C
;       -----------------------------------------
;       |         |         |         |         | 20
;       -----------------------------------------
;       |      FID_SEQ      |      FID_NUM      | 24
;       -----------------------------------------
;       |        DID        | FID_NBX | FID_RVN | 28
;       -----------------------------------------
;       | DID_NMX | DID_RVN |      DID_SEQ      | 2C
;       -----------------------------------------
;       |                  WCC                  | 30
;       -----------------------------------------
;       |                  FNB                  | 34
;       -----------------------------------------
;       |   NAME  |   DIR   |   DEV   |   NODE  | 38
;       -----------------------------------------
;       |         |         |   VER   |   TYPE  | 3C
;       -----------------------------------------
;       |                  NODE                 | 40
;       -----------------------------------------
;       |                  DEV                  | 44
;       -----------------------------------------
;       |                  DIR                  | 48
;       -----------------------------------------
;       |                  NAME                 | 4C
;       -----------------------------------------
;       |                  TYPE                 | 50
;       -----------------------------------------
;       |                  VER                  | 54
;       -----------------------------------------
;       |         |         |         |         | 58
;       -----------------------------------------
;       |         |         |         |         | 5C
;       -----------------------------------------(Input directory specification string)
;       |            INPUT FILE SPEC            | FAB$C_BLN+NAM$C_BLN
;       |                   .                   | (=INPFS)
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(Result file name string)
;       |        RESULTANT FILE NAME STRING     | FAB$C_BLN+NAM$C_BLN+<1*BUFLEN>
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(expanded file name string returned)
;       |        EXPANDED FILE NAME STRING      | FAB$C_BLN+NAM$C_BLN+<2*BUFLEN>
;       |                   .                   | (=EFNS)
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(root directory)
;       |                 ROOT                  | FAB$C_BLN+NAM$C_BLN+<3*BUFLEN>
;       |                   .                   | (=ROOT)
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(line to print to screen)
;       |                OUTLINE                | FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>
;       |                   .                   | (=OUTLINE)
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(current column offset into OUTLINE.  Current root directory length.  Directory flags /SIZE=1,/DATE=2.  First time root has been printed (True/False).)
;       | FRSTIME | DIRFLGS | ROOTLEN |   COL   | FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN
;       -----------------------------------------(XABFHC block)
;       |         |         |   BLN   |   BID   | 00 + FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x04
;       -----------------------------------------
;       |                  NXT                  | 04
;       -----------------------------------------
;       |        LRL        |   ATR   |   RFO   | 08
;       -----------------------------------------
;       |                  HBK                  | 0C
;       -----------------------------------------
;       |                  EBK                  | 10
;       -----------------------------------------
;       |   HSZ   |   BKZ   |        FFB        | 14
;       -----------------------------------------
;       |        DXQ        |        MRZ        | 18
;       -----------------------------------------
;       |         |         |        GBC        | 1C
;       -----------------------------------------
;       |         |         |         |         | 20
;       -----------------------------------------
;       |     VERLIMIT      |         |         | 24
;       -----------------------------------------
;       |                  SBN                  | 28
;       -----------------------------------------(XABDAT  block)
;       |         |         |   BLN   |   COD   | 00 + FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x04+XAB$C_FHCLEN
;       -----------------------------------------
;       |                  NXT                  | 04
;       -----------------------------------------
;       |         |         |         |         | 08
;       -----------------------------------------
;       |         |         |         |         | 0C
;       -----------------------------------------
;       |         |         |         |         | 10
;       -----------------------------------------
;       |                  CDT                  | 14
;       -                                       -
;       |                                       | 18
;       -----------------------------------------
;       |                  EDT                  | 1C
;       -                                       -
;       |                                       | 20
;       -----------------------------------------
;       |                  BDT                  | 24
;       -                                       -
;       |                                       | 28
;       -----------------------------------------
;                                               | FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x04+XAB$C_FHCLEN+XAB$C_DATLEN
;
;------------------------------------------------------------------------------

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR

        .EXTERNAL EDX_COMMANDS

;dir flags
GET_SIZE = 1
GET_DATE = 2

;column offset positions & constants
;....v....1....v....2....v....3....v....4....v....5....v....6....v....7....v....
;FILENAMEABC.EFG;21 00000000  25-JUL-1988 17:14
DATCOL = 29
SIZCOL = 19
SIZLEN =  8
DATLEN = 17
OUTLNLEN=132

;incodes
SRCHLP_CODE = 2         ;TPU prints outline and calls again
PROOT_CODE  = 3         ;TPU prints outline followed by two blank lines and calls us again
NXTTAB_CODE = 4         ;TPU prints outline followed by one blank line and calls us again
ADFILE_CODE = 5         ;TPU prints outline and calls us again
GETATR_CODE = 6         ;TPU prints outline and calls us again
RMS_ERR = 7             ;We print error message.  TPU exits.
FNF_ERR = 8             ;TPU prints 'no files found' and exits
NMF_ERR = 9             ;TPU prints outline and exits

;offsets
INPFS           = FAB$C_BLN+NAM$C_BLN
RSFN            = FAB$C_BLN+NAM$C_BLN+<1*BUFLEN>
EFNS            = FAB$C_BLN+NAM$C_BLN+<2*BUFLEN>
ROOT            = FAB$C_BLN+NAM$C_BLN+<3*BUFLEN>
OUTLINE         = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>
COL             = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN
ROOTLEN         = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x01
DIRFLGS         = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x02
FIRST_TIME      = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x03
XABFHC          = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x04
XABDAT          = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x04+XAB$C_FHCLEN
DIRBLKLEN       = FAB$C_BLN+NAM$C_BLN+<4*BUFLEN>+OUTLNLEN+^x04+XAB$C_FHCLEN+XAB$C_DATLEN

.ALIGN LONG
DIRH:     .ASCII  /Directory /          ;Directory header
DIRHLEN=.-DIRH                          ;Length of directory header
.ALIGN LONG
DEFAULT:  .ASCII /*.*;*/
DEFLEN=.-DEFAULT


        .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC
.ALIGN LONG
SIZE:     .ASCID  /SIZE/                ;/SIZE parameter
.ALIGN LONG
DATE:     .ASCID  /DATE/                ;/DATE parameter
.ALIGN LONG
DIRSPEC:  .ASCID  /DIRSPEC/             ;dir-spec parameter
.ALIGN LONG
FAOSIZE:  .ASCID  /!8UL/                ;Control string for adding size to output (SIZLEN=8)
;------------------------------------------------------------------------------

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
.ALIGN LONG
DIRBLKBSE:  .LONG  0                    ;Base address of dirblk

;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  EDX_DIRECTORY,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10>

        ;1.  Entry code is cased for consecutive reentries
        ;R6 = Entry code passed by caller
        ;CASE ENTRY CODE
        MOVL    DIRBLKBSE,R9                    ;Set R9 as base address of DIRBLK
        CASEL   R6, #1, #5                      ;Case entry point to jump to
1$:     .WORD   DSTRT-1$,-                      ; 1 = first call
                SRCHLP-1$,-                     ; 2 = go to SRCHLP
                PROOT-1$,-                      ; 3 = go to PROOT
                NXTTAB-1$,-                     ; 4 = go to NXTTAB
                ADFILE-1$,-                     ; 5 = go to ADFILE
                GETATR-1$                       ; 6 = go to GETATR
        MOVL    #EDX__UNKNCODE,R0               ;Put error status in R0
        BSBW    ERR                             ;Signal error
        RET                                     ;and return with error status in R0

        ;2.  On initial entry
        ;    A.  a.  Dirflgs is initialized
DSTRT:  PUSHL   #0                              ;Initialize dirflgs at zero
        PUSHL   SP                              ;Address of dirflgs
        CALLS   #1,GETDEFDIRFLGS                ;Get default qualifiers

        ;    A.  b.  The directory command is parsed for /SIZE, /DATE, and dir-spec.
        ;PARSE DIRECTORY COMMAND STRING USING CLI$DCL_PARSE
        PUSHAL  EDX_COMMANDS                    ;Address of command table for parse
        PUSHL   INSTR                           ;Address of input string descriptor
        CALLS   #2,G^CLI$DCL_PARSE              ;Parse input string
        BLBS    R0,CHKVM                        ;Branch on success
        RET                                     ;else return.  CLI$DCL_PARSE signaled error and our condition handler printed the error.

        ;    B.  Memory is allocated for DIRBLK
        ;        a.  Create VM_ZONE if we haven't already.
        ;CHECK VIRTUAL MEMORY ZONE
CHKVM:  BSBW    INITVMZONE                      ;Initialize our virtual memory zone

        ;        b.  If memory base address DIRBLKBSE isn't zero attempt to
        ;            deallocate memory which may have been allocated by a
        ;            previous call and then aborted by a user's CTRL-C input.
        ;TEST FOR MEMORY BLOCK ALREADY IN USE
TSTVM:  TSTL    DIRBLKBSE                       ;Make sure memory not already allocated
        BEQLU   ALOCVM                          ;Branch if memory not already allocated

        ;ATTEMPT TO DEALLOCATE PREVIOUSLY USED BLOCK
        MOVL    #DIRBLKLEN,-(SP)                ;Length of memory block to deallocate
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHAL  DIRBLKBSE                       ;Address of return address of memory block allocated
        PUSHL   R0                              ;Address containing length of memory to allocate
        CALLS   #3,G^LIB$FREE_VM                ;Attempt to deallocate memory previously in use
        CLRL    (SP)+                           ;Restore stack pointer

        ;        c.  Allocate new memory block for DIRBLK.
        ;ALLOCATE BLOCK OF MEMORY
ALOCVM: MOVL    #DIRBLKLEN,-(SP)                ;Length of memory block to allocate
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHAL  DIRBLKBSE                       ;Address to place return address of memory block allocated
        PUSHL   R0                              ;Address containing length of memory to allocate (LNKFABLEN by reference)
        CALLS   #3,G^LIB$GET_VM                 ;Allocate memory for new block in linked list
        CLRL    (SP)+                           ;Restore stack pointer
        BLBS    R0,INIFAB                       ;Continue if successful
        BSBW    ERR                             ;Else error signal message
        RET                                     ;and return

        ;    C.  New DIRBLK is initialized
        ;        a.  FAB block initialized
        ;INITIALIZE FAB
INIFAB: MOVL    DIRBLKBSE,R9                    ;Set R9 as base address of DIRBLK
        MOVB    #FAB$C_BID,FAB$B_BID(R9)        ;FAB block ID #
        MOVB    #FAB$C_BLN,FAB$B_BLN(R9)        ;FAB block length
        MOVAB   FAB$C_BLN(R9),FAB$L_NAM(R9)     ;NAM block address
        MOVAB   XABFHC(R9),FAB$L_XAB(R9)        ;XAB block address (XABFHC)
        MOVL    #FAB$M_NAM,FAB$L_FOP(R9)        ;FAB Options = use NAM block
        MOVAL   DEFAULT,FAB$L_DNA(R9)           ;Default file name of *.*;*
        MOVB    #DEFLEN,FAB$B_DNS(R9)           ;Default file name length
        MOVAL   INPFS(R9),FAB$L_FNA(R9)         ;Address of input string containing dir-spec
        BISB2   #FAB$M_GET,FAB$B_FAC(R9)        ;File Access options = GET
        BISB2   #<FAB$M_SHRGET+ -               ;Allow read/write sharing
                  FAB$M_SHRPUT+ -               ; in case we have to open the
                  FAB$M_SHRUPD+ -               ; file to get the file attributes
                  FAB$M_SHRDEL>,FAB$B_SHR(R9)   ;

        ;        b.  NAM block initialized
        ;INITIALIZE NAM BLOCK
        ADDL3   #FAB$C_BLN,R9,R10               ;R10 = Address of NAM block
        MOVB    #NAM$C_BID,NAM$B_BID(R10)       ;NAM block ID #
        MOVB    #NAM$C_BLN,NAM$B_BLN(R10)       ;NAM block length
        MOVB    #NAM$C_MAXRSS,NAM$B_RSS(R10)    ;Resultant file name string size
        ADDL3   #RSFN,R9,NAM$L_RSA(R10)         ;Resultant file name string address
        MOVB    #NAM$C_MAXRSS,NAM$B_ESS(R10)    ;Expanded file name string size
        ADDL3   #EFNS,R9,NAM$L_ESA(R10)         ;Expanded file name string address

        ;        c.  XABFHC block initialized
        ;INITIALIZE XABFHC BLOCK
        ADDL3   #XABFHC,R9,R10                  ;R10 = Base address of XABFHC
        MOVB    #XAB$C_FHC,XAB$B_COD(R10)       ;XABFHC ID code
        MOVB    #XAB$C_FHCLEN,XAB$B_BLN(R10)    ;XABFHC block length
        MOVAB   XABDAT(R9),XAB$L_NXT(R10)       ;Address of next XAB (XABDAT)

        ;        d.  XABDAT block initialized
        ;INITIALIZE XABDAT
        ADDL3   #XABDAT,R9,R10                  ;R10 = Base address of XABDAT
        MOVB    #XAB$C_DAT,XAB$B_COD(R10)       ;XABDAT ID code
        MOVB    #XAB$C_DATLEN,XAB$B_BLN(R10)    ;XABDAT block length

        ;        e.  Variables are initialized
        ;INITIALIZE VARIABLES
        MOVC5   #0,(SP),#SPACE,#OUTLNLEN,OUTLINE(R9)    ;Clear outline
        MOVB    #1,FIRST_TIME(R9)                       ;Set first time to true
        CLRB    COL(R9)                                 ;Set column offset := 0

        ;    D.  Dir-spec placed into FAB
        ;GET DIR-SPEC INTO FAB BLOCK BY CALLING CLI$GET_VALUE
        ;R2 becomes address of temporary descriptor built on stack for dir-spec string
        ;R3 becomes address of resulting dir-spec string length
        PUSHL   #0                              ;Build temp descriptor on stack
        PUSHL   #0                              ;for dir-spec string
        MOVL    SP,R2                           ;Save address of descriptor in R2
        MOVW    #NAM$C_MAXRSS, DSC$W_LENGTH(R2) ;Length of dirspec string buffer
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R2)  ;Descriptor type
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R2)  ;Descriptor Class
        ADDL3   #INPFS,R9,     DSC$A_POINTER(R2);Address of dirspec string buffer
        PUSHL   #0                              ;Place for return length
        MOVL    SP,R3                           ;Address of above (by reference)
        PUSHL   R3                              ;retlength
        PUSHL   R2                              ;retdesc
        PUSHAL  DIRSPEC                         ;Get dir-spec
        CALLS   #3,G^CLI$GET_VALUE              ;Get dir-spec
        MOVB    (R3),FAB$B_FNS(R9)              ;Length of string containing file name
        ADDL2   #12,SP                          ;Restore stack pointer

        ;    E.  Set DIRFLGS according to /SIZE and /DATE qualifiers
        ;Check for /SIZE
        POPL    R0                              ;Default dirflgs stored on stack
        MOVB    R0,DIRFLGS(R9)                  ;Set dirflgs
        PUSHAL  SIZE                            ;Check for /SIZE present in command string
        CALLS   #1,G^CLI$PRESENT                ;
        CMPL    R0,#CLI$_PRESENT
        BNEQ    31$
        BISB2   #GET_SIZE,DIRFLGS(R9)
        BRB     32$
31$:    CMPL    R0,#CLI$_NEGATED
        BNEQ    32$
        BICB2   #GET_SIZE,DIRFLGS(R9)

        ;Check for /DATE
32$:    PUSHAL  DATE                            ;Check for /DATE present in command string
        CALLS   #1,G^CLI$PRESENT                ;
        CMPL    R0,#CLI$_PRESENT
        BNEQ    33$
        BISB2   #GET_DATE,DIRFLGS(R9)
        BRB     PARSE
33$:    CMPL    R0,#CLI$_NEGATED
        BNEQ    PARSE
        BICB2   #GET_DATE,DIRFLGS(R9)

        ;    F.  $PARSE FAB to prepare for wildcard operations
        ;PARSE THE DIR-SPEC
PARSE:  PUSHL   R9                              ;Address of FAB block
        CALLS   #1,G^SYS$PARSE                  ;Parse it once to set up wildcard searching
        BLBS    R0,SRCHLP                       ;Branch if ok
        BSBW    ERR                             ;else signal error (could be Directory Not Found, Invalid Device Name, etc)
        BRW     CLEANUP                         ;and cleanup

        ;3.  $SEARCH FAB for next filename
        ;4.  If 'No more files' or 'File Not Found' or other error, exit with code
        ;SEARCH FOR A FILENAME
SRCHLP: PUSHL   R9                              ;Address of FAB
        CALLS   #1,G^SYS$SEARCH                 ;Find next file
        CMPL    R0,#RMS$_NORMAL                 ;Check for normal status
        BEQL    CKRT                            ;continue if normal
        CMPL    R0,#RMS$_FNF                    ;Check for 'File Not Found' status
        BNEQ    5$                              ; branch if not
        MOVL    #FNF_ERR,R1                     ; else set return status code to 'File Not Found'
        BRW     CLEANUP                         ; and go to cleanup
5$:     CMPL    R0,#RMS$_NMF                    ;Check for 'No More Files' status
        BNEQ    6$                              ; branch if not
        MOVL    #NMF_ERR,R1                     ; else set return status code to 'No More Files'
        BRW     CLEANUP                         ; and go to cleanup
6$:     BSBW    ERR                             ;Wasn't any of the expected errors
        BRW     CLEANUP                         ;so signal error and go to cleanup

        ;5.  Print new directory heading if needed
        ;WE HAVE A NEW FILENAME TO PROCESS
        ;PRINT OUT NEW DIRECTORY HEADING IF NEEDED
CKRT:   TSTB    FIRST_TIME(R9)                  ;See if first time
        BEQL    1$                              ;Branch if not
        ADDL3   #FAB$C_BLN,R9,R10               ;R10 = Address of NAM block
        MOVZBL  NAM$B_ESL(R10),R0               ;R0 = Length of expanded directory specification
        MOVC3   R0,@NAM$L_ESA(R10),OUTLINE(R9)  ;Move expanded directory specification to outline
        MOVB    NAM$B_ESL(R10),COL(R9)          ;Move length of directory specification to col
        MOVL    #PROOT_CODE,R1                  ;Set window status line
        BRW     PRINT                           ;call us again jumping to PROOT

1$:     MOVZBL  ROOTLEN(R9),R0                  ;Move length of root to R0 (byte)
        CMPC3   R0,ROOT(R9),RSFN(R9)            ;Compare old root with new
        BEQLU   NXTTAB                          ;Branch if root is still same
        MOVL    #PROOT_CODE,R1                  ;Print out old outline followed by two blank lines and have TPU
        BRW     PRINT                           ;call us again jumping to PROOT

        ;PRINT NEW DIRECTORY HEADING
        ;FILENAME IS OF FORM NODE::DEV:[DIR]NAME.TYPE;VER
PROOT:  ADDL3   #FAB$C_BLN,R9,R10               ;R10 = base address of NAM block
        CLRB    FIRST_TIME(R9)                  ;Set first_time to False
        CLRL    R6
        ADDB3   NAM$B_NODE(R10),-               ;Calculate length of node::dev[dir]
                NAM$B_DEV(R10),R6               ;Add node length + device length
        ADDB2   NAM$B_DIR(R10),R6               ;Add dir length
        MOVB    R6,ROOTLEN(R9)                  ;Place new length in rootlen
        MOVC3   R6,RSFN(R9),ROOT(R9)            ;Place new "disk:[dir]" to root buffer
        MOVC3   #DIRHLEN,DIRH,OUTLINE(R9)       ;Move "Directory " to outline
        MOVC3   R6,RSFN(R9),-
                <OUTLINE+DIRHLEN>(R9)           ;Add new "disk:[dir]" to outline making string "Directory DISK:[DIRECTORY]" form
        ADDB3   #DIRHLEN,R6,COL(R9)             ;Length of OUTLINE
        MOVL    #NXTTAB_CODE,R1                 ;Print out directory root followed by one blank line and have TPU
        BRW     PRINT                           ;Print new directory heading

        ;6.  Add new file to outline.
        ;    A.  Move COL offset pointer into outline to next tab stop (0,20,40,60)
        ;        Print outline if line full.
        ;MOVE TO NEXT TAB STOP (0,20,40,60)
NXTTAB: MOVZBL  COL(R9),R0                      ;R0 = COL
        BEQL    ADFILE                          ;If COL = 0 then go add next filename
        CMPL    R0,#20                          ;If COL >= 20
        BGEQ    2$                              ;then branch
        MOVZBL  #20,R0                          ;else COL := 20
        BRB     4$                              ;and goto check file length
2$:     CMPL    R0,#40                          ;If COL >= 40
        BGEQ    3$                              ; then branch
        MOVZBL  #40,R0                          ; else COL := 40
        BRB     4$                              ; and goto check file length
3$:     CMPL    R0,#60                          ;If COL >= 60
        BGEQ    5$                              ; then branch and print line
        MOVZBL  #60,R0                          ; else COL := 60
4$:     ADDL3   #FAB$C_BLN,R9,R10               ;Calculate length of filename to add.  R10 = Address of NAM block
        CLRL    R6                              ;Calculate length of file name to add
        ADDB3   NAM$B_NAME(R10),-               ;Calculate length of name.type;ver place in R6
                NAM$B_TYPE(R10),R6              ;Add length of name + type
        ADDB2   NAM$B_VER(R10),R6               ;Add length of version
        ADDL2   R0,R6                           ;Add length of filename
        CMPL    R6,#80                          ;Compare with screen width
        BGEQ    5$                              ;Add file if enough room left on line
        MOVB    R0,COL(R9)                      ;Set col at next tab stop
        BRB     ADFILE                          ;Branch to adfile
5$:     MOVL    #ADFILE_CODE,R1                 ;Not enough room for next filename. Print out the line
        BRW     PRINT

        ;    B.  Add filename to outline
        ;ADD NEW FILENAME TO OUTLINE
ADFILE: ADDL3   #FAB$C_BLN,R9,R10               ;R9 = Address of NAM block
        CLRL    R6
        ADDB3   NAM$B_NAME(R10),-               ;Calculate length of name.type;ver place in R6
                NAM$B_TYPE(R10),R6              ;Add length of name + type
        ADDB2   NAM$B_VER(R10),R6               ;Add length of version
        MOVAL   OUTLINE(R9),R7                  ;Base address of outline
        MOVZBL  COL(R9),R0                      ;add zero extended byte COL(R9) to longword R7
        ADDL2   R0,R7                           ;R7 = Address to start filename
        MOVC3   R6,@NAM$L_NAME(R10),(R7)        ;Move next filename in there
        ADDB2   R6,COL(R9)                      ;COL := COL + LENGTH(NAME.TYPE;VERS)

        ;7.  Check DIRFLGS for qualifiers like /SIZE and /DATE
        ;    A.  If no qualifiers present then goto loop
        ;CHECK FOR QUALIFIERS LIKE /SIZE AND /DATE
        TSTB    DIRFLGS(R9)                     ;Check for qualifiers like /SIZE or /DATE
        BNEQ    QUAL                            ;Branch if qualifiers present
        BRW     SRCHLP                          ;Otherwise goto search_loop (step 3)

        ;    B.  Print outline if filename too long
        ;/SIZE AND/OR /DATE PRESENT
        ;PRINT OUT CURRENT LINE IF FILENAME TOO LONG
QUAL:   CMPB    COL(R9),#<SIZCOL-1>             ;Check column offset.  Check for extra-long filename
        BLEQ    GETATR                          ;Branch if ok
        MOVL    #GETATR_CODE,R1                 ;Else print out line and return to FILATR
        BRW     PRINT

        ;Get file attributes
GETATR: PUSHL   R9                              ;Address of FAB
        CALLS   #1,G^SYS$OPEN                   ;Open the file to get file attributes
        BLBS    R0,1$                           ;Branch if OK

        ;Call sys$getmsg to get error message text and place it in outline
        ;R2 becomes address of temporary descriptor built on stack for outline string
        ;R3 becomes address of resulting message string length
        PUSHL   #0                              ;Build temp descriptor on stack
        PUSHL   #0                              ;for dir-spec string
        MOVL    SP,R2                                   ;Save address of descriptor in R2
        MOVW    #<NAM$C_MAXRSS-SIZCOL>,DSC$W_LENGTH(R2) ;Length of outline string buffer (what's left)
        MOVB    #DSC$K_DTYPE_T,        DSC$B_DTYPE(R2)  ;Descriptor type
        MOVB    #DSC$K_CLASS_S,        DSC$B_CLASS(R2)  ;Descriptor Class
        ADDL3   #<OUTLINE+SIZCOL>,R9,  DSC$A_POINTER(R2);Address of dirspec string buffer
        PUSHL   #0                                      ;Place for return length
        MOVL    SP,R3                           ;Address of above (by reference)
        PUSHL   #0                              ;Now call $getmsg.  outadr.
        PUSHL   #1                              ;flags.  include only message text
        PUSHL   R2                              ;bufadr (by descriptor)
        PUSHL   R3                              ;msglen (by reference)
        PUSHL   R0                              ;msgid
        CALLS   #5,G^SYS$GETMSG                 ;Get message text into outline
        ADDB3   #SIZCOL,(R3),COL(R9)            ;Add message text length to col
        ADDL2   #12,SP                          ;Restore stack pointer
        MOVL    #SRCHLP_CODE,R1                 ;Set return code
        BRW     PRINT                           ;Print outline

        ;File successfully opened.  Close file and process qualifiers.
1$:     PUSHL   R9                              ;Address of FAB
        CALLS   #1,G^SYS$CLOSE                  ;Close the file

        ;    D.  Add size info if requested
        ;CHECK FOR /SIZE
GETSIZ: BITB    #GET_SIZE,DIRFLGS(R9)           ;Do we have /SIZE
        BEQL    GETDAT                          ;no, branch to get date
        MOVL    <XABFHC+XAB$L_EBK>(R9),R4       ;Move file size to R4
        TSTW    <XABFHC+XAB$W_FFB>(R9)          ;First free byte = 0?
        BNEQ    2$                              ;If not, EBK = Blocks in use.
        DECL    R4                              ;Else don't count last block

        ;Call sys$fao to put file size in outline string
2$:     PUSHL   #0                              ;Build temp descriptor on stack for outbuf
        PUSHL   #0                              ;R2 becomes address of temporary descriptor
        MOVL    SP,R2                                   ;Save address of descriptor in R2
        MOVW    #SIZLEN,             DSC$W_LENGTH(R2)   ;Length of string
        MOVB    #DSC$K_DTYPE_T,      DSC$B_DTYPE(R2)    ;Descriptor type
        MOVB    #DSC$K_CLASS_S,      DSC$B_CLASS(R2)    ;Descriptor Class
        ADDL3   #<SIZCOL+OUTLINE>,R9,DSC$A_POINTER(R2)  ;Base address of DIRBLK + offset = start address for size string
        PUSHL   R4                                      ;P1 = filesize
        PUSHL   R2                              ;Address of outbuf descriptor
        PUSHL   #0                              ;Outlen
        PUSHAL  FAOSIZE                         ;Ctrstr
        CALLS   #4,G^SYS$FAO                    ;Write size to outline
        ADDL2   #8,SP                           ;Restore stack pointer
        MOVB    #<SIZCOL+SIZLEN>,COL(R9)        ;Move col pointer to end of size

        ;    E.  Add date info if requested
GETDAT: BITB    #GET_DATE,DIRFLGS(R9)           ;Do we have /DATE
        BEQL    1$                              ;no, branch to rest
        PUSHL   #0                              ;Build temp descriptor on stack for date string
        PUSHL   #0                              ;R2 becomes address of temporary descriptor
        MOVL    SP,R2                           ;Save address of descriptor in R2
        MOVW    #DATLEN,DSC$W_LENGTH(R2)                ;Length of date
        MOVB    #DSC$K_DTYPE_T,      DSC$B_DTYPE(R2)    ;Descriptor type
        MOVB    #DSC$K_CLASS_S,      DSC$B_CLASS(R2)    ;Descriptor Class
        ADDL3   #<DATCOL+OUTLINE>,R9,DSC$A_POINTER(R2)  ;Base address of DIRBLK + offset = start address for date string
        PUSHL   #0                                      ;cvtflg
        PUSHAL  <XABDAT+XAB$Q_CDT>(R9)          ;timadr
        PUSHL   R2                              ;timbuf
        PUSHL   #0                              ;timlen
        CALLS   #4,G^SYS$ASCTIM                 ;Convert binary time to ASCII string
        ADDL2   #8,SP                           ;Restore stack pointer
        MOVB    #<DATCOL+DATLEN>,COL(R9)        ;Set col pointer to end of date
1$:     MOVL    #SRCHLP_CODE,R1                 ;Set return code
        BRB     PRINT                           ;Print outline
;--

        ;Print outline
        ;R1 = retcode
PRINT:  PUSHAB  OUTLINE(R9)                             ;address of output string
        MOVZBL  COL(R9),R0                              ;length of output string
        PUSHL   R0                                      ;length of output string
        PUSHL   R1                                      ;retcode
        CALLS   #3,FMTOUTSTR                            ;format output string
        MOVC5   #0,(SP),#SPACE,#OUTLNLEN,OUTLINE(R9)    ;Clear outline
        CLRB    COL(R9)                                 ;Reset COL to 0
        RET     ;Print OUTSTR.  TPU editor should call us again passing RETCODE
;--

        ;Print outline, deallocate memory, and return
CLEANUP:
        ;Print outline
        ;R1 = retcode
        PUSHAB  OUTLINE(R9)                     ;address of output string
        MOVZBL  COL(R9),R0                      ;length of output string
        PUSHL   R0                              ;length of output string
        PUSHL   R1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string

        ;Deallocate memory
        MOVL    #DIRBLKLEN,-(SP)                ;Length of memory block to deallocate
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHAL  DIRBLKBSE                       ;Address of return address of memory block allocated
        PUSHL   R0                              ;Address containing length of memory to allocate
        CALLS   #3,G^LIB$FREE_VM                ;Attempt to deallocate memory previously in use
        CLRL    (SP)+                           ;Restore stack pointer
        CLRL    DIRBLKBSE                       ;Reset base pointer to zero
        RET
;--

        ;Signal unexpected error
ERR:    PUSHL   R0                              ;else signal error (could be Directory Not Found, Invalid Device Name, etc)
        CALLS   #1,EDX_SIGNAL                   ;
        MOVL    #RMS_ERR,R1                     ;set return code to error
        RSB
;------------------------------------------------------------------------------

        .SUBTITLE GETDEFDIRFLGS
;++
;
; Functional Description:
;       Attempts to translate DCL symbol 'DIR' and determine if /SIZE
;       or /DATE qualifiers are present.
;
; Calling Sequence:
;       CALLS   #1,GETDEFDIRFLGS
;
; Arguments:
;       4(AP) = byte to put dirflgs in
;
; Outputs:
;       R1 = dirflgs.
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  LIB$GET_SYMBOL is called to obtain the symbol translation
;       3.  CLI$PRESENT is called to determine if qualifiers are present
;           and dirflgs is set accordingly.
;
; Memory Map (Memory allocated on stack):
;
;       MEMORY ALLOCATED ON STACK:
;       -----------------------------------------(String to contain symbol name translation)
;       |                BUFFER                 | <^x00> (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(descriptor for string containing symbol translation)
;       |  class  |  dtype  |  string length    | <BUFLEN>
;       -----------------------------------------
;       |            buffer address             | <BUFLEN+^x04>
;       -----------------------------------------
;       |                 TBLIND                | <BUFLEN+^x08>
;       -----------------------------------------(original stack pointer)
;                                               | <BUFLEN+^x0C>
; Register usage:
;       R9 = used as base address of memory allocated on stack
;
;------------------------------------------------------------------------------

        .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC
.ALIGN LONG
DIR:    .ASCID  /DIR/

;------------------------------------------------------------------------------
        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  GETDEFDIRFLGS,^M<R2,R9>

        ;Initialize
        MOVAB   G^LIB$SIG_TO_RET,(FP)           ;Establish handler for signals from CLI$DCL_PARSE and CLI$PRESENT
        CLRL    @4(AP)                          ;Initialize dirflgs
        SUBL2   #<BUFLEN+^x0C>,SP               ;Allocate memory on stack
        MOVL    SP,R9                           ;Store base address in R9

        ;Initialize descriptor
        MOVL    #BUFLEN,        <BUFLEN+DSC$W_LENGTH >(R9)      ;Length
        MOVB    #DSC$K_DTYPE_T, <BUFLEN+DSC$B_DTYPE  >(R9)      ;Type
        MOVB    #DSC$K_CLASS_S, <BUFLEN+DSC$B_CLASS  >(R9)      ;Class
        MOVL    R9,             <BUFLEN+DSC$A_POINTER>(R9)      ;Address

        ;Translate DCL symbol
        PUSHAL  <BUFLEN+^x08>(R9)               ;Table indicator
        PUSHAW  <BUFLEN>(R9)                    ;Return length
        PUSHAL  <BUFLEN>(R9)                    ;Return buffer
        PUSHAL  DIR                             ;Address of descriptor of DCL symbol 'DIR' to translate
        CALLS   #4,G^LIB$GET_SYMBOL             ;Translate symbol
        BLBC    R0,19$                          ;Branch on failure

        ;Parse string and restore stack
        PUSHAL  G^DCL$AL_TAB_VEC                ;Address of command table for parse (use system DCLTABLES)
        PUSHAL  <BUFLEN>(R9)                    ;Address of input string descriptor
        CALLS   #2,G^CLI$DCL_PARSE              ;Parse input string
        BLBC    R0,19$                          ;Check success of DCL_PARSE (actually our handler will/should get the error)

        ;CHECK FOR /SIZE AND /DATE
        PUSHAL  SIZE                            ;Check for /SIZE present in command string
        CALLS   #1,G^CLI$PRESENT                ;
        BLBC    R0,13$                          ;Branch if not present
        BISB2   #GET_SIZE,@4(AP)                ;Set /SIZE flag
13$:    PUSHAL  DATE                            ;Check for /DATE present in command string
        CALLS   #1,G^CLI$PRESENT                ;
        BLBC    R0,19$                          ;Branch if not present
        BISB2   #GET_DATE,@4(AP)                ;Set /DATE flag

19$:    RET

;------------------------------------------------------------------------------
;==============================================================================
;       EDX SORT
;==============================================================================
        .SUBTITLE EDX_SORT
;
;++
;Sort Routines:
;  EDX_SORT                     !Main entry.  Parses R6
;  SORT_PREPARSE                !Preparse SORT command
;  SORT_PASSFILES               !Pass filenames for file sort
;  SORT_POSTPARSE               !Finish parsing SORT command
;  SORT_DO_FILE                 !Do file sort
;  SORT_RELEASE_REC             !Give record to sort when using record sort
;  SORT_RETURN_REC              !Get record when using record sort
;
;
; Functional Description:
;       Sorts using either file sort or record sort.  This routine uses
;       the VMS Sort/Merge (SOR) Utility Routines as described in the
;       VAX/VMS Utilities Routines Reference Manual.
;
; Calling Sequence:
;       CALLS   #0,EDX_SORT
;
; Argument inputs:
;       R6 = Code describing subfunction to perform (low word of INCODE)
;              1.  Preparse command line
;              2.  Pass files and do sort (for file sort)
;              3.  Postparse command line
;              4.  Pass a record to sort.  (Repeat until all records passed)
;              5.  Do record sort
;              6.  Receive a record in sorted order.  (Repeat until all records received)
;              7.  Cleanup
;
; Usage:
;   Either file sort or record sort is used.
;
;   With file sort, you pass it the name of a file on disk to sort,
;   it sorts the file creating a new file and returns to you the name of
;   the new file created.
;
;   With record sort, you pass it individual records (a record is a line
;   of text from the buffer), passing it one record per call until all
;   records have been passed.  The records are sorted, and then returned
;   to you one record per call, in sorted order, until all records have
;   been returned to you.
;
; Which sorting method to use:
;    File sort can handle all situations.  It is the method of choice
;    when a large number of records are to be sorted, since it is faster
;    to write a large buffer to disk than to pass it one line at a time
;    to and from sort, and there is no limit to the length of line which
;    can be sorted.  However, the file sort method takes a minimum of
;    a couple seconds because of time it takes to create a temporary
;    file on disk and then delete it.
;
;    Record sort is suitable when a small number of lines are to be
;    quickly sorted, and the lines are < 132 characters in length (SRT_MAXLRL).
;    As the number of records to sort increases, there reaches a point
;    where it becomes faster to use the file sort method instead.
;
; Sequence of calls for performing file sort:
;       1.  Call n=1 'Preparse command line' passing the SORT command
;           line to be parsed.  Returns indicating if SORT BUFFER,
;           SORT RANGE, HELP, or error in sort command.
;       2.  Call n=2 'Pass files and do sort' passing it name of file to sort.
;           Returns name of sorted file created.
;
; Sequence of calls for performing file sort:
;       1.  Call n=1 'Preparse command line' passing the SORT command
;           command line to be parsed.  Returns indicating if SORT BUFFER,
;           SORT RANGE, HELP, or error in sort command.
;       2.  Call n=3 'Postparse command line'
;       3.  Call n=4 'Pass a record to sort' passing it one record from
;           the buffer.  Repeat this call until all records have been
;           passed.
;       4.  Call n=5 'Do record sort' to perform the actual sort
;       5.  Call n=6 'Receive a record in sorted order'.  Returns one
;           record.  Repeat until all records have been passed back in
;           sorted order.
;       6.  Call n=7 'Cleanup' to free up memory allocated by sort.
;
;----------------------------------------------------------------------
; Internal sequence for performing file sort:
;       1.  EDX calls SORT_PREPARSE passing it the SORT command line.
;           SORT_PREPARSE parses the command line.  If there is an error
;           it returns with error status.  Otherwise it returns indicating
;           wheter SORT BUFFER or SORT RANGE was specified on command line.
;       2.  EDX writes a temporary file to disk to be sorted.
;       3.  EDX calls SORT_PASSFILES passing it the name of the temporary
;           file to be sorted.  SORT_PASSFILES generates a filename for
;           the output file, and then calls SOR$PASS_FILES passing the names
;           of the input file and the output file.
;       4.  SORT_POSTPARSE is called.  It extracts the information from CLI
;           about the previously parsed SORT command, and calls SOR$BEGIN_SORT.
;       5.  SORT_DO_FILE is called, which calls SOR$SORT_MERGE to do the actual
;           sort.  It also calls SOR$END_SORT to clean up afterwards.
;
; Internal sequence for performing record sort:
;       1.  EDX calls SORT_PREPARSE passing it the SORT command line.
;           SORT_PREPARSE parses the command line.  If there is an error
;           it returns with error status.  Otherwise it sets OUTSTR indicating
;           wheter SORT BUFFER or SORT RANGE was specified on command line.
;       2.  SORT_POSTPARSE is called.  It extracts the information from CLI
;           about the previously parsed SORT command, and calls SOR$BEGIN_SORT.
;           Return to user with OUTSTR previously set.
;       3.  SOR$RELEASE_REC is called for n=4.
;       4.  SOR$SORT_MERGE is called for n=5.
;       5.  SOR$RETURN_REC is called for n=6.
;       6.  SOR$END_SORT is called for n=7.
;
; Note:
;       The SOR$... symbols are defined in the SYS$LIBRARY:SORTSHR.EXE
;       shareable image.  The linker should resolve these symbols
;       automatically, as part of its search through the images in the
;       system shareable image library SYS$LIBRARY:IMAGELIB.OLB.
;
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  EDX_SORT,^M<R2>

        ;Case entry code
        ;R6 = Entry code passed by caller
        CASEB   R6, #1, #<7-1>                  ;Case entry point to jump to
1$:     .WORD   SRFINI-1$,-                     ; 1 = Sort initialize for file sort
                SRFDOF-1$,-                     ; 2 = Do file sort
                SRRINI-1$,-                     ; 3 = Sort initialize for record sort
                SRRPAS-1$,-                     ; 4 = Pass a record to sort
                SRRDOR-1$,-                     ; 5 = Do record sort
                SRRREC-1$,-                     ; 6 = Receive a record in sorted order
                SRRFIN-1$                       ; 7 = Cleanup record sort

        PUSHL   #EDX__UNKNCODE                  ;Unknown item code
        CALLS   #1,EDX_SIGNAL                   ;Signal internal error
        RET                                     ;and return

;       1.  Preparse sort command
SRFINI: CALLS   #0,SORT_PREPARSE
        RET

;       2.  Pass filenames and do sort
SRFDOF: CALLS   #0,SORT_PASSFILES
        BLBS    R0,10$
        RET                                     ;error return.  PASSFILES signaled and made OUTSTR
10$:    PUSHL   #0                              ;0 = using file sort
        CALLS   #1,SORT_POSTPARSE
        BLBS    R0,20$                          ;branch if OK
        PUSHL   R0
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET
20$:    CALLS   #0,SORT_DO_FILE
        RET

;       3.  Postparse command line
SRRINI: PUSHL   #1                              ;1 = using record sort
        CALLS   #1,SORT_POSTPARSE
        PUSHL   R0
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET

;       4.  Pass a record to sort
SRRPAS: CALLS   #0,SORT_RELEASE_REC
        RET

;       5.  Do record sort
SRRDOR: CALLS   #0,G^SOR$SORT_MERGE
        CHECK_STATUS
        PUSHL   R0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET

;       6.  Receive a record in sorted order
SRRREC: CALLS   #0,SORT_RETURN_REC
        RET

;       7.  Cleanup record sort
SRRFIN: CALLS   #0,G^SOR$END_SORT               ;cleanup
        PUSHL   R0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET

;------------------------------------------------------------------------------
;++
;       SORT_PREPARSE
;
; Functional Description:
;       Parses the command line for correctness and returns indicating
;       if BUFFER or RANGE was specified.  We hold off on examining the
;       rest of the results from the parsed command line until after
;       SOR$PASS_FILES has been called (if file sort is being used), then
;       the rest is done in SORT_POSTPARSE.
;
; Calling Sequence:
;       CALLS   #0,SORT_PREPARSE
;
; Argument inputs:
;       INSTR = Command line to be parsed
;
; Outputs:
;       OUTSTR - return value indicating domain to be sorted.
;          = 0 error occurred
;          = 1 BUFFER was specified
;          = 2 RANGE was specified
;          = 3 HELP was specified
;
;
;       STORAGE ALLOCATED ON STACK
;       -----------------------------------------
;       |  class  |  dtype  |  string length    | 0(R9)  scratch character buffer
;       -----------------------------------------
;       |            buffer address             |
;       -----------------------------------------
;       |     8 character buffer for name       |
;       -                                       -
;       |                                       |
;       -----------------------------------------
;
;--

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR
DOMAIN:
        .ASCID "DOMAIN"
BUFFER:
        .ASCII "BUFFER"
RANGE:
        .ASCII "RANGE"

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY SORT_PREPARSE,^M<R2,R9,R10,R11>

;Clean up any outstanding sort
        CALLS   #0,G^SOR$END_SORT                       ;clean up incase previous unfinished sort was active

; Allocate memory
        MOVL    SP,R0                                   ;Save original SP
        SUBL2   #<8+8>,SP                               ;memory for string buffer and descriptor
        MOVL    SP,R9                                   ;save address
        MOVW    #8,             DSC$W_LENGTH(R9)        ;Descriptor length
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(R9)         ;Fill in Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(R9)         ;Fill in Class
        MOVAB   8(R9),        DSC$A_POINTER(R9)         ;Buffer address

;The command is parsed.
        PUSHAL  EDX_COMMANDS                    ;Address of command table for parse
        PUSHL   INSTR                           ;Address of input string descriptor
        CALLS   #2,G^CLI$DCL_PARSE              ;Parse input string
        BLBC    R0,180$                         ;Branch on failuer

;Now see if BUFFER or RANGE was specified
        PUSHL   R9                              ;address of scratch buffer
        PUSHL   R9                              ;address of scratch buffer
        PUSHAQ  DOMAIN                          ;Get DOMAIN
        CALLS   #3,G^CLI$GET_VALUE
        CMPC3   (R9),8(R9),BUFFER
        BNEQ    160$
        PUSHL   #3                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;set return status
        RET
160$:   CMPC3   (R9),8(R9),RANGE
        BNEQ    170$
        PUSHL   #2                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;set return status
        RET
170$:   CMPC3   (R9),8(R9),HELP
        BNEQ    180$
        PUSHL   #4                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;set return status
        RET
180$:   PUSHL   #0                              ;0 means error
        CALLS   #1,FMTOUTSTR                    ;set return status
        RET

;------------------------------------------------------------------------------
;++
;       SORT_PASSFILES
;
; Functional Description:
;       Calls G^SOR$PASS_FILES, passing the name of the input filename to
;       be sorted, and the output filename to create.  The input filename
;       of the file to sort is passed to us in INSTR.  The output filename
;       is generated by us here.  It is of the form "EDX_TEMPSORT00000000.SRT"
;       where the 00000000 is the current process's PID in hexadecimal.
;       We use the current process's PID as part of the filename to help
;       make the filename unique.
;
; Calling Sequence:
;       CALLS   #0,SORT_PASSFILES
;
; Argument inputs:
;       INSTR = Input filename to pass to G^SOR$PASS_FILES
;
; Outputs:
;       OUTSTR = Output filename we generated, with return status of 1
;
; Outline:
;    The output filename is of the form: EDX_TEMPSORT00000000.SRT
;    where the 00000000 is replaced by the process's PID number.
;    1. Memory for output filename buffer is allocated on stack
;    2. The output filename is moved into the buffer
;    3. The process's PID is determined by calling SYS$GETJPI
;    4. 00000000 of the output filename is replaced by the
;       process's PID number.  (OTS$CVT_L_TZ)
;    5. G^SOR$PASS_FILES is called, passing the input filename from INSTR,
;       and the output filename we created.
;    6. If success, then our generated output filename is copied to OUTSTR
;       (for temporary storage).
;
;       STORAGE ALLOCATED ON STACK
;       -----------------------------------------
;       |  class  |  dtype  |  string length    | (R9)  string descriptor
;       -----------------------------------------
;       |             buffer address            |
;       -----------------------------------------
;       |      JPI$_PID     |         4         | itemlist for call to SYS$GETJPI
;       -----------------------------------------
;       |           address of -4(R10)          |
;       -----------------------------------------
;       |                   0                   |
;       -----------------------------------------
;       |                   0                   |
;       -----------------------------------------
;       |             process's PID             | -4(R10) PID
;       -----------------------------------------
;       |      buffer for output filename       | (R10)
;       .                                       .
;       .                                       .
;       -----------------------------------------
;
; Registar usage:
; R10 - Points to beginning of output filename buffer
;--

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC

.ALIGN LONG
SORFN:  .ASCII /EDX_TEMPSORT/   ;Sort file NAME
SORFNL= .-SORFN                 ;Length of sort file NAME
SORFT:  .ASCII /.SRT/           ;Sort file TYPE
SORFTL= .-SORFT                 ;Length of sort file TYPE
SORFPL= 8                       ;Length of PID
SORFLL=SORFNL+SORFPL+SORFTL     ;Sort file length total

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY SORT_PASSFILES,^M<R9,R10>

;    1. Memory for output filename buffer is allocated on stack
        SUBL2   #SORFLL,SP                      ;allocate buffer for output filename
        BICB2   #^B0011,SP                      ;longword align stack pointer
        MOVL    SP,R10                          ;Save address of output filename buffer

;    2. The output filename is moved into the buffer
        MOVC3   #SORFNL, SORFN, (R10)                   ;Copy over "EDX_TEMPSORT"
        MOVC5   #0,(SP),#^A"0",#SORFPL,SORFNL(R10)      ;fill PID range with "00000000"
        MOVC3   #SORFTL, SORFT, <SORFNL+SORFPL>(R10)    ;Copy over ".SOR"

;    3. The process's PID is determined by calling SYS$GETJPI
;       Create itemlist for GETJPI
        PUSHL   #0                              ;longword buffer for PID   -4(R10)
        PUSHL   #0                              ;end of itemlist
        PUSHL   #0                              ;return length address
        PUSHAL  -4(R10)                         ;buffer address
        MOVW    #JPI$_PID,-(SP)                 ;item code
        MOVW    #4,-(SP)                        ;buffer length
        MOVL    SP,R0                           ;save address of itemlist

;       Call GETJPI
        PUSHL   #0                              ;efn
        PUSHL   #0                              ;pidadr
        PUSHL   #0                              ;prcnam
        PUSHL   R0                              ;itmlst
        PUSHL   #0                              ;iosb
        PUSHL   #0                              ;astadr
        PUSHL   #0                              ;astprm
        CALLS   #7,G^SYS$GETJPIW
        BLBS    R0,40$
        PUSHL   R0                              ;else error...
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL
        CALLS   #1,FMTOUTSTR
        RET

;    4. 00000000 of the output filename is replaced by the process's PID number.
;       Build descriptor of "00000000" substring within output filename string.
40$:    SUBL2   #8,SP
        MOVL    SP,R9                                   ;Save address of descriptor
        MOVW    #SORFPL,        DSC$W_LENGTH(R9)        ;length of PID
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(R9)         ;Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(R9)         ;Class
        MOVAB   SORFNL(R10),     DSC$A_POINTER(R9)      ;address

        PUSHL   #SORFPL                                 ;Min digits
        PUSHL   R9                                      ;out-str (by descriptor)
        PUSHAL  -4(R10)                                 ;value (PID by reference)
        CALLS   #2,G^OTS$CVT_L_TZ                       ;convert PID to hexadecimal text
        BLBS    R0,50$
        PUSHL   R0                                      ;else error...
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL
        CALLS   #1,FMTOUTSTR
        RET

;    5. G^SOR$PASS_FILES is called, passing the input filename from INSTR,
;       and the output filename we created.
;       Fudge descriptor so it points to full output filename string
50$:    MOVW    #SORFLL, DSC$W_LENGTH(R9)               ;length of filename string
        MOVL    R10,     DSC$A_POINTER(R9)              ;address of filename string
        PUSHL   R9                                      ;out-file by descriptor
        PUSHL   INSTR                                   ;in-file by descriptor
        CALLS   #2,G^SOR$PASS_FILES
        BLBS    R0,60$
        PUSHL   R0                                      ;else error...
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL                           ;Signal error
        CALLS   #1,FMTOUTSTR                            ;set OUTSTR
        RET

;    6. If success, then our generated output filename is copied to OUTSTR
;       (for temporary storage).
60$:    PUSHL   R10                             ;address of output string
        PUSHL   #SORFLL                         ;length of output string
        PUSHL   #1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET

;------------------------------------------------------------------------------
;++
;       SORT_POSTPARSE
;
; Functional Description:
;       Extracts information from CLI about the previously parsed SORT command.
;       Builds and item list of this information and calls SOR$BEGIN_SORT.
;
; Calling Sequence:
;       CALLS   #1,SORT_POSTPARSE
;
; Argument inputs:
;     (AP) - number of arguments (#1 by value)
;    4(AP) - (0 or 1 by value)
;            0 = using file sort.
;            1 = using record sort.
;
; Outputs:
;       R0 - Status.  Signaled if bad.
;
; Implicit:
;       It is assumed a SORT command line was preveously parsed by
;       SORT_PREPARSE.
;
; Outline:
;    1. Memory is allocated on the stack.
;    2. The memory is filled in depending upon qualifiers found
;       in the command string.  The key_buffer itemlist is filled
;       from the top down, with a new item added whenever a /KEYn
;       sort key qualifier is found.
;    3. SOR$BEGIN_SORT is called to initialize the sort
;
;       STORAGE ALLOCATED ON STACK
;       -----------------------------------------
;       |              option bits              | (SP)
;       -----------------------------------------
;       |  number of keys   |    (not used)     | key_buffer argument starts at -2(R11)
;       ----------------------------------------- (R11)
;       |   9 quadword itemlist of sort keys    |   <-- R10 points into key_buffer
;       -              (72 bytes)               -
;       .                                       . (9 quadwords)
;       .                                       .
;       -                                       -
;       |                                       |
;       -----------------------------------------
;       |                                       | scratch longword
;       -----------------------------------------
;       |  class  |  dtype  |  string length    | 0(R9)  scratch character buffer
;       -----------------------------------------
;       |            buffer address             |
;       -----------------------------------------
;       |   255 character buffer for name       |
;       -                                       -
;       .                                       . (64 longwords)
;       .                                       .
;       -----------                             -
;       | not used|                             |
;       -----------------------------------------
;
; Registar usage:
; R11 - Points to the beginning of the key_buffer itemlist
; R10 - Points to the end of the key_buffer itemlist where new
;       items are added.
;
; Notes:
;       The SOR$... symbols are defined in the SYS$LIBRARY:SORTSHR.EXE
;       shareable image.  The linker should resolve these symbols
;       automatically, as part of its search through the images in the
;       system shareable image library SYS$LIBRARY:IMAGELIB.OLB.

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
KEYn:   .ASCID "KEYn"
KEYn_POSITION:
        .ASCID "KEYn.POSITION"
KEYn_SIZE:
        .ASCID "KEYn.SIZE"
KEYn_DESCENDING:
        .ASCID "KEYn.DESCENDING"
KEYn_REVERSE:
        .ASCID "KEYn.REVERSE"

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR
KEY:    .ASCID "KEY"
KEY_POSITION:
        .ASCID "KEY.POSITION"
KEY_SIZE:
        .ASCID "KEY.SIZE"
KEY_DESCENDING:
        .ASCID "KEY.DESCENDING"
KEY_REVERSE:
        .ASCID "KEY.REVERSE"
DESCENDING:
        .ASCID "DESCENDING"
DUPLICATES:
        .ASCID "DUPLICATES"
EBCDIC:
        .ASCID "EBCDIC"
MULTINATIONAL:
        .ASCID "MULTINATIONAL"
HELP:
        .ASCID "HELP"
REVERSE:
        .ASCID "REVERSE"
STABLE:
        .ASCID "STABLE"
START:
        .ASCID "START"

SRT_MAXLRL = 132        ;Maximum length of line we will support for record sort

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY SORT_POSTPARSE,^M<R2,R9,R10,R11>
; Allocate memory
        MOVL    SP,R0                                   ;Save original SP
        SUBL2   #<255+8>,SP                             ;memory for string buffer
        MOVL    SP,R9                                   ;save address
        SUBL2   #<10*8 +4>,SP                           ;memory for key_buffer
        MOVL    SP,R10                                  ;set R10 points into key_buffer
        SUBL2   #2,SP                                   ;for number of keys
        MOVL    SP,R11                                  ;Set R11 points to key_buffer header
        SUBL2   #2,SP                                   ;to longword align stack
        SUBL2   SP,R0                                   ;R0 = total length of memory allocated
        MOVC5   #0,(SP),#^x00,R0,(SP)                   ; Zero allocated memory
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(R9)         ;Fill in Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(R9)         ;Fill in Class
        MOVAB   8(R9),        DSC$A_POINTER(R9)         ;Buffer address

;Check for KEY qualifier
10$:    PUSHAQ  KEY                             ;Test for KEY, then test for KEY1 - KEY9
        CALLS   #1,G^CLI$PRESENT
        BLBS    R0,12$                          ;branch if present and process
        BRW     18$                             ;Jump into loop for KEYn stuff

12$:    MOVW    #DSC$K_DTYPE_T, (R10)           ;Fill in Type is text characters

;Check for KEY.DESCENDING and/or KEY.REVERSE (identical)
        PUSHAQ  KEY_DESCENDING                  ;Test for KEY.DESCENDING
        CALLS   #1,G^CLI$PRESENT
        BLBS    R0,13$                          ;branch if descending

        PUSHAQ  KEY_REVERSE                     ;else check for REVERSE (identical function)
        CALLS   #1,G^CLI$PRESENT
        BLBC    R0,14$                          ;branch if not descending
13$:    MOVW    #1,2(R10)                       ;set key descending (same as reverse)

;Get KEY.POSITION
14$:    MOVW    #<BUFLEN-1>,(R9)                ;Reset descriptor length of scratch buffer
        PUSHL   R9                              ;scratch buffer
        PUSHL   R9                              ;scratch buffer
        PUSHAQ  KEY_POSITION                    ;get POSITION=x for KEYn
        CALLS   #3,G^CLI$GET_VALUE
        PUSHAB  4(R10)                          ;result by reference
        PUSHAB  8(R9)                           ;string by reference
        MOVZWL  (R9),-(SP)                      ;length of string
        CALLS   #3,G^LIB$CVT_DTB                ;Convert string to number
        DECW    4(R10)                          ;Convert position to offset

;Get KEY.SIZE
        MOVW    #<BUFLEN-1>,(R9)                ;Reset descriptor length
        PUSHL   R9                              ;address of scratch buffer
        PUSHL   R9                              ;address of scratch buffer
        PUSHAQ  KEY_SIZE                        ;Get SIZE
        CALLS   #3,G^CLI$GET_VALUE
        PUSHAB  6(R10)                          ;result by reference
        PUSHAB  8(R9)                           ;string by reference
        MOVZWL  (R9),-(SP)                      ;length of string
        CALLS   #3,G^LIB$CVT_DTB                ;Convert string to number

        INCW    (R11)                           ;Increment count of number of keys
        ADDL2   #8,R10                          ;Increment key_buffer pointer

;CHECK FOR KEYn QUALIFIERS
18$:    MOVZBL  #^A"1",R2                       ;R2 counts from "1" to "9"
19$:    PUSHAQ  KEYn                            ;Test for KEY1 - KEY9 present
        MOVL    (SP),R0                         ;R0 = address of descriptor
        ADDL3   #3,4(R0),R0                     ;R0 = address of n
        MOVB    R2,(R0)                         ;make KEYn into KEY1 - KEY9
        CALLS   #1,G^CLI$PRESENT
        BLBS    R0, 20$                         ;branch if present and process
        BRW     100$                            ;else loop

;Start next item on key_buffer itemlist
20$:    MOVW    #DSC$K_DTYPE_T, (R10)           ;Fill in Type is text characters

;Check for key DESCENDING and/or REVERSE (identical)
        PUSHAQ  KEYn_DESCENDING
        MOVL    (SP),R0                         ;R0 = address of descriptor
        ADDL3   #3,4(R0),R0                     ;R0 = address of n
        MOVB    R2,(R0)                         ;make KEYn_DESCENDING into KEY1_DESCENDING - KEY9_DESCENDING
        CALLS   #1,G^CLI$PRESENT
        BLBS    R0,29$                          ;branch if descending

        PUSHAQ  KEYn_REVERSE                    ;else check for REVERSE (identical function)
        MOVL    (SP),R0                         ;R0 = address of descriptor
        ADDL3   #3,4(R0),R0                     ;R0 = address of n
        MOVB    R2,(R0)                         ;make KEYn_REVERSE into KEY1_REVERSE - KEY9_REVERSE
        CALLS   #1,G^CLI$PRESENT
        BLBC    R0,30$                          ;branch if not descending and not reverse
29$:    MOVW    #1,2(R10)                       ;set key descending (same as reverse)

;GET KEYn.POSITION
30$:    MOVW    #<BUFLEN-1>,(R9)                ;Reset descriptor length of scratch buffer
        PUSHL   R9                              ;scratch buffer
        PUSHL   R9                              ;scratch buffer
        PUSHAQ  KEYn_POSITION                   ;get POSITION=x for KEYn
        MOVL    (SP),R0                         ;R0 = address of descriptor
        ADDL3   #3,4(R0),R0                     ;R0 = address of n
        MOVB    R2,(R0)                         ;make KEYn_POSITION into KEY1_POSITION - KEY9_POSITION
        CALLS   #3,G^CLI$GET_VALUE
        PUSHAB  4(R10)                          ;result by reference
        PUSHAB  8(R9)                           ;string by reference
        MOVZWL  (R9),-(SP)                      ;length of string
        CALLS   #3,G^LIB$CVT_DTB                ;Convert string to number
        DECW    4(R10)                          ;Convert position to offset

;GET KEYn.SIZE
        MOVW    #<BUFLEN-1>,(R9)                ;Reset descriptor length
        PUSHL   R9                              ;address of scratch buffer
        PUSHL   R9                              ;address of scratch buffer
        PUSHAQ  KEYn_SIZE                       ;Get SIZE
        MOVL    (SP),R0                         ;R0 = address of descriptor
        ADDL3   #3,4(R0),R0                     ;R0 = address of n
        MOVB    R2,(R0)                         ;make KEYn_SIZE into KEY1_SIZE - KEY9_SIZE
        CALLS   #3,G^CLI$GET_VALUE
        PUSHAB  6(R10)                          ;result by reference
        PUSHAB  8(R9)                           ;string by reference
        MOVZWL  (R9),-(SP)                      ;length of string
        CALLS   #3,G^LIB$CVT_DTB                ;Convert string to number

        INCW    (R11)                           ;Increment count of number of keys
        ADDL2   #8,R10                          ;Increment key_buffer pointer

100$:   ACBW    #^A"9", #1, R2, 19$             ;Loop until all /KEY processed

101$:   TSTW    (R11)                           ;Check that we have at least one key
        BNEQ    110$                            ;branch if we had at least one KEYn

;Default sort values
        MOVW    #DSC$K_DTYPE_T, (R10)           ;Fill in Type is text characters
        CLRW    2(R10)                          ;sort defaults to ascending
        CLRW    4(R10)                          ;sort starts at offset 0
        MOVW    #132,6(R10)                     ;key length defaults to 132
        MOVZBW  #1,(R11)                        ;Count of number of keys is 1

        PUSHAQ  DESCENDING                      ;Check for /DESCENDING (same as /REVERSE)
        CALLS   #1,G^CLI$PRESENT
        BLBS    R0,106$                         ;branch if present
        PUSHAQ  REVERSE                         ;Check for /REVERSE (same as /DESCENDING)
        CALLS   #1,G^CLI$PRESENT
        BLBC    R0,107$                         ;branch if not present
106$:   MOVW    #1,2(R10)                       ;set key descending

107$:   PUSHAQ  START
        CALLS   #1,G^CLI$PRESENT
        BLBC    R0,110$                         ;branch if not present and check for /KEYn
        MOVW    #<BUFLEN-1>,(R9)                ;Reset descriptor length of scratch buffer
        PUSHL   R9                              ;scratch buffer
        PUSHL   R9                              ;scratch buffer
        PUSHAQ  START                           ;get /START=value
        CALLS   #3,G^CLI$GET_VALUE
        PUSHAB  4(R10)                          ;result by reference
        PUSHAB  8(R9)                           ;string by reference
        MOVZWL  (R9),-(SP)                      ;length of string
        CALLS   #3,G^LIB$CVT_DTB                ;Convert string to number
        DECW    4(R10)                          ;Convert start position to offset
        MOVW    #132,6(R10)                     ;reset key size to 132 (clobbered by CVT_DTB)

110$:   PUSHL   #SOR$M_NOSIGNAL                 ;place for option qualifiers
        MOVL    SP,R2                           ;R2 pointer to options bits
        PUSHAQ  STABLE                          ;Test for /STABLE
        CALLS   #1,G^CLI$PRESENT                ;
        BLBC    R0, 120$                        ;Branch if not present
        BISL2   #SOR$M_STABLE,(R2)              ;Set stable bit

120$:   PUSHAQ  EBCDIC                          ;Test for /EBCDIC
        CALLS   #1,G^CLI$PRESENT                ;
        BLBC    R0, 125$                        ;Branch if not present
        BISL2   #SOR$M_EBCDIC,(R2)              ;Set EBCDIC bit

125$:   PUSHAQ  MULTINATIONAL                   ;Test for /MULTINATIONAL
        CALLS   #1,G^CLI$PRESENT                ;
        BLBC    R0, 130$                        ;Branch if not present
        BISL2   #SOR$M_MULTI,(R2)               ;Set MULTINATIONAL bit

130$:   PUSHAQ  DUPLICATES                      ;Test for /NODUPLICATES
        CALLS   #1,G^CLI$PRESENT                ;
        CMPL    R0, #CLI$_NEGATED               ;test for /NODUPLICATES
        BNEQ    140$                            ;branch if not
        BISL2   #SOR$M_NODUPS,(R2)              ;Set noduplicates bit

140$:   PUSHL   #SRT_MAXLRL                     ;length of longest line if using record sort
        MOVL    SP,R0                           ;save address
        PUSHL   R2                              ;options by reference
        PUSHL   #0                              ;LRL (length of longest line)
        BLBC    4(AP),142$                      ;if using file sort leave LRL=0
        MOVL    R0,(SP)                         ;else set to MAXLRL (by reference)
142$:   PUSHL   R11                             ;key_buffer by reference
        CALLS   #3,G^SOR$BEGIN_SORT

        BLBS    R0,150$                         ;check for error
        PUSHL   R0                              ;save R0
        PUSHL   R0                              ;push for EDX_SIGNAL
        CALLS   #1,EDX_SIGNAL                   ;signal error
        POPL    R0                              ;Restore R0
150$:   RET

;------------------------------------------------------------------------------
;++
;       SORT_DO_FILE
;
; Functional Description:
;       Perform actual sort.
;
; Calling Sequence:
;       CALLS   #0,SORT_DO_FILE
;
; Implicit inputs:
;       It is assumed that SOR$BEGIN_SORT has already been called
;       (by SORT_POSTPARSE).
;
; Outputs:
;       OUTSTR has already been set by SORT_PASSFILES with success code
;       of 1 and string containing ouput filename.  This will be used as
;       our return string unless an error occurs here, in which case
;       we remake OUTSTR with our own error information.
;
; Outline:
;       1.  SOR$SORT_MERGE is called to sort file creating new output file
;       2.  SOR$END_SORT is called to clean up
;
        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY SORT_DO_FILE,^M<>
        CALLS   #0,G^SOR$SORT_MERGE                     ;DO SORT
        BLBS    R0,20$                                  ;branch if OK
        PUSHL   R0                                      ;else error...
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL
        CALLS   #1,FMTOUTSTR
20$:    CALLS   #0,G^SOR$END_SORT
        RET                                             ;OUTSTR was set previously

;------------------------------------------------------------------------------
;++
;       SORT_RELEASE_REC
;
; Functional Description:
;       Pass a record to SORT when using record sort.  Calls G^SOR$RELEASE_REC
;
; Calling Sequence:
;       CALLS   #0,SORT_RELEASE_REC
;
; Inputs:
;       INSTR - record being released to SORT
;
; Outputs:
;       Status in OUTSTR: 0 = error
;                         1 = success
;                         2 = line too long
;
; SRT_MAXLRL is maximum length of record we can do via record sort
;--
        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  SORT_RELEASE_REC,^M<R2>
        PUSHL   INSTR                           ;Address of input string descriptor
        CALLS   #1,G^SOR$RELEASE_REC
        BLBC    R0,10$                          ;branch on bad status
        PUSHL   #1                              ;good status
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET

;Check for line too long status
10$:    MOVL    R0,R2                           ;Save return condition
        PUSHL   R0                              ;Return value
        MOVL    SP,R0                           ;R0 = address of return value
        PUSHL   #SOR$_BAD_LRL                   ;error value to check for
        PUSHL   SP                              ;address of error value to check for
        PUSHL   R0                              ;address of return value
        CALLS   #2,G^LIB$MATCH_COND             ;returns R0 = 0 if not require PC and PSL
        TSTL    R0
        BEQL    20$                             ;branch if not SOR$_BAD_LRL
        MOVL    #2,R0                           ;Set return status to 2 (line too long)
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET

20$:    PUSHL   R0                              ;else error...
        CALLS   #1,EDX_SIGNAL
        PUSHL   #0                              ;return 0 for error
        CALLS   #1,FMTOUTSTR
        RET

;------------------------------------------------------------------------------
;++
;       SORT_RETURN_REC
;
; Functional Description:
;       Returns a record when using record sort
;
; Calling Sequence:
;       CALLS   #0,SORT_RETURN_REC
;
; Outputs:
;       OUTSTR - returned record.
;
; Memory Map (Memory allocated on stack):
;
;       MEMORY ALLOCATED ON STACK:
;       -----------------------------------------(String to contain record returned by SOR$RETURN_REC)
;       |                BUFFER                 | (R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(descriptor for string in which record is returned by SOR$RETURN_REC
;       |  class  |  dtype  |  string length    | <SRT_MAXLRL>(R9)
;       -----------------------------------------
;       |            buffer address             | <SRT_MAXLRL+^x04>(R9)
;       -----------------------------------------
;                                               | <SRT_MAXLRL+^x08>(R9)
; Register usage:
;       R9 = used as base address of memory allocated on stack
;
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  SORT_RETURN_REC,^M<R9>

        SUBL2   #<SRT_MAXLRL+^x08>,SP                           ;ALLOCATE MEMORY ON STACK
        MOVL    SP,R9                                           ;Store base address in R9
        MOVW    #SRT_MAXLRL,    <SRT_MAXLRL+DSC$W_LENGTH >(R9)  ;Length  ;INITIALIZE DESCRIPTOR
        MOVB    #DSC$K_DTYPE_T, <SRT_MAXLRL+DSC$B_DTYPE  >(R9)  ;Type
        MOVB    #DSC$K_CLASS_S, <SRT_MAXLRL+DSC$B_CLASS  >(R9)  ;Class
        MOVL    R9,             <SRT_MAXLRL+DSC$A_POINTER>(R9)  ;Address
        PUSHAW  <SRT_MAXLRL>(R9)                                ;length by reference will go into descriptor
        PUSHAQ  <SRT_MAXLRL>(R9)                                ;descriptor
        CALLS   #2,G^SOR$RETURN_REC                             ;Get next string (in sorted order)
        BLBS    R0,1$
        CMPL    R0,#SS$_ENDOFFILE
        BEQL    1$
        CHECK_STATUS
1$:     MOVQ    <SRT_MAXLRL>(R9),-(SP)          ;descriptor
        PUSHL   R0                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET


;==============================================================================
;       EDX SPELL
;==============================================================================

;Constants
BLOCK_SIZE = 512                        ;Number of bytes in a block
SPACE = ^x20                            ;Ascii space character

;DEFINE OFFSETS INTO DICTIONARY HEADER BLOCK
DIC_VERNO  = ^x00       ;Dictionary version number
DIC_HID    = ^x01       ;Dictionary header ID
DIC_LEXVBN = ^x04       ;Dictionary lexical database starting virtual block number
DIC_LEXBLN = ^x08       ;Dictionary lexical database size in blocks
DIC_INDVBN = ^x0C       ;Dictionary index starting virtual block number
DIC_INDLEN = ^x10       ;Dictionary index length in bytes
DIC_INDSWD = ^x14       ;Dictionary index size of word = INDSWD (constant)
DIC_INDPLN = ^x18       ;Dictionary index block size (number of lexical database blocks between index words)
DIC_CWDVBN = ^x1C       ;Dictionary common word list starting virtual block number
DIC_CWDLEN = ^x20       ;Dictionary common word list length
DICVERNO  = 2           ;EDX Dictionary Version Number


        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
.ALIGN LONG
DICFABIO:                                               ; Fab used for I/O
        $FAB    FNM = <EDX_DICTIONARY>, -               ; Output file name
                DNM = <SYS$LIBRARY:EDX_DICTIONARY.DAT>, -
                NAM = DICNAMIO, -
                FAC = <BIO,GET>, -                      ; Block I/O write operation
                SHR = <GET>
DICRABIO:
        $RAB    FAB = DICFABIO                          ; Pointer to FAB

DICNAMIO:                                               ; NAM block for resulting filename
        $NAM    ESS = NAM$C_MAXRSS

DICFABMAP:                                              ; Fab used for mapping lexical database to memory
        $FAB    FNM = <EDX_DICTIONARY>, -               ; Output file name
                DNM = <SYS$LIBRARY:EDX_DICTIONARY.DAT>, -
                FOP = <UFO>, -
                FAC = <GET>, -
                SHR = <GET,UPI>, -                      ;UPI must be set says the book
                RTV = -1                                ;keep all pointers

PERSDICFAB:                                             ; Personal dictionary
        $FAB    FNM = <EDXPERSDIC>, -
                DNM = <SYS$LOGIN:EDXPERSDIC.DAT>, -
                FAC = <GET>, -
                SHR = <GET>
PERSDICRAB:
        $RAB    FAB = PERSDICFAB, -                     ; Pointer to FAB
                UBF = WDBUF,-
                USZ = WDBUF_SIZE

WDBUF_SIZE = 80                         ;personal dictionary inword buffer size
WDBUF:          .BLKB   WDBUF_SIZE      ;personal inword buffer
.ALIGN LONG
DIC_HEADER:  .LONG  0                   ;address of dictionary header block
DIC_INDEX:   .LONG  0                   ;address of dictionary index blocks
DIC_CMNWDS:  .LONG  0                   ;address of common words

DIC_LWL:     .LONG  0                   ;last misspelled word length
DIC_LWA:     .LONG  0                   ;copy of last misspelled word (address)
ASSUME DIC_LWL+4 EQUAL DIC_LWA          ;DIC_LWL + DIC_LWA form descriptor

MAPRANGE:    .LONG  ^x200, ^x200        ;any program (P0) region address
LEXDBA:      .BLKL  2                   ;Lexical Database Address (address range returned here)
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  EDX_SPELL,^M<>
        ;Case entry code
        ;R6 = Entry code passed by caller
        TSTL    DIC_HEADER
        BNEQ    10$
        CALLS   #0,SPELL_INIT                   ;initialize spelling checker
        BLBS    R0,10$                          ;branch if OK
        PUSHL   R0                              ;error return status
        CALLS   #1,FMTOUTSTR                    ;set return status
        RET                                     ;and return with error status (status already printed by SPELL_INIT)

10$:    CASEB   R6, #1, #<8-1>                  ;Case entry point to jump to
1$:     .WORD   DICBPA-1$,-                     ; 1 = Dictionary browse previous page
                DICBRW-1$,-                     ; 2 = Dictionary browse using word
                DICBPZ-1$,-                     ; 3 = Dictionary browse next page
                SPLTXT-1$,-                     ; 4 = Spell textline
                SPLGUS-1$,-                     ; 5 = Spell guess
                ACEPTW-1$,-                     ; 6 = Accept word (add to accepted word list)
                PERDIC-1$,-                     ; 7 = Add word to personal dictionary
                DMPCMW-1$                       ; 8 = Dump commonword list
        PUSHL   #EDX__UNKNCODE                  ;Unknown item code
        CALLS   #1,EDX_SIGNAL                   ;Signal internal error
        RET                                     ;and return
DICBPA:
DICBRW:
DICBPZ: CALLS   #0,DIC_BROWSE
        RET
SPLTXT: PUSHL   INSTR
        CALLS   #1,SPELL_TEXTLINE
        RET
SPLGUS: CALLS   #0,SPELL_GUESS
        RET
ACEPTW: CALLS   #0,SPELL_ACCEPT_WORD
        RET
PERDIC: CALLS   #0,ADD_PERSDIC
        RET
DMPCMW: CALLS   #0,DUMP_COMMONWORDS
        RET
;------------------------------------------------------------------------------

        .SUBTITLE SPELL_INIT
;++
;
; Functional Description:
;       Initializes the EDX dictionary.  Opens all necessary files,
;       reads in all necessary data.  On error prints error and returns
;       error status.
;       Uses system service routine $CRMPSC to map the dictionary straight
;       into memory.  This method does not use up any user pgflquo quota.
;
; Calling Sequence:
;       CALLS   #0,SPELL_INIT
;
; Outputs:
;       R0 = STATUS
;
; Outline:
;       1.  A test is made to see if the initialization has already
;           been done.
;       2.  The EDX dictionary database file EDX_DICTIONARY.DAT is opened
;           and connected to.
;       3.  The rest of the file is mapped into memory using $CRMPSC.
;       4.  Pointers to the index, common words, and lexical database are set.
;       5.  User's personal dictionary file, if one is found, is opened
;           and the words there are inserted into the binary tree of accepted
;           words.
;
; Memory Map (Memory allocated on stack):
;       -----------------------------------------
;       |          buffer for filename          | DICNAMIO+NAM$B_ESA
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------
;
;Registar usage:
; R11 = DIC_HEADER starting address of dictionary header block in memory
;--

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  SPELL_INIT,^M<R2,R9,R10,R11>
        TSTL    DIC_HEADER                      ;check if we've already initialized
        BEQL    1$
        MOVL    #SS$_NORMAL,R0
        RET                                     ;Initialization already done

1$:     PUSHL   #EDX__DICLOAD                   ;loading dictionary message
        CALLS   #1,EDX_SIGNAL                   ;signal message

        SUBL2   #NAM$C_MAXRSS,SP                ;Allocate buffer for filename
        BICB2   #^B0011,SP                      ;longword align stack pointer
        MOVL    SP,DICNAMIO+NAM$L_ESA           ;Store buffer address in NAM block

        $OPEN   FAB=DICFABIO                    ;Open EDX dictionary file
        BLBC    R0,2$                           ;branch if error
        $CONNECT RAB=DICRABIO                   ;Connect to input
        BLBS    R0,3$                           ;branch if OK

2$:     PUSHL   #0                              ;0 FAO args
        PUSHL   R0                              ;Error status
        PUSHAL  BELL                            ;Ring terminal bell
        CALLS   #1,G^LIB$PUT_OUTPUT             ;
        PUSHL   DICNAMIO+NAM$L_ESA              ;filename addresss
        MOVZBL  DICNAMIO+NAM$B_ESL,-(SP)        ;filename size
        PUSHL   #2                              ;2 FAO args
        PUSHL   #EDX__ERROPENDIC                ;error opening dictionary file message
        CALLS   #6,EDX_SIGNAL                   ;signal message
        MOVL    #EDX__ERROPENDIC,R0             ;set return status
        RET

;Allocate memory for dictionary header block
;Address to return start position of block is DIC_HEADER
3$:     JSB     INITVMZONE
        MOVL    #BLOCK_SIZE,-(SP)               ;Length of memory block to allocate
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHAL  DIC_HEADER                      ;Address to place return address of memory block allocated
        PUSHL   R0                              ;Address containing length of memory to allocate (LNKFABLEN by reference)
        CALLS   #3,G^LIB$GET_VM                 ;Allocate memory for new block in linked list
        CLRL    (SP)+                           ;Restore stack pointer
        BLBS    R0,4$                           ;branch if OK
        PUSHL   #0
        PUSHL   R0
        PUSHL   #0
        PUSHL   #EDX__SPLINITERR                ;spell init error
        CALLS   #4,EDX_SIGNAL                   ;signal error
        MOVL    #EDX__SPLINITERR,R0             ;set return status
        RET

;READ IN DICTIONARY HEADER
4$:     MOVL    DIC_HEADER,R11                  ;Set R11
        MOVL    #1,DICRABIO+RAB$L_BKT           ;Block number to read
        MOVL    DIC_HEADER,DICRABIO+RAB$L_UBF   ;Buffer
        MOVW    #BLOCK_SIZE,DICRABIO+RAB$W_USZ  ;Buffer size = 1 BLOCK
        $READ   RAB=DICRABIO                    ;read in dictionary header block
        BLBS    R0,10$                          ;branch if OK
        PUSHL   #0
        PUSHL   R0
        PUSHL   #0
        PUSHL   #EDX__SPLINITERR                ;spell init error
        CALLS   #4,EDX_SIGNAL                   ;signal error
        MOVL    #EDX__SPLINITERR,R0             ;set return status
        RET

;CHECK VALIDITY OF HEADER
10$:    CMPB    1(R11), #^A"E"                  ;Header must say "EDX"
        BNEQ    18$
        CMPB    2(R11), #^A"D"
        BNEQ    18$
        CMPB    3(R11), #^A"X"
        BNEQ    18$
        CMPB     (R11), #2                      ;version number must be 2
        BEQL    20$

        MOVZBL  3(R11),-(SP)                    ;version number
        PUSHL   #1                              ;one FAO argument
        PUSHL   #EDX__DICVERSERR                ;error in dictionary version number
        CALLS   #3,EDX_SIGNAL                   ;signal error
        MOVL    #EDX__DICVERSERR,R0             ;set return status
        RET

18$:    PUSHL   DICFABIO+FAB$L_FNA              ;filename addresss
        MOVZBL  DICFABIO+FAB$B_FNS,-(SP)        ;filename size
        PUSHL   #2                              ;2 FAO args
        PUSHL   #EDX__DICHEADERR                ;error in dictionary header
        CALLS   #4,EDX_SIGNAL                   ;signal error
        MOVL    #EDX__DICHEADERR,R0             ;set return status
        RET

;MAP LEXICAL DATABASE INTO MEMORY
20$:    $CLOSE  FAB=DICFABIO                            ;close it for I/O
        $OPEN   FAB=DICFABMAP                           ;open it for mapping
        BLBC    R0,22$                                  ;branch if error

;Calculate length in blocks of lexical database + index + common words
        DIVL3   #BLOCK_SIZE,DIC_CWDLEN(R11),R0
        INCL    R0                                      ;R0 = number of blocks for common words
        SUBL3   DIC_LEXVBN(R11),DIC_CWDVBN(R11),R2      ;R1 = number of blocks for lexical database + index
        ADDL2   R2,R0                                   ;R1 = number of blocks for lexical database + index + common words
        $CRMPSC_S -                                     ;map the lexical database straight into memory
                INADR=MAPRANGE,-
                RETADR=LEXDBA,-
                VBN=DIC_LEXVBN(R11),-
                PAGCNT=R1,-
                FLAGS=#SEC$M_EXPREG,-
                CHAN=DICFABMAP+FAB$L_STV,-
                PFC=DIC_INDPLN(R11)
        BLBS    R0,30$
22$:    PUSHL   #0                              ;0 FAO args
        PUSHL   R0                              ;Error status
        PUSHAL  BELL                            ;Ring terminal bell
        CALLS   #1,G^LIB$PUT_OUTPUT             ;
        PUSHL   #0                              ;2 FAO args
        PUSHL   #EDX__ERRMAPDIC                 ;error mapping dictionary file message
        CALLS   #4,EDX_SIGNAL                   ;signal message
        MOVL    #EDX__ERRMAPDIC,R0              ;set return status
        RET

;SET POINTERS TO INDEX, COMMON WORDS, LEXICAL DATABASE.
30$:    MULL2   #BLOCK_SIZE,R2
        ADDL3   R2,LEXDBA,DIC_CMNWDS                    ;dic_cmnwds = lexdba+ (dic_cwdvbn - dic_lexvbn)*BLOCK_SIZE
        SUBL3   DIC_LEXVBN(R11),DIC_INDVBN(R11),R0      ;dic_index = lexdba+ (dic_indvbn-dic_lexvbn)*BLOCK_SIZE
        MULL2   #BLOCK_SIZE,R0
        ADDL3   R0,LEXDBA,DIC_INDEX

;OPEN AND READ IN THE USER'S PERSONAL DICTIONARY FILE
40$:    $OPEN   FAB=PERSDICFAB                  ;Open user's personal dictionary file
        BLBC    R0,42$                          ;branch if error
        $CONNECT RAB=PERSDICRAB                 ;Connect to input
        BLBS    R0,43$                          ;branch if OK
42$:    ;error processing would go here
        CMPL    R0,#RMS$_FNF                    ;compare with file not found
        BEQL    100$
        PUSHL   #0                              ;0 FAO args
        PUSHL   R0                              ;RMS error
        PUSHL   PERSDICFAB+FAB$L_FNA            ;filename address
        MOVZBL  PERSDICFAB+FAB$B_FNS,-(SP)      ;filename size
        PUSHL   #2                              ;2 FAO args
        PUSHL   #EDX__PERSDICERR                ;error opening personal dictionary
        CALLS   #6,EDX_SIGNAL                   ;signal message
        BRB     100$                            ;and jump to end

43$:    SUBL2   #8,SP                                   ;build string descriptor for
        MOVL    SP,R9                                   ; WDBUF string buffer.
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(R9)         ;Fill in Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(R9)         ;Fill in Class
        MOVAB   WDBUF,          DSC$A_POINTER(R9)       ;Fill in address
        MOVAB   PERSDICRAB,R10
50$:    $GET    RAB=PERSDICRAB                  ;LOOP READ IN ALL WORDS
        BLBC    R0,100$                         ;expect End Of File error
        MOVW    RAB$W_RSZ(R10),DSC$W_LENGTH(R9) ;length of line
        PUSHL   R9                              ;address of descriptor
        CALLS   #1,SPELL_TEXTLINE               ;this trims, upcases, and sets word for inclusion in accepted word tree
        CALLS   #0,SPELL_ACCEPT_WORD            ;add word to accepted word list
        BRB     50$                             ;loop

100$:   $CLOSE  FAB=PERSDICFAB                  ;close file (ignore error if we get one)
        MOVL    #SS$_NORMAL,R0                  ;initialization successfull
        RET
;------------------------------------------------------------------------------

        .SUBTITLE SPELL_TEXTLINE
;++
;
; Functional Description:
;       Checks the spelling of each word in the input string
;
; Calling Sequence:
;       CALLS   #1,SPELL_TEXTLINE
;
; Argument inputs:
;       4(AP)   address of descriptor of string containing words to check
;               (usually INSTR)
;
; Outputs:
;       LIB$_NORMAL if all words in line spelled correctly
;       LIB$_NOTFOU if a word in line was spelled incorrectly
;       OUTSTR = characters 1-9 is return status value
;                characters 10-12 is decimal value of offset from start of
;                  instr where misspelled word begins
;                character 13 is space character
;                characters 14-16 is decimal value of length of misspelled
;                  word.
;
; Outline:
;       1.  Memory is allocated on the stack
;
;       2.  The next word in INSTR is parsed off
;           a.  INSTR is searched for the start of a word.  The start of a
;               word is any character {A...Z,a...z}.
;           b.  INSTR is searched for the end of a word.  The end of a word
;               is any character other than {A...Z,a...z} and the appostrophie
;               ("'") character.  A special check is made to handle the
;               appostrophie.  Words line "we're" or "you'd" are accepted
;               as is.  Words which have a trailing "'s" such as "Mark's" or
;               "Saturday's" have the "'s" trimmed off.  We ignore quotes
;               which occur at the end of a word with no letters following.
;
;               When a single quote character "'" is encountered:
;                i.   If we are at the end of the line, the quote is rejected.
;                ii.  If the next character following the quote is not a
;                     letter (A-Z,a-z), the quote is rejected.
;                iii. If the next character following the quote is a "S"
;                     or a "s",
;
;       3.  A dictionary lookup search is made for a match to the resulting
;           parsed off word.
;
;       4.  Loop back to step 2 until all words in INSTR have been checked.
;
;
; Memory Map (Memory allocated on stack):
;       -----------------------------------------(descriptor for FAO call)
;       |  class  |  dtype  |  string length    | (R2)
;       -----------------------------------------
;       |            buffer address             |
;       -----------------------------------------(descriptor for STR$UPCASE call)
;       |  class  |  dtype  |  string length    |
;       -----------------------------------------
;       |            buffer address             |
;       -----------------------------------------(return string buffer for FAO call)
;       |              FAO BUFFER               | (R3)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(base address stored in R11)
;       |                OFFSET                 | <^x00>
;       -----------------------------------------
;       |              WORD_START               | <^x04>
;       -----------------------------------------
;       |              WORD_LENGTH              | <^x08>
;       -----------------------------------------
;                                               | <+^x0C>
OFFSET      = ^x00
WORD_START  = ^x04
WORD_LENGTH = ^x08
;R9  = textline length (word) (instr descriptor length, type, class)
;R10 = textline address
;R11 = address of local memory
        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
.ALIGN LONG
FAOSPLOUT:  .ASCID  /!3UL !3UL/
SPLOUTLEN=7

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  SPELL_TEXTLINE,^M<R2,R3,R9,R10,R11>

        SUBL2   #^x0C,SP                        ;allocate local memory
        MOVL    SP,R11                          ;save address of local memory
        CLRL    OFFSET(R11)                     ;offset=0
        MOVQ    @4(AP),R9                       ;descriptor.  length -> R9, address -> R10

;SEARCH FOR START OF WORD
1$:     CMPW    OFFSET(R11),R9                  ;check for end of line
        BLSS    3$                              ;branch if not end of line
        PUSHL   #LIB$_NORMAL
        CALLS   #1,FMTOUTSTR                    ;set return status
        RET                                     ;All done.  No more words to check on this line
3$:     MOVAB   @OFFSET(R11)[R10],R1
        MOVZBL  @OFFSET(R11)[R10],R0
        CMPB    @OFFSET(R11)[R10], #^A"A"       ;if char ={A..Z,a..z} then exitloop, start of word found
        BLSS    9$                              ;char < A, char not a letter
        CMPB    @OFFSET(R11)[R10], #^A"Z"       ;
        BLEQ    10$                             ;matches A..Z
        CMPB    @OFFSET(R11)[R10], #^A"a"       ;try a..z
        BLSS    9$                              ;no match, loop again (char < z & char > Z)
        CMPB    @OFFSET(R11)[R10], #^A"z"       ;
        BLEQ    10$                             ;matches a..z
9$:     INCL    OFFSET(R11)                     ;move to next character
        BRB     1$

;SEARCH FOR END OF WORD
;OFFSET now at start of word, find end of word.
10$:    MOVL    OFFSET(R11),WORD_START(R11)     ;save word start offset
11$:    INCL    OFFSET(R11)                     ;move to next character
        CMPW    OFFSET(R11),R9                  ;check for end of line
        BLSS    50$                             ;not end of line, continue
        BRW     200$                            ;end of line.  Exitloop, word found

50$:    CMPB    @OFFSET(R11)[R10], #^A"'"       ;check for appostrophie
        BNEQ    150$                            ;branch if not an appostrophie to normal checking

; HANDLE APOSTROPHE
        INCL    OFFSET(R11)                     ;move to next character
        CMPW    OFFSET(R11),R9                  ;check for end of line
        BGEQ    100$                            ;end of line, reject "'"

; Check that next char after apostrophe is a letter
        CMPB    @OFFSET(R11)[R10], #^A"A"       ;if char ={A..Z,a..z} then exitloop, start of word found
        BLSS    100$                            ;char < A, char not a letter, reject "'"
        CMPB    @OFFSET(R11)[R10], #^A"Z"       ;
        BLEQ    80$                             ;matches A..Z, continue.
        CMPB    @OFFSET(R11)[R10], #^A"a"       ;try a..z
        BLSS    100$                            ;char not a letter, reject "'"
        CMPB    @OFFSET(R11)[R10], #^A"z"       ;
        BGTR    100$                            ;char not a letter, reject "'"

; char was a letter.  Now check if letter was S (as in 's)
80$:    CMPB    @OFFSET(R11)[R10], #^A"S"       ;check for "'s"
        BEQL    100$                            ;
90$:    CMPB    @OFFSET(R11)[R10], #^A"s"       ;
        BNEQ    11$                             ;not "'s", accept appostrophie and continue

100$:   DECL    OFFSET(R11)
        SUBL3   WORD_START(R11), OFFSET(R11),-
                WORD_LENGTH(R11)                ;Reject "'".  Remove "'" and declare end of word
        ADDL2   #2,OFFSET(R11)                  ;set offset beyond end of current word
        BRB     201$                            ;(skip setting offset for next word)

; NORMAL CHECK FOR CHAR <> LETTER
150$:   CMPB    @OFFSET(R11)[R10], #^A"A"       ;if char ={A..Z,a..z} then exitloop, start of word found
        BLSS    200$                            ;char < A, char not a letter, reject "'"
        CMPB    @OFFSET(R11)[R10], #^A"Z"       ;
        BLEQ    160$                            ;matches A..Z, continue.
        CMPB    @OFFSET(R11)[R10], #^A"a"       ;try a..z
        BLSS    200$                            ;char not a letter, reject "'"
        CMPB    @OFFSET(R11)[R10], #^A"z"       ;
        BGTR    200$                            ;char not a letter, reject "'"
160$:   BRW     11$                             ;continue loop

200$:   SUBL3   WORD_START(R11), OFFSET(R11),-  ;end of line, set word length
                WORD_LENGTH(R11)                ;
201$:   PUSHAB  @WORD_START(R11)[R10]           ;address of word start
        PUSHL   WORD_LENGTH(R11)                ;Length of word
        CALLS   #2,DIC_LOOKUP_WORD              ;see if word is in dictionary
        BLBC    R0,210$                         ;branch if word not found
        BRW     1$                              ;start again searching for next word in line

;FOUND MISSPELLED WORD
210$:   MOVL    R0,R9                           ;Status from DIC_LOOKUP_WORD
        TSTL    DIC_LWA                         ;check for previous misspelled word to deallocate
        BEQL    211$                            ;branch if no previous word to deallocate
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHAL  DIC_LWA                         ;Address of address of memory block to deallocate
        PUSHAL  DIC_LWL                         ;Address containing length of memory to deallocate
        CALLS   #3,G^LIB$FREE_VM                ;Deallocate memory used for new FAB block

211$:   PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHAL  DIC_LWA                         ;Address to place return address of memory block allocated
        PUSHAL  WORD_LENGTH(R11)                ;Address containing length of memory to allocate
        CALLS   #3,G^LIB$GET_VM                 ;Allocate memory for new block in linked list
        MOVC3   WORD_LENGTH(R11),-              ;Copy word to storage
                @WORD_START(R11)[R10],-
                @DIC_LWA
        MOVL    WORD_LENGTH(R11),DIC_LWL        ;save word length

        SUBL2   #4,SP                                   ;upcase stored word
        MOVW    DIC_LWL,        DSC$W_LENGTH(SP)        ;Length
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(SP)         ;Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(SP)         ;Class
        MOVL    DIC_LWA,        DSC$A_POINTER(SP)       ;Address
        PUSHAL  (SP)                                    ;src-str (descriptor)
        PUSHAL  4(SP)                                   ;dst_str (descriptor, same)
        CALLS   #2,G^STR$UPCASE                         ;upcase misspelled word for storage

        MOVB    #1,GMODE                        ;reset guess mode pointers
        MOVB    #1,GSUBMODE
        MOVB    #1,GCOL

        SUBL2   #<SPLOUTLEN+8>,SP               ;Build temp descriptor
        MOVL    SP,R2                           ;Save address of descriptor in R2
        PUSHL   R0                              ;save status from DIC_LOOKUP_WORD
        MOVW    #SPLOUTLEN,     DSC$W_LENGTH(R2);Length of output FAO string
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(R2) ;Descriptor type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(R2) ;Descriptor Class
        MOVAB   8(R2),R3                        ;base address
        MOVL    R3,DSC$A_POINTER(R2)            ;base address
        PUSHL   WORD_LENGTH(R11)                ;length of misspelled word
        PUSHL   WORD_START(R11)                 ;starting offset of misspelled word
        PUSHL   R2                              ;Outbuf (by descriptor)
        PUSHL   #0                              ;Outlen (not used)
        PUSHAQ  FAOSPLOUT                       ;Ctrstr (by descriptor)
        CALLS   #5,G^SYS$FAO                    ;Write size to outline
        PUSHL   R3                              ;address of output string
        PUSHL   #SPLOUTLEN                      ;length of output string
        PUSHL   R9                              ;status from DIC_LOOKUP_WORD
        CALLS   #3,FMTOUTSTR
        RET
;------------------------------------------------------------------------------

        .SUBTITLE DIC_LOOKUP_WORD
;++
;
; Functional Description:
;       Searches the EDX dictionary for a given word
;
; Calling Sequence:
;       CALLS   #2,DIC_LOOKUP_WORD
;
; Argument inputs:
;     (AP) - number of arguments (#2 by value)
;    4(AP) - length of word to search for (word, by value)
;    8(AP) - starting address of word
;            (A string descriptor may be used for the two arguments)
;
; Outputs:
;       R0 = LIB$_NORMAL - word was found
;          = LIB$_NOTFOU - word was not found
;
; Outline:
;       1.  The input word is trimmed, upcased, and copied
;           to a target_word buffer with a leading and trailing
;           space appended.
;
;       2.  The dictionary common word list is searched for the word.
;
;       3.  The main lexical database is searched for the word.
;
;       4.  The list of accepted words is searched for a match.
;
;
; Memory Map (Memory allocated on stack):
;       -----------------------------------------(temp descriptor for input word)
;       |  class  |  dtype  |       length      |
;       -----------------------------------------
;       |           input word address          |
;       -----------------------------------------(descriptor for target_word buffer+1
;       |  class  |  dtype  |       length      | (R8)
;       -----------------------------------------
;       |       target_word buffer address      |
;       -----------------------------------------
;       |          TARGET_WORD BUFFER           | (R9)  (R5=R9+1)
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;                                               |(original stack pinter)
;
;Registar usage:
; R11 = DIC_HEADER starting address
; R10 = DIC_INDEX  starting address
; R9  = address of upcased target word with leading and trailing space
;(R8) - low word = length of upcased target word including leading and trailing space
;--
        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
TARGET_WORD_LEN:  .BLKL  1
TARGET_WORD_A:    .BLKL  1
ASSUME TARGET_WORD_LEN+4 EQUAL TARGET_WORD_A            ;TARGET_WORD_LEN + TARGET_WORD_A form descriptor

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  DIC_LOOKUP_WORD,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>

;;      MOVB    #DSC$K_DTYPE_T,<^x06>(AP)       ;debug
;;      MOVB    #DSC$K_CLASS_S,<^x07>(AP)       ;debug
;;      PUSHAQ  4(AP)                           ;debug
;;      CALLS   #1,G^LIB$PUT_OUTPUT             ;debug

        BSBW    SETUP_DICWORD                   ;copy word over to local storage with leading and trailing blank
        CMPL    #2,(R8)                         ;Check for zero length word (two spaces)
        BNEQ    2$
        MOVL    #LIB$_NORMAL,R0                 ;accept zero length word as OK
        RET

;SEARCH COMMON WORD LIST FOR MATCH
2$:     MOVL    DIC_HEADER,R11
        MATCHC  (R8),(R9),DIC_CWDLEN(R11),@DIC_CMNWDS   ;Find match to target_string in common word list
        BNEQ    50$
        BRW     100$    ;word found
50$:    MOVL    R9,TARGET_WORD_A                        ;save target_word address
        MOVZWL  (R8),TARGET_WORD_LEN                    ;save target_word length
        ADDL3   #1,R9,R5                                ;address of target guide word
        BSBW    BINSRCH_MAINDIC                         ;do binary search of index
        MOVL    LEXDBA,R9                               ;lexical database address
        MATCHC  TARGET_WORD_LEN,-
                @TARGET_WORD_A,-
                R5, (R9)[R4]            ;Find match to target_string in dictionary pages
        BNEQ    90$
100$:   MOVL    #LIB$_NORMAL,R0         ;word found
        RET

;SEARCH ACCEPTED WORD LIST FOR MATCH
90$:    SUBL2   #2,TARGET_WORD_LEN      ;don't count leading and trailing blanks
        INCL    TARGET_WORD_A           ;move over first blank
        PUSHAL  NEWNODE                 ;new node return address
        PUSHAB  COMPARE_NODE            ;compare node routine
        PUSHAQ  TARGET_WORD_LEN         ;our word to search for (descriptor)
        PUSHAL  TREE_HEAD               ;tree head for the binary tree
        CALLS   #4,G^LIB$LOOKUP_TREE    ;search for the word
        BLBS    R0,100$                 ;word found
        MOVL    #LIB$_NOTFOU,R0         ;word not found
        RET
;------------------------------------------------------------------------------

        .SUBTITLE SETUP_DICWORD
;++
;
; Functional Description:
;       Copies input word to local storage, upcases, trims, adds leading
;       and trailing space.
;
; Calling Sequence:
;       JSB  SETUP_DICWORD
;
; Inputs:
;    4(AP) - length of word to search for (word, by value)
;    8(AP) - starting address of word
;            (A string descriptor may be used for the two arguments)
;
; Outputs:
;       R0  - destroyed
;       R1  - destroyed
;       R8  - Low word is length of resulting word incliding leading and
;             trailing space.
;       R9  - Address of word starting with leading space.
;       R11 - destroyed
;
; Side effects:
;       Allocates space on stack for resulting word
;
; Outline:
;       1.  A buffer is allocated on the stack.  The buffer is of length
;           DIC_INDSWD + 2, then the stack os longword aligned.
;
;       2.  A temporary descriptor is built on the stack for the new
;           buffer.
;
;       3.  A temporary descriptor is built on the stack for the input
;           string.  (This to insure we have the type and calss fields
;           filled in).
;
;       4.  The input word is trimmed by STR$TRIM and copied over to the
;           new buffer on the stack.
;
;       5.  The word on the buffer is upcased by STR$UPCASE.
;
;       6.  The leading and trailing space characters are added.
;
; Memory Map (Memory allocated on stack):
;       -----------------------------------------(temp descriptor for input word)
;       |  class  |  dtype  |       length      |
;       -----------------------------------------
;       |           input word address          |
;       -----------------------------------------(descriptor for target_word buffer+1
;       |  class  |  dtype  |       length      | (R8)
;       -----------------------------------------
;       |       target_word buffer address      |
;       -----------------------------------------
;       |          TARGET_WORD BUFFER           | (R9)  (R5=R9+1)
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;                                               |(original stack pinter)
;
;--
SETUP_DICWORD:

;TRIM WORD, UPCASE, ADD LEADING AND TRAILING BLANK
        MOVL    SP,R0                           ;save original SP
        MOVL    R0,R11                          ;Save return address ptr
        MOVZWL  4(AP),R1                        ;length of word
        SUBL2   R1,SP                           ;allocate space for word
        MOVL    DIC_HEADER,R1
        SUBL2   DIC_INDSWD(R1),SP               ;insure long enough for guide word
        SUBL2   #2,SP                           ;more space for leading and trailing blanks
        BICB2   #^B0011,SP                      ;longword align stack pointer
        MOVL    SP,R9                           ;R9 = address of target_word buffer
        SUBL2   SP,R0                           ;R0 = total length of target_word buffer

        SUBL2   #8,SP                                   ;allocate space for descriptor
        MOVL    SP,R8                                   ;address of descriptor for target_word buffer+1
        SUBW3   #1,R0,          DSC$W_LENGTH(SP)        ;build descriptor for target_word
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(SP)         ;Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(SP)         ;Class
        ADDL3   #1,R9,          DSC$A_POINTER(SP)       ;address

        SUBL2   #8,SP                                   ;allocate space for descriptor
        MOVL    SP,R0                                   ;address of descriptor
        MOVW    4(AP),          DSC$W_LENGTH(SP)        ;length
        MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(SP)         ;Type
        MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(SP)         ;Class
        MOVL    8(AP),          DSC$A_POINTER(SP)       ;address

        PUSHAW  (R8)                            ;out-len (word, by reference)
        PUSHL   R0                              ;src-str (address of descriptor)
        PUSHL   R8                              ;dst-str (address of descriptor of target_word buffer+1)
        CALLS   #3,G^STR$TRIM                   ;copy in-word to target_word buffer and get trimmed length

2$:     PUSHL   R8                              ;src-str (address of descriptor for target_word buffer+1)
        PUSHL   R8                              ;dst-str (same place)
        CALLS   #2,G^STR$UPCASE                 ;upcase target_word

                                                ;ADD LEADING AND TRAILING SPACES
        MOVB    #SPACE,(R9)                     ;add leading space
        ADDW2   #2,(R8)                         ;adjust length to include leading and trailing spaces
        MOVZWL  (R8),R0                         ;convert length to longword
        MOVB    #SPACE,(R9)[R0]                 ;add trailing space

        JMP     @(R11)                          ;our equivalent of returning

;------------------------------------------------------------------------------

        .SUBTITLE BINSRCH_MAINDIC
;++
;
; Functional Description:
;       Performs the binary search on the index to the main lexical database
;
; Calling Sequence:
;       JSB  BINSRCH_MAINDIC
;
; Inputs:
;       R5  = Address of target guide word (at least of length DIC_INDSWD)
;
; Outputs:
;       R4 = offset in bytes from start of lexical database to page R6 (i.e. start search here)
;       R5 = length in bytes between page R6 and page R8 including page R8 (i.e. length to search starting at R4)
;       R6 = low boundary dictionary page number
;       R7 = offset of last guide word entry in dictionary index
;       R8 = high boundary dictionary page number
;       R9 = offset of guide word entry in dictionary index for page R8
;       R11 = DIC_HEADER
;       R10 = DIC_INDEX
;
; Side effects:
;       Alters registers R4 - R9
;       Registers R11, R10 must have address of DIC_HEADER, DIC_INDEX
;
; Outline:
;       1.  A binary search is performed on the guide word index to
;           the lexical database.
;       2.  A linear search is then performed to determine the
;           upper and lower dictionary lecixal database page boundaries
;           wherein the word must lie.  This step is necessary because
;           the format of the guide word index allows for multiple
;           occurances of the same guide word.  (The guide word, being
;           the first n characters of the first word on a lexical database
;           page, may be a very common word beginning and more than one
;           lexical database page may have the same guide word).
;
;--

;BINARY SEARCH LOOP.
; R11 = DIC_HEADER
; R10 = DIC_INDEX
; R9 = byte offset into index block (=R8*index_word_size)
; R8 = test page number offset
; R7 = high boundary dictionary page number offset
; R6 = low boundary dictionary page number offset
; R5 = address of target guide word (=target_word buffer+1)
BINSRCH_MAINDIC:
        MOVL    DIC_HEADER,R11
        MOVL    DIC_INDEX,R10
        CLRL    R6                                      ;prepare for binary search.  R6=low_boundary
        MOVL    DIC_INDLEN(R11),R7                      ;index_length/index_word_size=number_of_pages
        DIVL2   DIC_INDSWD(R11),R7                      ;R7=last page number (high_boundary)
        DECL    R7                                      ;R7=maximum page offset
51$:    ADDL3   R6,R7,R8                                ;new=(low+high)/2
        DIVL2   #2,R8
        CMPL    R6,R8                                   ;exitloop when guess=lowb
        BEQL    53$
        MULL3   DIC_INDSWD(R11),R8,R9                   ;R9=new*index-word-size
        CMPC3   DIC_INDSWD(R11),(R10)[R9],(R5)          ;DO THE COMPARE
        BEQL    53$                                     ;guess = target_index.  Switch to linear search.
        BLSS    52$                                     ;guess < target_index.
        MOVL    R8,R7                                   ;guess > target_index.
        BRB     51$
52$:    MOVL    R8,R6
        BRB     51$

; Now do linear search up and down to find true page boundaries
; within which the word must lie.
; R8 = starting page number
; Check for R8 < target_index.  Also test for R8 = beginning of dictionary  (the " A " test)
; Move toward A's until R8 < target index and set R6 as lower bound
; then move toward Z's until R8 > target_index and leave R8 at upper bound
53$:    MULL3   DIC_INDSWD(R11),R8,R9                   ;R9=new*index-word-size
        CMPC3   DIC_INDSWD(R11),(R10)[R9],(R5)          ;DO THE COMPARE
        BLSS    70$                                     ;found R8 < target_index
        TSTL    R8                                      ;test for R8 = 0
        BEQL    70$                                     ;R8 = 0  beginning of dictionary
        DECL    R8                                      ;go back a page
        BGTR    53$                                     ;loop while R8 > 0 and > target_index
        BRB     80$                                     ;exitloop if R8 index = 0 (or -1 if was 0 before DECL)

        ;Now look toward Z's for R8 > target_index
        ;R7 becomes offset of last guide word entry in dictionary
        ;R8 becomes high boundary page offset
70$:    MOVL    R8,R6                                   ;Set R6=lowb
        SUBL3   DIC_INDSWD(R11),DIC_INDLEN(R11),R7      ;R7=offset of last guide word entry in dictionary index
71$:    INCL    R8                                      ;Start searching towards Z's for guess > target_index
        MULL3   DIC_INDSWD(R11),R8,R9                   ;R9=new*index-word-size
        CMPL    R9,R7                                   ;check for R9 = last index entry (can't go any higher)
        BGEQ    80$                                     ;accept if last page in dictionary
        CMPC3   DIC_INDSWD(R11),(R10)[R9],(R5)          ;DO THE COMPARE
        BGTR    80$                                     ;found R8 < target_index
        BRB     71$

;Register usage
; R4 - becomes offset in bytes from start of lexical database to page R8
; R5 = becomes length in bytes between page R6 and page R8 including page R8 to search
; R6 = low boundary dictionary page number
; R8 = high boundary dictionary page number
80$:    SUBL3   R6,R8,R5                                ;R5 = number of pages
        INCL    R5                                      ;include R8 page
        MULL2   DIC_INDPLN(R11),R5                      ;R5 = number of bytes to search
        MULL3   DIC_INDPLN(R11),R6,R4                   ;R4 = offset in bytes from start of lexical database to page R6 (high boundary page)
        RSB
;------------------------------------------------------------------------------

        .SUBTITLE DIC_BROWSE
;++
;
; Functional Description:
;       Returns words from the dictionary for EDX to display in it's
;       dictionary lookup buffer.  This routine returns in OUSTSTR a
;       very long string of length ROWS x COLUMNS which is to be broken
;       up by EDX into pieces of length COLUMNS and displayed.
;
;       We either do a lookup best match to given word, a display next
;       page, or a display previous page, depending upon the value of R6.
;
; Calling Sequence:
;       CALLS   #0,DIC_BROWSE
;
; Argument inputs:
;                ....v....1....v....2....v....3....v....4....v....5....v....6...
;       INSTR - "yyyyyyyyzzzzzzzzwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww...
;               where yyyyyyyy is ascii for a hex longword indicating
;                   the number of rows in the DIC window to fill
;               and zzzzzzzz is ascii for a hex longword indicating
;                   the number of columns in the DIC window to fill
;                   and wwwwwwwwwwww... is the word to best match if
;                   we are not doing a prev_page or next_page display.
;
; Implicit inputs:
;       R6 - 1 display previous page
;            2 do best match word and display page
;            3 display next page
;
; Outputs:
;       OUTSTR - a string of length ROWS x COLUMNS (yyyyyyyy x zzzzzzzz)
;               containing all the best match words in alphabetical order
;               and arranged so that the first n characters is to be put
;               as row 1, the next n characters as row 2, etc...
;
;       For typical values of 10 ROWS and 80 COLUMNS the output is displayed
;       as 4 columns, each word a maximum length of 19 characters else
;       the word overflows into the next column.
;
;           Example final output display:
;
;               word1           word11          word21          word31
;               word2           word12          word22          word32
;               word3           word13          word23          word33
;               word4           word14          word24          word34
;               word5           word15          word25          word35
;               word6           word16          word26          word36
;               word7           word17          word27          word37
;               word8           word18          word28          word38
;               word9           word19          word29          word39
;               word10          word20          word30          word40
;
;       The above typical example has 4 word columns and 10 rows.
;       In the above example we'd try to make our best fit word word21.
;
; Implicit:
;       Pointers DICPTRA and DICPTRZ are set.  DICPTRZ points to the
;       space character following the last word in the lexical database
;       displayed on the screen.  DICPTRA points to the space character
;       preceeding the first word in the lexical database displayed.
;       These pointers are used if the user requests to see the next
;       or previous screen full of words in the dictionary.
;
; Outline:
;       1.  INSTR is parsed, yyyyyyyy, zzzzzzzz, are converted to integers.
;       2.  Depending on R6 we either call dic_browse_prev_page,
;           dic_browse_word, or dic_browse_next_page (which is just calling
;           dic_browse_fill passing it DICPTRZ)
;
; Memory Map:
;       The value of yyyyyyyy is left on the stack by the first call to
;       LIB$CVT_HTB.  The value of zzzzzzzz is left on the stack by the
;       second call to LIB$CVT_HTB.
;
;       MEMORY BUILT ON STACK:
;       -----------------------------------------(descriptor for word to best match)
;       |                   |  string length    | pushed on stack if R6 specifies DIC_BROWSE_WORD
;       -----------------------------------------
;       |            string address             |
;       -----------------------------------------
;       |            number of columns          | value of zzzzzzzz
;       -----------------------------------------
;       |            number of rows             | value of yyyyyyyy
;       -----------------------------------------(R8)
;                                               | <-- original SP
;
;--
        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
DICPTRA:  .BLKL  1
DICPTRZ:  .BLKL  1
WORD_COLUMN_LENGTH=20

        .MACRO  CHECK_STATUS,?DEST
        BLBS    R0,DEST
        PUSHL   R0      ;save R0 status
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL
        POPL    R0      ;restore R0 status
DEST:   .ENDM   CHECK_STATUS

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  DIC_BROWSE,^M<R2>
        MOVL    INSTR,R2                        ;address of instr descriptor
        MOVL    4(R2),R2                        ;address of instr string
        PUSHL   #0                              ;place for result
        PUSHL   SP                              ;address of place for result
        PUSHL   R2                              ;address of instr string
        PUSHL   #8                              ;length of hex longword
        CALLS   #3,G^LIB$CVT_HTB                ;convert ascii hex to binary
        CHECK_STATUS

        ADDL2   #8,R2                           ;address of instr+8 (for zzzzzzzz columns)
        PUSHL   #0                              ;place for result
        PUSHL   SP                              ;address of place for result
        PUSHL   R2                              ;address of instr string
        PUSHL   #8                              ;length of hex longword
        CALLS   #3,G^LIB$CVT_HTB                ;convert ascii hex to binary
        CHECK_STATUS                            ;SP now points to number of columns

        CASEB   R6, #1, #<3-1>                  ;Case wether to do lookup word, prev page, or next page
1$:     .WORD   10$-1$,-                        ; 1 = display prev page
                20$-1$,-                        ; 2 = Use wwwwwwwwwww... word in INSTR
                30$-1$                          ; 3 = display next page
        MOVL    #EDX__UNKNCODE,R0               ;Put error status in R0
;       JSB     ERR                             ;Signal error
        RET                                     ;and return with error status in R0

10$:    CALLS   #2,DIC_BROWSE_PREV_PAGE
        RET

20$:    ADDL3   #8,R2,-(SP)                     ;address of instr+16 (wwwwwwwwwwwwwww... word)
        MOVZWL  @INSTR,R0                       ;length of instr
        SUBL3   #16,R0,-(SP)                    ;length - 16 for xxxxxxxxyyyyyyyyzzzzzzzz
        CALLS   #4,DIC_BROWSE_WORD
        RET

30$:    PUSHL   DICPTRZ                         ;(dic_browse_next_page)
        CALLS   #3,DIC_BROWSE_FILL
        RET

;------------------------------------------------------------------------------

        .SUBTITLE DIC_BROWSE_PREV_PAGE
;++
;
; Functional Description:
;       Starting at DICPTRA, counts backwards an appropriate number of
;       words, and calls dic_browse_fill to do the rest given the starting
;       point.
;
; Argument inputs:
;         (AP) = 2 four arugments
;        4(AP) = nchars - number of characters across window display (width)
;        8(AP) = nrows  - number of rows in window display to fill (height)
;
; Outline:
;       1.  Count backwards N words.  In the above example these words will
;           occupy word31 - word40, the right most column.  N = nrows+1.
;
;       2.  Count backwards M more words.  In the above example these words
;           will occupy word1 - word30.  In general M is the number of words
;           necessary to fill all the previous columns we have.  M is
;           calculated as follows:
;               M = ( total_number_of_word_columns - 1 ) * nrows        ( if M < 0 then M = 0 )
;
;       where total_number_of_word_columns = INT( nchars / WORD_COLUMN_LENGTH )
;       where nchars = 4(AP)
;
;           If a word is longer than WORD_COLUMN_LENGTH-1, then we count it
;           as two words.  For example, in the above example if word3 were
;           longer than WORD_COLUMN_LENGTH-1, it would spill into the column
;           for word13.  Thus this word effectively takes up two word spaces.
;
;--

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  DIC_BROWSE_PREV_PAGE,^M<R3,R8>

; Step 1.  Count N words backwards not looking at word length
        MOVL    DICPTRA,R3
        MOVL    8(AP),R8                        ;R8 = nrows
        INCL    R8                              ;R8 = nrows+1 = N, number of words to count backwards
101$:   DECL    R3                              ;pointer into dictionary
        CMPL    R3,LEXDBA                       ;check for at beginning of dictionary
        BLEQ    121$                            ;at beginning of dictionary
103$:   CMPB    (R3),#SPACE                     ;check for space
        BEQL    110$                            ;found the space
        DECL    R3                              ;pointer
        BRB     103$                            ;loop
110$:   SOBGTR  R8,101$                         ;loop until we cover R8 number of words

; Step 2.
; Count M words backwards looking at word length
;     if word length >= word_column_length-1 then count as two words
;     nchars = 4(AP)
;     total_number_of_word_columns = INT( nchars / WORD_COLUMN_LENGTH )
;     M = ( total_number_of_word_columns - 1 ) * nrows
; R8 = M
        DIVL3   #WORD_COLUMN_LENGTH,4(AP),R8    ;R8 = total number of word columns
        DECL    R8                              ;R8 = ( total number of word columns - 1 )
        MULL2   8(AP),R8                        ;R8 = M = ( total number of word columns - 1 )*nrows
        INCL    R8                              ;R8 = M+1  (will be decremented by SOBGTR)
        BRB     120$                            ;enter loop
111$:   DECL    R3                              ;pointer into dictionary
        CMPL    R3,LEXDBA                       ;check for at beginning of dictionary
        BLEQ    121$                            ;at beginning of dictionary
        CLRL    R0                              ;counter of word length
113$:   CMPB    (R3),#SPACE                     ;check for space
        BEQL    120$                            ;found the space
        DECL    R3                              ;pointer
        INCL    R0                              ;word length
        CMPL    R0,#<WORD_COLUMN_LENGTH-1>      ;see if word is longer than 19 chars
        BNEQ    113$                            ;loop (if word < 19)
        DECL    R8                              ;count as word (word longer than 19)
        CLRL    R0                              ;reset word length
        BRB     113$                            ;loop
120$:   SOBGTR  R8,111$                         ;loop until we cover R8 number of words

121$:   PUSHL   8(AP)                           ;nrows
        PUSHL   4(AP)                           ;nchars
        INCL    R3                              ;point to first char of first word
        PUSHL   R3                              ;Pointer into dictionary
        CALLS   #3,DIC_BROWSE_FILL
        RET
;------------------------------------------------------------------------------

        .SUBTITLE DIC_BROWSE_WORD
;++
;
; Functional Description:
;       Accepts a word defined by 4(AP),8(AP).  Searches in the dictionary
;       for the best match to the given word.  Counts backwards an
;       appropriate number of words, and calls dic_browse_fill to
;       do the rest given the starting point.
;
; Argument inputs:
;         (AP) = 4 four arugments
;        4(AP) = length of string containing word to best match (low word, high word is ignored)
;        8(AP) = address of string containing word to best match
;       12(AP) = nchars - number of characters across window display (width)
;       16(AP) = nrows  - number of rows in window display to fill (height)
;
; Outline:
;       1.  The given word is copied over to local storage, a leading space
;           is added, and it is blank padded to DIC_INDSWD + 1 in length.
;
;       2.  The index to the dictionary main lexical database is searched
;           to determine the page range within which the word must lie if
;           it exists.
;
;       3.  Search range of dictionary pages for match to word.  If no match
;           found search again for word(1:length-1).  If no match found search
;           for word(1:length-2), and so on until we reach search for word(1:1),
;           which is a space character.  (If we can't find a single space
;           character somethings really wrong.)
;
;       4.  Find best match word.  Search forwards until
;           current_word > target_word.
;
;       4.  Count backwards N words.  In the example given in DIC_BROWSE,
;           these words will occupy word11 - word20, the second column.
;           N = nrows+1.
;
;       5.  Count backwards M more words.  In the above example these words
;           will occupy word1 - word10.  In general M is the number of words
;           necessary to fill all the previous columns we have.  M is
;           calculated as follows:
;               M = ( INT( total_number_of_word_columns / 2 ) - 1 ) * nrows     ( if M < 0 then M = 0 )
;
;       where total_number_of_word_columns = INT( nchars / WORD_COLUMN_LENGTH )
;       where nchars = 12(AP)
;
;           If a word is longer than WORD_COLUMN_LENGTH-1, then we count it
;           as two words.  For example, in the above example if word3 were
;           longer than WORD_COLUMN_LENGTH-1, it would spill into the column
;           for word13.  Thus this word effectively takes up two word spaces.
;
;
; MEMORY ALLOCATED ON STACK:
;
;       -----------------------------------------
;       |             OUTSTR BUFFER             | (R10)
;       |                   .                   |
;       |                   .                   |
;       |                   .                   |
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;
;--

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  DIC_BROWSE_WORD,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>
;;      MOVB    #DSC$K_DTYPE_T,<^x06>(AP)       ;debug print word to match
;;      MOVB    #DSC$K_CLASS_S,<^x07>(AP)       ;debug
;;      PUSHAQ  4(AP)                           ;debug
;;      CALLS   #1,G^LIB$PUT_OUTPUT             ;debug

; Steps 1,2.
        BSBW    SETUP_DICWORD                   ;copy word over to local storage with leading and trailing blank
        MOVL    R9,TARGET_WORD_A                ;save target_word address
        MOVZWL  (R8),TARGET_WORD_LEN            ;save target_word length
        ADDL3   #1,R9,R5                        ;address of target guide word
        BSBW    BINSRCH_MAINDIC                 ;do binary search of index

; Step 3.
;Find best match word
        MOVL    LEXDBA,R9                       ;lexical database address
        MOVL    TARGET_WORD_LEN,R7
51$:    MATCHC  R7,-
                @TARGET_WORD_A,-
                R5, (R9)[R4]                    ;Find match to target_string in dictionary pages
        BEQL    60$                             ;word found
        SOBGTR  R7, 51$                         ;search again for word minus one character from end

;Find best match of next character.
;At this point R3 points to one character after last character matched.
;Either a character of current word, a space character at end of word,
;or first character of next word (or null byte signifying end of dictionary)
;if complete match.  Back up one character, then search forwards for first
;space, marking end of current word and beginning of next word.
;Then search forward word by word until current dictionary word > target_word
60$:    MOVL    R3,R7
        DECL    R7                              ;back up one character
        BRB     62$                             ;jump into loop
61$:    INCL    R7                              ;so we find space before next word
        CMPB    (R7),#^x00                      ;check for end of dictionary
        BNEQ    62$                             ;branch if not end of dictionary
        DECL    R7                              ;move back to space character (space after last word in lexical database)
        BRB     100$                            ;and branch
62$:    LOCC    #SPACE, #80, (R7)               ;search for space char delimiting end of word.  R1 = address of found character
        MOVL    R1,R7                           ;address of space before next word
        CMPC3   TARGET_WORD_LEN, -              ;compare next word with target word
                (R7), -                         ;(destroys R0-R3)
                @TARGET_WORD_A                  ;
        BLSSU   61$                             ;Branch if current word in dictionary less than target word

; Step 4.
; At this point, R7 points to space following word we seek.
; Count N words backwards not looking at word length
; N = nrows+1
100$:   MOVL    16(AP),R8                       ;R8 = nrows
        INCL    R8                              ;R8 = nrows+1 = N, the number of words to count backwards
101$:   DECL    R7                              ;pointer into dictionary
        CMPL    R7,LEXDBA                       ;check for at beginning of dictionary
        BLEQ    121$                            ;at beginning of dictionary
103$:   CMPB    (R7),#SPACE                     ;check for space
        BEQL    110$                            ;found the space
        DECL    R7                              ;pointer
        BRB     103$                            ;loop
110$:   SOBGTR  R8,101$                         ;loop until we cover R8 number of words

; Step 5.
; Count M words backwards looking at word length
;     if word length >= word_column_length-1 then count as two words
;     nchars = 12(AP)
;     total_number_of_word_columns = INT( nchars / WORD_COLUMN_LENGTH )
;     M = ( INT( total_number_of_word_columns / 2 ) - 1 ) * nrows
; R8 = M
        DIVL3   #WORD_COLUMN_LENGTH,12(AP),R8   ;R8 = total number of word columns
        DIVL2   #2,R8                           ;R8 = INT( total number of word columns / 2 )
        DECL    R8                              ;R8 = INT( total number of word columns / 2 ) -1
        MULL2   16(AP),R8                       ;R8 = M
        INCL    R8                              ;R8 = M+1  (will be decremented by SOBGTR)
        BRB     120$                            ;enter loop
111$:   DECL    R7                              ;pointer into dictionary
        CMPL    R7,LEXDBA                       ;check for at beginning of dictionary
        BLEQ    121$                            ;at beginning of dictionary
        CLRL    R0                              ;counter of word length
113$:   CMPB    (R7),#SPACE                     ;check for space
        BEQL    120$                            ;found the space
        DECL    R7                              ;pointer
        INCL    R0                              ;word length
        CMPL    R0,#<WORD_COLUMN_LENGTH-1>      ;see if word is longer than 19 chars
        BNEQ    113$                            ;loop (if word < 19)
        DECL    R8                              ;count as word (word longer than 19)
        CLRL    R0                              ;reset word length
        BRB     113$                            ;loop
120$:   SOBGTR  R8,111$                         ;loop until we cover R8 number of words

121$:   PUSHL   16(AP)                          ;nrows
        PUSHL   12(AP)                          ;nchars
        INCL    R7                              ;point to first char of word
        PUSHL   R7                              ;Pointer into dictionary
        CALLS   #3,DIC_BROWSE_FILL
        RET
;------------------------------------------------------------------------------

        .SUBTITLE DIC_BROWSE_FILL
;++
;
; Functional Description:
;       Fills OUTSTR with words from dictionary starting at 4(AP) address
;       into lexical database.
;
; Argument inputs:
;         (AP) = 3 number of arugments
;        4(AP) = address in dictionary lexical database to start at.
;        8(AP) = nchars - number of characters across window display (width)
;       12(AP) = nrows  - number of rows in window display to fill (height)
;
; Outline:
;           Create temporary buffer for OUTSTR and fill it in.  We fill in
;           the words starting with the first (left most) column, working our
;           way down that column to the bottom.  Then proceeding with the
;           next column until all the columns are filled.  For each word
;           we calculate the offset into OUTSTR as follows:
;
;       offset = row_number * nchars_per_row +
;                       word_column_number * word_column_length
;
;           where row_number goes from 0 to nrows-1 with nrows = 16(AP)
;           and word_column_number goes from 0 to number_of_word_columns-1
;           with number_of_word_columns = INT( nchars / WORD_COLUMN_LENGTH )
;
;           If not working on first (left most) column then we check
;           to see if the word in the previous column is overflowing into
;           the cell we were going to place our current word.  If so we
;           move down the column to the next cell and try again.
;
;           If working on the last (right most) column then we check to
;           see if the word we are inserting is longer than will fit on
;           the screen.  If so we truncate it and replace the last character
;           with a "."
;
; MEMORY ALLOCATED ON STACK:
;       -----------------------------------------
;       |             OUTSTR BUFFER             | (R10)
;       |                   .                   |
;       |                   .                   |
;       |                   .                   |
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;
;--

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  DIC_BROWSE_FILL,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>

; Registar usage:
; R1 = points to space char after word in dictionary.  Set by LOCC
; R2 = offset into OUTSTR
; R6 = length of current word
; R7 = row_number working on (0 to nrow-1)
; R8 = word_column_number working on (0 to ncol-1)
; R9 = pointer into dictionary at start of next word from 4(AP)
; R10 points to start of our OUTSTR buffer
; R11 points to end of current word

        MOVL    4(AP),DICPTRA                   ;set DICPTRA
        MOVL    4(AP),R9                        ;R9 = address of first char of first word
        MULL3   8(AP),12(AP),R0                 ;calculate length of OUTSTR (rows x columns)
        SUBL2   R0,SP                           ;allocate memory on stack to bulid OUTSTR
        SUBL2   #80,SP                          ;allocate 80 so min is at least 80 (necessary for dump_dictionary)
        BICB2   #^B0011,SP                      ;longword align stack pointer
        MOVL    SP,R10                          ;save starting address of string
        MOVC5   #0,(SP),#SPACE,R0,(R10)         ;blank fill our OUTSTR buffer

;LOOP OVER ALL COLUMNS
;  LOOP OVER ALL ROWS
; R8 = word column number
; R7 = row number
        CLRL    R8                              ;start at first column
125$:   CLRL    R7                              ;Start at first row of new column
130$:   CMPB    (R9),#00                        ;check for end of dictionary
        BEQL    200$                            ;branch if at end of dictionary
        LOCC    #SPACE, #80, (R9)               ;search for space char delimiting end of word.  R1 = address of found character
        MOVL    R1,R11                          ;Save R1 for later
        SUBL3   R9,R1,R6                        ;length of word
132$:   MULL3   R7,8(AP),R2                     ;OFFSET R2=row_length*row_number
        MULL3   R8,#WORD_COLUMN_LENGTH,R3       ;R3=word_column_number*word_column_length
        ADDL2   R3,R2                           ;R2 = offset into OUTSTR
        TSTL    R8                              ;test word_column_number
        BEQL    140$                            ;branch if this is first column
        SUBL3   #1,R2,R0                        ;Test previous character for blank
        CMPB    (R10)[R0],#SPACE                ;
        BEQL    135$                            ;branch if OK, was a space
        AOBLSS  12(AP),R7,132$                  ;loop over nrows
        CLRL    R7
        DIVL3   #WORD_COLUMN_LENGTH,8(AP),R0    ;R0 = total number of word columns
        AOBLSS  R0,R8,132$                      ;loop over ncols
        BRB     200$

135$:   DIVL3   #WORD_COLUMN_LENGTH,8(AP),R0    ;R0 = number of word_columns we can fit across screen
        DECL    R0                              ;(word_columns count from 0 to 3)
        CMPL    R0,R8                           ;is word_column = last_word_column?
        BNEQ    140$                            ;branch if not

        CMPL    R6,#<WORD_COLUMN_LENGTH>                ;see if word longer than screen length left
        BLEQ    140$                                    ;continue if not
        PUSHL   R2
        MOVC3   #<WORD_COLUMN_LENGTH-1>,(R9),(R10)[R2]  ;insert word into OUTSTR
        POPL    R2
        ADDL2   #<WORD_COLUMN_LENGTH-1>,R2
        MOVB    #^A".",(R10)[R2]
        BRB     142$

140$:   MOVC3   R6,(R9),(R10)[R2]               ;insert word into OUTSTR

142$:   ADDL3   #1,R11,R9                       ;R9 points to start of next word
145$:   AOBLSS  12(AP),R7,130$                  ;loop over nrows
        DIVL3   #WORD_COLUMN_LENGTH,8(AP),R0    ;R0 = total number of word columns
        AOBLSS  R0,R8,125$                      ;loop over ncols

;We drop out here when our OUTSTR buffer is full
;Set OUTSTR and return
200$:   MOVL    R9,DICPTRZ                      ;set DICPTRZ
        PUSHL   R10                             ;address of OUTSTR buffer
        MULL3   8(AP),12(AP),-(SP)              ;length of OUTSTR buffer (rows x columns)
        PUSHL   #1                              ;return status
        CALLS   #3,FMTOUTSTR
        RET
;------------------------------------------------------------------------------

        .SUBTITLE SPELL_GUESS
;++
;
; Functional Description:
;       Guesses the spelling of misspelled word stored in DIC_LWA,DIC_LWL.
;       Algorythm taken from the very popular Vassar Spelling Checker.
;       With credit to Vassar where credit is due.
;
; Calling Sequence:
;       CALLS   #0,SPELL_GUESS
;
; Argument inputs:
;       DIC_LWA - Address of misspelled word
;       DIC_LWL - Length of misspelled word
;
; Outputs:
;       here's another word to try
;       retcode=LIB$_NORMAL, outline="guessed word"
;       ask user if guessed word is what he ment
;     or
;       no more guesses, retcode = LIB$_NOTFOU
;
; Outline:
;       1.  Reversals   (test for transposed characters)
;       2.  vowels      (test for wrong vowel used)
;       3.  minus chars (test for extra character in word)
;       4.  plus chars  (test for character missing from word)
;       5.  consonants  (test for wrong character used)
;       6.  give up     (give up)
;
; Memory Map (Memory allocated on stack):
;       -----------------------------------------
;       |           GUESS WORD BUFFER           | (R9)
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;                                               |(original stack pinter)
;
;--
        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
GMODE:     .BLKB  1     ;guess mode    (1=reversals,2=vowels,3=minus,4=plus,5=consonants,6=giveup)
GSUBMODE:  .BLKB  1     ;guess submode (letter we're currently replacing with)
GCOL:      .BLKB  1     ;guess column  (character # in word working on)

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  SPELL_GUESS,^M<R2,R9,R10>
        SUBL2   DIC_LWL,SP                      ;allocate memory for guess word
        DECL    SP                              ;allocate more memory for guess_pluss
        BICB2   #^B0011,SP                      ;longword align stack pointer
        MOVL    SP,R9                           ;store address of guess word buffer

GUSINI: CASEB   GMODE, #1, #<6-1>               ;Case entry point to jump to
1$:     .WORD   GUSREV-1$,-                     ; 1 = guess reversals
                GUSVOL-1$,-                     ; 2 = guess vowels
                GUSMIN-1$,-                     ; 3 = guess minus
                GUSPLS-1$,-                     ; 4 = guess plus
                GUSCON-1$,-                     ; 5 = guess consonants
                GIVEUP-1$                       ; 6 = give up
        MOVL    #EDX__UNKNCODE,R0               ;Put error status in R0
;       JSB     ERR                             ;Signal error
        RET                                     ;and return with error status in R0

GIVEUP: MOVB    #1,GMODE                        ;reset GMODE
        MOVB    #1,GCOL                         ;reset GCOL
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        PUSHL   #SS$_ENDOFFILE
        CALLS   #1,FMTOUTSTR
        RET

CKVOWEL:        ;test R0 for vowel char.  return R0=1 if vowel, R0=0 if not vowel.
        CMPB    R0, #^A"A"              ;test for vowel "A"
        BEQL    10$
        CMPB    R0, #^A"E"              ;test for vowel "E"
        BEQL    10$
        CMPB    R0, #^A"I"              ;test for vowel "I"
        BEQL    10$
        CMPB    R0, #^A"O"              ;test for vowel "O"
        BEQL    10$
        CMPB    R0, #^A"U"              ;test for vowel "U"
        BEQL    10$
        CLRL    R0
        RSB
10$:    MOVZBL  #1,R0
11$:    RSB

;   Guess reversals.  Copy word and transpose x with x-1 till x = DIC_LWL
GUSREV: CMPB    GCOL,DIC_LWL                    ;test for end of word
        BLSS    2$                              ;branch if not
        INCB    GMODE                           ;go to next guess mode
        MOVB    #1,GCOL                         ;reset GCOL
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRW     GUSINI                          ;go do next mode

2$:     MOVC3   DIC_LWL,@DIC_LWA,(R9)           ;copy over word
        MOVZBL  GCOL,R10                        ;swap chars
        DECL    R10                             ;convert index to offset
        MOVZBL  GCOL,R1
        MOVB    (R9)[R10],R2
        MOVB    (R9)[R1],(R9)[R10]
        MOVB    R2,(R9)[R1]
        PUSHL   R9                              ;address of guess word
        PUSHL   DIC_LWL                         ;word length
        CALLS   #2,DIC_LOOKUP_WORD              ;See if word exists
        INCB    GCOL                            ;move to next character
        BLBC    R0,GUSREV                       ;loop if word not found
        PUSHL   R9                              ;address of output string
        PUSHL   DIC_LWL                         ;length of output string
        PUSHL   R0                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;return with string containing a correctly spelled word, status

;Guess vowel replacements.  for each {a,e,i,o,u} replace with {a,e,i,o,u}
;GSUBMODE goes from 1-5 as letter replacement goes a,e,i,o,u
GUSVOL: CMPB    GCOL,DIC_LWL                    ;test for beyond end of word
        BLEQ    2$                              ;branch if not
        INCB    GMODE                           ;go to next guess mode
        MOVB    #1,GCOL                         ;reset GCOL
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRW     GUSINI                          ;go do next mode

2$:     MOVC3   DIC_LWL,@DIC_LWA,(R9)           ;copy over word
        MOVZBL  GCOL,R10
        DECL    R10                             ;convert index to offset
        MOVZBL  (R9)[R10],R0
        BSBW    CKVOWEL                         ;test if R0 is vowel char
        BLBS    R0,10$                          ;branch if vowel
        INCB    GCOL                            ;this character is not a vowel
        BRW     GUSVOL                          ;loop and test next character

10$:    CASEB   GSUBMODE, #1, #<5-1>            ;Case entry point to jump to
11$:    .WORD   21$-11$,-                       ; 1 = replace with an "A"
                22$-11$,-                       ; 2 = replace with an "E"
                23$-11$,-                       ; 3 = replace with an "I"
                24$-11$,-                       ; 4 = replace with an "O"
                25$-11$                         ; 5 = replace with an "U"
        MOVL    #EDX__GUSINTERR2,R0             ;Put error status in R0
;       JSB     ERR                             ;Signal error
        RET                                     ;and return with error status in R0

21$:    MOVB    #^A"A", (R9)[R10]
        BRB     30$
22$:    MOVB    #^A"E", (R9)[R10]
        BRB     30$
23$:    MOVB    #^A"I", (R9)[R10]
        BRB     30$
24$:    MOVB    #^A"O", (R9)[R10]
        BRB     30$
25$:    MOVB    #^A"U", (R9)[R10]
30$:    MOVL    DIC_LWA,R1
        CMPB    (R9)[R10],(R1)[R10]             ;check that we didn't replace an "A" with an "A", etc.
        BNEQ    32$                             ;continue if word is different
        INCB    GSUBMODE                        ;guess next vowel
        CMPB    GSUBMODE, #5                    ;test for all vowels tried
        BLEQ    31$                             ;branch if not all vowels tried
        INCB    GCOL                            ;all vowels tried.  move to next column
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
31$:    BRW     GUSVOL
32$:    PUSHL   R9                              ;address of guess word
        PUSHL   DIC_LWL                         ;word length
        CALLS   #2,DIC_LOOKUP_WORD              ;See if word exists
        INCB    GSUBMODE                        ;set to guess next vowel
        CMPB    GSUBMODE, #5                    ; test for all vowels tried
        BLEQ    38$                             ; branch if not all vowels tried
        INCB    GCOL                            ; all vowels tried.  move to next column
        MOVB    #1,GSUBMODE                     ; reset GSUBMODE
38$:    BLBS    R0,40$                          ;Test status from DIC_LOOKUP_WORD.  Branch if word exists.
        BRW     GUSVOL                          ;else loop and try again

40$:    PUSHL   R9                              ;address of output string
        PUSHL   DIC_LWL                         ;length of output string
        PUSHL   R0                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;return with string containing a correctly spelled word, status

;Guess minus.  Test for extra character.  Try eliding one character at a time
GUSMIN: CMPB    GCOL,DIC_LWL                    ;test for beyond end of word
        BLEQ    2$                              ;branch if not
        INCB    GMODE                           ;go to next guess mode
        MOVB    #1,GCOL                         ;reset GCOL
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRW     GUSINI                          ;go do next mode

2$:     MOVC3   DIC_LWL,@DIC_LWA,(R9)           ;copy over word
        MOVZBL  GCOL,R10                        ;remove GCOL'th character from word
        DECL    R10                             ;convert index to offset
        MOVZBL  GCOL,R1
        CMPB    (R9)[R1],(R9)[R10]              ;if prev char = current char then
        BNEQ    8$                              ; the result would be the same as last time.
        INCB    GCOL                            ; so skip it
        BRW     GUSMIN
8$:     SUBL3   R1,DIC_LWL,R2
        MOVC3   R2,(R9)[R1],(R9)[R10]           ;(shift GCOL'th+1 to end of word left one)

        PUSHL   R9                              ;address of guess word
        SUBL3   #1,DIC_LWL,-(SP)                ;length of guess word
        CALLS   #2,DIC_LOOKUP_WORD              ;See if word exists
        INCB    GCOL                            ;move to next character
        BLBS    R0,40$                          ;branch if word exists
        BRW     GUSMIN                          ;else loop and try again

40$:    PUSHL   R9                              ;address of output string
        SUBL3   #1,DIC_LWL,-(SP)                ;length of output string
        PUSHL   R0                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;return with string containing a correctly spelled word, status

;Guess plus.  Test if a letter is missing from word.  Add one letter anywhere in word
;GSUBMODE goes from 1-26 as letter replacement goes from a-z
GUSPLS: CMPB    GSUBMODE, #26                   ;test for GSUBMODE=26 (all letters of alphabet)
        BLEQ    2$                              ;branch if not done "Z" yet
        CMPB    GCOL,DIC_LWL                    ;test for beyond end of word
        BGTR    1$                              ;branch if GCOL greater than word_length+1
        INCB    GCOL                            ;move to next character in word
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRB     2$                              ;and continue
1$:     INCB    GMODE                           ;go to next guess mode
        MOVB    #1,GCOL                         ;reset GCOL
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRW     GUSINI                          ;go do next mode

2$:     MOVC3   DIC_LWL,@DIC_LWA,(R9)           ;copy over word (movc3 destroys R0-R5)
        MOVZBL  GCOL,R10                        ;add character before GCOL'th character
        DECL    R10                             ;convert index to offset
        MOVZBL  GCOL,R1
        SUBL3   R10,DIC_LWL,R2                  ;length from GCOL'th to end
        MOVC3   R2,(R9)[R10],(R9)[R1]           ;(shift GCOL'th to end of word right one)
        ADDB3   #^A"A", GSUBMODE, (R9)[R10]     ;convert GSUBMODE={1-26} to ASCII {A-Z} (which is {65-90}
        DECB    (R9)[R10]                       ; by adding 64 to GSUBMODE

        PUSHL   R9                              ;address of guess word
        ADDL3   #1,DIC_LWL,-(SP)                ;length of guess word
        CALLS   #2,DIC_LOOKUP_WORD              ;See if word exists
        INCB    GSUBMODE                        ;try next character in alphabet
        BLBS    R0,40$                          ;branch if word exists
        BRW     GUSPLS                          ;else loop and try again

40$:    PUSHL   R9                              ;address of output string
        ADDL3   #1,DIC_LWL,-(SP)                ;length of output string
        PUSHL   R0                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;return with string containing a correctly spelled word, status

;guess consonants.  Test for any one character wrong.
;Replace each character with every other character of the alphabet
;GSUBMODE goes from 1-26 as letter replacement goes from a-z
GUSCON: CMPB    GSUBMODE, #26                   ;test for GSUBMODE=26 (all letters of alphabet)
        BLEQ    2$                              ;branch if not done "Z" yet
        CMPB    GCOL,DIC_LWL                    ;test for beyond end of word
        BGEQ    1$                              ;branch if GCOL greater than word_length+1
        INCB    GCOL                            ;move to next character in word
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRB     2$                              ;and continue
1$:     INCB    GMODE                           ;go to next guess mode
        MOVB    #1,GCOL                         ;reset GCOL
        MOVB    #1,GSUBMODE                     ;reset GSUBMODE
        BRW     GUSINI                          ;go do next mode

2$:     MOVC3   DIC_LWL,@DIC_LWA,(R9)           ;copy over word
        MOVZBL  GCOL,R10
        DECL    R10                             ;convert index to offset
        ADDB3   #^A"A", GSUBMODE, R1            ;convert GSUBMODE={1-26} to ASCII {A-Z} (which is {65-90}
        DECB    R1                              ; by adding 64 to GSUBMODE
        MOVZBL  (R9)[R10],R0                    ;original character
        CMPB    R0,R1                           ;Skip if replacing original
        BEQL    19$                             ; with same char
        BSBW    CKVOWEL                         ;test if original char a vowel
        BLBC    R0,31$                          ;branch if not a vowel
        MOVZBL  R1,R0                           ;test replacement char for vowel
        BSBW    CKVOWEL                         ;test if original char a vowel
        BLBC    R0,31$                          ;branch if replacement not a vowel
19$:    INCB    GSUBMODE                        ;Both original and replacement were vowels
        BRW     GUSCON                          ; We skip this since Guess Vowels already did it

31$:    MOVB    R1,(R9)[R10]                    ;replace char
        PUSHL   R9                              ;address of guess word
        PUSHL   DIC_LWL                         ;word length
        CALLS   #2,DIC_LOOKUP_WORD              ;See if word exists
        INCB    GSUBMODE                        ;move to next character
        BLBS    R0,40$                          ;branch if word exists
        BRW     GUSCON                          ;else loop and try again

40$:    PUSHL   R9                              ;address of output string
        PUSHL   DIC_LWL                         ;length of output string
        PUSHL   R0                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;return with string containing a correctly spelled word, status
;------------------------------------------------------------------------------

        .SUBTITLE ACCEPTED_WORD_LIST
;++
;       SPELL_ACCEPT_WORD
;
; Functional Description:
;       Constructs a balanced binary tree of words which the user has instructed
;       us to accept as properly spelled.  The VMS library routine
;       LIB$INSERT_TREE is used to build the tree.  DIC_LOOKUP_WORD uses
;       the VMS library routine LIB$LOOKUP_TREE to search this tree for a
;       match before declaring a word misspelled.
;
;       The routines ALLOCATE_NODE and COMPARE_NODE are called by LIB$INSET_TREE
;       and LIB$LOOKUP_TREE.  ALLOCATE_NODE allocates memory and inserts
;       the word to accept in the allocated memory.  COMPARE_NODE
;       alphabetically compares the word stored in a given memory block
;       with a given word to determine which comes first.
;
; Calling Sequence:
;       CALLS #0,SPELL_ACCEPT_WORD
;
; Inputs:
;       DIC_LWA - Address of word to accept.  Set by DIC_LOOKUP_WORD.
;       DIC_LWL - Length of word to accept.  Set by DIC_LOOKUP_WORD.
;
;--
        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR
BTFLAGS:    .LONG  0    ;no duplicates flag

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
NEWNODE:    .LONG  0
TREE_HEAD:  .LONG  0

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  SPELL_ACCEPT_WORD,^M<>
        JSB     INITVMZONE
        PUSHAL  NEWNODE                 ;new node return address
        PUSHAB  ALLOCATE_NODE           ;allocate node routine
        PUSHAB  COMPARE_NODE            ;compare node routine
        PUSHAL  BTFLAGS                 ;no duplicates
        PUSHAQ  DIC_LWL                 ;DIC_LWL + DIC_LWA, our word to add
        PUSHAL  TREE_HEAD               ;tree head for the binary tree
        CALLS   #6,G^LIB$INSERT_TREE    ;add the word
        PUSHL   R0
        CALLS   #1,FMTOUTSTR
        RET

;; For debugging purposes:
;;      .ENTRY  TRAVERSE_TREE,^M<>
;;      PUSHAB  PRINT_NODE
;;      PUSHAL  TREE_HEAD
;;      CALLS   #2,G^LIB$TRAVERSE_TREE
;;      RET
;;      .ENTRY  PRINT_NODE,^M<>
;;      SUBL2   #8,SP                                   ;allocate space for descriptor
;;      MOVL    4(AP),R0
;;      MOVW    10(R0),         DSC$W_LENGTH(SP)        ;length
;;      MOVB    #DSC$K_DTYPE_T, DSC$B_DTYPE(SP)         ;Type
;;      MOVB    #DSC$K_CLASS_S, DSC$B_CLASS(SP)         ;Class
;;      MOVAL   12(R0),         DSC$A_POINTER(SP)       ;address
;;      PUSHL   SP
;;      CALLS   #1,G^LIB$PUT_OUTPUT
;;      RET

;++
;       ALLOCATE_NODE
;
; Functional Description:
;       Allocates memory for a new node being added in a balanced binary
;       tree by LIB$INSERT_TREE.  (alloc-rtn)
;
; Calling Sequence:
;       Called by LIB$INSERT_TREE
;
; Argument inputs:
;     (AP) - number of arguments (#3 by value)
;    4(AP) - sym-str (input).  Address of string descriptor of string to
;            insert in this node.  (Descriptor class and type fields not used).
;    8(AP) - ret-adr (output).  Address to place starting address of block of
;            memory allocated and filled in.
;   12(AP) - [user-data] (not used)
;
; Outputs:
;       R0 = SS$_NORMAL
;
; Outline:
;       1.  Memory is allocated and filled in as shown below:
;
; Memory Map:
;       -----------------------------------------( address of node placed in ret-adr, @8(AP) )
;       |              left link                |
;       -----------------------------------------
;       |              right link               |
;       -----------------------------------------
;       |   STRING LENGTH   |      balance      |
;       -----------------------------------------
;       |                STRING                 | 12(R10)
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;
; The node header, consisting of the first 10 bytes of the node containing
; the left link, right link, and balance, is reserved for use by LIB$INSERT_TREE
; We fill in the string length, and the string itself, and we allocate enough
; memory to hold it all (12 bytes + length of string).
;
;Registar usage:
; R10 = address of node memory block
; R9  = address of string descriptor
;--

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  ALLOCATE_NODE,^M<R2,R3,R4,R5,R9,R10>
        CLRL    -(SP)                           ;reserve a place to put length of memory to allocate
        ADDW3   #12,@4(AP),(SP)                 ;calculate length of memory = 12 for header + length of string (from descriptor)
        MOVL    SP,R0                           ;R0 = address containing length of memory to allocate
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHL   8(AP)                           ;Address to place starting address of allocated memory
        PUSHL   R0                              ;length of memory to allocate (by reference)
        CALLS   #2,G^LIB$GET_VM                 ;get memory for new node
        CLRL    (SP)+                           ;fix stack pointer
        BLBS    R0,2$                           ;branch on success
        PUSHL   R0                              ;else we're in trouble...
        PUSHL   R0
        CALLS   #1,EDX_SIGNAL
        CALLS   #1,FMTOUTSTR
        RET
2$:     MOVL    4(AP),R9                        ;address of string descriptor
        MOVL    @8(AP),R10                      ;address of memory block
        MOVW    (R9),10(R10)                    ;fill in length of string
        MOVC3   (R9),@4(R9),12(R10)             ;fill in string
        MOVZBL  #1,R0                           ;set success status
        RET                                     ;and return
;++
;       COMPARE_NODE
;
; Functional Description:
;       Compares string to string contained in a given node.  Returns
;       +1,0,-1 for string GTR,EQL,LSS than given node.
;
; Calling Sequence:
;       Called by LIB$INSERT_TREE
;
; Argument inputs:
;     (AP) - number of arguments (#3 by value)
;    4(AP) - sym-str (input).  Address of string descriptor of string to
;            compare with given node.  (Descriptor class and type fields not used).
;    8(AP) - treehead (input).  Address of node to compare with string.
;            The format of a node is shown in the memory map below.
;   12(AP) - [user-data] (not used)
;
; Outputs:
;       R0 = +1 if string > node
;             0 if string = node
;            -1 if string < node
;
; Memory Map:
;       ----------------------------------------- (R10)
;       |              left link                |
;       -----------------------------------------
;       |              right link               |
;       -----------------------------------------
;       |   STRING LENGTH   |      balance      |
;       -----------------------------------------
;       |                STRING                 | 12(R10)
;       |                   .                   |
;       |                   .                   |
;       -----------------------------------------
;
;Registar usage:
; R10 = address of node memory block
; R9  = address of string descriptor
;--

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  COMPARE_NODE,^M<R2,R3,R9,R10>
        MOVL    4(AP),R9                                ;address of string descriptor
        MOVL    8(AP),R10                               ;address of node memory block
        CMPC5   (R9),@4(R9),#SPACE,10(R10),12(R10)      ;do the compare
        BLSS    1$                                      ;string < node
        BEQL    2$                                      ;string = node
        MOVZBL  #1,R0                                   ;string > node
        RET
1$:     MNEGL   #1,R0                                   ;string < node
        RET
2$:     CLRL    R0                                      ;string = node
        RET
;------------------------------------------------------------------------------

        .SUBTITLE ADD_PERSDIC
;++
;       ADD_PERSDIC
;
; Functional Description:
;       Adds the current unrecognised word to the user's personal dictionary.
;
; Calling Sequence:
;       CALLS #0,SPELL_ACCEPT_WORD
;
; Inputs:
;       DIC_LWA - Address of word to accept.  Set by DIC_LOOKUP_WORD.
;       DIC_LWL - Length of word to accept.  Set by DIC_LOOKUP_WORD.
;
; Outline:
;       1.  Open user's personal dictionary.  If file does not exist,
;           it is created.
;       2.  Add new word to end of file.
;       3.  Close file.
;
; Memory Map (Memory allocated on stack):
;       -----------------------------------------
;       |          buffer for filename          | (R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------
;--

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
ADDPDICFAB:                                             ; Personal dictionary
        $FAB    FNM = <EDXPERSDIC>, -
                DNM = <SYS$LOGIN:EDXPERSDIC.DAT>, -
                NAM = ADDPDICNAM, -
                FAC = <PUT>, -
                SHR = <GET>, -
                FOP = CIF                               ;Create if nonexistent
ADDPDICRAB:
        $RAB    FAB = ADDPDICFAB, -                     ; Pointer to FAB
                ROP = EOF                               ; Position to end of file for append operation
ADDPDICNAM:
        $NAM    RSS = NAM$C_MAXRSS
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  ADD_PERSDIC,^M<R9>

        SUBL2   #NAM$C_MAXRSS,SP                ;Allocate buffer for filename
        BICB2   #^B0011,SP                      ;longword align stack pointer
        MOVL    SP,R9                           ;store buffer address in R9
        MOVL    R9,ADDPDICNAM+NAM$L_RSA         ;Store buffer address in NAM block

;OPEN THE USER'S PERSONAL DICTIONARY FILE
        $CREATE FAB=ADDPDICFAB                  ;Open user's personal dictionary file
        BLBC    R0,20$                          ;A new file is created only if
        CMPL    R0,#RMS$_CREATED                ;one does not already exist.
        BNEQ    10$
        PUSHL   R9                              ;filename address
        MOVZBL  ADDPDICNAM+NAM$B_RSL,-(SP)      ;filename size
        PUSHL   #2                              ;2 FAO args
        PUSHL   #EDX__CREPERSDIC                ;Created new personal dictionary
        CALLS   #4,EDX_SIGNAL                   ;signal message 'Created new personal dictionary'

10$:    $CONNECT RAB=ADDPDICRAB                 ;Connect to input
        BLBS    R0,30$                          ;branch if OK

20$:    ;error processing
        PUSHL   #0                              ;0 FAO args
        PUSHL   R0                              ;RMS error
        PUSHL   R9                              ;filename address
        MOVZBL  ADDPDICNAM+NAM$B_RSL,-(SP)      ;filename size
        PUSHL   #2                              ;2 FAO args
        PUSHL   #EDX__PERSDICERR                ;error opening personal dictionary
        MOVL    R0,R9                           ;Save R0 error
        CALLS   #6,EDX_SIGNAL                   ;signal message
        MOVL    R9,R0                           ;Restore R0 error
        RET                                     ;and return with R0 error

30$:    MOVL    DIC_LWA,ADDPDICRAB+RAB$L_RBF
        MOVW    DIC_LWL,ADDPDICRAB+RAB$W_RSZ
        $PUT    RAB=ADDPDICRAB                  ;Add word to user's personal dictionary
        BLBS    R0,40$                          ;Branch if good
        MOVL    ADDPDICRAB,R1
        PUSHL   RAB$L_STV(R1)                   ;push STV and STS of RAB
        PUSHL   RAB$L_STS(R1)
        CALLS   #2,EDX_SIGNAL                   ;Signal error
        BRB     100$

40$:    PUSHL   R9                              ;filename address
        MOVZBL  ADDPDICNAM+NAM$B_RSL,-(SP)      ;filename size
        PUSHL   DIC_LWA                         ;word address
        PUSHL   DIC_LWL                         ;word size
        PUSHL   #4                              ;4 FAO args
        PUSHL   #EDX__WORDADD                   ;Added word to personal dictionary
        CALLS   #6,EDX_SIGNAL                   ;signal message

100$:   $CLOSE  FAB=ADDPDICFAB                  ;close file
        RET
;------------------------------------------------------------------------------

        .SUBTITLE DUMP_COMMONWORDS
;++
;       DUMP_COMMONWORDS
;
; Functional Description:
;       Returns as a single string the list of common words as stored in
;       the EDX dictionary database file.
;
; Calling Sequence:
;       CALLS #0,DUMP_COMMONWORDS
;
; Outputs:
;       OUTSTR - String of common words
;
;--
        .PSECT  CODE    NOWRT,EXE,PIC,LONG,SHR
        .ENTRY  DUMP_COMMONWORDS,^M<R11>

        MOVL    DIC_HEADER,R11
        PUSHL   DIC_CMNWDS                      ;address of output string
        PUSHL   DIC_CWDLEN(R11)                 ;length of output string
        PUSHL   #1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;return with string containing a correctly spelled word, status

;------------------------------------------------------------------------------
;==============================================================================
;       LOCK FILES
;==============================================================================

        .SUBTITLE LOCK_FILE
;++
;
; Functional Description:
;       This routine locks a file to prevent others from editing that file
;       by opening that file with a noshare attribute.
;
; Calling Sequence:
;       CALLS   #0,LOCK_FILE
;
; Outline:
;       A new block of memory is allocated and used as shown below.
;       A linked list of LNKFABLST BLOCKS is maintained.  The static
;       variable LNKFABLST points to the first block.  LNKFABNXT within
;       each block points to the next block or is zero if no more blocks.
;
;       LNKFABLST BLOCK
;       -----------------------------------------(start of FAB block)
;       |         IFI       |    BLN   |   BID  | 00 + LNKFABLST
;       -----------------------------------------
;       |                  FOP                  | 04
;       -----------------------------------------
;       |                  STS                  | 08
;       -----------------------------------------
;       |                  STV                  | 0C
;       -----------------------------------------
;       |                  ALQ                  | 10
;       -----------------------------------------
;       |   SHR   |    FAC  |        DEQ        | 14
;       -----------------------------------------
;       |                  CTX                  | 18
;       -----------------------------------------
;       |   RFM   |   RAT   |   ORG   |   RTV   | 1C
;       -----------------------------------------
;       |         |         |FACILITY | JOURNAL | 20
;       -----------------------------------------
;       |                  XAB                  | 24
;       -----------------------------------------
;       |                  NAM                  | 28
;       -----------------------------------------
;       |                  FNA                  | 2C
;       -----------------------------------------
;       |                  DNA                  | 30
;       -----------------------------------------
;       |        MRS        |   DNS   |   FNS   | 34
;       -----------------------------------------
;       |                  MRN                  | 38
;       -----------------------------------------
;       |   FSZ   |   BKS   |        BLS        | 3C
;       -----------------------------------------
;       |                  DEV                  | 40
;       -----------------------------------------
;       |                  SDC                  | 44
;       -----------------------------------------
;       |   RCF   | ACMODES |        GBC        | 48
;       -----------------------------------------
;       |         |         |         |         | 4C
;       ----------------------------------------- (start of NAM block)
;       |   RSL   |   RSS   |   BLN   |   BID   | 00 + FAB$C_BLN + LNKFABLST
;       -----------------------------------------
;       |                  RSA                  | 04
;       -----------------------------------------
;       |   ESL   |   ESS   |   RFS   |   NOP   | 08
;       -----------------------------------------
;       |                  ESA                  | 0C
;       -----------------------------------------
;       |                  RLF                  | 10
;       -----------------------------------------
;       |         |         |         |         | 14
;       -----------------------------------------
;       |         |         |         |         | 18
;       -----------------------------------------
;       |         |         |         |         | 1C
;       -----------------------------------------
;       |         |         |         |         | 20
;       -----------------------------------------
;       |      FID_SEQ      |      FID_NUM      | 24
;       -----------------------------------------
;       |        DID        | FID_NBX | FID_RVN | 28
;       -----------------------------------------
;       | DID_NMX | DID_RVN |      DID_SEQ      | 2C
;       -----------------------------------------
;       |                  WCC                  | 30
;       -----------------------------------------
;       |                  FNB                  | 34
;       -----------------------------------------
;       |   NAME  |   DIR   |   DEV   |   NODE  | 38
;       -----------------------------------------
;       |         |         |   VER   |   TYPE  | 3C
;       -----------------------------------------
;       |                  NODE                 | 40
;       -----------------------------------------
;       |                  DEV                  | 44
;       -----------------------------------------
;       |                  DIR                  | 48
;       -----------------------------------------
;       |                  NAME                 | 4C
;       -----------------------------------------
;       |                  TYPE                 | 50
;       -----------------------------------------
;       |                  VER                  | 54
;       -----------------------------------------
;       |         |         |         |         | 58
;       -----------------------------------------
;       |         |         |         |         | 5C
;       -----------------------------------------(pointer to next LNKFABLST block in linked list)
;       |               LNKFABNXT               | 00 + NAM$C_BLN + FAB$C_BLN + LNKFABLST
;       -----------------------------------------(expanded file name string returned)
;       |        EXPANDED FILE NAME STRING      | 04 + NAM$C_BLN + FAB$C_BLN + LNKFABLST
;       |                   .                   |
;       |                   .                   |
;       |                                       | (NAM$C_MAXRSS in length)
;       -----------------------------------------
;       |        RESULTANT FILE NAME STRING     | 04 + NAM$C_BLN + FAB$C_BLN + LNKFABLST + BUFLEN
;       |                   .                   |
;       |                   .                   |
;       |                                       | (NAM$C_MAXRSS in length)
;       -----------------------------------------
;                                               | 04 + NAM$C_BLN + FAB$C_BLN + LNKFABLST + 2*BUFLEN
;
;------------------------------------------------------------------------------

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR

LNKFABNXT = FAB$C_BLN + NAM$C_BLN                       ;Offset to LNKFABNXT
LNKFABLEN = FAB$C_BLN + NAM$C_BLN + 4 + <2*BUFLEN>      ;Length of memory block to allocate

LNKFABLST:: .LONG  0                                    ;Pointer to first LNKFABLST BLOCK (initialize at zero)
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  LOCK_FILE,^M<R2,R3,R5,R6,R8,R9>
        ;Check virtual memory zone
        BSBW    INITVMZONE                      ;Initialize our virtual memory zone

        ;Go to end of linked list of LNKFABLST BLOCKS
2$:     MOVAL   LNKFABLST,R5                    ;Address of pointer to where linked list starts
3$:     MOVL    (R5),R6                         ;Value of pointer to where linked list starts/continues
        BEQLU   4$                              ;If value of pointer is zero, we're at the end of the list
        ADDL3   R6,#<FAB$C_BLN+NAM$C_BLN>,R5    ;R6 + offset into current LNKFABLST BLOCK = address of pointer to next FAB block (LNKFABNXT)
        BRB     3$                              ;Check value of LNKFABNXT stored in R6.
                                                ;If zero we're at end of list.
                                                ;If nonzero, then value is pointer to next LNKFABLST BLOCK.

        ;Allocate memory for new LNKFABLST BLOCK
        ;Address to return start position of block is in R5 (LNKFABNXT of last block)
4$:     MOVL    #LNKFABLEN,-(SP)                ;Length of memory block to allocate
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHL   R5                              ;Address to place return address of memory block allocated
        PUSHL   R0                              ;Address containing length of memory to allocate (LNKFABLEN by reference)
        CALLS   #3,G^LIB$GET_VM                 ;Allocate memory for new block in linked list
        CLRL    (SP)+                           ;Restore stack pointer

        ;Initialize LNKFABLST BLOCK
        ;R5 = Address where address of new LNKFABLST BLOCK stored
        MOVL    (R5),R8                         ;R8 = Base address of new LNKFABLST BLOCK
        ADDL3   #FAB$C_BLN,R8,R9                ;R9 = Address of NAM block within LNKFABLST BLOCK
        MOVB    #FAB$C_BID,FAB$B_BID(R8)        ;FAB block ID #
        MOVB    #FAB$C_BLN,FAB$B_BLN(R8)        ;FAB block length
        MOVB    #FAB$M_NIL,FAB$B_SHR(R8)        ;Specify no file sharing (exclusive access)
        MOVL    R9,FAB$L_NAM(R8)                ;NAM block address
        MOVL    INSTR,R3                        ;Address of input string descriptor
        MOVL    4(R3),FAB$L_FNA(R8)             ;Address of string containing file name
        MOVB    (R3),FAB$B_FNS(R8)              ;Length of string containing file name

        ;Initialize NAM block
        MOVB    #NAM$C_BID,NAM$B_BID(R9)        ;NAM block ID #
        MOVB    #NAM$C_BLN,NAM$B_BLN(R9)        ;NAM block length
        MOVB    #NAM$C_MAXRSS,NAM$B_ESS(R9)     ;Expanded file name string size
        MOVB    #NAM$C_MAXRSS,NAM$B_RSS(R9)     ;Resultant file name string size
        ADDL3   R9,#<NAM$C_BLN+4>,NAM$L_ESA(R9) ;Expanded file name string address
        ADDL3   R9,#<NAM$C_BLN+4+BUFLEN>,-
                NAM$L_RSA(R9)                   ;Resultant file name string address

        ;open the file
        $OPEN   FAB=(R8)                        ;Open the file to lock it
        BLBC    R0,5$                           ;Branch if unsuccessful
        PUSHL   NAM$L_RSA(R9)                   ;Address of resultant filename string
        MOVZBL  NAM$B_RSL(R9),R1                ;Filename size
        PUSHL   R1                              ;Filename size
        PUSHL   #2                              ;two FAO arguments
        PUSHL   #EDX__LOCKED                    ;Successfully locked message
        CALLS   #4,EDX_SIGNAL                   ;Signal success message
        PUSHL   #1                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Normal exit

        ;Process error opening file
        ;Signal error message
5$:     MOVL    R0,R3                           ;Save error status
        CMPL    R0,#RMS$_FLK                    ;See if the error was 'file locked by another user'
        BNEQ    6$                              ;If not then branch
        CALLS   #0,SRCH_LNKFABLST               ;(changes R2) else see if we have file already locked
        CMPL    R0,#EDX__LOCKED                 ;Check for locked status
        BNEQ    6$                              ;Branch if it's not us.
        PUSHL   NAM$L_ESA(R9)                   ;Address of expanded filename string
        MOVZBL  NAM$B_ESL(R9),R1                ;Filename size
        PUSHL   R1                              ;Filename size
        PUSHL   #2                              ;two FAO arguments
        PUSHL   #EDX__ALK                       ;We already have file locked
        CALLS   #4,EDX_SIGNAL                   ;Signal that message
        BRB     7$                              ;Branch to deallocate memory

6$:     PUSHL   #0                              ;Zero FAO arguments for error
        PUSHL   R3                              ;Push error code on stack
        PUSHL   NAM$L_ESA(R9)                   ;Address of expanded filename string
        MOVZBL  NAM$B_ESL(R9),R1                ;Filename size
        PUSHL   R1                              ;Filename size
        PUSHL   #2                              ;two FAO arguments
        PUSHL   #EDX__NOLOCK                    ;Error message
        CALLS   #6,EDX_SIGNAL                   ;Signal the error
        BRB     7$                              ;Branch to deallocate memory

7$:     ;Free newest LNKFABLST BLOCK that was allocated
        ;R5 = address of previous LNKFABLST BLOCK + LNKFABNXT pointer which points to new LNKFABLST BLOCK
        CLRL    (R5)                            ;Previous node becomes last node by zeroing LNKFABNXT
        MOVL    #LNKFABLEN,-(SP)                ;Length of memory block to deallocate
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHL   R5                              ;Address of return address of memory block allocated
        PUSHL   R0                              ;Address containing length of memory to allocate
        CALLS   #3,G^LIB$FREE_VM                ;Deallocate memory used for new FAB block
        CLRL    (SP)+                           ;Restore stack pointer
        CLRL    (R5)                            ;Reset LNKFABNXT pointer of previous FAB block
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Error exit
;------------------------------------------------------------------------------

        .SUBTITLE UNLOCK_FILE
;++
;
; Functional Description:
;       This procedure unlocks the specified file locked by routine LOCK_FILE
;       by closing it and deallocating the memory for the LNKFABLST BLOCK.
;
; Calling Sequence:
;       CALLS   #0,UNLOCK_FILE
;
; Argument inputs:
;       INSTR = Address of input filespec descriptor
;
; Outline:
;       1.  We search the linked list LNKFABLST for the specified filename
;       2.  If found we close it and remove it.  If not found we signal the error.
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(expanded file name string of input filespec)
;       |        EXPANDED FILE NAME STRING      | 00 (base address is stored in R7)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------
;                                               | BUFLEN
;
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  UNLOCK_FILE,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10>

        ;Find matching LNKFABLST BLOCK for INSTR filename
        CALLS   #0,SRCH_LNKFABLST               ;(changes R2) Search for LNKFABLST BLOCK containing filename
        CMPL    R0,#EDX__LOCKED                 ;If successful then R1 = Address of previous LNKFABLST BLOCK
        BEQLU   2$                              ;And R2 = Address of LNKFABLST BLOCK containing filename
        CMPL    R0,#EDX__NOTLOCKED              ;Test for not found failure
        BEQLU   1$                              ;Branch if file not found
        PUSHL   R0                              ;Else signal error
        CALLS   #1,EDX_SIGNAL                   ;
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;and return (unknown error exit)

1$:     ;File Not Found
        ;Came to end of linked list.  No match found
        ;Reparse input filename not using physical device names
        SUBL2   #BUFLEN,SP                      ;Move stack pointer over memory we claim
        MOVL    SP,R7                           ;Store base address.  We'll use this memory for our output buffer
        MOVL    INSTR,R3                        ;Address of INSTR to R3
        MOVW    (R3),R6                         ;Length of input filespec from descriptor
        MOVL    4(R3),R5                        ;Address of input filespec from descriptor
        MOVL    #NAM$C_MAXRSS,R8                ;Length of output filespec buffer
        CLRL    R2                              ;Don't use physical device names
        CALLS   #0,EDX_PARSE                    ;Parse filespec
        PUSHL   R7                              ;Address of filename string
        PUSHL   R1                              ;Filename size
        PUSHL   #2                              ;two FAO arguments
        PUSHL   #EDX__NOTLOCKED                 ;File not locked message
        CALLS   #4,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Error exit

2$:     ;Found match.  Close file.
        ;R1 = Address of previous LNKFABNXT of previous LNKFABLST BLOCK
        ;R2 = Address of LNKFABLST to close
        MOVL    R1,R4                           ;Save address of previous LNKFABNXT
        MOVL    R2,R5                           ;Save address of LNKFABLST
        $CLOSE  FAB=R5                          ;Close file
        BLBS    R0,6$                           ;Branch on success
        PUSHL   R0                              ;Signal error
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Error exit

        ;Signal success message
6$:     PUSHL   <FAB$C_BLN+NAM$L_RSA>(R5);      Address of resultant filename string
        MOVZBL  <FAB$C_BLN+NAM$B_RSL>(R5),R1    ;Filename size
        PUSHL   R1                              ;Filename size
        PUSHL   #2                              ;two FAO arguments
        PUSHL   #EDX__UNLOCKED                  ;File unlocked message
        CALLS   #4,EDX_SIGNAL                   ;Signal message

        ;Remove LNKFABLST node from linked list and deallocate LNKFABLST node memory
        ;R4 = Address of LNKFABNXT of previous LNKFABLST BLOCK
        ;R5 = Base address of LNKFABLST node to remove
        MOVL    <NAM$C_BLN+FAB$C_BLN>(R5),(R4)  ;LNKFABNXT of previous LNKFABLST BLOCK points to next LNKFABLST BLOCK
        PUSHL   R5                              ;Address of memory to deallocate
        MOVL    SP,R1                           ;Address of address of memory block to deallocate (address by reference)
        PUSHL   #LNKFABLEN                      ;Length of memory block to deallocate
        MOVL    SP,R0                           ;Address containing length of memory block to deallocate (length by reference)
        PUSHAL  VM_ZONE                         ;Our virtual memory zone id
        PUSHL   R1                              ;Address of address of memory block to deallocate (address by reference)
        PUSHL   R0                              ;Address containing length of memory to deallocate
        CALLS   #3,G^LIB$FREE_VM                ;Deallocate memory used for new FAB block
        PUSHL   #1                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Normal exit
;------------------------------------------------------------------------------

        .SUBTITLE EDX_CKFILK
;++
;
; Functional Description:
;       This procedure searches the linked list of filenames locked by
;       LOCK_FILE for a specified filename.  If the file is found it
;       returns #1 in RETCODE to TPU.  If the file is not found it returns
;       #0 in RETCODE to TPU.
;
; Calling Sequence:
;       CALLS   #0,EDX_CKFILK
;
; Argument inputs:
;       INSTR = Address of input filespec descriptor
;
; Outline:
;       1.  Call SRCH_LNKFABLST.  It does all the work.
;           We just check the return status and set RETCODE accordingly.
;--

        .ENTRY  EDX_CKFILK,^M<R2>
        ;Find matching LNKFABLST BLOCK for INSTR filename
        CALLS   #0,SRCH_LNKFABLST               ;(changes R2) Search for LNKFABLST BLOCK containing filename
        CMPL    R0,#EDX__LOCKED                 ;Compare with success
        BNEQ    1$                              ;Branch if it's not
        PUSHL   #1                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;Return (normal is-locked)
1$:     CMPL    R0,#EDX__NOTLOCKED              ;Test for not found failure
        BNEQ    2$                              ;Branch if some other failure
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;Return (normal not-locked)
2$:     PUSHL   R0                              ;Else signal error
        CALLS   #1,EDX_SIGNAL                   ;
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;and return (unknown error exit)

;------------------------------------------------------------------------------

        .SUBTITLE SRCH_LNKFABLST
;++
;
; Functional Description:
;       This procedure searches the linked list of filenames locked by
;       LOCK_FILE for a specified filename.
;
; Calling Sequence:
;       CALLS   #0,SRCH_LNKFABLST
;
; Argument inputs:
;       INSTR = Address of input filespec descriptor
;
; Returns:
;       R0 = #EDX_LOCKED if successful, #EDX_NOTLOCKED if failure, or error status code
;       R1 = Base address of previous LNKFABLST BLOCK
;       R2 = Base address of current LNKFABLST BLOCK which has filename
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  The input filename is parsed to give a full filename
;       3.  The filename of the first LNKFABLST BLOCK is parsed
;       4.  A comparison of the two filenames is made
;           If they match we've found our LNKFABLST BLOCK
;           If they don't match we try the next LNKFABLST BLOCK
;           If we come to the end of the linked list with no match we
;           return with the error #EDX_NOTLOCKED
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(expanded file name string of input filespec)
;       |        EXTENDED FILE NAME STRING      | 00 (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(expanded file name string from LNKFABLST block)
;       |        EXTENDED FILE NAME STRING      | BUFLEN
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(original stack pointer)
;                                               | 2*BUFLEN
;
;--

        .ENTRY  SRCH_LNKFABLST,^M<R3,R4,R5,R6,R7,R8,R9,R10>

        ;Allocate memory on stack
        SUBL2   #<2*BUFLEN>,SP                  ;Move stack pointer over memory we claim
        MOVL    SP,R9                           ;Store base address.  We'll use this memory for the FAB/NAM block

        ;Parse input filename
        ;R9 = Address of output buffer
        MOVL    INSTR,R3                        ;Address of INSTR to R3
        MOVW    (R3),R6                         ;Length of input filespec from descriptor
        MOVL    4(R3),R5                        ;Address of input filespec from descriptor
        MOVL    R9,R7                           ;Address of output filespec buffer
        MOVL    #NAM$C_MAXRSS,R8                ;Length of output filespec buffer
        MOVZBL  #1,R2                           ;Use physical device names
        CALLS   #0,EDX_PARSE                    ;Parse filespec
        BLBS    R0,1$                           ;Branch if successful
        RET                                     ;Else return with error in R0
1$:     MOVL    R1,R10                          ;Save result length

        ;Go through linked list of LNKFABLST BLOCKS
        ;R10 = length of parsed input filespec
        MOVAL   LNKFABLST,R4                    ;Pointer to where linked list starts
2$:     MOVL    (R4),R5                         ;R5 = base address of next LNKFABLST BLOCK
        BEQLU   4$                              ;If value of base address is zero, we're at the end of the list
        MOVZBL  <FAB$C_BLN+NAM$B_RSS>(R5),R6    ;Length of input filespec string
        ADDL2   #<4+FAB$C_BLN+ -
                NAM$C_BLN+BUFLEN>,R5            ;R5 = address of resultant file name string in current LNKFABLST BLOCK
        ADDL3   #BUFLEN,R9,R7                   ;Address of output filespec buffer
        MOVL    #NAM$C_MAXRSS,R8                ;Length of output filespec buffer
        MOVZBL  #1,R2                           ;Use physical device names
        CALLS   #0,EDX_PARSE                    ;Parse output filespec

        ;Compare filenames
        ;R10 = Length of parsed input filename
        ;R9  = Address of parsed input filename
        ;R7  = Address of parsed LNKFABLST filename
        CMPC3   R10,(R9),(R7)                   ;Compare strings (destroys R0 through R3)
        BEQLU   5$                              ;Branch if equal
        SUBL3   #<4+BUFLEN>,R5,R4               ;R4 = address of LNKFABNXT of current next LNKFABLST BLOCK
        BRB     2$                              ;Loop and check next LNKFABLST BLOCK

4$:     ;Came to end of linked list.  No match found
        MOVL    #EDX__NOTLOCKED,R0              ;Set return code
        RET                                     ;And return.  File not found in list

5$:     ;Found match.  Close file.
        ;R4 = Address of previous LNKFABNXT of previous LNKFABLST BLOCK
        ;R5 = 4+NAM$C_BLN+FAB$C_BLN + base address of LNKFABLST to close
        SUBL3   #<4+NAM$C_BLN+FAB$C_BLN+BUFLEN>,-
                R5,R2                           ;R2 = base address of LNKFABLST to close
        MOVL    R4,R1                           ;R1 = base address of previous LNKFABNXT
        MOVL    #EDX__LOCKED,R0                 ;R0 = return code
        RET                                     ;and return
;------------------------------------------------------------------------------

        .SUBTITLE EDX_PARSE
;++
;
; Functional Description:
;       This routine accepts a filespec as input and parses it returning
;       the full file specification using physical device names.
;
; Calling Sequence:
;       CALLS   #0,EDX_PARSE
;
; Argument inputs:
;       R2 = If odd then use physical device names.
;       R5 = Address of input filespec string
;       R6 = Length of input filespec string
;       R7 = Address of output filespec buffer
;       R8 = Length of output filespec buffer
;
; Outputs:
;       R0 = Parse status
;       R1 = Length of fully parsed output filename
;
; Outline:
;       1.  Memory is allocated on the stack to use for FAB/NAM BLOCK
;       2.  The FAB and NAM blocks are initialized
;       3.  The filespec is parsed
;
; Memory Map (Memory allocated on stack):
;
;       FAB/NAM BLOCK
;       -----------------------------------------(start of FAB block)
;       |         IFI       |    BLN   |   BID  | 00 + R9
;       -----------------------------------------
;       |                  FOP                  | 04
;       -----------------------------------------
;       |                  STS                  | 08
;       -----------------------------------------
;       |                  STV                  | 0C
;       -----------------------------------------
;       |                  ALQ                  | 10
;       -----------------------------------------
;       |   SHR   |    FAC  |        DEQ        | 14
;       -----------------------------------------
;       |                  CTX                  | 18
;       -----------------------------------------
;       |   RFM   |   RAT   |   ORG   |   RTV   | 1C
;       -----------------------------------------
;       |         |         |FACILITY | JOURNAL | 20
;       -----------------------------------------
;       |                  XAB                  | 24
;       -----------------------------------------
;       |                  NAM                  | 28
;       -----------------------------------------
;       |                  FNA                  | 2C
;       -----------------------------------------
;       |                  DNA                  | 30
;       -----------------------------------------
;       |        MRS        |   DNS   |   FNS   | 34
;       -----------------------------------------
;       |                  MRN                  | 38
;       -----------------------------------------
;       |   FSZ   |   BKS   |        BLS        | 3C
;       -----------------------------------------
;       |                  DEV                  | 40
;       -----------------------------------------
;       |                  SDC                  | 44
;       -----------------------------------------
;       |   RCF   | ACMODES |        GBC        | 48
;       -----------------------------------------
;       |         |         |         |         | 4C
;       ----------------------------------------- (start of NAM block)
;       |   RSL   |   RSS   |   BLN   |   BID   | 00 + FAB$C_BLN + R9 = R10
;       -----------------------------------------
;       |                  RSA                  | 04
;       -----------------------------------------
;       |   ESL   |   ESS   |   RFS   |   NOP   | 08
;       -----------------------------------------
;       |                  ESA                  | 0C
;       -----------------------------------------
;       |                  RLF                  | 10
;       -----------------------------------------
;       |         |         |         |         | 14
;       -----------------------------------------
;       |         |         |         |         | 18
;       -----------------------------------------
;       |         |         |         |         | 1C
;       -----------------------------------------
;       |         |         |         |         | 20
;       -----------------------------------------
;       |      FID_SEQ      |      FID_NUM      | 24
;       -----------------------------------------
;       |        DID        | FID_NBX | FID_RVN | 28
;       -----------------------------------------
;       | DID_NMX | DID_RVN |      DID_SEQ      | 2C
;       -----------------------------------------
;       |                  WCC                  | 30
;       -----------------------------------------
;       |                  FNB                  | 34
;       -----------------------------------------
;       |   NAME  |   DIR   |   DEV   |   NODE  | 38
;       -----------------------------------------
;       |         |         |   VER   |   TYPE  | 3C
;       -----------------------------------------
;       |                  NODE                 | 40
;       -----------------------------------------
;       |                  DEV                  | 44
;       -----------------------------------------
;       |                  DIR                  | 48
;       -----------------------------------------
;       |                  NAME                 | 4C
;       -----------------------------------------
;       |                  TYPE                 | 50
;       -----------------------------------------
;       |                  VER                  | 54
;       -----------------------------------------
;       |         |         |         |         | 58
;       -----------------------------------------
;       |         |         |         |         | 5C
;       -----------------------------------------
;
;--
        .ENTRY  EDX_PARSE,^M<R9,R10,R11>

        ;Allocate zero filled memory on stack
        SUBL2   #<FAB$C_BLN+NAM$C_BLN>,SP                       ;Allocate memory on stack
        MOVL    SP,R9                                           ;Store base address.  We'll use this memory for the FAB/NAM block
        PUSHR   #^M<R2,R3,R4,R5>
        MOVC5   #0,(SP),#^x00,#<FAB$C_BLN+NAM$C_BLN>,(R9)       ; Zero allocated memory
        POPR    #^M<R2,R3,R4,R5>

        ;Initialize FAB BLOCK
        ;R5 = Address of input filename
        ;R6 = Length of input filename
        ;R7 = Address of output filename buffer
        ;R8 = Length of output filename buffer
        ;R9 = Address of FAB/NAM BLOCK
        ADDL3   #FAB$C_BLN,R9,R10               ;R10 = Address of NAM block
        MOVB    #FAB$C_BID,FAB$B_BID(R9)        ;FAB block ID #
        MOVB    #FAB$C_BLN,FAB$B_BLN(R9)        ;FAB block length
        MOVL    R10,FAB$L_NAM(R9)               ;NAM block address
        MOVL    R5,FAB$L_FNA(R9)                ;Address of string containing file name
        MOVB    R6,FAB$B_FNS(R9)                ;Length of string containing file name

        ;Initialize NAM block
        ;R2 - If odd then use physical device names
        MOVB    #NAM$C_BID,NAM$B_BID(R10)       ;NAM block ID #
        MOVB    #NAM$C_BLN,NAM$B_BLN(R10)       ;NAM block length
        MOVL    R7,NAM$L_ESA(R10)               ;Expanded file name string address
        MOVB    R8,NAM$B_ESS(R10)               ;Expanded file name string size
        BISB2   #NAM$M_SYNCHK,NAM$B_NOP(R10)    ;Parse only
        BLBC    R2,2$                           ;Branch else use physical device names
        BISB2   #NAM$M_NOCONCEAL,NAM$B_NOP(R10) ;Translate resultant file name using physical device names

        ;Parse the filename
2$:     $PARSE  FAB=(R9)                        ;Parse the filename
        MOVZBL  NAM$B_ESL(R10),R1               ;Move expanded filename length to R1
        RET                                     ;Parse status in R0, filename length in R1

;------------------------------------------------------------------------------
;==============================================================================
;       MISCELLANEOUS
;==============================================================================
        .SUBTITLE EDX_SETDEF
;++
;
; Functional Description:
;       This procedure changes a user's default directory.
;
; Calling Sequence:
;       CALLS   #0,EDX_SETDEF
;
; Argument inputs:
;       INSTR = Address of descriptor of string containing new directory to go to
;
; Outline:
;       1.  Memory is allocated on the stack to use for FAB/NAM BLOCK
;       2.  The FAB and NAM blocks are initialized
;       3.  The filespec is parsed
;       4.  The node and disk are extracted and SYS$DISK is defined
;       4.  Call SYS$SETDDIR
;       5.  Check return status and signal if error
;
; Memory Map (Memory allocated on stack):
;
;       FAB/NAM BLOCK
;       -----------------------------------------(start of FAB block)
;       |         IFI       |    BLN   |   BID  | 00 (R9 = base address)
;       -----------------------------------------
;       |                  FOP                  | 04
;       -----------------------------------------
;       |                  STS                  | 08
;       -----------------------------------------
;       |                  STV                  | 0C
;       -----------------------------------------
;       |                  ALQ                  | 10
;       -----------------------------------------
;       |   SHR   |    FAC  |        DEQ        | 14
;       -----------------------------------------
;       |                  CTX                  | 18
;       -----------------------------------------
;       |   RFM   |   RAT   |   ORG   |   RTV   | 1C
;       -----------------------------------------
;       |         |         |FACILITY | JOURNAL | 20
;       -----------------------------------------
;       |                  XAB                  | 24
;       -----------------------------------------
;       |                  NAM                  | 28
;       -----------------------------------------
;       |                  FNA                  | 2C
;       -----------------------------------------
;       |                  DNA                  | 30
;       -----------------------------------------
;       |        MRS        |   DNS   |   FNS   | 34
;       -----------------------------------------
;       |                  MRN                  | 38
;       -----------------------------------------
;       |   FSZ   |   BKS   |        BLS        | 3C
;       -----------------------------------------
;       |                  DEV                  | 40
;       -----------------------------------------
;       |                  SDC                  | 44
;       -----------------------------------------
;       |   RCF   | ACMODES |        GBC        | 48
;       -----------------------------------------
;       |         |         |         |         | 4C
;       ----------------------------------------- (start of NAM block)
;       |   RSL   |   RSS   |   BLN   |   BID   | 00 + FAB$C_BLN (= R10)
;       -----------------------------------------
;       |                  RSA                  | 04
;       -----------------------------------------
;       |   ESL   |   ESS   |   RFS   |   NOP   | 08
;       -----------------------------------------
;       |                  ESA                  | 0C
;       -----------------------------------------
;       |                  RLF                  | 10
;       -----------------------------------------
;       |         |         |         |         | 14
;       -----------------------------------------
;       |         |         |         |         | 18
;       -----------------------------------------
;       |         |         |         |         | 1C
;       -----------------------------------------
;       |         |         |         |         | 20
;       -----------------------------------------
;       |      FID_SEQ      |      FID_NUM      | 24
;       -----------------------------------------
;       |        DID        | FID_NBX | FID_RVN | 28
;       -----------------------------------------
;       | DID_NMX | DID_RVN |      DID_SEQ      | 2C
;       -----------------------------------------
;       |                  WCC                  | 30
;       -----------------------------------------
;       |                  FNB                  | 34
;       -----------------------------------------
;       |   NAME  |   DIR   |   DEV   |   NODE  | 38
;       -----------------------------------------
;       |         |         |   VER   |   TYPE  | 3C
;       -----------------------------------------
;       |                  NODE                 | 40
;       -----------------------------------------
;       |                  DEV                  | 44
;       -----------------------------------------
;       |                  DIR                  | 48
;       -----------------------------------------
;       |                  NAME                 | 4C
;       -----------------------------------------
;       |                  TYPE                 | 50
;       -----------------------------------------
;       |                  VER                  | 54
;       -----------------------------------------
;       |         |         |         |         | 58
;       -----------------------------------------
;       |         |         |         |         | 5C
;       -----------------------------------------(expanded file name string returned)
;       |        EXPANDED FILE NAME STRING      | FAB$C_BLN+NAM$C_BLN
;       |                   .                   |
;       |                                       |
;       -----------------------------------------
;                                               | FAB$C_BLN+NAM$C_BLN+BUFLEN
;
;--
        .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC

.ALIGN LONG
SYS$DISK:  .ASCID /SYS$DISK/            ;Logical name table search list to use
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  EDX_SETDEF ^M<R2,R3,R4,R5,R9,R10>

        ;Allocate zero filled memory on stack
        SUBL2   #<FAB$C_BLN+NAM$C_BLN+BUFLEN>,SP                ;Allocate memory on stack
        MOVL    SP,R9                                           ;Store base address.  We'll use this memory for the FAB/NAM block
        MOVC5   #0,(SP),#^x00,#<FAB$C_BLN+NAM$C_BLN>,(R9)       ; Zero allocated memory

        ;Initialize FAB BLOCK
        ;R9 = Address of FAB BLOCK
        MOVL    INSTR,R0                        ;R0 = Address of descriptor
        ADDL3   #FAB$C_BLN,R9,R10               ;R10 = Address of NAM block
        MOVB    #FAB$C_BID,FAB$B_BID(R9)        ;FAB block ID #
        MOVB    #FAB$C_BLN,FAB$B_BLN(R9)        ;FAB block length
        MOVL    R10,FAB$L_NAM(R9)               ;NAM block address
        MOVL    4(R0),FAB$L_FNA(R9)             ;Address of string containing file name
        MOVB    (R0),FAB$B_FNS(R9)              ;Length of string containing file name

        ;Initialize NAM block
        ;R10 = Address of NAM BLOCK
        MOVB    #NAM$C_BID,NAM$B_BID(R10)       ;NAM block ID #
        MOVB    #NAM$C_BLN,NAM$B_BLN(R10)       ;NAM block length
        ADDL3   #NAM$C_BLN,R10,NAM$L_ESA(R10)   ;Expanded file name string address
        MOVB    #NAM$C_MAXRSS,NAM$B_ESS(R10)    ;Expanded file name string size

        ;Parse the filename
        $PARSE  FAB=(R9)                        ;Parse the filename
        BLBS    R0,2$                           ;Branch on success
        PUSHL   R0                              ;Error code
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Error exit

        ;Set default disk by defining SYS$DISK as NODE::DISK:
        ;Build descriptor on stack for NODE::DISK:
2$:     PUSHL   #0                      ;Allocate 2 zero-filled longwords on stack
        PUSHL   #0                      ;
        MOVL    SP,R0                   ;R0 will be address of descriptor
        ADDB3   NAM$B_NODE(R10),-
                NAM$B_DEV(R10),(R0)                     ;Length of NODE::DISK:
        BEQL    3$                                      ;Branch if zero length.  Disk not specified.
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R0)          ;Type
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R0)          ;Class
        MOVL    NAM$L_NODE(R10),DSC$A_POINTER(R0)       ;Address of NODE::DISK:

        ;Call LIB$SET_LOGICAL
        PUSHL   R0                      ;Address of descriptor of NODE::DISK:
        PUSHAL  SYS$DISK                ;Address of descriptor of SYS$DISK
        CALLS   #2,G^LIB$SET_LOGICAL    ;Set logical name
        BLBS    R0,3$                   ;Branch if success
        PUSHL   R0                      ;Otherwise signal error
        CALLS   #1,EDX_SIGNAL           ;
        PUSHL   #0                      ;retcode
        CALLS   #1,FMTOUTSTR            ;format return status
        RET                             ;and return error setting sys$disk

        ;Set default directory
3$:     PUSHL   #0                      ;cur-dir-addr
        PUSHL   #0                      ;length-addr
        PUSHL   INSTR                   ;Address of string descriptor
        CALLS   #3,G^SYS$SETDDIR        ;Set default directory
        PUSHL   #1                      ;Assume success return status
        BLBS    R0,4$                   ;Branch if OK
        PUSHL   #0                      ;Change that to a failure return status
        PUSHL   R0                      ;Otherwise signal error
        CALLS   #1,EDX_SIGNAL           ;
4$:     CALLS   #1,FMTOUTSTR            ;format return status (status already on stack)
        RET                             ;return
;------------------------------------------------------------------------------

        .SUBTITLE SET LOGICAL
;++
;
; Functional Description:
;       Defines a logical name.  The logical name is created in supervisor
;       mode and placed in the LNM$PROCESS table.
;
; Calling Sequence:
;       CALLS   #0,SET_LOGICAL
;
; Argument inputs:
;       INSTR = Address of descriptor of input string.  String is of the form:
;               "log-nam value".  It should be a substring of the full DCL
;               type command "DEFINE log-nam value".
;
;       log-nam = Logical name to be defined or redefined.
;       value   = Value to be given to the logical name.
;
; Outline:
;       1.  The input string is parsed.  A descriptor for the substring
;           "log-nam" and a descriptor for the substring "value" are made.
;       2.  LIB$SET_LOGICAL is called to define the logical name.
;           The return status checked and signaled if there is an error.
;
;------------------------------------------------------------------------------

        .ENTRY  SET_LOGICAL,^M<R2,R3,R4,R5,R6>

        ;Parse input string.  Look for first space.
        MOVL    INSTR,R3                ;R3 = Address of descriptor
        MOVZWL  (R3),R2                 ;R2 = Length of string
        MOVL    4(R3),R4                ;R4 = Address of string
        LOCC    #SPACE,R2,(R4)          ;Locate first space in string
        SUBL2   R0,R2                   ;R2 = Length of "log-nam"
        SKPC    #SPACE,R0,(R1)          ;Locate first non-space in string

        ;R0 = Length of "value"
        ;R1 = Address of "value"
        ;R2 = Length of "log-nam"
        ;R4 = Address of "log-nam"
        ;Build descriptors on stack for "log-nam" and "value"
        SUBL2   #16,SP                          ;Allocate 4 longwords on stack
        MOVL    SP,R6                           ;R6 will be address of "log-nam" descriptor
        ADDL3   #8,R6,R5                        ;R5 will be address of "value" descriptor
        MOVW    R2,DSC$W_LENGTH(R6)             ;Length of "log-nam"
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R6)  ;Type
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R6)  ;Class
        MOVL    R4,DSC$A_POINTER(R6)            ;Address of "log-nam"
        MOVW    R0,DSC$W_LENGTH(R5)             ;Length of "value"
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R5)  ;Type
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R5)  ;Class
        MOVL    R1,DSC$A_POINTER(R5)            ;Address of "value"

        ;Call LIB$SET_LOGICAL
        PUSHL   R5                      ;Address of descriptor of "value"
        PUSHL   R6                      ;Address of descriptor of "log-nam"
        CALLS   #2,G^LIB$SET_LOGICAL    ;Set logical name
        BLBC    R0,1$                   ;Branch if failure
        PUSHL   #1                      ;retcode
        CALLS   #1,FMTOUTSTR            ;format return status
        RET                             ;Return.  Normal exit

        ;Process error in creating logical name
1$:     PUSHL   R0                      ;Error code
        CALLS   #1,EDX_SIGNAL           ;Signal error
        PUSHL   #0                      ;retcode
        CALLS   #1,FMTOUTSTR            ;format return status
        RET                             ;Error exit

;------------------------------------------------------------------------------

        .SUBTITLE SET_SYMBOL
;++
;
; Functional Description:
;       Creates a DCL symbol.
;
; Calling Sequence:
;       CALLS   #0,SET_SYMBOL
;
; Argument inputs:
;       INSTR = Address of descriptor of input string.  String is of the form:
;               "symbol-name0equivalence0tblind" where 0 represents an ascii
;               0 character.
;
;       symbol-name = Name to be defined or redefined.
;       expression  = Expression to be given to the symbol.
;       tblind      = Indicator of the table which will contain the defined
;                     symbol.  1=local, 2=global.  (See LIB$SET_SYMBOL)
;
; Outline:
;       1.  The input string is parsed.  A descriptor for the substring
;           "symbol-name", a descriptor for the substring "expression",
;           and the value of tblind is extracted.
;
;       2.  LIB$SET_SYMBOL is called to create the DCL symbol.
;           The return status checked and signaled if there is an error.
;
;       -----------------------------------------(descriptor for "symbol-name")
;       |  class  |  dtype  |  string length    | <^x00>
;       -----------------------------------------
;       |            buffer address             | <^x04>
;       -----------------------------------------(descriptor for "expression")
;       |  class  |  dtype  |  string length    | <^x08>
;       -----------------------------------------
;       |            buffer address             | <^x0C>
;       -----------------------------------------
;       |                 TBLIND                | <^x10>
;       -----------------------------------------
;                                               | <+^x14>
;
;--

        .ENTRY  SET_SYMBOL,^M<R2,R3,R4,R5,R6,R7,R9>

        ;R4 = address of symbol-name
        ;R5 = length of symbol-name
        ;R6 = address of equivalence
        ;R7 = length of equivalence
        ;Parse input string.  Look for first null character.
        MOVL    INSTR,R0                ;Address of descriptor
        MOVL    4(R0),R2                ;R2 = Address of string
        MOVZWL  (R0),R3                 ;R3 = Length of string
        MOVL    R2,R4                   ;R4 = Address of "symbol-name"
        LOCC    #0,R3,(R2)              ;Locate first null in string
        SUBL3   R0,R3,R5                ;R5 = Length of "symbol-name"

        ADDL2   R5,R2                   ;address of rest of string
        MOVL    R0,R3                   ;new remaining length of string
        INCL    R2                      ;skip over found null
        DECL    R3                      ;skip over found null
        MOVL    R2,R6                   ;R6 = Address of "equivalence"
        LOCC    #0,R3,(R2)              ;Locate second null in string
        SUBL3   R0,R3,R7                ;R7 = Length of "equivalence"

        ADDL2   R7,R2                   ;address of rest of string
        INCL    R2                      ;R2 = address of tblind byte char


        ;R2 = address of tblind byte char
        ;R4 = address of symbol-name
        ;R5 = length of symbol-name
        ;R6 = address of equivalence
        ;R7 = length of equivalence
        ;Build descriptors on stack for "symbol-name" and "equivalence"
        SUBL2   #^x14,SP                ;Allocate 5 longwords on stack
        MOVL    SP,R9                   ;Save address of allocated memory

        CLRL    ^x10(R9)                ;Clear space for tblind
        SUBB3   #^x30,(R2),^x10(R9)     ;convert tblind to integer value

        MOVW    R5,DSC$W_LENGTH(R9)             ;Length of "symbol-name"
        MOVB    #DSC$K_DTYPE_T,DSC$B_DTYPE(R9)  ;Type
        MOVB    #DSC$K_CLASS_S,DSC$B_CLASS(R9)  ;Class
        MOVL    R4,DSC$A_POINTER(R9)            ;Address of "symbol-name"

        MOVW    R7,<^x08+DSC$W_LENGTH>(R9)              ;Length of "expression"
        MOVB    #DSC$K_DTYPE_T,<^x08+DSC$B_DTYPE>(R9)   ;Type
        MOVB    #DSC$K_CLASS_S,<^X08+DSC$B_CLASS>(R9)   ;Class
        MOVL    R6,<^x08+DSC$A_POINTER>(R9)             ;Address of "expression"

        ;Call LIB$SET_SYMBOL
        PUSHAL  ^x10(R9)                ;tblind
        PUSHAL  ^x08(R9)                ;"expression"
        PUSHAL  (R9)                    ;"symbol-name"
        CALLS   #3,G^LIB$SET_SYMBOL     ;Set symbol
        BLBC    R0,2$                   ;Branch if failure
        PUSHL   #1                      ;retcode
        CALLS   #1,FMTOUTSTR            ;format return status
        RET                             ;Return.  Normal exit

        ;Process error in setting symbol
2$:     PUSHL   R0                      ;Error code
        CALLS   #1,EDX_SIGNAL           ;Signal error
        PUSHL   #0                      ;retcode
        CALLS   #1,FMTOUTSTR            ;format return status
        RET                             ;Error exit

;------------------------------------------------------------------------------

        .SUBTITLE SHOW LOGICAL
;++
;
; Functional Description:
;       Translates a logical name
;
; Calling Sequence:
;       CALLS   #0,SHOW_LOGICAL
;
; Argument inputs:
;       INSTR = Address of descriptor of logical name to translate
;       OUTSTR = Address of output descriptor to place translation string
;
; Outputs:
;       OUTSTR = translation of logical name
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  Itemlist for call to SYS$TRNLNM is initialized
;       3.  SYS$TRNLNM is called to obtain logical name translation
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(String to contain logical name translation)
;       |                BUFFER                 | <^x00> (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(return length of string containing logical name translation)
;       |                 RETLEN                | <BUFLEN>
;       -----------------------------------------(item list for sys$trnlnm)
;       |    LNM$_STRING    |      BUFLEN       | <BUFLEN+^x04>
;       -----------------------------------------
;       |           Address of BUFFER           | <BUFLEN+^x08>
;       -----------------------------------------
;       |           Address of RETLEN           | <BUFLEN+^x0C>
;       -----------------------------------------
;       |                   0                   | <BUFLEN+^x10>
;       -----------------------------------------(original stack pointer)
;                                               | <BUFLEN+^x14>
;
;------------------------------------------------------------------------------
        .PSECT  STATIC  RD,NOWRT,NOEXE,LONG,PIC

.ALIGN LONG
LNM_TABLE:  .ASCID /LNM$FILE_DEV/       ;Logical name table search list to use
;------------------------------------------------------------------------------

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR
        .ENTRY  SHOW_LOGICAL,^M<R9>

        ;Allocate memory on stack
        SUBL2   #<BUFLEN+^x14>,SP               ;Move stack pointer over memory we claim
        MOVL    SP,R9                           ;Store base address.

        ;Initialize item list
        MOVW    #BUFLEN,<BUFLEN+^x04>(R9)       ;Buffer length
        MOVW    #LNM$_STRING,<BUFLEN+^x06>(R9)  ;Item code
        MOVL    R9,<BUFLEN+^x08>(R9)            ;Address of BUFFER
        MOVAL   <BUFLEN>(R9),<BUFLEN+^x0C>(R9)  ;Address of RETLEN
        CLRL    <BUFLEN+^x10>(R9)               ;End of item list

        ;Translate logical name
        MOVL    #LNM$M_CASE_BLIND,-(SP)         ;Attr
        MOVL    SP,R0                           ;Address of above (by reference)
        PUSHAL  <BUFLEN+^x04>(R9)               ;Item list
        PUSHL   #0                              ;Access mode
        PUSHL   INSTR                           ;Address of descriptor of input string containing logical name to translate
        PUSHAL  LNM_TABLE                       ;Tabnam
        PUSHL   R0                              ;Attr (by reference)
        CALLS   #5,G^SYS$TRNLNM                 ;Translate logical name
        CLRL    (SP)+                           ;Restore stack pointer
        BLBC    R0,1$                           ;Branch on failure

        ;Copy translation to output
        PUSHL   R9                              ;address of output string
        MOVZWL  <BUFLEN>(R9),R0                 ;length of output string
        PUSHL   R0                              ;length of output string
        PUSHL   #1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;Normal exit

        ;Process error translating logical name
1$:     PUSHL   R0                              ;Error code
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Error exit
;------------------------------------------------------------------------------

        .SUBTITLE SHOW SYMBOL
;++
;
; Functional Description:
;       Translates a DCL symbol
;
; Calling Sequence:
;       CALLS   #0,SHOW_SYMBOL
;
; Argument inputs:
;       INSTR = Address of descriptor of symbol to translate
;       OUTSTR = Address of output descriptor to place translation string
;
; Outputs:
;       OUTSTR = Translation of DCL symbol
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  LIB$GET_SYMBOL is called to obtain the symbol translation
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(String to contain symbol name translation)
;       |                BUFFER                 | <^x00> (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(descriptor for string containing symbol translation)
;       |  class  |  dtype  |  string length    | <BUFLEN>
;       -----------------------------------------
;       |            buffer address             | <BUFLEN+^x04>
;       -----------------------------------------
;       |                 TBLIND                | <BUFLEN+^x08>
;       -----------------------------------------(original stack pointer)
;                                               | <BUFLEN+^x0C>
;
;--
        .ENTRY  SHOW_SYMBOL,^M<R9>

        ;Allocate memory on stack
        SUBL2   #<BUFLEN+^x0C>,SP               ;Move stack pointer over memory we claim
        MOVL    SP,R9                           ;Store base address.

        ;Initialize descriptor
        MOVW    #BUFLEN,        <BUFLEN+DSC$W_LENGTH >(R9)      ;Length
        MOVB    #DSC$K_DTYPE_T, <BUFLEN+DSC$B_DTYPE  >(R9)      ;Type
        MOVB    #DSC$K_CLASS_S, <BUFLEN+DSC$B_CLASS  >(R9)      ;Class
        MOVL    R9,             <BUFLEN+DSC$A_POINTER>(R9)      ;Address

        ;Translate DCL symbol
        PUSHAL  <BUFLEN+^x08>(R9)               ;Table indicator
        PUSHAW  <BUFLEN>(R9)                    ;Return length
        PUSHAL  <BUFLEN>(R9)                    ;Return buffer
        PUSHL   INSTR                           ;Address of descriptor of DCL symbol to translate
        CALLS   #4,G^LIB$GET_SYMBOL             ;Translate symbol
        BLBC    R0,1$                           ;Branch on failure

        ;Copy translation to output
        PUSHL   R9                              ;address of output string
        MOVZWL  <BUFLEN>(R9),R0                 ;length of output string
        PUSHL   R0                              ;length of output string
        PUSHL   <BUFLEN+^x08>(R9)               ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;Normal exit

        ;Process error translating DCL symbol
1$:     PUSHL   R0                              ;Error code
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format return status
        RET                                     ;Error exit
;------------------------------------------------------------------------------

        .SUBTITLE DELETE FILE
;++
;
; Functional Description:
;       Deletes the specified file.
;
; Calling Sequence:
;       CALLS   #0,DELETE_FILE
;
; Argument inputs:
;       INSTR = Address of descriptor of filename to delete
;
;--
        .ENTRY  DELETE_FILE,^M<>

        PUSHAQ  @INSTR
        CALLS   #1,G^LIB$DELETE_FILE
        BLBC    R0,1$                           ;Branch on failure
        PUSHL   #1                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;Normal return

        ;Process error deleting file
1$:     PUSHL   R0                              ;Error code
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;Error exit

        .SUBTITLE TRA_EBC_ASC
;++
;
; Functional Description:
;       Translates EBCDIC to ASCII
;
; Calling Sequence:
;       CALLS   #0,TRA_EBC_ASC
;
; Argument inputs:
;       INSTR  = Address of input  descriptor of EBCDIC string
;       OUTSTR = Address of output descriptor to place ASCII string
;
; Outputs:
;       OUTSTR = ASCII translation of input string
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  LIB$TRA_EBC_ASC is called to obtain the translation string
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(String to contain translation)
;       |                BUFFER                 | <^x00> (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(descriptor for string containing symbol translation)
;       |  class  |  dtype  |  string length    | <MAXLEN>
;       -----------------------------------------
;       |            buffer address             | <MAXLEN+^x04>
;       -----------------------------------------
;--
        .ENTRY  TRA_EBC_ASC,^M<>

        ;Allocate memory on stack
        SUBL2   #<MAXLEN+^x08>,SP               ;Move stack pointer over memory we claim
        MOVL    SP,R9                           ;Store base address.

        ;Initialize descriptor
        MOVW    @INSTR,         <MAXLEN+DSC$W_LENGTH >(R9)      ;Length
        MOVB    #DSC$K_DTYPE_T, <MAXLEN+DSC$B_DTYPE  >(R9)      ;Type
        MOVB    #DSC$K_CLASS_S, <MAXLEN+DSC$B_CLASS  >(R9)      ;Class
        MOVL    R9,             <MAXLEN+DSC$A_POINTER>(R9)      ;Address

        PUSHAQ  <MAXLEN>(R9)                    ;output buffer
        PUSHAQ  @INSTR                          ;input string
        CALLS   #2,G^LIB$TRA_EBC_ASC            ;translate string
        BLBC    R0,1$                           ;Branch on failure

        ;Copy translation to output
        PUSHL   R9                              ;address of output string
        MOVZWL  <MAXLEN>(R9),R0                 ;length of output string
        PUSHL   R0                              ;length of output string
        PUSHL   #1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;Normal exit

        ;Process error
1$:     PUSHL   R0                              ;Error code
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;Error exit

;------------------------------------------------------------------------------

        .SUBTITLE TRA_ASC_EBC
;++
;
; Functional Description:
;       Translates ASCII to EBCDIC
;
; Calling Sequence:
;       CALLS   #0,TRA_ASC_EBC
;
; Argument inputs:
;       INSTR  = Address of input  descriptor of ASCII string
;       OUTSTR = Address of output descriptor to place EBCDIC string
;
; Outputs:
;       OUTSTR = EBCDIC translation of input string
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  LIB$TRA_ASC_EBC is called to obtain the translation string
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(String to contain translation)
;       |                BUFFER                 | <^x00> (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------(descriptor for string containing symbol translation)
;       |  class  |  dtype  |  string length    | <MAXLEN>
;       -----------------------------------------
;       |            buffer address             | <MAXLEN+^x04>
;       -----------------------------------------
;--
        .ENTRY  TRA_ASC_EBC,^M<>

        ;Allocate memory on stack
        SUBL2   #<MAXLEN+^x08>,SP               ;Move stack pointer over memory we claim
        MOVL    SP,R9                           ;Store base address.

        ;Initialize descriptor
        MOVW    @INSTR,         <MAXLEN+DSC$W_LENGTH >(R9)      ;Length
        MOVB    #DSC$K_DTYPE_T, <MAXLEN+DSC$B_DTYPE  >(R9)      ;Type
        MOVB    #DSC$K_CLASS_S, <MAXLEN+DSC$B_CLASS  >(R9)      ;Class
        MOVL    R9,             <MAXLEN+DSC$A_POINTER>(R9)      ;Address

        PUSHAQ  <MAXLEN>(R9)                    ;output buffer
        PUSHAQ  @INSTR                          ;input string
        CALLS   #2,G^LIB$TRA_ASC_EBC            ;translate string
        BLBC    R0,1$                           ;Branch on failure

        ;Copy translation to output
        PUSHL   R9                              ;address of output string
        MOVZWL  <MAXLEN>(R9),R0                 ;length of output string
        PUSHL   R0                              ;length of output string
        PUSHL   #1                              ;retcode
        CALLS   #3,FMTOUTSTR                    ;format output string
        RET                                     ;Normal exit

        ;Process error
1$:     PUSHL   R0                              ;Error code
        CALLS   #1,EDX_SIGNAL                   ;Signal error
        PUSHL   #0                              ;retcode
        CALLS   #1,FMTOUTSTR                    ;format output string
        RET                                     ;Error exit

;==============================================================================

        .SUBTITLE ENCRYPT_INIT
;++
; ENCRYPT_INIT
;
; Functional Description:
;       ENCRYPT_INIT initializes the Data Encryption Standard algorithm.
;       The input password is hashed into a quadword KEY value and a
;       quadword RANBITS value.  These values are then used to initialize
;       the Data Encryption Standard algorithm.
;
; Calling Sequence:
;       CALLS   #1,ENCRYPT_INIT
;
; Input:
;       4(AP) - PASSWORD character string. (by descriptor, read access)
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------
;       |                  KEY                  | 00 (R9)
;       -                                       -
;       |                                       |
;       -----------------------------------------
;
;--
        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR
.ALIGN LONG
RANBITS:        .QUAD   0
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR

        .ENTRY  ENCRYPT_INIT, ^M<R9>
        SUBL2   #8,SP                   ;Allocate memory for KEY
        MOVL    SP,R9                   ;Store address in R9
        PUSHAL  RANBITS                 ;Address of RANBITS
        PUSHL   R9                      ;Address of KEY
        PUSHL   INSTR                   ;Address of PASSWORD descriptor
        CALLS   #3,HCKPWD               ;Hash the password into KEY and RANBITS
        PUSHL   R9                      ;Address of KEY
        CALLS   #1,DES_INIT             ;Initialize DES algorithm
        PUSHL   #1                      ;retcode
        CALLS   #1,FMTOUTSTR            ;format return status
        RET

;-----------------------------------------------------------------------------

;++
; ENCRYPT
;
; Functional Description:
;       Encrypts the input string using the Data Encryption Standard in
;       output feedback mode.
;
; Calling Sequence:
;       CALLS   #0,ENCRYPT
;
; Argument inputs:
;       INSTR  = Address of input descriptor of ASCII string to encrypt
;
; Outputs:
;       OUTSTR = Address of output descriptor of encrypted string
;
; Outline:
;       1.  Memory is allocated on the stack
;       2.  Copy INSTR to allocated memory
;       3.  XOR characters with random bits from DES (in longword chunks)
;       4.  Return encrypted string
;
; Memory Map (Memory allocated on stack):
;
;       -----------------------------------------(string)
;       |                BUFFER                 | <^x00> (base address is stored in R9)
;       |                   .                   |
;       |                   .                   |
;       |                                       |
;       -----------------------------------------
;                                               | <MAXLEN+8>
;
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR

        .ENTRY  ENCRYPT,^M<R2,R3,R9>

        ;Test for zero length string
1$:     TSTW    @INSTR                  ;Length in descriptor
        BNEQ    2$                      ;continue if not zero length
        BRW     100$                    ;else length was zero and exit

        ;Allocate memory on stack
2$:     SUBL2   #<MAXLEN+8>,SP          ;Move stack pointer over memory we claim
        MOVL    SP,R9                   ;Store base address.

        ;Copy string to buffer
        MOVL    INSTR,R0                ;address of descriptor
        MOVC3   (R0),@4(R0),(R9)        ;move password to our buffer

        ;XOR string with random numbers
        MOVZWL  @INSTR,R2               ;Length of string
        DIVL3   #4,R2,R2                ;number of 4-byte chunks in string
        CLRL    R3                      ;Number of 4-byte chunks processed so far
30$:    PUSHAQ  RANBITS                 ;output (quadword)
        PUSHAQ  RANBITS                 ;input (quadword)
        CALLS   #2,DES_ENCRYPT          ;Get new quadword of random bits from DES
        XORL2   RANBITS,(R9)[R3]        ;character = random_number+character
        INCL    R3                      ;
        XORL2   RANBITS+4,(R9)[R3]      ;character = random_number+character
31$:    AOBLEQ  R2, R3, 30$             ;Loop

        ;Return encrypted string
100$:   PUSHL   R9                      ;address of output string
        MOVZWL  @INSTR,-(SP)            ;length of output string
        PUSHL   #1                      ;retcode
        CALLS   #3,FMTOUTSTR            ;format output string
        RET

;-----------------------------------------------------------------------------

        .SUBTITLE       HACK_PASSWORD
;++
; THE PASSWORD HASHING ALGORITHM
;
; The algorithm used to smash the password into a quadword KEY value and
; a quadword RANBITS consists of several different applications of the
; basic Cyclic Redundancy Check (CRC).  The the theory of "primitive
; polynomials modulo 2" lies behind the success of using CRCs to hash
; passwords.
;
;
; EXAMPLE OF CRC CALCULATION:
;
;       A CRC (Cyclic Redundancy Check) is basically longhand synthetic
;       division of two polynomials under modulo two arithmetic.  Below
;       is an example:
;
;                 1x^3 + 1x^2 + 0x   + 1                           1 1 0 1
;               ------------------------------------             -------------
; 1x^2 + 0x + 1 | 1x^5 + 1x^4 + 1x^3 + 0x^2 + 1x + 0       1 0 1 | 1 1 1 0 1 0
;                 1x^5 + 0x^4 + 1x^3                               1 0 1
;                 ----------------------------------               -----------
;                        1x^4 + 0x^3 + 0x^2 + 1x + 0                 1 0 0 1 0
;                        1x^4 + 0x^3 + 1x^2                          1 0 1
;                        ---------------------------                 ---------
;                               0x^3 + 1x^2 + 1x + 0                   0 1 1 0
;                                      1x^2 + 0x + 1                     1 0 1
;                                      -------------                     -----
;                                             1x + 1                       1 1
;
;       When calculating a CRC, the divisor (1 0 1 above) is the CRC
;       polynomial, the dividend (1 1 1 0 1 0 above) is the fixed or
;       variable length input bit stream, and the remainder (1 1 above)
;       is the CRC we seek.  We do not require the quotient (1 1 0 1 above).
;
;       The division to find the remainder can be described as follows:
;
;               1.  Align the coefficient of the highest degree term of
;               the divisor and the coefficient of the highest degree
;               term of the dividend and subtract (the same as addition,
;               or XORing.)
;
;               2.  Align the coefficient of the highest degree term of
;               the divisor and the coefficient of the highest degree
;               term of the dividend and subtract again.
;
;               3.  Repeat the process until the difference has lower
;               degree than the divisor.  The difference is the remainder.
;
;
;       Choosing a primitive polynomial for the CRC polynomial is what gives
;       the CRC it's power.
;
;       By viewing the password character string as a long bit stream
;       representing the dividend of a CRC calculation, the CRC may be
;       used to convert a password into a pseudo-random remainder value.
;
;       Reference:
;               Peterson, W.W., and D.T. Brown.: "Cyclic Codes for Error Detection".
;               Proc. IRE, vol. 49, pp. 228-235, Jan. 1961.
;
;-----------------------------------------------------------------------------
;
; MACROS:
;       GENBITS
;       A variation of the CRC calculation can be used to generate a
;       random bit stream.  Instead of feeding in bits from a password
;       string, the bits popped off the high end of the shift register
;       are fed back into the low end.  If the CRC is using a primitive
;       polynomial of degree n as the divisor, then this recurrence
;       relation is guaranteed to cycle through all possible sequences
;       of n bits (except all zeros) before it repeats.
;
;       Reference:
;               NUMERICAL RECIPES: The Art of Scientific Computing, by
;               William H. Press, Brian P. Flannery, Saul A. Teukolsky,
;               and William T. Vetterling.  1986 Cambridge University Press.
;
;       Register usage:
;       R0,R1 - holds CRC calculation
;       R3 - bit flags:  bit#0 set if low bit of byte_9 is set
;                        bit#1 set if high bit of R1 is set
;       R4 - loop control counter

        .MACRO  GENBITS count,hreg,mask,?L1,?L2,?L3
        MOVL    count,R4        ;Loop counter
L1:     BBC     #31,hreg,L2     ;Test bit about to be shoved off
        BBSS    #0,R3,L2        ;Set flag indicating bit was set
L2:     ASHQ    #1,R0,R0        ;Shift R0,R1
        BBCC    #0,R3,L3        ;Test if high bit of quad R0R1 was set
        XORL2   #CRC_MASK2,R0   ;Do XOR.  This line should have used #mask instead
;;;;    XORL2   #mask,R0        ;  of #CRC_MASK2 due to a blunder.
L3:     SOBGTR  R4,L1           ;
        .ENDM                   ;

;-----------------------------------------------------------------------------

;++
; HCKPWD
;
; Functional Description:
;       Converts a character string containing a password to two 64-bit
;       quadword values.
;
; Calling Sequence:
;       CALLS   #3,HCKPWD
;
; Input:
;        4(AP) - PASSWORD character string. (by descriptor, read access)
;        8(AP) - KEY      quadword, write access, by reference.
;       12(AP) - RANBITS  quadword, write access, by reference.
;
; Outputs:
;        8(AP) - KEY     a 64 bit quadword pseudo-random bit pattern.
;       12(AP) - RANBITS a 64 bit quadword pseudo-random bit pattern.
;
; Outline:
;       1.  A 32 bit pseudo-random bit pattern is generated by passing
;           the password character string through a CRC calculation
;           using the AUTODIN-II polynomial.  (This is the same way
;           user login passwords are encrypted and stored.)
;
;       2.  The 32 bit pseudo-random bit pattern is used as the seed
;           for a random bit generator which is used to generate a
;           64 bit quadword of random bits.
;
;       3.  The 64 bit quadword of random bits is used as the seed value
;           for a CRC which is performed on the password character
;           string.
;
;       4.  The 64 bit quadword remainder of the CRC calculated in
;           step 3 is returned as the KEY value used for initializing
;           the DES algorithm.  It is also used as the seed for a random
;           bit generator which is used to generate another 64 bit pseudo-
;           random quadword which is used as the initial value to start the
;           the DES algorithm in output feedback mode.
;
; Register usage:
;
;       R0,R1 - holds CRC calculation
;       R2 - holds byte_9
;       R3 - bit flags:  bit#0 set if low bit of byte_9 is set.
;                        bit#1 set if high bit of R1 is set
;       R4 - loop control counter.
;       R5 - counts number of characters in password processed so far
;       R6 - length of password character string
;       R7 - address of password character string
;--
CRC_MASK1 = ^B010101111         ;x^32+x^7+x^5+x^3+x^2+x^1+1     ;Primitive polynomial
CRC_MASK2 = ^B000011011         ;x^64+x^4+x^3+x^1+1             ;Primitive polynomial
        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR

        .ENTRY  HCKPWD,^M<R2,R3,R4,R5,R6,R7>
        PUSHL   INSTR                   ;password
        CALLS   #1,AUTODIN_CRC          ;Do CRC to get 32 pseudo-random bits in R0
        GENBITS #32,R0,CRC_MASK1        ;Expand 32 bits in R0 to 64 bits in R0,R1

        ;STEP 3.
        ;Do CRC on PASSWORD to get 64 bits in R0, R1
        BSBW    PSWD_CRC

        ;STEP 4.
        MOVQ    R0,@8(AP)               ;output RO,R1 as KEY
        GENBITS #64,R1,CRC_MASK2        ;generate 64 more random bits
        MOVQ    R0,@12(AP)              ;output R0,R1 as RANBITS
        RET
;-----------------------------------------------------------------------------

        .SUBTITLE AUTODIN_CRC
;++
; AUTODIN_CRC
;
; Functional Description:
;       Perform cyclic redundancy check on input character string PASSWORD
;       creating a 32 bit pseudo-random longword.
;
; Calling Sequence:
;       CALLS   #1,AUTODIN_CRC
;
; Argument inputs:
;       4(AP) = Address of descriptor of PASSWORD string.
;
; Outputs:
;       R0 = 32 bit pseudo-random longword.
;
; Outline:
;       The VAX CRC (Cyclic Redundancy Check) instruction is used to
;       calculate the CRC of the input PASSWORD using the AUTODIN-II
;       polynomial.
;
;--
;
; Description of CRC instruction setup:
;
; The polynomial used is:       1 + x^2 + x^4 + x^5 + x^7 + x^8 + x^10 + x^11 + x^12 + x^16 + x^22 + x^23 + x^26 + x^32
; The binary representation is: 1101 1011  1000 0000 0001 0000 0000 1
; Expressed in hex is:          ^xEDB88320
; (This is the AUTODIN-II polynomial which is also used by VMS to hash
;  a user's login password.)
;
; A full picture of how this is done is given below.  First the entire
; polynomial is written in expanded form.  (Note that the CRC instruction
; takes bits off from the right, thus the right most bit represents the high
; order coefficients of x^n and the bits on the far left represent the low
; order coefficients of x^0.  This is why the polynomial is written down
; backwards.)
; 1x^0 + 1x^1 + 1x^2 + 0x^3 + 1x^4 + 1x^5 + 0x^6 + 1x^7 + 1x^8 + 0x^9 + 1x^10 + 1x^11 + 1x^12 + 0x^13 + 0x^14 + 0x^15 + 1x^16 + 0x^17 + 0x^18 + 0x^19 + 0x^20 + 0x^21 + 1x^22 + 1x^23 + 0x^24 + 0x^25 + 1x^26 + 0x^27 + 0x^28 + 0x^29 + 0x^30 + 0x31 + 1x^32
;
; Then just the coefficients of the polynomial are extracted:
; 1      1      1      0      1      1      0      1      1      0      1       1       1       0       0       0       1       0       0       0       0       0       1       1       0       0       1       0       0       0       0       0      1
;
; The 1 at the far right representing 1x^32 is dropped, and the remaining
; coefficients together represent a binary number.  The binary number is
; converted to hexadecimal for convenience.
;|          E             |             D             |             B               |               8               |               8               |               3               |               2               |               0               |
;
; The resulting hexadecimal number is EDB88320. This is the value POLY used
; by LIB$CRC_TABLE to create the crc-table which is needed by the CRC
; instruction.
;
;--
        .ENTRY  AUTODIN_CRC, ^M<>
        SUBL2   #<16*4>,SP              ;Allocate 16 longwords on stack for CRC_TABLE
        PUSHL   SP                      ;Address of CRC_TABLE
        PUSHAL  #^xEDB88320             ;AUTODIN-II polynomial
        CALLS   #2,G^LIB$CRC_TABLE      ;Calculate CRC-TABLE
        MOVQ    @4(AP),R0               ;Descriptor.  R0 = length, R1 = address
        CRC     (SP),#-1,R0,(R1)        ;Do CRC.  Result is left in R0
        RET
;-----------------------------------------------------------------------------

        .SUBTITLE PSWD_CRC
;++
; PSWD_CRC
;
; Functional Description:
;       Perform cyclic redundancy check on input character string PASSWORD
;       creating a 64 bit pseudo-random quadword.
;
; Calling Sequence:
;       JSB     PSWD_CRC
;
; Argument inputs:
;       R0,R1 - Initial value for CRC
;
; Outputs:
;       R0,R1 - Final value of CRC calculation.  A 64 bit random value.
;
; Outline:
;       The basic flow diagram is shown below.  The password character
;       string is viewed as a long bit stream representing the dividend
;       polynomial.  Characters are taken one at a time from the password
;       and placed in the low byte of R2, hereinafter referred to as byte_9.
;       Shifting is then done in a manner which maintains the integrity of
;       the bit stream:
;               1.  The quadword formed by R0 and R1 is left shifted one bit.
;               2.  Byte_9 is right shifted one byte.
;               3.  The low bit of byte_9 that was pushed off moves to
;                   the low bit of R0.
;
;       If the high bit pushed off R1 was a '1' then we subtract (XOR)
;       the divisor (our primitive polynomial) from the quadword R0,R1
;       (which contains the high 64 bits of our remainder so far).
;
;       The process is repeated until the password is exhausted, and the last
;       bit from the password has shifted off the high end of R1.
;
;                                                      PASSWORD ---
;                                                                 |
;                                                                 V
;
;                                                                --->
;                                                     R2      | byte_9  |
;                                    | .3....v....2....v....1....v....0 |
;                                                                     |
;                                  <------                            v
;                     R1                              R0
; 64 | ...6....v....5....v....4....v....3....v....2....v....1....v....0 |
;  1                                                              11 11  = x^64+x^4+x^3+x^1+1
;
;
; Register usage:
;
;       R0,R1 - holds CRC calculation
;       R2 - holds byte_9
;       R3 - bit flags:  bit#0 set if low bit of byte_9 is set.
;                        bit#1 set if high bit of R1 is set
;       R4 - loop control counter.
;       R5 - counts number of characters in password processed so far
;       R6 - length of password character string
;       R7 - address of password character string
;
;--
PSWD_CRC:
        MOVQ    @4(AP),R6               ;descriptor to R6,R7.  R7 = address
        MOVZWL  R6,R6                   ;length of string
        CLRL    R3                      ;clear bit flags
        CLRL    R5                      ;initialize loop counter
100$:   MOVB    (R7)[R5],R2             ;move next byte from character string to byte_9
        MOVZBL  #8,R4                   ;loop 8 times for 8 bits in byte_9
120$:   BBC     #31,R1,130$             ;test bit about to be shoved off
        BBSS    #0,R3,130$              ;set flag indicating high bit of quad R0R1 was set
130$:   BLBC    R2,140$                 ;test bit about to be shoved off of byte_9
        BBSS    #1,R3,140$              ;set flag indicating low bit of byte_9 was set
140$:   ASHQ    #1,R0,R0                ;shift R0,R1
        ASHL    #-1,R2,R2               ;shift byte_9
        BBCC    #1,R3,150$              ;test if low bit of byte_9 was set
        INCL    R0                      ;set low bit of quad R0R1
150$:   BBCC    #0,R3,160$              ;test if high bit of quad R0R1 was set
        XORL2   #CRC_MASK2,R0           ;do XOR
160$:   SOBGTR  R4,120$                 ;loop until 8 bits in byte_9 exhausted
        AOBLSS  R6,R5,100$              ;loop until all password characters exhausted
        GENBITS #64,R1,CRC_MASK2        ;finish off CRC
        RSB
;-----------------------------------------------------------------------------

        .SUBTITLE       DES DATA ENCRYPTION STANDARD

;++
;       AMERICAN NATIONAL STANDARD DATA ENCRYPTION ALGORITHM
;       American National Standard X3.92-1981
;
; Functional Description:
;       This subsection implements the Data Encryption Standard (DES)
;       for encrypting data.  It is self contained and may be extracted
;       for use in your own programs.
;
;       It consists of two routines, DES_INIT and DES_ENCRYPT.  DES_INIT
;       must be called first to initialize the encryption algorithm with
;       the KEY which is used to encipher and decipher the data.  After
;       initializing the encryption algorithm with KEY, subsequent calls
;       may be made to DES_ENCRYPT to encrypt or decrypt data.
;
;               FORTRAN Example:
;                       INTEGER*4 KEY(2),INPUT(2),OUTPUT(2)
;                       CALL DES_INIT(KEY)                      !Initialize
;                       CALL DES_ENCRYPT(INPUT,OUTPUT)          !Encrypt data
;                       CALL DES_ENCRYPT(INPUT,OUTPUT,%VAL(1))  !Decrypt data
;
; References:
;       "Data Encryption Standard", 1977 January 15, Federal Information
;       Processing Standards Publication, number 46 (Washington: U.S.
;       Department of Commerce, National Bureau of Standards).
;
;       "DES Modes of Operation", 1980 December 2, Federal Information
;       Processing Standards Publication, number 81 (Washington: U.S.
;       Department of Commerce, National Bureau of Standards).
;
;--
;
; MACRO DEFINITIONS:
;
;       The literature for DES numbers bits backwards from the way VAX
;       architecture numbers bits.  DES numbers bits by starting at the
;       left with the most significant bit and numbering them 1,2,3...
;       ending with the least significant bit.
;
;       VAX architecture numbers bits starting at the right with the least
;       significant bit and numbering them 0,1,2,3... ending at the left
;       with the most significant bit.
;
;       Below is an example of how DES and VAX numbers the bits for a
;       32 bit longword.  The numbering is similar for quadwords and
;       variable length bit fields in general.
;
;                1  2  3 ...                  30  31  32  DES bit numbering
;               ----------------------------------------
;               |                                      |
;               ----------------------------------------  VAX bit numbering
;               31 30 29 ...                   2   1   0
;
;       In the following discussions, bit# refers to the VAX bit numbering
;       scheme, and bit without the # refers to the DES indicated bit number.
;       For example, bit#5 refers to VAX bit numbering, and bit 5 refers
;       to DES bit numbering.
;
;
;       BITDATA
;       This macro converts data indicating bit positions from the DES
;       bit numbering scheme to the VAX bit numbering scheme.  The first
;       parameter, nbits, is the number of bits in the bit field.  Following
;       parameters are the DES bit number data.
;
;       Data is converted from the DES bit numbering scheme to the VAX bit
;       numbering scheme using the formula:
;               vaxbit# = (num_bits_in_field - DES_bit_number)
;
        .MACRO  BITDATA nbits, -
                n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12,n13,n14,n15,n16
        .IRP    num,<n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12,n13,n14,n15,n16>
        .IIF    NOT_BLANK, num, .BYTE <nbits-num>
        .ENDR
        .ENDM   BITDATA
;
;
;       PERMUTE
;       This macro takes bits from IN and moves them to OUT in a shuffled
;       order.  DATA is a stream of data bytes indicating the bit order
;       bits from IN are to be chosen.  For example, if DATA = 58,50,42,...
;       then first bit 58 from IN is copied to bit 1 of OUT, then bit 50
;       from IN is copied to bit 2 of OUT, then bit 42 from IN is copied
;       to bit 3 of OUT, etc.
;
;       For proper functioning, DATA must first be converted from the DES
;       bit numbering scheme to the VAX bit numbering scheme using the
;       BITDATA macro.  Also, since DES bit 1 is actually the highest most
;       significant bit, we start with the highest most significant bit
;       on OUT, and work our way down towards the right most least significant
;       bit.
;
;       This macro uses R0,R1.
;
        .MACRO  PERMUTE in, out, data, nbits, ?L1, ?L2
        SUBL3   #1,nbits,R0             ;Initialize loop counter
        CLRQ    out                     ;clear output quadword
L1:     SUBL3   R0,nbits,R1             ;get index into data (index goes from 0 to nbits-1)
        DECL    R1                      ;.
        MOVZBL  data[R1],R1             ;R1=bit number to get
        BBC     R1,in,L2                ;Branch if input bit clear
        BBSS    R0,out,L2               ;else set corresponding output bit
L2:     SOBGEQ  R0,L1                   ;Loop
        .ENDM
;--

;++
; DES_INIT
;
; Functional Description:
;       This routine initializes the data encryption algorithm using the
;       input quadword KEY.  Using KEY it calculates the sixteen 48 bit
;       sub-master keys SUBKEY(1)-SUBKEY(16) and stores them in memory
;       array DES_SUBKEY.
;
; Calling Sequence:
;       CALLS   #1,DES_INIT
;
; Input:
;       4(AP) - KEY a 64 bit quadword value (by reference, read access)
;
; Outline:
;   1.  56 of the 64 bits of input quadword KEY are used to create CnDn.
;       DES_PMC1 (Permuted Choice 1) data dictates how this is done.  Bit
;       57 (DES numbering) of KEY becomes the first bit (bit 1, DES numbering)
;       of CnDn, bit 49 of KEY becomes the second bit of CnDn, bit 41 of KEY
;       becomes the third bit of CnDn, etc.
;
;   2.  The first 28 bits of CnDn (bit#55-bit#28) become Cn.  The second 28
;       bits of CnDn (bit#27-bit#0) become Dn.
;
;   3.  Cn is left shifted (actually left rotated, bits move from lower
;       to higher, with bit#28 moving to bit#0).  Cn is rotated by two bit
;       positions, except for N={1,2,9,16}, in which case Cn is rotated by
;       one bit position.  (n = N-1 before rotating, n = N after rotating,
;       n=0 to start).
;
;   4.  Step 3 is repeated for Dn.
;
;   5.  Cn and Dn are recombined to create CnDn.
;
;   6.  48 of the 56 bits of this new CnDn are used to create SUBKEY(N).
;       DES_PMC2 (Permuted Choice 2) data dictates how this is done.  Bit
;       14 (DES bit numbering) of CnDn becomes the first bit (bit 1, DES
;       bit numbering) of SUBKEY(N), bit 17 of CnDn becomes the second bit
;       of SUBKEY(N), bit 11 of CnDn becomes the third bit of SUBKEY(N), etc.
;
;   7.  Repeat steps 2,3,4,5,6 until all 16 SUBKEYs have been generated.
;       Only the 16 SUBKEYs are actually used in the encryption algorithm.
;       The original KEY is no longer needed.
;
; Memory maps:
;
;       DES_SUBKEY (in permanent memory psect DATA)
;       --------------------------------------------------------------
;       |                   SUBKEY(1)  (3 words)                     | 00 + DES_SUBKEY
;       --------------------------------------------------------------
;       |                   SUBKEY(2)  (3 words)                     | 06
;       --------------------------------------------------------------
;       |                   SUBKEY(3)  (3 words)                     | 0C
;       --------------------------------------------------------------
;       |                   SUBKEY(4)  (3 words)                     | 12
;       --------------------------------------------------------------
;       |                   SUBKEY(5)  (3 words)                     | 18
;       --------------------------------------------------------------
;       |                   SUBKEY(6)  (3 words)                     | 1E
;       --------------------------------------------------------------
;       |                   SUBKEY(7)  (3 words)                     | 24
;       --------------------------------------------------------------
;       |                   SUBKEY(8)  (3 words)                     | 2A
;       --------------------------------------------------------------
;       |                   SUBKEY(9)  (3 words)                     | 30
;       --------------------------------------------------------------
;       |                   SUBKEY(10) (3 words)                     | 36
;       --------------------------------------------------------------
;       |                   SUBKEY(11) (3 words)                     | 3C
;       --------------------------------------------------------------
;       |                   SUBKEY(12) (3 words)                     | 42
;       --------------------------------------------------------------
;       |                   SUBKEY(13) (3 words)                     | 48
;       --------------------------------------------------------------
;       |                   SUBKEY(14) (3 words)                     | 4E
;       --------------------------------------------------------------
;       |                   SUBKEY(15) (3 words)                     | 54
;       --------------------------------------------------------------
;       |                   SUBKEY(16) (3 words)                     | 5A
;       --------------------------------------------------------------
;                                                                    | 60
;
;       TEMPORARY STORAGE allocated on stack
;       -----------------------------------------
;       |                CnDn                   | 00  (R9 = base address)
;       -                                       -
;       |                                       | 04
;       -----------------------------------------
;                                               | 08
;--

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR

.ALIGN  LONG
DES_PMC1:            ;Permuted Choice 1 (table 7) (64 bits to 56)
        BITDATA 64  57,49,41,33,25,17, 9, 1,58,50,42,34,26,18,10, 2
        BITDATA 64  59,51,43,35,27,19,11, 3,60,52,44,36,63,55,47,39
        BITDATA 64  31,23,15, 7,62,54,46,38,30,22,14, 6,61,53,45,37
        BITDATA 64  29,21,13, 5,28,20,12, 4

.ALIGN  LONG
DES_PMC2:       ;Permuted Choice 2 (table 9) (56 bits to 48)
        BITDATA 56  14,17,11,24, 1, 5, 3,28,15, 6,21,10,23,19,12, 4
        BITDATA 56  26, 8,16, 7,27,20,13, 2,41,52,31,37,47,55,30,40
        BITDATA 56  51,45,33,48,44,49,39,56,34,53,46,42,50,36,29,32
;--

        .PSECT  DATA    RD,WRT,NOEXE,LONG,PIC,NOSHR

.ALIGN  LONG
DES_SUBKEY:     .BLKW   16*3    ;Storage for SUBKEY(1)-SUBKEY(16)
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR

        .ENTRY  DES_INIT ^M<R2,R3,R8,R9,R11>

        ;Allocate temporary storage on stack
        SUBL2   #8,SP                   ;Move SP over memory we claim
        MOVL    SP,R9                   ;Store base address in R9
        MOVAB   DES_SUBKEY,R8           ;To make routine position independent

        ;STEP 1
        ;Initial selection and permutation
        PERMUTE in=@4(AP), -            ;KEY
                out=(R9), -             ;(R9)=CnDn
                data=DES_PMC1, -        ;Permuted Choice 1
                nbits=#56

        ;Begin loop to generate 16 sub-master keys
        MOVZBL  #1,R11                  ;R11 = loop index N

        ;STEP 2
        ;Separate CnDn into two halves Cn and Dn
10$:    EXTZV   #0,#28,(R9),R2          ;R2 = Low half CnDn = Dn
        EXTZV   #28,#28,(R9),R3         ;R3 = High half of CnDn = Cn

        ;STEPS 3,4
        ;For most values of N perform two shifts (R0=2)
        ;except for N={1,2,9,16} perform one shift (R0=1)
        MOVZBL  #2,R0                   ;R0 = 2  assume two shifts
        CMPL    R11,#1                  ;check for N = 1,2,9,16
        BEQL    15$
        CMPL    R11,#2
        BEQL    15$
        CMPL    R11,#9
        BEQL    15$
        CMPL    R11,#16
        BNEQ    25$
15$:    DECL    R0                      ;R0=1  only one shift

        ;Rotate Cn and Dn.  We only want to rotate bits(0)-(27)
25$:    ASHL    #1,R3,R3                ;rotate R3 (Cn)
        BBCC    #28,R3,30$              ;Check bit#27 shifted to bit#28.
        INCL    R3                      ;set bit#0 if bit#28 was set
30$:    ASHL    #1,R2,R2                ;Rotate R2 (Dn)
        BBCC    #28,R2,40$              ;Check bit#27 shifted to bit#28
        INCL    R2                      ;set bit#0 if bit#28 was set
40$:    SOBGTR  R0,25$                  ;Loop (on shifts)

        ;STEP 5
        ;Reconstruct CnDn
        MOVL    R2,(R9)                 ;Put back Dn half (bit#s 0-27)
        INSV    R3,#28,#28,(R9)         ;Put back Cn half (bit#s 28-56)

        ;STEP 6
        ;Permute CnDn to SUBKEY(N)
        MULL3   #6,R11,R2                       ;Calculate address of SUBKEY(N)
        ADDL2   R8,R2                           ;
        SUBL2   #6,R2                           ;
        PERMUTE in=(R9), -                      ;(R9)=CnDn
                out=(R2), -                     ;out=SUBKEY(N)
                data=DES_PMC2, -                ;Permuted Choice 2
                nbits=#48

        ;STEP 7
        AOBLEQ  #16,R11,10$                     ;Loop (on N)

        RET
;-----------------------------------------------------------------------------

;++
; DES_ENCRYPT
;
; Functional Description:
;       This routine takes the quadword INPUT and encrypts it using the
;       Data Encryption Standard creating the encrypted quadword OUTPUT.
;
; Calling Sequence:
;       CALLS   #2,DES_ENCRYPT
;        or
;       CALLS   #3,DES_ENCRYPT
;
; Inputs:
;        4(AP) - INPUT    a 64 bit quadword value (by reference, read access)
;        8(AP) - OUTPUT   a 64 bit quadword value (by reference, write access)
;       12(AP) - DECRYPT  OPTIONAL.  0=encrypt(the default)
;                                    1=decrypt (by value)
;                                    This parameter is optional.
;
; Implicit:
;       It is assumed that DES_INIT has already been called to initialize
;       the encryption algorithm.
;
; Outline:
;   1.  The 64 bits of quadword INPUT are permuted to quadword LNRN
;       according to DES_INIPRM data (Initial Permutation IP, table 1,
;       see description of PERMUTE macro and BITDATA macro for details).
;
;   2.  The low longword of quadword LNRN (bit#0-bit#31, also known
;       as RN) is permuted to IE (48 bits) according to DES_EXPFCN data
;       (Expansion Function E, table 3, see description of PERMUTE macro
;       and BITDATA macro for details).
;
;   3.  The 48 bits of IE are eXclusively ORed (XOR) with the 48 bits
;       of SUBKEY(1).
;
;   4.  The 48 bits of IE are replaced by 32 bits according to DES_SBOX
;       data (Selection Function S(1),...,S(8), tables 4 & 6).  The details
;       are as follows.  The 48 bits of IE (bit#0-bit#47) are divided into
;       8 groups of 6 bits each as shown below.  Each group of 6 bits then
;       is replaced by 4 bits from SBOX data.
;
;  47....42 41....36 35....30 29....24 23....18 17....12 11....6  5....0  IE input (48 bits)
;   ||||||   ||||||   ||||||   ||||||   ||||||   ||||||   ||||||  ||||||
;   SBOX(1)  SBOX(2)  SBOX(3)  SBOX(4)  SBOX(5)  SBOX(6)  SBOX(7) SBOX(8)
;    ||||     ||||     ||||     ||||     ||||     ||||     ||||    ||||
;   31..28   27..24   23..20   19..16   15..12   11..8     7..4    3..0   IE output (32 bits)
;
;             [bit#5 bit#0] = row number of SBOX(8) (starting with row 0)
; [bit#4 bit#3 bit#2 bit#1] = column number of SBOX(8) (starting with column 0)
;
;       Here is an example of how this 6-bit-to-4-bit substitution works.
;       For the first group of 6 bits, (bit#0-bit#5), bit#0 and bit#5
;       together form a two bit binary number which indicates the row within
;       the SBOX(8) data matrix.  Bits #1 through bit#4 together form a
;       four bit binary number which indicates the column within the SBOX(8)
;       matrix.  With the row and column indexes determined, the SBOX(8)
;       data element is the 4 bit binary number which replaces the group of
;       6 input bits.  The other 7 groups of 6 input bits are replaced by
;       4 output bits in a similar matter using SBOX(7)-SBOX(1).
;
;       (Note that in this implementation the output bits are stored in
;       IE overwriting the input bits.  For example, the 4 output bits
;       corresponding to the 6 input bits 0-5 of IE are stored in
;       IE as bits 0-3, overwriting the no longer needed IE bits 0-5.)
;
;   5.  The resulting 32 bits of IE are permuted according to DES_PFP data
;       (Permutation Function P, table 5), and then exclusively ORed (XOR)
;       with the high longword of quadword LNRN (bit#32-bit#63, also known
;       as LN)
;
;   6.  The low longword and the high longword of quadword LNRN are swapped.
;
;   7.  Steps 2,3,4,5,6 are repeated for a total of 16 times, using
;       SUBKEY(2)-SUBKEY(16) in step 3.  Step 6 is skipped the last time.
;
;   8.  The 64 bits of quadword LNRN are permuted to quadword OUTPUT according
;       to DES_INVINIPRM data (Inverse of Initial Permutation IP, table 2,
;       see description of PERMUTE macro and BITDATA macro for details).
;
; Memory map:
;
;       TEMPORARY STORAGE allocated on the stack
;       -----------------------------------------
;       |                  IE                   | 00  (R9 = base address)
;       -                                       -
;       |                                       | 04
;       -----------------------------------------
;       |                  RN                   | 08  (LNRN = RN, LN)
;       - - - - - - - - - - - - - - - - - - - - -
;       |                  LN                   | 0C
;       -----------------------------------------
;                                               | 10
;--

        .PSECT  STATSHR RD,NOWRT,NOEXE,LONG,PIC,SHR

.ALIGN  LONG
DES_INIPRM:     ;Initial Permutation (table 1) (64 bits to 64)
        BITDATA 64  58,50,42,34,26,18,10, 2,60,52,44,36,28,20,12, 4
        BITDATA 64  62,54,46,38,30,22,14, 6,64,56,48,40,32,24,16, 8
        BITDATA 64  57,49,41,33,25,17, 9, 1,59,51,43,35,27,19,11, 3
        BITDATA 64  61,53,45,37,29,21,13, 5,63,55,47,39,31,23,15, 7

.ALIGN  LONG
DES_INVINIPRM:  ;Inverse of Initial Permutation (table 2) (64 bits to 64)
        BITDATA 64  40, 8,48,16,56,24,64,32,39, 7,47,15,55,23,63,31
        BITDATA 64  38, 6,46,14,54,22,62,30,37, 5,45,13,53,21,61,29
        BITDATA 64  36, 4,44,12,52,20,60,28,35, 3,43,11,51,19,59,27
        BITDATA 64  34, 2,42,10,50,18,58,26,33, 1,41, 9,49,17,57,25

.ALIGN  LONG
DES_EXPFCN:     ;Expansion Function E (table 3) (32 bits to 48)
        BITDATA 32  32, 1, 2, 3, 4, 5, 4, 5, 6, 7, 8, 9, 8, 9,10,11
        BITDATA 32  12,13,12,13,14,15,16,17,16,17,18,19,20,21,20,21
        BITDATA 32  22,23,24,25,24,25,26,27,28,29,28,29,30,31,32, 1

.ALIGN  LONG
DES_PFP:        ;Permutation Function P (table 5) (32 bits to 32)
        BITDATA 32  16, 7,20,21,29,12,28,17, 1,15,23,26, 5,18,31,10
        BITDATA 32   2, 8,24,14,32,27, 3, 9,19,13,30, 6,22,11, 4,25

.ALIGN  LONG
DES_SBOX:       ;Selection Functions (table 4,6) (6 bits to 4)
; S(1)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE   14, 4,13, 1, 2,15,11, 8, 3,10, 6,12, 5, 9, 0, 7  ;00
        .BYTE    0,15, 7, 4,14, 2,13, 1,10, 6,12,11, 9, 5, 3, 8  ;01
        .BYTE    4, 1,14, 8,13, 6, 2,11,15,12, 9, 7, 3,10, 5, 0  ;10
        .BYTE   15,12, 8, 2, 4, 9, 1, 7, 5,11, 3,14,10, 0, 6,13  ;11

; S(2)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE   15, 1, 8,14, 6,11, 3, 4, 9, 7, 2,13,12, 0, 5,10  ;00
        .BYTE    3,13, 4, 7,15, 2, 8,14,12, 0, 1,10, 6, 9,11, 5  ;01
        .BYTE    0,14, 7,11,10, 4,13, 1, 5, 8,12, 6, 9, 3, 2,15  ;10
        .BYTE   13, 8,10, 1, 3,15, 4, 2,11, 6, 7,12, 0, 5,14, 9  ;11

; S(3)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE   10, 0, 9,14, 6, 3,15, 5, 1,13,12, 7,11, 4, 2, 8  ;00
        .BYTE   13, 7, 0, 9, 3, 4, 6,10, 2, 8, 5,14,12,11,15, 1  ;01
        .BYTE   13, 6, 4, 9, 8,15, 3, 0,11, 1, 2,12, 5,10,14, 7  ;10
        .BYTE    1,10,13, 0, 6, 9, 8, 7, 4,15,14, 3,11, 5, 2,12  ;11

; S(4)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE    7,13,14, 3, 0, 6, 9,10, 1, 2, 8, 5,11,12, 4,15  ;00
        .BYTE   13, 8,11, 5, 6,15, 0, 3, 4, 7, 2,12, 1,10,14, 9  ;01
        .BYTE   10, 6, 9, 0,12,11, 7,13,15, 1, 3,14, 5, 2, 8, 4  ;10
        .BYTE    3,15, 0, 6,10, 1,13, 8, 9, 4, 5,11,12, 7, 2,14  ;11

; S(5)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE    2,12, 4, 1, 7,10,11, 6, 8, 5, 3,15,13, 0,14, 9  ;00
        .BYTE   14,11, 2,12, 4, 7,13, 1, 5, 0,15,10, 3, 9, 8, 6  ;01
        .BYTE    4, 2, 1,11,10,13, 7, 8,15, 9,12, 5, 6, 3, 0,14  ;10
        .BYTE   11, 8,12, 7, 1,14, 2,13, 6,15, 0, 9,10, 4, 5, 3  ;11

; S(6)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE   12, 1,10,15, 9, 2, 6, 8, 0,13, 3, 4,14, 7, 5,11  ;00
        .BYTE   10,15, 4, 2, 7,12, 9, 5, 6, 1,13,14, 0,11, 3, 8  ;01
        .BYTE    9,14,15, 5, 2, 8,12, 3, 7, 0, 4,10, 1,13,11, 6  ;10
        .BYTE    4, 3, 2,12, 9, 5,15,10,11,14, 1, 7, 6, 0, 8,13  ;11

; S(7)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE    4,11, 2,14,15, 0, 8,13, 3,12, 9, 7, 5,10, 6, 1  ;00
        .BYTE   13, 0,11, 7, 4, 9, 1,10,14, 3, 5,12, 2,15, 8, 6  ;01
        .BYTE    1, 4,11,13,12, 3, 7,14,10,15, 6, 8, 0, 5, 9, 2  ;10
        .BYTE    6,11,13, 8, 1, 4,10, 7, 9, 5, 0,15,14, 2, 3,12  ;11

; S(8)  column#  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15  ;row#
        .BYTE   13, 2, 8, 4, 6,15,11, 1,10, 9, 3,14, 5, 0,12, 7  ;00
        .BYTE    1,15,13, 8,10, 3, 7, 4,12, 5, 6,11, 0,14, 9, 2  ;01
        .BYTE    7,11, 4, 1, 9,12,14, 2, 0, 6,10,13,15, 3, 5, 8  ;10
        .BYTE    2, 1,14, 7, 4,10, 8,13,15,12, 9, 0, 3, 5, 6,11  ;11
;--

        .PSECT  CODE    NOWRT,EXE,LONG,PIC,SHR

        .ENTRY  DES_ENCRYPT, ^M<R2,R3,R4,R6,R7,R8,R9,R10,R11>

        ;Allocate temporary storage on stack
        SUBL2   #^x10,SP                ;Move SP over memory we claim
        MOVL    SP,R9                   ;Store base address in R9
        MOVAB   DES_SUBKEY,R4           ;To make routine position independent

        ;STEP 1
        ;Initial Permutation            ;INPUT(64 bits) -> LNRN(64 bits)
        PERMUTE in=@4(AP), -            ;in=INPUT (quadword)
                out=8(R9), -            ;out=LNRN
                data=DES_INIPRM, -      ;data= Initial Permutation IP (table 1)
                nbits=#64               ;Number of output bits = 64

        ; LOOP THROUGH STEPS 2,3,4,5,6 (The 16 stages of encryption)
        ; R11 - Loop control counter.  Counts from 0 to 15
        ; R10 - Index N
        ;       For encryption R10 = R11 i.e. N counts from 0 to 15
        ;       For decryption R10 = 15 - R11 i.e. N counts from 15 to 0
        CLRL    R11                     ;Initialize R11
10$:    MOVL    R11,R10                 ;Assume encryption
        CMPL    (AP),#3                 ;See if optional 3rd parameter specified in call
        BLSS    11$                     ;Branch if no third parameter.
        CMPL    12(AP),#1               ;Test 3rd parameter for decryption
        BNEQ    11$                     ;Branch of not.  Encryption.
        SUBL3   R11,#15,R10             ;R10 = 15 - R11

        ;STEP 2
        ;Expansion function (permutation)
        ;RN (of LNRN, 32 bits) -> IE(48 bits)
11$:    PERMUTE in=8(R9), -              ;in=RN
                out=(R9), -              ;out=IE
                data=DES_EXPFCN, -       ;data= Expansion Function (table 3)
                nbits=#48                ;Number of output bits = 48

        ;STEP 3
        ;Add SUBKEY(N) to IE
        MULL3   #6,R10,R0                       ;R0 = offset of SUBKEY(N)
        ADDL2   R4,R0                           ;R0 = Address of SUBKEY(N)
        XORL2   (R0),(R9)                       ;IE = IE + SUBKEY(N)
        XORW2   4(R0),4(R9)

        ;STEP 4
        ; IE(48 bits) -> SBOX -> IE(32 bits)
        ;
        ; R8 = Loop control counter b
        ;        for block number 8 - 1.  R8 counts from 7 to 0.
        ;      Loop 8 times for 8 groups of 6-bit-to-4-bit substitutions.
        ;
        ; R7 = Index into IE as start position offset for input bits.
        ;      Indexes from 0 to 41 step 6
        ;      over 8 groups of 6 input bits.
        ;
        ; R6 = Index into IE as start position offset for output bits.
        ;      Indexes from 0 to 27 step 4
        ;      over 8 groups of 4 output bits.
        ;
        ; R1 = Row index into substitution table SBOX(b)  (b=R8)
        ;      Bit#5 from 6 bit subgroup of IE becomes bit#0 of R1 and
        ;      bit#0 from 6 bit subgroup of IE becomes bit#1 of R1.  The
        ;      result is interpreted as a two bit binary number.
        ;
        ; R0 = Column index into substitution table SBOX(b)  (b=R8)
        ;      Bit#1-bit#4 of 6 bit subgroup of IE becomes bit#0-bit#3 of R0.
        ;      The result is interpreted as a four bit binary number.
        ;
        ;INITIALIZE LOOP
        MOVZBL  #7,R8                   ;Loop control counter b
        CLRQ    R6                      ;R6 = Offset into IE for output groups of 4
                                        ;R7 = Offset into IE for input groups of 6

        ;LOOP OVER 8 GROUPS
100$:   EXTZV   R7,#6,(R9),R0           ;Next 6 bits from IE to R0
        CLRL    R1                      ;Copy bit#0 of R0 to bit#0 of R1.
        BLBC    R0,110$                 ; test R0 bit#0
        INCL    R1                      ; set R1 bit#0
110$:   BBC     #5,R0,120$              ;Copy bit#5 of R0 to bit#1 of R1.
        BISB2   #^B0010,R1              ; set R1 bit#1
120$:   BICB2   #^B11100001,R0          ;Move bits#1-4 of R0 to bits#0-3 of R0.
        ASHL    #-1,R0,R0               ;.
        MULL3   #<16*4>,R8,R2           ;Calculate index into S-box.  R2 now points to start of SBOX(b)
        MULL2   #16,R1                  ; (16 per row)
        ADDL2   R1,R2                   ; R2 now points to row within SBOX(b)
        ADDL2   R0,R2                   ; R2 now points to data element
        MOVZBL  DES_SBOX[R2],R2         ;R2 now contains data element
        INSV    R2,R6,#4,(R9)           ;Move 4 bit data element to IE
        ADDL2   #6,R7                   ;Advance input offset R7 to next start bit in IE
        ADDL2   #4,R6                   ;Advance output offset R6 to next start bit in IE
        SOBGEQ  R8,100$                 ;Loop (R8=b, block number)

        ;STEP 5
        PERMUTE in=(R9), -              ;(R9)=IE (32 bits)
                out=R2, -               ;R2 = Permuted IE (also clears R3)
                data=DES_PFP, -         ;Permutation Function P (table 5)
                nbits=#32               ;

        ;Add permuted IE to LN
        XORL2   R2,12(R9)               ;R2 = permuted IE, 12(R9) = LN
        AOBLSS  #16,R11,190$            ;Test for last iteration.
        BRB     200$                    ;Exit loop.  Skip step 6 last time through.

        ;STEP 6
190$:   MOVL    8(R9),R0                ;RN -> temp
        MOVL    12(R9),8(R9)            ;LN -> RN
        MOVL    R0,12(R9)               ;temp -> LN
        BRW     10$                     ;LOOP  (STEP 7)

        ;STEP 8
        ;Final output permutation
200$:   PERMUTE in=8(R9), -             ;8(R9)=LNRN
                out=@8(AP), -           ;@8(AP)=OUTPUT
                data=DES_INVINIPRM, -   ;Inverse of Initial Permutation (table 2)
                nbits=#64               ;

        RET

;------------------------------------------------------------------------------
        .END