; 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